inc/Module/Install.pm

   1 #line 1 "inc/Module/Install.pm - /Library/Perl/5.8.1/Module/Install.pm"
   2 # $File: //depot/cpan/Module-Install/lib/Module/Install.pm $ $Author: autrijus $
   3 # $Revision: #67 $ $Change: 1885 $ $DateTime: 2004/03/11 05:55:27 $ vim: expandtab shiftwidth=4
   4
   5 package Module::Install;
   6 $VERSION = '0.33';
   7
   8 die << "." unless $INC{join('/', inc => split(/::/, __PACKAGE__)).'.pm'};
   9 Please invoke ${\__PACKAGE__} with:
  10
  11     use inc::${\__PACKAGE__};
  12
  13 not:
  14
  15     use ${\__PACKAGE__};
  16
  17 .
  18
  19 use strict 'vars';
  20 use Cwd ();
  21 use File::Find ();
  22 use File::Path ();
  23
  24 @inc::Module::Install::ISA = 'Module::Install';
  25
  26 #line 129
  27
  28 sub import {
  29     my $class = shift;
  30     my $self = $class->new(@_);
  31
  32     if (not -f $self->{file}) {
  33         require "$self->{path}/$self->{dispatch}.pm";
  34         File::Path::mkpath("$self->{prefix}/$self->{author}");
  35         $self->{admin} =
  36           "$self->{name}::$self->{dispatch}"->new(_top => $self);
  37         $self->{admin}->init;
  38         @_ = ($class, _self => $self);
  39         goto &{"$self->{name}::import"};
  40     }
  41
  42     *{caller(0) . "::AUTOLOAD"} = $self->autoload;
  43
  44     # Unregister loader and worker packages so subdirs can use them again
  45     delete $INC{"$self->{file}"};
  46     delete $INC{"$self->{path}.pm"};
  47 }
  48
  49 #line 156
  50
  51 sub autoload {
  52     my $self = shift;
  53     my $caller = caller;
  54
  55     my $cwd = Cwd::cwd();
  56     my $sym = "$caller\::AUTOLOAD";
  57
  58     $sym->{$cwd} = sub {
  59         my $pwd = Cwd::cwd();
  60         if (my $code = $sym->{$pwd}) {
  61             goto &$code unless $cwd eq $pwd; # delegate back to parent dirs
  62         }
  63         $$sym =~ /([^:]+)$/ or die "Cannot autoload $caller";
  64         unshift @_, ($self, $1);
  65         goto &{$self->can('call')} unless uc($1) eq $1;
  66     };
  67 }
  68
  69 #line 181
  70
  71 sub new {
  72     my ($class, %args) = @_;
  73
  74     return $args{_self} if $args{_self};
  75
  76     $args{dispatch} ||= 'Admin';
  77     $args{prefix}   ||= 'inc';
  78     $args{author}   ||= '.author';
  79     $args{bundle}   ||= 'inc/BUNDLES';
  80
  81     $class =~ s/^\Q$args{prefix}\E:://;
  82     $args{name}     ||= $class;
  83     $args{version}  ||= $class->VERSION;
  84
  85     unless ($args{path}) {
  86         $args{path}  = $args{name};
  87         $args{path}  =~ s!::!/!g;
  88     }
  89     $args{file}     ||= "$args{prefix}/$args{path}.pm";
  90
  91     bless(\%args, $class);
  92 }
  93
  94 #line 210
  95
  96 sub call {
  97     my $self   = shift;
  98     my $method = shift;
  99     my $obj = $self->load($method) or return;
 100
 101     unshift @_, $obj;
 102     goto &{$obj->can($method)};
 103 }
 104
 105 #line 225
 106
 107 sub load {
 108     my ($self, $method) = @_;
 109
 110     $self->load_extensions(
 111         "$self->{prefix}/$self->{path}", $self
 112     ) unless $self->{extensions};
 113
 114     foreach my $obj (@{$self->{extensions}}) {
 115         return $obj if $obj->can($method);
 116     }
 117
 118     my $admin = $self->{admin} or die << "END";
 119 The '$method' method does not exist in the '$self->{prefix}' path!
 120 Please remove the '$self->{prefix}' directory and run $0 again to load it.
 121 END
 122
 123     my $obj = $admin->load($method, 1);
 124     push @{$self->{extensions}}, $obj;
 125
 126     $obj;
 127 }
 128
 129 #line 255
 130
 131 sub load_extensions {
 132     my ($self, $path, $top_obj) = @_;
 133
 134     unshift @INC, $self->{prefix}
 135         unless grep { $_ eq $self->{prefix} } @INC;
 136
 137     local @INC = ($path, @INC);
 138     foreach my $rv ($self->find_extensions($path)) {
 139         my ($file, $pkg) = @{$rv};
 140         next if $self->{pathnames}{$pkg};
 141
 142         eval { require $file; 1 } or (warn($@), next);
 143         $self->{pathnames}{$pkg} = delete $INC{$file};
 144         push @{$self->{extensions}}, $pkg->new( _top => $top_obj );
 145     }
 146 }
 147
 148 #line 279
 149
 150 sub find_extensions {
 151     my ($self, $path) = @_;
 152     my @found;
 153
 154     File::Find::find(sub {
 155         my $file = $File::Find::name;
 156         return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
 157         return if $1 eq $self->{dispatch};
 158
 159         $file = "$self->{path}/$1.pm";
 160         my $pkg = "$self->{name}::$1"; $pkg =~ s!/!::!g;
 161         push @found, [$file, $pkg];
 162     }, $path) if -d $path;
 163
 164     @found;
 165 }
 166
 167 1;
 168
 169 __END__
 170
 171 #line 614