=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.3 $=~/\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 <w@suika.fam.cx>

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

=cut

1; # $Date: 2007/09/21 08:10:31 $