root/Encode-DoubleEncodedUTF8/trunk/inc/Module/Install.pm

Revision 2162 (checked in by miyagawa, 13 years ago)

import

Line 
1 #line 1
2 package Module::Install;
3
4 # For any maintainers:
5 # The load order for Module::Install is a bit magic.
6 # It goes something like this...
7 #
8 # IF ( host has Module::Install installed, creating author mode ) {
9 #     1. Makefile.PL calls "use inc::Module::Install"
10 #     2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
11 #     3. The installed version of inc::Module::Install loads
12 #     4. inc::Module::Install calls "require Module::Install"
13 #     5. The ./inc/ version of Module::Install loads
14 # } ELSE {
15 #     1. Makefile.PL calls "use inc::Module::Install"
16 #     2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
17 #     3. The ./inc/ version of Module::Install loads
18 # }
19
20 use 5.004;
21 use strict 'vars';
22
23 use vars qw{$VERSION};
24 BEGIN {
25     # All Module::Install core packages now require synchronised versions.
26     # This will be used to ensure we don't accidentally load old or
27     # different versions of modules.
28     # This is not enforced yet, but will be some time in the next few
29     # releases once we can make sure it won't clash with custom
30     # Module::Install extensions.
31     $VERSION = '0.64';
32 }
33
34 # Whether or not inc::Module::Install is actually loaded, the
35 # $INC{inc/Module/Install.pm} is what will still get set as long as
36 # the caller loaded module this in the documented manner.
37 # If not set, the caller may NOT have loaded the bundled version, and thus
38 # they may not have a MI version that works with the Makefile.PL. This would
39 # result in false errors or unexpected behaviour. And we don't want that.
40 my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
41 unless ( $INC{$file} ) {
42     die <<"END_DIE";
43 Please invoke ${\__PACKAGE__} with:
44
45     use inc::${\__PACKAGE__};
46
47 not:
48
49     use ${\__PACKAGE__};
50
51 END_DIE
52 }
53
54 # If the script that is loading Module::Install is from the future,
55 # then make will detect this and cause it to re-run over and over
56 # again. This is bad. Rather than taking action to touch it (which
57 # is unreliable on some platforms and requires write permissions)
58 # for now we should catch this and refuse to run.
59 if ( -f $0 and (stat($0))[9] > time ) {
60         die << "END_DIE";
61 Your installer $0 has a modification time in the future.
62
63 This is known to create infinite loops in make.
64
65 Please correct this, then run $0 again.
66
67 END_DIE
68 }
69
70 use Cwd        ();
71 use File::Find ();
72 use File::Path ();
73 use FindBin;
74
75 *inc::Module::Install::VERSION = *VERSION;
76 @inc::Module::Install::ISA     = __PACKAGE__;
77
78 sub autoload {
79     my $self = shift;
80     my $who  = $self->_caller;
81     my $cwd  = Cwd::cwd();
82     my $sym  = "${who}::AUTOLOAD";
83     $sym->{$cwd} = sub {
84         my $pwd = Cwd::cwd();
85         if ( my $code = $sym->{$pwd} ) {
86             # delegate back to parent dirs
87             goto &$code unless $cwd eq $pwd;
88         }
89         $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
90         unshift @_, ($self, $1);
91         goto &{$self->can('call')} unless uc($1) eq $1;
92     };
93 }
94
95 sub import {
96     my $class = shift;
97     my $self  = $class->new(@_);
98     my $who   = $self->_caller;
99
100     unless ( -f $self->{file} ) {
101         require "$self->{path}/$self->{dispatch}.pm";
102         File::Path::mkpath("$self->{prefix}/$self->{author}");
103         $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
104         $self->{admin}->init;
105         @_ = ($class, _self => $self);
106         goto &{"$self->{name}::import"};
107     }
108
109     *{"${who}::AUTOLOAD"} = $self->autoload;
110     $self->preload;
111
112     # Unregister loader and worker packages so subdirs can use them again
113     delete $INC{"$self->{file}"};
114     delete $INC{"$self->{path}.pm"};
115 }
116
117 sub preload {
118     my ($self) = @_;
119
120     unless ( $self->{extensions} ) {
121         $self->load_extensions(
122             "$self->{prefix}/$self->{path}", $self
123         );
124     }
125
126     my @exts = @{$self->{extensions}};
127     unless ( @exts ) {
128         my $admin = $self->{admin};
129         @exts = $admin->load_all_extensions;
130     }
131
132     my %seen;
133     foreach my $obj ( @exts ) {
134         while (my ($method, $glob) = each %{ref($obj) . '::'}) {
135             next unless $obj->can($method);
136             next if $method =~ /^_/;
137             next if $method eq uc($method);
138             $seen{$method}++;
139         }
140     }
141
142     my $who = $self->_caller;
143     foreach my $name ( sort keys %seen ) {
144         *{"${who}::$name"} = sub {
145             ${"${who}::AUTOLOAD"} = "${who}::$name";
146             goto &{"${who}::AUTOLOAD"};
147         };
148     }
149 }
150
151 sub new {
152     my ($class, %args) = @_;
153
154     # ignore the prefix on extension modules built from top level.
155     my $base_path = Cwd::abs_path($FindBin::Bin);
156     unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
157         delete $args{prefix};
158     }
159
160     return $args{_self} if $args{_self};
161
162     $args{dispatch} ||= 'Admin';
163     $args{prefix}   ||= 'inc';
164     $args{author}   ||= ($^O eq 'VMS' ? '_author' : '.author');
165     $args{bundle}   ||= 'inc/BUNDLES';
166     $args{base}     ||= $base_path;
167     $class =~ s/^\Q$args{prefix}\E:://;
168     $args{name}     ||= $class;
169     $args{version}  ||= $class->VERSION;
170     unless ( $args{path} ) {
171         $args{path}  = $args{name};
172         $args{path}  =~ s!::!/!g;
173     }
174     $args{file}     ||= "$args{base}/$args{prefix}/$args{path}.pm";
175
176     bless( \%args, $class );
177 }
178
179 sub call {
180         my ($self, $method) = @_;
181         my $obj = $self->load($method) or return;
182         splice(@_, 0, 2, $obj);
183         goto &{$obj->can($method)};
184 }
185
186 sub load {
187     my ($self, $method) = @_;
188
189     $self->load_extensions(
190         "$self->{prefix}/$self->{path}", $self
191     ) unless $self->{extensions};
192
193     foreach my $obj (@{$self->{extensions}}) {
194         return $obj if $obj->can($method);
195     }
196
197     my $admin = $self->{admin} or die <<"END_DIE";
198 The '$method' method does not exist in the '$self->{prefix}' path!
199 Please remove the '$self->{prefix}' directory and run $0 again to load it.
200 END_DIE
201
202     my $obj = $admin->load($method, 1);
203     push @{$self->{extensions}}, $obj;
204
205     $obj;
206 }
207
208 sub load_extensions {
209     my ($self, $path, $top) = @_;
210
211     unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
212         unshift @INC, $self->{prefix};
213     }
214
215     foreach my $rv ( $self->find_extensions($path) ) {
216         my ($file, $pkg) = @{$rv};
217         next if $self->{pathnames}{$pkg};
218
219         local $@;
220         my $new = eval { require $file; $pkg->can('new') };
221         unless ( $new ) {
222             warn $@ if $@;
223             next;
224         }
225         $self->{pathnames}{$pkg} = delete $INC{$file};
226         push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
227     }
228
229     $self->{extensions} ||= [];
230 }
231
232 sub find_extensions {
233     my ($self, $path) = @_;
234
235     my @found;
236     File::Find::find( sub {
237         my $file = $File::Find::name;
238         return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
239         my $subpath = $1;
240         return if lc($subpath) eq lc($self->{dispatch});
241
242         $file = "$self->{path}/$subpath.pm";
243         my $pkg = "$self->{name}::$subpath";
244         $pkg =~ s!/!::!g;
245
246         # If we have a mixed-case package name, assume case has been preserved
247         # correctly.  Otherwise, root through the file to locate the case-preserved
248         # version of the package name.
249         if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
250             open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!";
251             my $in_pod = 0;
252             while ( <PKGFILE> ) {
253                 $in_pod = 1 if /^=\w/;
254                 $in_pod = 0 if /^=cut/;
255                 next if ($in_pod || /^=cut/);  # skip pod text
256                 next if /^\s*#/;               # and comments
257                 if ( m/^\s*package\s+($pkg)\s*;/i ) {
258                     $pkg = $1;
259                     last;
260                 }
261             }
262             close PKGFILE;
263         }
264
265         push @found, [ $file, $pkg ];
266     }, $path ) if -d $path;
267
268     @found;
269 }
270
271 sub _caller {
272     my $depth = 0;
273     my $call  = caller($depth);
274     while ( $call eq __PACKAGE__ ) {
275         $depth++;
276         $call = caller($depth);
277     }
278     return $call;
279 }
280
281 1;
Note: See TracBrowser for help on using the browser.