"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.