/[vz-tools]/trunk/inc/Module/Install.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /trunk/inc/Module/Install.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 51 by dpavlin, Thu Nov 8 11:35:15 2007 UTC revision 52 by dpavlin, Fri Aug 15 09:59:29 2008 UTC
# Line 17  package Module::Install; Line 17  package Module::Install;
17  #     3. The ./inc/ version of Module::Install loads  #     3. The ./inc/ version of Module::Install loads
18  # }  # }
19    
20  use 5.004;  BEGIN {
21            require 5.004;
22    }
23  use strict 'vars';  use strict 'vars';
24    
25  use vars qw{$VERSION};  use vars qw{$VERSION};
26  BEGIN {  BEGIN {
27      # All Module::Install core packages now require synchronised versions.          # All Module::Install core packages now require synchronised versions.
28      # This will be used to ensure we don't accidentally load old or          # This will be used to ensure we don't accidentally load old or
29      # different versions of modules.          # different versions of modules.
30      # This is not enforced yet, but will be some time in the next few          # This is not enforced yet, but will be some time in the next few
31      # releases once we can make sure it won't clash with custom          # releases once we can make sure it won't clash with custom
32      # Module::Install extensions.          # Module::Install extensions.
33      $VERSION = '0.67';          $VERSION = '0.76';
34    
35            *inc::Module::Install::VERSION = *VERSION;
36            @inc::Module::Install::ISA     = __PACKAGE__;
37    
38  }  }
39    
40    
41    
42    
43    
44  # Whether or not inc::Module::Install is actually loaded, the  # Whether or not inc::Module::Install is actually loaded, the
45  # $INC{inc/Module/Install.pm} is what will still get set as long as  # $INC{inc/Module/Install.pm} is what will still get set as long as
46  # the caller loaded module this in the documented manner.  # the caller loaded module this in the documented manner.
# Line 38  BEGIN { Line 48  BEGIN {
48  # they may not have a MI version that works with the Makefile.PL. This would  # they may not have a MI version that works with the Makefile.PL. This would
49  # result in false errors or unexpected behaviour. And we don't want that.  # result in false errors or unexpected behaviour. And we don't want that.
50  my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';  my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
51  unless ( $INC{$file} ) {  unless ( $INC{$file} ) { die <<"END_DIE" }
52      die <<"END_DIE";  
53  Please invoke ${\__PACKAGE__} with:  Please invoke ${\__PACKAGE__} with:
54    
55      use inc::${\__PACKAGE__};          use inc::${\__PACKAGE__};
56    
57  not:  not:
58    
59      use ${\__PACKAGE__};          use ${\__PACKAGE__};
60    
61  END_DIE  END_DIE
62  }  
63    
64    
65    
66    
67  # If the script that is loading Module::Install is from the future,  # If the script that is loading Module::Install is from the future,
68  # then make will detect this and cause it to re-run over and over  # then make will detect this and cause it to re-run over and over
69  # again. This is bad. Rather than taking action to touch it (which  # again. This is bad. Rather than taking action to touch it (which
70  # is unreliable on some platforms and requires write permissions)  # is unreliable on some platforms and requires write permissions)
71  # for now we should catch this and refuse to run.  # for now we should catch this and refuse to run.
72  if ( -f $0 and (stat($0))[9] > time ) {  if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" }
73          die << "END_DIE";  
74  Your installer $0 has a modification time in the future.  Your installer $0 has a modification time in the future.
75    
76  This is known to create infinite loops in make.  This is known to create infinite loops in make.
# Line 65  This is known to create infinite loops i Line 78  This is known to create infinite loops i
78  Please correct this, then run $0 again.  Please correct this, then run $0 again.
79    
80  END_DIE  END_DIE
81  }  
82    
83    
84    
85    
86    # Build.PL was formerly supported, but no longer is due to excessive
87    # difficulty in implementing every single feature twice.
88    if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
89    
90    Module::Install no longer supports Build.PL.
91    
92    It was impossible to maintain duel backends, and has been deprecated.
93    
94    Please remove all Build.PL files and only use the Makefile.PL installer.
95    
96    END_DIE
97    
98    
99    
100    
101    
102    # To save some more typing in Module::Install installers, every...
103    # use inc::Module::Install
104    # ...also acts as an implicit use strict.
105    $^H |= strict::bits(qw(refs subs vars));
106    
107    
108    
109    
110    
111  use Cwd        ();  use Cwd        ();
112  use File::Find ();  use File::Find ();
113  use File::Path ();  use File::Path ();
114  use FindBin;  use FindBin;
115    
 *inc::Module::Install::VERSION = *VERSION;  
 @inc::Module::Install::ISA     = __PACKAGE__;  
   
