Util/AutoLoad/Config.pm

=head1 NAME

Message::Util::AutoLoad::Config - manakai's Autoload Configurator

=head1 DESCRIPTION

The C<Message::Util::AutoLoad::Config> module provides
a way to register a Perl module to the autoload registry.

=cut

use strict;
package Message::Util::AutoLoad::Config;
our $VERSION = do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

use Data::Dumper;
our $Modified;

=head1 SYNOPSIS

  use Message::Util::AutoLoad::Config;
  my $config = new Message::Util::AutoLoad::Config;

  $config->register_method ($class_name, $method_name, $module_name);

=head1 METHODS

=over 4

=item $config = Message::Util::AutoLoad::Config->new;

Creates a new instance of the autoload configurator.

=cut

sub new ($) {
  my $class = shift;
  require Message::Util::AutoLoad::Registry;
  return bless {}, $class;
} # new

=item $config->register_method ($class_name, $method_name, $module_name, $method_class_name, $prototype);

Associates a pair of class and method into a module so
that invocation to the method on an object of that class
will autoload the module.

If the pair is already associated with any module,
then that association is removed and the new association
takes effect.

=over 4

=item $class_name

The fully-qualified package name of the class.

=item $method_name

The name of the method.  It does not include the package
name.

=item $module_name

The fully-qualified package name of the module.

=item $prototype

The subroutine prototype (not including parentheses).
It may be C<undef>, which stands for no prototype.

=item $method_class_name

The fully-qualified package name of the class
to which the method belongs.

=back

=cut

sub register_method ($$$$$) {
  my ($self, $class, $method, $module, $class2, $proto) = @_;
  $Message::Util::AutoLoad::Registry::Method->{$class}->{$method} = {
    module => $module,
    class => $class2,
    prototype => $proto,
  };
  $Modified = 1;
} # register_method

=item $config->register_all ($list);

Registers a set of autoload definitions
returned by C<< I<PCDocument>->get_autoload_definition_list >>.

=over 4

=item $list

A set of autoload definitions.

=back

=cut

sub register_all ($$) {
  my ($self, $list) = @_;

  for my $class (keys %{$list->{method} or {}}) {
    for my $method (keys %{$list->{method}->{$class}}) {
      $Message::Util::AutoLoad::Registry::Method->{$class}->{$method}
          = $list->{method}->{$class}->{$method};
      $Modified = 1;
    }
  }

  for my $fname (keys %{$list->{feature} or {}}) {
    $Message::Util::AutoLoad::Registry::Feature->{$fname}->{$_}
        = $list->{feature}->{$fname}->{$_}
        for keys %{$list->{feature}->{$fname}};
    $Modified = 1;
  }

  for my $nsuri (keys %{$list->{element_type} or {}}) {
    $Message::Util::AutoLoad::Registry::ElementType->{$nsuri}->{$_}
        = $list->{element_type}->{$nsuri}->{$_}
        for keys %{$list->{element_type}->{$nsuri}};
    $Modified = 1;
  }
} # register_all

=item $config->save;

Writes the current configuration for autoload
to the C<Message::Util::AutoLoad::Registry> file
(if the autoload configuration is modified through
C<Message::Util::AutoLoad::Config> module).

=cut

sub save ($) {
  return unless $Modified;
  my @time = gmtime time;
  my $r = <<EOH;
## This file is automatically generated at @{[
    sprintf '%04d-%02d-%02dT%02d:%02d:%02dZ',
    $time[5] + 1900, $time[4] + 1, $time[3], $time[2], $time[1], $time[0]]}.
## Don't edit by hand!

package Message::Util::AutoLoad::Registry;
use strict;

