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.12 $=~/\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;
    }
  }
} # 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

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

  ## 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} = 1;
    }
  }
  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 ||= $pack_name;
    }
    $r .= "*${class_name}::AUTOLOAD = \\&${al_pack_name}::AUTOLOAD;\n";
  }

$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: 2005/11/23 11:21:39 $
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			our $VERSION = do{my @r=(q$Revision: 1.12 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
15
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			for my $class (keys %{$list->{method} or {}}) {
109			for my $method (keys %{$list->{method}->{$class}}) {
110			$Message::Util::AutoLoad::Registry::Method->{$class}->{$method}
111			= $list->{method}->{$class}->{$method};
112			$Modified = 1;
113			}
114			}
115			} # register_all
116
117			=item $config->save;
118
119			Writes the current configuration for autoload
120			to the C<Message::Util::AutoLoad::Registry> file
121			(if the autoload configuration is modified through
122			C<Message::Util::AutoLoad::Config> module).
123
124			=cut
125
126			sub save ($) {
127			return unless $Modified;
128			my @time = gmtime time;
129			my $r = <<EOH;
130			## This file is automatically generated at @{[
131			sprintf '%04d-%02d-%02dT%02d:%02d:%02dZ',
132			$time[5] + 1900, $time[4] + 1, $time[3], $time[2], $time[1], $time[0]]}.
133			## Don't edit by hand!
134
135			package Message::Util::AutoLoad::Registry;
136			use strict;
137
138			EOH
139
140			## Method-to-module mapping
141			my $method = Dumper ($Message::Util::AutoLoad::Registry::Method);
142			$method =~ s/\$VAR1/our \$Method/;
143			$r .= $method;
144
145			## Method prototype declarations for \|can\| method
146			my $clean = sub {
147			join '::', map {
148			s/[^A-Za-z0-9_]/_/g;
149			s/^[0-9]/_/;
150			$_;
151			} grep {length} split /::/, shift;
152			};
153			my $class_methods = {};
154			my $class_revisas = {};
155			for my $pack (keys %$Message::Util::AutoLoad::Registry::Method) {
156			next unless keys %{$Message::Util::AutoLoad::Registry::Method->{$pack}};
157			my $pack_name = $clean->($pack);
158			for my $method
159			(keys %{$Message::Util::AutoLoad::Registry::Method->{$pack}}) {
160			my $m = $Message::Util::AutoLoad::Registry::Method->{$pack}->{$method};
161			my $method_name = $clean->($method);
162			my $class_name = $clean->($m->{class});
163			$class_methods->{$class_name}->{$method_name}
164			= defined $m->{prototype} ? " ($m->{prototype})" : '';
165			$class_revisas->{$class_name}->{$pack_name} = 1;
166			}
167			}
168			for my $class_name (keys %$class_methods) {
169			$r .= "package $class_name;\n";
170			for my $method_name (keys %{$class_methods->{$class_name}}) {
171			$r .= "sub $method_name$class_methods->{$class_name}->{$method_name};\n";
172			}
173			}
174			for my $class_name (keys %$class_revisas) {
175			my $al_pack_name;
176			for my $pack_name (keys %{$class_revisas->{$class_name}}) {
177			$r .= "push \@${pack_name}::ISA, '$class_name'
178			unless $pack_name->isa ('$class_name');\n";
179			$al_pack_name \|\|= $pack_name;
180			}
181			$r .= "*${class_name}::AUTOLOAD = \\&${al_pack_name}::AUTOLOAD;\n";
182			}
183
184			$r .= <<EOH;
185
186			1;
187
188			\__END__
189
190			\=head1 NAME
191
192			Message::Util::AutoLoad::Registry - manakai's Autoload Registry
193
194			\=head1 DESCRIPTION
195
196			This file is used as the registry for the autoload
197			mechanism used in manakai.
198
199			EOH
200
201			my $file_name = $main::INC{'Message/Util/AutoLoad/Registry.pm'};
202			open my $file, '>', $file_name or die "$0: $file_name: $!";
203			print $file $r;
204			close $file;
205			$Modified = 0;
206			} # save
207
208			=back
209
210			=head1 LICENSE
211
212			Copyright 2006 Wakaba <[email protected]>
213
214			This program is free software; you can redistribute it and/or
215			modify it under the same terms as Perl itself.
216
217			=cut
218
219			1; # $Date: 2005/11/23 11:21:39 $