116  sub autoload {  sub autoload {
117      my $self = shift;          my $self = shift;
118      my $who  = $self->_caller;          my $who  = $self->_caller;
119      my $cwd  = Cwd::cwd();          my $cwd  = Cwd::cwd();
120      my $sym  = "${who}::AUTOLOAD";          my $sym  = "${who}::AUTOLOAD";
121      $sym->{$cwd} = sub {          $sym->{$cwd} = sub {
122          my $pwd = Cwd::cwd();                  my $pwd = Cwd::cwd();
123          if ( my $code = $sym->{$pwd} ) {                  if ( my $code = $sym->{$pwd} ) {
124              # delegate back to parent dirs                          # delegate back to parent dirs
125              goto &$code unless $cwd eq $pwd;                          goto &$code unless $cwd eq $pwd;
126          }                  }
127          $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";                  $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
128          unshift @_, ($self, $1);                  unshift @_, ( $self, $1 );
129          goto &{$self->can('call')} unless uc($1) eq $1;                  goto &{$self->can('call')} unless uc($1) eq $1;
130      };          };
131  }  }
132    
133  sub import {  sub import {
134      my $class = shift;          my $class = shift;
135      my $self  = $class->new(@_);          my $self  = $class->new(@_);
136      my $who   = $self->_caller;          my $who   = $self->_caller;
137    
138      unless ( -f $self->{file} ) {          unless ( -f $self->{file} ) {
139          require "$self->{path}/$self->{dispatch}.pm";                  require "$self->{path}/$self->{dispatch}.pm";
140          File::Path::mkpath("$self->{prefix}/$self->{author}");                  File::Path::mkpath("$self->{prefix}/$self->{author}");
141          $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );                  $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
142          $self->{admin}->init;                  $self->{admin}->init;
143          @_ = ($class, _self => $self);                  @_ = ($class, _self => $self);
144          goto &{"$self->{name}::import"};                  goto &{"$self->{name}::import"};
145      }          }
146    
147      *{"${who}::AUTOLOAD"} = $self->autoload;          *{"${who}::AUTOLOAD"} = $self->autoload;
148      $self->preload;          $self->preload;
149    
150      # Unregister loader and worker packages so subdirs can use them again          # Unregister loader and worker packages so subdirs can use them again
151      delete $INC{"$self->{file}"};          delete $INC{"$self->{file}"};
152      delete $INC{"$self->{path}.pm"};          delete $INC{"$self->{path}.pm"};
153    
154            return 1;
155  }  }
156    
157  sub preload {  sub preload {
158      my ($self) = @_;          my $self = shift;
159            unless ( $self->{extensions} ) {
160      unless ( $self->{extensions} ) {                  $self->load_extensions(
161          $self->load_extensions(                          "$self->{prefix}/$self->{path}", $self
162              "$self->{prefix}/$self->{path}", $self                  );
163          );          }
164      }  
165            my @exts = @{$self->{extensions}};
166      my @exts = @{$self->{extensions}};          unless ( @exts ) {
167      unless ( @exts ) {                  my $admin = $self->{admin};
168          my $admin = $self->{admin};                  @exts = $admin->load_all_extensions;
169          @exts = $admin->load_all_extensions;          }
170      }  
171            my %seen;
172      my %seen;          foreach my $obj ( @exts ) {
173      foreach my $obj ( @exts ) {                  while (my ($method, $glob) = each %{ref($obj) . '::'}) {
174          while (my ($method, $glob) = each %{ref($obj) . '::'}) {                          next unless $obj->can($method);
175              next unless $obj->can($method);                          next if $method =~ /^_/;
176              next if $method =~ /^_/;                          next if $method eq uc($method);
177              next if $method eq uc($method);                          $seen{$method}++;
178              $seen{$method}++;                  }
179          }          }
180      }  
181            my $who = $self->_caller;
182      my $who = $self->_caller;          foreach my $name ( sort keys %seen ) {
183      foreach my $name ( sort keys %seen ) {                  *{"${who}::$name"} = sub {
184          *{"${who}::$name"} = sub {                          ${"${who}::AUTOLOAD"} = "${who}::$name";
185              ${"${who}::AUTOLOAD"} = "${who}::$name";                          goto &{"${who}::AUTOLOAD"};
186              goto &{"${who}::AUTOLOAD"};                  };
187          };          }
     }  
188  }  }
189    
190  sub new {  sub new {
191      my ($class, %args) = @_;          my ($class, %args) = @_;
192    
193      # ignore the prefix on extension modules built from top level.          # ignore the prefix on extension modules built from top level.
194      my $base_path = Cwd::abs_path($FindBin::Bin);          my $base_path = Cwd::abs_path($FindBin::Bin);
195      unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {          unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
196          delete $args{prefix};                  delete $args{prefix};
197      }          }
198    
199      return $args{_self} if $args{_self};          return $args{_self} if $args{_self};
200    
201      $args{dispatch} ||= 'Admin';          $args{dispatch} ||= 'Admin';
202      $args{prefix}   ||= 'inc';          $args{prefix}   ||= 'inc';
203      $args{author}   ||= ($^O eq 'VMS' ? '_author' : '.author');          $args{author}   ||= ($^O eq 'VMS' ? '_author' : '.author');
204      $args{bundle}   ||= 'inc/BUNDLES';          $args{bundle}   ||= 'inc/BUNDLES';
205      $args{base}     ||= $base_path;          $args{base}     ||= $base_path;
206      $class =~ s/^\Q$args{prefix}\E:://;          $class =~ s/^\Q$args{prefix}\E:://;
207      $args{name}     ||= $class;          $args{name}     ||= $class;
208      $args{version}  ||= $class->VERSION;          $args{version}  ||= $class->VERSION;
209      unless ( $args{path} ) {          unless ( $args{path} ) {
210          $args{path}  = $args{name};                  $args{path}  = $args{name};
211          $args{path}  =~ s!::!/!g;                  $args{path}  =~ s!::!/!g;
212      }          }
213      $args{file}     ||= "$args{base}/$args{prefix}/$args{path}.pm";          $args{file}     ||= "$args{base}/$args{prefix}/$args{path}.pm";
214            $args{wrote}      = 0;
215    
216      bless( \%args, $class );          bless( \%args, $class );
217  }  }
218    
219  sub call {  sub call {
# Line 184  sub call { Line 224  sub call {
224  }  }
225    
226  sub load {  sub load {
227      my ($self, $method) = @_;          my ($self, $method) = @_;
   
     $self->load_extensions(  
         "$self->{prefix}/$self->{path}", $self  
     ) unless $self->{extensions};  
228    
229      foreach my $obj (@{$self->{extensions}}) {          $self->load_extensions(
230          return $obj if $obj->can($method);                  "$self->{prefix}/$self->{path}", $self
231      }          ) unless $self->{extensions};
232    
233            foreach my $obj (@{$self->{extensions}}) {
234                    return $obj if $obj->can($method);
235            }
236    
237      my $admin = $self->{admin} or die <<"END_DIE";          my $admin = $self->{admin} or die <<"END_DIE";
238  The '$method' method does not exist in the '$self->{prefix}' path!  The '$method' method does not exist in the '$self->{prefix}' path!
239  Please remove the '$self->{prefix}' directory and run $0 again to load it.  Please remove the '$self->{prefix}' directory and run $0 again to load it.
240  END_DIE  END_DIE
241    
242      my $obj = $admin->load($method, 1);          my $obj = $admin->load($method, 1);
243      push @{$self->{extensions}}, $obj;          push @{$self->{extensions}}, $obj;
244    
245      $obj;          $obj;
246  }  }
247    
248  sub load_extensions {  sub load_extensions {
249      my ($self, $path, $top) = @_;          my ($self, $path, $top) = @_;
250    
251      unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {          unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
252          unshift @INC, $self->{prefix};                  unshift @INC, $self->{prefix};
253      }          }
254    
255      foreach my $rv ( $self->find_extensions($path) ) {          foreach my $rv ( $self->find_extensions($path) ) {
256          my ($file, $pkg) = @{$rv};                  my ($file, $pkg) = @{$rv};
257          next if $self->{pathnames}{$pkg};                  next if $self->{pathnames}{$pkg};
258    
259          local $@;                  local $@;
260          my $new = eval { require $file; $pkg->can('new') };                  my $new = eval { require $file; $pkg->can('new') };
261          unless ( $new ) {                  unless ( $new ) {
262              warn $@ if $@;                          warn $@ if $@;
263              next;                          next;
264          }                  }
265          $self->{pathnames}{$pkg} = delete $INC{$file};                  $self->{pathnames}{$pkg} = delete $INC{$file};
266          push @{$self->{extensions}}, &{$new}($pkg, _top => $top );                  push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
267      }          }
268    
269      $self->{extensions} ||= [];          $self->{extensions} ||= [];
270  }  }
271    
272  sub find_extensions {  sub find_extensions {
273      my ($self, $path) = @_;          my ($self, $path) = @_;
274    
275            my @found;
276            File::Find::find( sub {
277                    my $file = $File::Find::name;
278                    return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
279                    my $subpath = $1;
280                    return if lc($subpath) eq lc($self->{dispatch});
281    
282                    $file = "$self->{path}/$subpath.pm";
283                    my $pkg = "$self->{name}::$subpath";
284                    $pkg =~ s!/!::!g;
285    
286      my @found;                  # If we have a mixed-case package name, assume case has been preserved
287      File::Find::find( sub {                  # correctly.  Otherwise, root through the file to locate the case-preserved
288          my $file = $File::Find::name;                  # version of the package name.
289          return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;                  if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
290          my $subpath = $1;                          my $content = Module::Install::_read($subpath . '.pm');
291          return if lc($subpath) eq lc($self->{dispatch});                          my $in_pod  = 0;
292                            foreach ( split //, $content ) {
293          $file = "$self->{path}/$subpath.pm";                                  $in_pod = 1 if /^=\w/;
294          my $pkg = "$self->{name}::$subpath";                                  $in_pod = 0 if /^=cut/;
295          $pkg =~ s!/!::!g;                                  next if ($in_pod || /^=cut/);  # skip pod text
296                                    next if /^\s*#/;               # and comments
297          # If we have a mixed-case package name, assume case has been preserved                                  if ( m/^\s*package\s+($pkg)\s*;/i ) {
298          # correctly.  Otherwise, root through the file to locate the case-preserved                                          $pkg = $1;
299          # version of the package name.                                          last;
300          if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {                                  }
301              open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!";                          }
302              my $in_pod = 0;                  }
             while ( <PKGFILE> ) {  
                 $in_pod = 1 if /^=\w/;  
                 $in_pod = 0 if /^=cut/;  
                 next if ($in_pod || /^=cut/);  # skip pod text  
                 next if /^\s*#/;               # and comments  
                 if ( m/^\s*package\s+($pkg)\s*;/i ) {  
                     $pkg = $1;  
                     last;  
                 }  
             }  
             close PKGFILE;  
         }  
303    
304          push @found, [ $file, $pkg ];                  push @found, [ $file, $pkg ];
305      }, $path ) if -d $path;          }, $path ) if -d $path;
306    
307      @found;          @found;
308  }  }
309    
310    
311    
312    
313    
314    #####################################################################
315    # Utility Functions
316    
317  sub _caller {  sub _caller {
318      my $depth = 0;          my $depth = 0;
319      my $call  = caller($depth);          my $call  = caller($depth);
320      while ( $call eq __PACKAGE__ ) {          while ( $call eq __PACKAGE__ ) {
321          $depth++;                  $depth++;
322          $call = caller($depth);                  $call = caller($depth);
323      }          }
324      return $call;          return $call;
325    }
326    
327    sub _read {
328            local *FH;
329            open FH, "< $_[0]" or die "open($_[0]): $!";
330            my $str = do { local $/; <FH> };
331            close FH or die "close($_[0]): $!";
332            return $str;
333    }
334    
335    sub _write {
336            local *FH;
337            open FH, "> $_[0]" or die "open($_[0]): $!";
338            foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
339            close FH or die "close($_[0]): $!";
340    }
341    
342    sub _version ($) {
343            my $s = shift || 0;
344               $s =~ s/^(\d+)\.?//;
345            my $l = $1 || 0;
346            my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
347               $l = $l . '.' . join '', @v if @v;
348            return $l + 0;
349    }
350    
351    # Cloned from Params::Util::_CLASS
352    sub _CLASS ($) {
353            (
354                    defined $_[0]
355                    and
356                    ! ref $_[0]
357                    and
358                    $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s
359            ) ? $_[0] : undef;
360  }  }
361    
362  1;  1;
363    
364    # Copyright 2008 Adam Kennedy.
Legend:
Removed from v.51  
changed lines
  Added in v.52
  ViewVC Help
Powered by ViewVC 1.1.26