EOH

  local $Data::Dumper::Sortkeys = 1;

  ## Method-to-module mapping
  my $method = Dumper ($Message::Util::AutoLoad::Registry::Method);
  $method =~ s/\$VAR1/our \$Method/;
  $r .= $method;

  ## Feature-to-module mapping
  my $feature = Dumper ($Message::Util::AutoLoad::Registry::Feature);
  $feature =~ s/\$VAR1/our \$Feature/;
  $r .= $feature;

  ## Element-type-to-module mapping
  my $et = Dumper ($Message::Util::AutoLoad::Registry::ElementType);
  $et =~ s/\$VAR1/our \$ElementType/;
  $r .= $et;

  ## Method prototype declarations for |can| method
  my $clean = sub {
    join '::', map {
      s/[^A-Za-z0-9_]/_/g;
      s/^[0-9]/_/;
      $_;
    } grep {length} split /::/, shift;
  };
  my $class_methods = {};
  my $class_revisas = {};
  for my $pack (keys %$Message::Util::AutoLoad::Registry::Method) {
    next unless keys %{$Message::Util::AutoLoad::Registry::Method->{$pack}};
    my $pack_name = $clean->($pack);
    for my $method
        (keys %{$Message::Util::AutoLoad::Registry::Method->{$pack}}) {
      my $m = $Message::Util::AutoLoad::Registry::Method->{$pack}->{$method};
      my $method_name = $clean->($method);
      my $class_name = $clean->($m->{class});
      $class_methods->{$class_name}->{$method_name}
          = defined $m->{prototype} ? " ($m->{prototype})" : '';
      $class_revisas->{$class_name}->{$pack_name} = $clean->($m->{module});
    }
  }
  for my $class_name (keys %$class_methods) {
    $r .= "package $class_name;\n";
    for my $method_name (keys %{$class_methods->{$class_name}}) {
      $r .= "sub $method_name$class_methods->{$class_name}->{$method_name};\n";
    }
  }
  for my $class_name (keys %$class_revisas) {
    my $al_pack_name;
    for my $pack_name (keys %{$class_revisas->{$class_name}}) {
      $r .= "push \@${pack_name}::ISA, '$class_name'
          unless $pack_name->isa ('$class_name');\n";
      $al_pack_name ||= $class_revisas->{$class_name}->{$pack_name};
    }
    $r .= <<EOH;
sub ${class_name}::AUTOLOAD {
  require $al_pack_name;
  no strict 'refs';
  if ($class_name->can (\$${class_name}::AUTOLOAD)) {
    goto &{\$${class_name}::AUTOLOAD};
  } else {
    require Carp;
    Carp::croak (qq<Can't locate method "\$${class_name}::AUTOLOAD">);
  }
}
EOH
  }

$r .= <<EOH;

1;

\__END__

\=head1 NAME

Message::Util::AutoLoad::Registry - manakai's Autoload Registry

\=head1 DESCRIPTION

This file is used as the registry for the autoload
mechanism used in manakai.

EOH

  my $file_name = $main::INC{'Message/Util/AutoLoad/Registry.pm'};
  open my $file, '>', $file_name or die "$0: $file_name: $!";
  print $file $r;
  close $file;
  $Modified = 0;
} # save

=back

=head1 LICENSE

Copyright 2006 Wakaba <[email protected]>

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

