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	=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.2 $=~/\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
109	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
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	} # 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	local $Data::Dumper::Sortkeys = 1;
156
157	## Method-to-module mapping
158	my $method = Dumper ($Message::Util::AutoLoad::Registry::Method);
159	$method =~ s/\$VAR1/our \$Method/;
160	$r .= $method;
161
162	## 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	## 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	$class_revisas->{$class_name}->{$pack_name} = $clean->($m->{module});
193	}
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	$al_pack_name \|\|= $class_revisas->{$class_name}->{$pack_name};
207	}
208	$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	}
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	1; # $Date: 2006/11/04 12:25:19 $