"Fossies" - the Fresh Open Source Software Archive 
Member "RT-Extension-Assets-1.05/inc/Module/Install.pm" (6 May 2015, 12431 Bytes) of package /linux/misc/RT-Extension-Assets-1.05.tar.gz:
As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style:
standard) with prefixed line numbers and
code folding option.
Alternatively you can here
view or
download the uninterpreted source code file.
For more information about "Install.pm" see the
Fossies "Dox" file reference documentation and the last
Fossies "Diffs" side-by-side code changes report:
1.02_vs_1.04.
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.006;
21 use strict 'vars';
22 use Cwd ();
23 use File::Find ();
24 use File::Path ();
25
26 use vars qw{$VERSION $MAIN};
27 BEGIN {
28 # All Module::Install core packages now require synchronised versions.
29 # This will be used to ensure we don't accidentally load old or
30 # different versions of modules.
31 # This is not enforced yet, but will be some time in the next few
32 # releases once we can make sure it won't clash with custom
33 # Module::Install extensions.
34 $VERSION = '1.14';
35
36 # Storage for the pseudo-singleton
37 $MAIN = undef;
38
39 *inc::Module::Install::VERSION = *VERSION;
40 @inc::Module::Install::ISA = __PACKAGE__;
41
42 }
43
44 sub import {
45 my $class = shift;
46 my $self = $class->new(@_);
47 my $who = $self->_caller;
48
49 #-------------------------------------------------------------
50 # all of the following checks should be included in import(),
51 # to allow "eval 'require Module::Install; 1' to test
52 # installation of Module::Install. (RT #51267)
53 #-------------------------------------------------------------
54
55 # Whether or not inc::Module::Install is actually loaded, the
56 # $INC{inc/Module/Install.pm} is what will still get set as long as
57 # the caller loaded module this in the documented manner.
58 # If not set, the caller may NOT have loaded the bundled version, and thus
59 # they may not have a MI version that works with the Makefile.PL. This would
60 # result in false errors or unexpected behaviour. And we don't want that.
61 my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
62 unless ( $INC{$file} ) { die <<"END_DIE" }
63
64 Please invoke ${\__PACKAGE__} with:
65
66 use inc::${\__PACKAGE__};
67
68 not:
69
70 use ${\__PACKAGE__};
71
72 END_DIE
73
74 # This reportedly fixes a rare Win32 UTC file time issue, but
75 # as this is a non-cross-platform XS module not in the core,
76 # we shouldn't really depend on it. See RT #24194 for detail.
77 # (Also, this module only supports Perl 5.6 and above).
78 eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006;
79
80 # If the script that is loading Module::Install is from the future,
81 # then make will detect this and cause it to re-run over and over
82 # again. This is bad. Rather than taking action to touch it (which
83 # is unreliable on some platforms and requires write permissions)
84 # for now we should catch this and refuse to run.
85 if ( -f $0 ) {
86 my $s = (stat($0))[9];
87
88 # If the modification time is only slightly in the future,
89 # sleep briefly to remove the problem.
90 my $a = $s - time;
91 if ( $a > 0 and $a < 5 ) { sleep 5 }
92
93 # Too far in the future, throw an error.
94 my $t = time;
95 if ( $s > $t ) { die <<"END_DIE" }
96
97 Your installer $0 has a modification time in the future ($s > $t).
98
99 This is known to create infinite loops in make.
100
101 Please correct this, then run $0 again.
102
103 END_DIE
104 }
105
106
107 # Build.PL was formerly supported, but no longer is due to excessive
108 # difficulty in implementing every single feature twice.
109 if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
110
111 Module::Install no longer supports Build.PL.
112
113 It was impossible to maintain duel backends, and has been deprecated.
114
115 Please remove all Build.PL files and only use the Makefile.PL installer.
116
117 END_DIE
118
119 #-------------------------------------------------------------
120
121 # To save some more typing in Module::Install installers, every...
122 # use inc::Module::Install
123 # ...also acts as an implicit use strict.
124 $^H |= strict::bits(qw(refs subs vars));
125
126 #-------------------------------------------------------------
127
128 unless ( -f $self->{file} ) {
129 foreach my $key (keys %INC) {
130 delete $INC{$key} if $key =~ /Module\/Install/;
131 }
132
133 local $^W;
134 require "$self->{path}/$self->{dispatch}.pm";
135 File::Path::mkpath("$self->{prefix}/$self->{author}");
136 $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
137 $self->{admin}->init;
138 @_ = ($class, _self => $self);
139 goto &{"$self->{name}::import"};
140 }
141
142 local $^W;
143 *{"${who}::AUTOLOAD"} = $self->autoload;
144 $self->preload;
145
146 # Unregister loader and worker packages so subdirs can use them again
147 delete $INC{'inc/Module/Install.pm'};
148 delete $INC{'Module/Install.pm'};
149
150 # Save to the singleton
151 $MAIN = $self;
152
153 return 1;
154 }
155
156 sub autoload {
157 my $self = shift;
158 my $who = $self->_caller;
159 my $cwd = Cwd::getcwd();
160 my $sym = "${who}::AUTOLOAD";
161 $sym->{$cwd} = sub {
162 my $pwd = Cwd::getcwd();
163 if ( my $code = $sym->{$pwd} ) {
164 # Delegate back to parent dirs
165 goto &$code unless $cwd eq $pwd;
166 }
167 unless ($$sym =~ s/([^:]+)$//) {
168 # XXX: it looks like we can't retrieve the missing function
169 # via $$sym (usually $main::AUTOLOAD) in this case.
170 # I'm still wondering if we should slurp Makefile.PL to
171 # get some context or not ...
172 my ($package, $file, $line) = caller;
173 die <<"EOT";
174 Unknown function is found at $file line $line.
175 Execution of $file aborted due to runtime errors.
176
177 If you're a contributor to a project, you may need to install
178 some Module::Install extensions from CPAN (or other repository).
179 If you're a user of a module, please contact the author.
180 EOT
181 }
182 my $method = $1;
183 if ( uc($method) eq $method ) {
184 # Do nothing
185 return;
186 } elsif ( $method =~ /^_/ and $self->can($method) ) {
187 # Dispatch to the root M:I class
188 return $self->$method(@_);
189 }
190
191 # Dispatch to the appropriate plugin
192 unshift @_, ( $self, $1 );
193 goto &{$self->can('call')};
194 };
195 }
196
197 sub preload {
198 my $self = shift;
199 unless ( $self->{extensions} ) {
200 $self->load_extensions(
201 "$self->{prefix}/$self->{path}", $self
202 );
203 }
204
205 my @exts = @{$self->{extensions}};
206 unless ( @exts ) {
207 @exts = $self->{admin}->load_all_extensions;
208 }
209
210 my %seen;
211 foreach my $obj ( @exts ) {
212 while (my ($method, $glob) = each %{ref($obj) . '::'}) {
213 next unless $obj->can($method);
214 next if $method =~ /^_/;
215 next if $method eq uc($method);
216 $seen{$method}++;
217 }
218 }
219
220 my $who = $self->_caller;
221 foreach my $name ( sort keys %seen ) {
222 local $^W;
223 *{"${who}::$name"} = sub {
224 ${"${who}::AUTOLOAD"} = "${who}::$name";
225 goto &{"${who}::AUTOLOAD"};
226 };
227 }
228 }
229
230 sub new {
231 my ($class, %args) = @_;
232
233 delete $INC{'FindBin.pm'};
234 {
235 # to suppress the redefine warning
236 local $SIG{__WARN__} = sub {};
237 require FindBin;
238 }
239
240 # ignore the prefix on extension modules built from top level.
241 my $base_path = Cwd::abs_path($FindBin::Bin);
242 unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) {
243 delete $args{prefix};
244 }
245 return $args{_self} if $args{_self};
246
247 $args{dispatch} ||= 'Admin';
248 $args{prefix} ||= 'inc';
249 $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
250 $args{bundle} ||= 'inc/BUNDLES';
251 $args{base} ||= $base_path;
252 $class =~ s/^\Q$args{prefix}\E:://;
253 $args{name} ||= $class;
254 $args{version} ||= $class->VERSION;
255 unless ( $args{path} ) {
256 $args{path} = $args{name};
257 $args{path} =~ s!::!/!g;
258 }
259 $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
260 $args{wrote} = 0;
261
262 bless( \%args, $class );
263 }
264
265 sub call {
266 my ($self, $method) = @_;
267 my $obj = $self->load($method) or return;
268 splice(@_, 0, 2, $obj);
269 goto &{$obj->can($method)};
270 }
271
272 sub load {
273 my ($self, $method) = @_;
274
275 $self->load_extensions(
276 "$self->{prefix}/$self->{path}", $self
277 ) unless $self->{extensions};
278
279 foreach my $obj (@{$self->{extensions}}) {
280 return $obj if $obj->can($method);
281 }
282
283 my $admin = $self->{admin} or die <<"END_DIE";
284 The '$method' method does not exist in the '$self->{prefix}' path!
285 Please remove the '$self->{prefix}' directory and run $0 again to load it.
286 END_DIE
287
288 my $obj = $admin->load($method, 1);
289 push @{$self->{extensions}}, $obj;
290
291 $obj;
292 }
293
294 sub load_extensions {
295 my ($self, $path, $top) = @_;
296
297 my $should_reload = 0;
298 unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
299 unshift @INC, $self->{prefix};
300 $should_reload = 1;
301 }
302
303 foreach my $rv ( $self->find_extensions($path) ) {
304 my ($file, $pkg) = @{$rv};
305 next if $self->{pathnames}{$pkg};
306
307 local $@;
308 my $new = eval { local $^W; require $file; $pkg->can('new') };
309 unless ( $new ) {
310 warn $@ if $@;
311 next;
312 }
313 $self->{pathnames}{$pkg} =
314 $should_reload ? delete $INC{$file} : $INC{$file};
315 push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
316 }
317
318 $self->{extensions} ||= [];
319 }
320
321 sub find_extensions {
322 my ($self, $path) = @_;
323
324 my @found;
325 File::Find::find( sub {
326 my $file = $File::Find::name;
327 return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
328 my $subpath = $1;
329 return if lc($subpath) eq lc($self->{dispatch});
330
331 $file = "$self->{path}/$subpath.pm";
332 my $pkg = "$self->{name}::$subpath";
333 $pkg =~ s!/!::!g;
334
335 # If we have a mixed-case package name, assume case has been preserved
336 # correctly. Otherwise, root through the file to locate the case-preserved
337 # version of the package name.
338 if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
339 my $content = Module::Install::_read($subpath . '.pm');
340 my $in_pod = 0;
341 foreach ( split /\n/, $content ) {
342 $in_pod = 1 if /^=\w/;
343 $in_pod = 0 if /^=cut/;
344 next if ($in_pod || /^=cut/); # skip pod text
345 next if /^\s*#/; # and comments
346 if ( m/^\s*package\s+($pkg)\s*;/i ) {
347 $pkg = $1;
348 last;
349 }
350 }
351 }
352
353 push @found, [ $file, $pkg ];
354 }, $path ) if -d $path;
355
356 @found;
357 }
358
359
360
361
362
363 #####################################################################
364 # Common Utility Functions
365
366 sub _caller {
367 my $depth = 0;
368 my $call = caller($depth);
369 while ( $call eq __PACKAGE__ ) {
370 $depth++;
371 $call = caller($depth);
372 }
373 return $call;
374 }
375
376 # Done in evals to avoid confusing Perl::MinimumVersion
377 eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
378 sub _read {
379 local *FH;
380 open( FH, '<', $_[0] ) or die "open($_[0]): $!";
381 binmode FH;
382 my $string = do { local $/; <FH> };
383 close FH or die "close($_[0]): $!";
384 return $string;
385 }
386 END_NEW
387 sub _read {
388 local *FH;
389 open( FH, "< $_[0]" ) or die "open($_[0]): $!";
390 binmode FH;
391 my $string = do { local $/; <FH> };
392 close FH or die "close($_[0]): $!";
393 return $string;
394 }
395 END_OLD
396
397 sub _readperl {
398 my $string = Module::Install::_read($_[0]);
399 $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
400 $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
401 $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
402 return $string;
403 }
404
405 sub _readpod {
406 my $string = Module::Install::_read($_[0]);
407 $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
408 return $string if $_[0] =~ /\.pod\z/;
409 $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
410 $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
411 $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
412 $string =~ s/^\n+//s;
413 return $string;
414 }
415
416 # Done in evals to avoid confusing Perl::MinimumVersion
417 eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
418 sub _write {
419 local *FH;
420 open( FH, '>', $_[0] ) or die "open($_[0]): $!";
421 binmode FH;
422 foreach ( 1 .. $#_ ) {
423 print FH $_[$_] or die "print($_[0]): $!";
424 }
425 close FH or die "close($_[0]): $!";
426 }
427 END_NEW
428 sub _write {
429 local *FH;
430 open( FH, "> $_[0]" ) or die "open($_[0]): $!";
431 binmode FH;
432 foreach ( 1 .. $#_ ) {
433 print FH $_[$_] or die "print($_[0]): $!";
434 }
435 close FH or die "close($_[0]): $!";
436 }
437 END_OLD
438
439 # _version is for processing module versions (eg, 1.03_05) not
440 # Perl versions (eg, 5.8.1).
441 sub _version {
442 my $s = shift || 0;
443 my $d =()= $s =~ /(\.)/g;
444 if ( $d >= 2 ) {
445 # Normalise multipart versions
446 $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
447 }
448 $s =~ s/^(\d+)\.?//;
449 my $l = $1 || 0;
450 my @v = map {
451 $_ . '0' x (3 - length $_)
452 } $s =~ /(\d{1,3})\D?/g;
453 $l = $l . '.' . join '', @v if @v;
454 return $l + 0;
455 }
456
457 sub _cmp {
458 _version($_[1]) <=> _version($_[2]);
459 }
460
461 # Cloned from Params::Util::_CLASS
462 sub _CLASS {
463 (
464 defined $_[0]
465 and
466 ! ref $_[0]
467 and
468 $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
469 ) ? $_[0] : undef;
470 }
471
472 1;
473
474 # Copyright 2008 - 2012 Adam Kennedy.