1; # $Date: 2006/11/04 12:25:19 $
1	wakaba	1.1	=head1 NAME
2
3			Message::Util::AutoLoad::Config - manakai's Autoload Configurator
4
5			=head1 DESCRIPTION
6
7			The C<Message::Util::AutoLoad::Config> module provides
8			a way to register a Perl module to the autoload registry.
9
10			=cut
11
12			use strict;
13			package Message::Util::AutoLoad::Config;
14	wakaba	1.3	our $VERSION = do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
15	wakaba	1.1
16			use Data::Dumper;
17			our $Modified;
18
19			=head1 SYNOPSIS
20
21			use Message::Util::AutoLoad::Config;
22			my $config = new Message::Util::AutoLoad::Config;
23
24			$config->register_method ($class_name, $method_name, $module_name);
25
26			=head1 METHODS
27
28			=over 4
29
30			=item $config = Message::Util::AutoLoad::Config->new;
31
32			Creates a new instance of the autoload configurator.
33
34			=cut
35
36			sub new ($) {
37			my $class = shift;
38			require Message::Util::AutoLoad::Registry;
39			return bless {}, $class;
40			} # new
41
42			=item $config->register_method ($class_name, $method_name, $module_name, $method_class_name, $prototype);
43
44			Associates a pair of class and method into a module so
45			that invocation to the method on an object of that class
46			will autoload the module.
47
48			If the pair is already associated with any module,
49			then that association is removed and the new association
50			takes effect.
51
52			=over 4
53
54			=item $class_name
55
56			The fully-qualified package name of the class.
57
58			=item $method_name
59
60			The name of the method. It does not include the package
61			name.
62
63			=item $module_name
64
65			The fully-qualified package name of the module.
66
67			=item $prototype
68
69			The subroutine prototype (not including parentheses).
70			It may be C<undef>, which stands for no prototype.
71
72			=item $method_class_name
73
74			The fully-qualified package name of the class
75			to which the method belongs.
76
77			=back
78
79			=cut
80
81			sub register_method ($$$$$) {
82			my ($self, $class, $method, $module, $class2, $proto) = @_;
83			$Message::Util::AutoLoad::Registry::Method->{$class}->{$method} = {
84			module => $module,
85			class => $class2,
86			prototype => $proto,
87			};
88			$Modified = 1;
89			} # register_method
90
91			=item $config->register_all ($list);
92
93			Registers a set of autoload definitions
94			returned by C<< I<PCDocument>->get_autoload_definition_list >>.
95
96			=over 4
97
98			=item $list
99
100			A set of autoload definitions.
101
102			=back
103
104			=cut
105
106			sub register_all ($$) {
107			my ($self, $list) = @_;
108	wakaba	1.2
109	wakaba	1.1	for my $class (keys %{$list->{method} or {}}) {
110			for my $method (keys %{$list->{method}->{$class}}) {
111			$Message::Util::AutoLoad::Registry::Method->{$class}->{$method}
112			= $list->{method}->{$class}->{$method};
113			$Modified = 1;
114			}
115			}
116	wakaba	1.2
117			for my $fname (keys %{$list->{feature} or {}}) {
118			$Message::Util::AutoLoad::Registry::Feature->{$fname}->{$_}
119			= $list->{feature}->{$fname}->{$_}
120			for keys %{$list->{feature}->{$fname}};
121			$Modified = 1;
122			}
123
124			for my $nsuri (keys %{$list->{element_type} or {}}) {
125			$Message::Util::AutoLoad::Registry::ElementType->{$nsuri}->{$_}
126			= $list->{element_type}->{$nsuri}->{$_}
127			for keys %{$list->{element_type}->{$nsuri}};
128			$Modified = 1;
129			}
130	wakaba	1.1	} # register_all
131
132			=item $config->save;
133
134			Writes the current configuration for autoload
135			to the C<Message::Util::AutoLoad::Registry> file
136			(if the autoload configuration is modified through
137			C<Message::Util::AutoLoad::Config> module).
138
139			=cut
140
141			sub save ($) {
142			return unless $Modified;
143			my @time = gmtime time;
144			my $r = <<EOH;
145			## This file is automatically generated at @{[
146			sprintf '%04d-%02d-%02dT%02d:%02d:%02dZ',
147			$time[5] + 1900, $time[4] + 1, $time[3], $time[2], $time[1], $time[0]]}.
148			## Don't edit by hand!
149
150			package Message::Util::AutoLoad::Registry;
151			use strict;
152
153			EOH
154
155	wakaba	1.2	local $Data::Dumper::Sortkeys = 1;
156
157	wakaba	1.1	## Method-to-module mapping
158			my $method = Dumper ($Message::Util::AutoLoad::Registry::Method);
159			$method =~ s/\$VAR1/our \$Method/;
160			$r .= $method;
161
162	wakaba	1.2	## Feature-to-module mapping
163			my $feature = Dumper ($Message::Util::AutoLoad::Registry::Feature);
164			$feature =~ s/\$VAR1/our \$Feature/;
165			$r .= $feature;
166
167			## Element-type-to-module mapping
168			my $et = Dumper ($Message::Util::AutoLoad::Registry::ElementType);
169			$et =~ s/\$VAR1/our \$ElementType/;
170			$r .= $et;
171
172	wakaba	1.1	## Method prototype declarations for \|can\| method
173			my $clean = sub {
174			join '::', map {
175			s/[^A-Za-z0-9_]/_/g;
176			s/^[0-9]/_/;
177			$_;
178			} grep {length} split /::/, shift;
179			};
180			my $class_methods = {};
181			my $class_revisas = {};
182			for my $pack (keys %$Message::Util::AutoLoad::Registry::Method) {
183			next unless keys %{$Message::Util::AutoLoad::Registry::Method->{$pack}};
184			my $pack_name = $clean->($pack);
185			for my $method
186			(keys %{$Message::Util::AutoLoad::Registry::Method->{$pack}}) {
187			my $m = $Message::Util::AutoLoad::Registry::Method->{$pack}->{$method};
188			my $method_name = $clean->($method);
189			my $class_name = $clean->($m->{class});
190			$class_methods->{$class_name}->{$method_name}
191			= defined $m->{prototype} ? " ($m->{prototype})" : '';
192	wakaba	1.2	$class_revisas->{$class_name}->{$pack_name} = $clean->($m->{module});
193	wakaba	1.1	}
194			}
195			for my $class_name (keys %$class_methods) {
196			$r .= "package $class_name;\n";
197			for my $method_name (keys %{$class_methods->{$class_name}}) {
198			$r .= "sub $method_name$class_methods->{$class_name}->{$method_name};\n";
199			}
200			}
201			for my $class_name (keys %$class_revisas) {
202			my $al_pack_name;
203			for my $pack_name (keys %{$class_revisas->{$class_name}}) {
204			$r .= "push \@${pack_name}::ISA, '$class_name'
205			unless $pack_name->isa ('$class_name');\n";
206	wakaba	1.2	$al_pack_name \|\|= $class_revisas->{$class_name}->{$pack_name};
207	wakaba	1.1	}
208	wakaba	1.2	$r .= <<EOH;
209			sub ${class_name}::AUTOLOAD {
210			require $al_pack_name;
211			no strict 'refs';
212			if ($class_name->can (\$${class_name}::AUTOLOAD)) {
213			goto &{\$${class_name}::AUTOLOAD};
214			} else {
215			require Carp;
216			Carp::croak (qq<Can't locate method "\$${class_name}::AUTOLOAD">);
217			}
218			}
219			EOH
220	wakaba	1.1	}
221
222			$r .= <<EOH;
223
224			1;
225
226			\__END__
227
228			\=head1 NAME
229
230			Message::Util::AutoLoad::Registry - manakai's Autoload Registry
231
232			\=head1 DESCRIPTION
233
234			This file is used as the registry for the autoload
235			mechanism used in manakai.
236
237			EOH
238
239			my $file_name = $main::INC{'Message/Util/AutoLoad/Registry.pm'};
240			open my $file, '>', $file_name or die "$0: $file_name: $!";
241			print $file $r;
242			close $file;
243			$Modified = 0;
244			} # save
245
246			=back
247
248			=head1 LICENSE
249
250			Copyright 2006 Wakaba <[email protected]>
251
252			This program is free software; you can redistribute it and/or
253			modify it under the same terms as Perl itself.
254
255			=cut
256
257	wakaba	1.3	1; # $Date: 2006/11/04 12:25:19 $