[Summary view] [Print] [Text view]

   1  package CPANPLUS::inc;
   2  
   3  =head1 NAME
   4  
   5  CPANPLUS::inc
   6  
   7  =head1 DESCRIPTION
   8  
   9  OBSOLETE
  10  
  11  =cut
  12  
  13  sub original_perl5opt   { $ENV{PERL5OPT}    };
  14  sub original_perl5lib   { $ENV{PERL5LIB}    };
  15  sub original_inc        { @INC              };
  16  
  17  1;
  18  
  19  __END__
  20  
  21  use strict;
  22  use vars        qw[$DEBUG $VERSION $ENABLE_INC_HOOK %LIMIT $QUIET];
  23  use File::Spec  ();
  24  use Config      ();
  25  
  26  ### 5.6.1. nags about require + bareword otherwise ###
  27  use lib ();
  28  
  29  $QUIET              = 0;
  30  $DEBUG              = 0;
  31  %LIMIT              = ();
  32  
  33  =pod
  34  
  35  =head1 NAME
  36  
  37  CPANPLUS::inc - runtime inclusion of privately bundled modules
  38  
  39  =head1 SYNOPSIS
  40  
  41      ### set up CPANPLUS::inc to do it's thing ###
  42      BEGIN { use CPANPLUS::inc };
  43  
  44      ### enable debugging ###
  45      use CPANPLUS::inc qw[DEBUG];
  46  
  47  =head1 DESCRIPTION
  48  
  49  This module enables the use of the bundled modules in the
  50  C<CPANPLUS/inc> directory of this package. These modules are bundled
  51  to make sure C<CPANPLUS> is able to bootstrap itself. It will do the
  52  following things:
  53  
  54  =over 4
  55  
  56  =item Put a coderef at the beginning of C<@INC>
  57  
  58  This allows us to decide which module to load, and where to find it.
  59  For details on what we do, see the C<INTERESTING MODULES> section below.
  60  Also see the C<CAVEATS> section.
  61  
  62  =item Add the full path to the C<CPANPLUS/inc> directory to C<$ENV{PERL5LIB>.
  63  
  64  This allows us to find our bundled modules even if we spawn off a new
  65  process. Although it's not able to do the selective loading as the
  66  coderef in C<@INC> could, it's a good fallback.
  67  
  68  =back
  69  
  70  =head1 METHODS
  71  
  72  =head2 CPANPLUS::inc->inc_path()
  73  
  74  Returns the full path to the C<CPANPLUS/inc> directory.
  75  
  76  =head2 CPANPLUS::inc->my_path()
  77  
  78  Returns the full path to be added to C<@INC> to load
  79  C<CPANPLUS::inc> from.
  80  
  81  =head2 CPANPLUS::inc->installer_path()
  82  
  83  Returns the full path to the C<CPANPLUS/inc/installers> directory.
  84  
  85  =cut
  86  
  87  {   my $ext     = '.pm';
  88      my $file    = (join '/', split '::', __PACKAGE__) . $ext;
  89  
  90      ### os specific file path, if you're not on unix
  91      my $osfile  = File::Spec->catfile( split('::', __PACKAGE__) ) . $ext;
  92  
  93      ### this returns a unixy path, compensate if you're on non-unix
  94      my $path    = File::Spec->rel2abs(
  95                          File::Spec->catfile( split '/', $INC{$file} )
  96                      );
  97  
  98      ### don't forget to quotemeta; win32 paths are special
  99      my $qm_osfile = quotemeta $osfile;
 100      my $path_to_me          = $path; $path_to_me    =~ s/$qm_osfile$//i;
 101      my $path_to_inc         = $path; $path_to_inc   =~ s/$ext$//i;
 102      my $path_to_installers  = File::Spec->catdir( $path_to_inc, 'installers' );
 103  
 104      sub inc_path        { return $path_to_inc  }
 105      sub my_path         { return $path_to_me   }
 106      sub installer_path  { return $path_to_installers }
 107  }
 108  
 109  =head2 CPANPLUS::inc->original_perl5lib
 110  
 111  Returns the value of $ENV{PERL5LIB} the way it was when C<CPANPLUS::inc>
 112  got loaded.
 113  
 114  =head2 CPANPLUS::inc->original_perl5opt
 115  
 116  Returns the value of $ENV{PERL5OPT} the way it was when C<CPANPLUS::inc>
 117  got loaded.
 118  
 119  =head2 CPANPLUS::inc->original_inc
 120  
 121  Returns the value of @INC the way it was when C<CPANPLUS::inc> got
 122  loaded.
 123  
 124  =head2 CPANPLUS::inc->limited_perl5opt(@modules);
 125  
 126  Returns a string you can assign to C<$ENV{PERL5OPT}> to have a limited
 127  include facility from C<CPANPLUS::inc>. It will roughly look like:
 128  
 129      -I/path/to/cpanplus/inc -MCPANPLUS::inc=module1,module2
 130  
 131  =cut
 132  
 133  {   my $org_opt = $ENV{PERL5OPT};
 134      my $org_lib = $ENV{PERL5LIB};
 135      my @org_inc = @INC;
 136  
 137      sub original_perl5opt   { $org_opt || ''};
 138      sub original_perl5lib   { $org_lib || ''};
 139      sub original_inc        { @org_inc, __PACKAGE__->my_path };
 140  
 141      sub limited_perl5opt    {
 142          my $pkg = shift;
 143          my $lim = join ',', @_ or return;
 144  
 145          ### -Icp::inc -Mcp::inc=mod1,mod2,mod3
 146          my $opt =   '-I' . __PACKAGE__->my_path . ' ' .
 147                      '-M' . __PACKAGE__ . "=$lim";
 148  
 149          $opt .=     $Config::Config{'path_sep'} .
 150                      CPANPLUS::inc->original_perl5opt
 151                  if  CPANPLUS::inc->original_perl5opt;
 152  
 153          return $opt;
 154      }
 155  }
 156  
 157  =head2 CPANPLUS::inc->interesting_modules()
 158  
 159  Returns a hashref with modules we're interested in, and the minimum
 160  version we need to find.
 161  
 162  It would looks something like this:
 163  
 164      {   File::Fetch             => 0.06,
 165          IPC::Cmd                => 0.22,
 166          ....
 167      }
 168  
 169  =cut
 170  
 171  {
 172      my $map = {
 173          ### used to have 0.80, but not it was never released by coral
 174          ### 0.79 *should* be good enough for now... asked coral to 
 175          ### release 0.80 on 10/3/2006
 176          'IPC::Run'                  => '0.79', 
 177          'File::Fetch'               => '0.07',
 178          #'File::Spec'                => '0.82', # can't, need it ourselves...
 179          'IPC::Cmd'                  => '0.24',
 180          'Locale::Maketext::Simple'  => 0,
 181          'Log::Message'              => 0,
 182          'Module::Load'              => '0.10',
 183          'Module::Load::Conditional' => '0.07',
 184          'Params::Check'             => '0.22',
 185          'Term::UI'                  => '0.05',
 186          'Archive::Extract'          => '0.07',
 187          'Archive::Tar'              => '1.23',
 188          'IO::Zlib'                  => '1.04',
 189          'Object::Accessor'          => '0.03',
 190          'Module::CoreList'          => '1.97',
 191          'Module::Pluggable'         => '2.4',
 192          'Module::Loaded'            => 0,
 193          #'Config::Auto'             => 0,   # not yet, not using it yet
 194      };
 195  
 196      sub interesting_modules { return $map; }
 197  }
 198  
 199  
 200  =head1 INTERESTING MODULES
 201  
 202  C<CPANPLUS::inc> doesn't even bother to try find and find a module
 203  it's not interested in. A list of I<interesting modules> can be
 204  obtained using the C<interesting_modules> method described above.
 205  
 206  Note that all subclassed modules of an C<interesting module> will
 207  also be attempted to be loaded, but a version will not be checked.
 208  
 209  When it however does encounter a module it is interested in, it will
 210  do the following things:
 211  
 212  =over 4
 213  
 214  =item Loop over your @INC
 215  
 216  And for every directory it finds there (skipping all non directories
 217  -- see the C<CAVEATS> section), see if the module requested can be
 218  found there.
 219  
 220  =item Check the version on every suitable module found in @INC
 221  
 222  After a list of modules has been gathered, the version of each of them
 223  is checked to find the one with the highest version, and return that as
 224  the module to C<use>.
 225  
 226  This enables us to use a recent enough version from our own bundled
 227  modules, but also to use a I<newer> module found in your path instead,
 228  if it is present. Thus having access to bugfixed versions as they are
 229  released.
 230  
 231  If for some reason no satisfactory version could be found, a warning
 232  will be emitted. See the C<DEBUG> section for more details on how to
 233  find out exactly what C<CPANPLUS::inc> is doing.
 234  
 235  =back
 236  
 237  =cut
 238  
 239  {   my $Loaded;
 240      my %Cache;
 241  
 242  
 243      ### returns the path to a certain module we found
 244      sub path_to {
 245          my $self    = shift;
 246          my $mod     = shift or return;
 247  
 248          ### find the directory
 249          my $path    = $Cache{$mod}->[0][2] or return;
 250  
 251          ### probe them explicitly for a special file, because the
 252          ### dir we found the file in vs our own paths may point to the
 253          ### same location, but might not pass an 'eq' test.
 254  
 255          ### it's our inc-path
 256          return __PACKAGE__->inc_path
 257                  if -e File::Spec->catfile( $path, '.inc' );
 258  
 259          ### it's our installer path
 260          return __PACKAGE__->installer_path
 261                  if -e File::Spec->catfile( $path, '.installers' );
 262  
 263          ### it's just some dir...
 264          return $path;
 265      }
 266  
 267      ### just a debug method
 268      sub _show_cache { return \%Cache };
 269  
 270      sub import {
 271          my $pkg = shift;
 272  
 273          ### filter DEBUG, and toggle the global
 274          map { $LIMIT{$_} = 1 }  
 275              grep {  /DEBUG/ ? ++$DEBUG && 0 : 
 276                      /QUIET/ ? ++$QUIET && 0 :
 277                      1 
 278              } @_;
 279          
 280          ### only load once ###
 281          return 1 if $Loaded++;
 282  
 283          ### first, add our own private dir to the end of @INC:
 284          {
 285              push @INC,  __PACKAGE__->my_path, __PACKAGE__->inc_path,
 286                          __PACKAGE__->installer_path;
 287  
 288              ### XXX stop doing this, there's no need for it anymore;
 289              ### none of the shell outs need to have this set anymore
 290  #             ### add the path to this module to PERL5OPT in case
 291  #             ### we spawn off some programs...
 292  #             ### then add this module to be loaded in PERL5OPT...
 293  #             {   local $^W;
 294  #                 $ENV{'PERL5LIB'} .= $Config::Config{'path_sep'}
 295  #                                  . __PACKAGE__->my_path
 296  #                                  . $Config::Config{'path_sep'}
 297  #                                  . __PACKAGE__->inc_path;
 298  #
 299  #                 $ENV{'PERL5OPT'} = '-M'. __PACKAGE__ . ' '
 300  #                                  . ($ENV{'PERL5OPT'} || '');
 301  #             }
 302          }
 303  
 304          ### next, find the highest version of a module that
 305          ### we care about. very basic check, but will
 306          ### have to do for now.
 307          lib->import( sub {
 308              my $path    = pop();                    # path to the pm
 309              my $module  = $path or return;          # copy of the path, to munge
 310              my @parts   = split qr!\\|/!, $path;    # dirs + file name; could be
 311                                                      # win32 paths =/
 312              my $file    = pop @parts;               # just the file name
 313              my $map     = __PACKAGE__->interesting_modules;
 314  
 315              ### translate file name to module name 
 316              ### could contain win32 paths delimiters
 317              $module =~ s!/|\\!::!g; $module =~ s/\.pm//i;
 318  
 319              my $check_version; my $try;
 320              ### does it look like a module we care about?
 321              my ($interesting) = grep { $module =~ /^$_/ } keys %$map;
 322              ++$try if $interesting;
 323  
 324              ### do we need to check the version too?
 325              ++$check_version if exists $map->{$module};
 326  
 327              ### we don't care ###
 328              unless( $try ) {
 329                  warn __PACKAGE__ .": Not interested in '$module'\n" if $DEBUG;
 330                  return;
 331  
 332              ### we're not allowed
 333              } elsif ( $try and keys %LIMIT ) {
 334                  unless( grep { $module =~ /^$_/ } keys %LIMIT  ) {
 335                      warn __PACKAGE__ .": Limits active, '$module' not allowed ".
 336                                          "to be loaded" if $DEBUG;
 337                      return;
 338                  }
 339              }
 340  
 341              ### found filehandles + versions ###
 342              my @found;
 343              DIR: for my $dir (@INC) {
 344                  next DIR unless -d $dir;
 345  
 346                  ### get the full path to the module ###
 347                  my $pm = File::Spec->catfile( $dir, @parts, $file );
 348  
 349                  ### open the file if it exists ###
 350                  if( -e $pm ) {
 351                      my $fh;
 352                      unless( open $fh, "$pm" ) {
 353                          warn __PACKAGE__ .": Could not open '$pm': $!\n"
 354                              if $DEBUG;
 355                          next DIR;
 356                      }
 357  
 358                      my $found;
 359                      ### XXX stolen from module::load::conditional ###
 360                      while (local $_ = <$fh> ) {
 361  
 362                          ### the following regexp comes from the
 363                          ### ExtUtils::MakeMaker documentation.
 364                          if ( /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/ ) {
 365  
 366                              ### this will eval the version in to $VERSION if it
 367                              ### was declared as $VERSION in the module.
 368                              ### else the result will be in $res.
 369                              ### this is a fix on skud's Module::InstalledVersion
 370  
 371                              local $VERSION;
 372                              my $res = eval $_;
 373  
 374                              ### default to '0.0' if there REALLY is no version
 375                              ### all to satisfy warnings
 376                              $found = $VERSION || $res || '0.0';
 377  
 378                              ### found what we came for
 379                              last if $found;
 380                          }
 381                      }
 382  
 383                      ### no version defined at all? ###
 384                      $found ||= '0.0';
 385  
 386                      warn __PACKAGE__ .": Found match for '$module' in '$dir' "
 387                                       ."with version '$found'\n" if $DEBUG;
 388  
 389                      ### reset the position of the filehandle ###
 390                      seek $fh, 0, 0;
 391  
 392                      ### store the found version + filehandle it came from ###
 393                      push @found, [ $found, $fh, $dir, $pm ];
 394                  }
 395  
 396              } # done looping over all the dirs
 397  
 398              ### nothing found? ###
 399              unless (@found) {
 400                  warn __PACKAGE__ .": Unable to find any module named "
 401                                      . "'$module'\n" if $DEBUG;
 402                  return;
 403              }
 404  
 405              ### find highest version
 406              ### or the one in the same dir as a base module already loaded
 407              ### or otherwise, the one not bundled
 408              ### or otherwise the newest
 409              my @sorted = sort {
 410                              _vcmp($b->[0], $a->[0])                  ||
 411                              ($Cache{$interesting}
 412                                  ?($b->[2] eq $Cache{$interesting}->[0][2]) <=>
 413                                   ($a->[2] eq $Cache{$interesting}->[0][2])
 414                                  : 0 )                               ||
 415                              (($a->[2] eq __PACKAGE__->inc_path) <=>
 416                               ($b->[2] eq __PACKAGE__->inc_path))    ||
 417                              (-M $a->[3] <=> -M $b->[3])
 418                            } @found;
 419  
 420              warn __PACKAGE__ .": Best match for '$module' is found in "
 421                               ."'$sorted[0][2]' with version '$sorted[0][0]'\n"
 422                      if $DEBUG;
 423  
 424              if( $check_version and 
 425                  not (_vcmp($sorted[0][0], $map->{$module}) >= 0) 
 426              ) {
 427                  warn __PACKAGE__ .": Cannot find high enough version for "
 428                                   ."'$module' -- need '$map->{$module}' but "
 429                                   ."only found '$sorted[0][0]'. Returning "
 430                                   ."highest found version but this may cause "
 431                                   ."problems\n" unless $QUIET;
 432              };
 433  
 434              ### right, so that damn )#$(*@#)(*@#@ Module::Build makes
 435              ### assumptions about the environment (especially its own tests)
 436              ### and blows up badly if it's loaded via CP::inc :(
 437              ### so, if we find a newer version on disk (which would happen when
 438              ### upgrading or having upgraded, just pretend we didn't find it,
 439              ### let it be loaded via the 'normal' way.
 440              ### can't even load the *proper* one via our CP::inc, as it will
 441              ### get upset just over the fact it's loaded via a non-standard way
 442              if( $module =~ /^Module::Build/ and
 443                  $sorted[0][2] ne __PACKAGE__->inc_path and
 444                  $sorted[0][2] ne __PACKAGE__->installer_path
 445              ) {
 446                  warn __PACKAGE__ .": Found newer version of 'Module::Build::*' "
 447                                   ."elsewhere in your path. Pretending to not "
 448                                   ."have found it\n" if $DEBUG;
 449                  return;
 450              }
 451  
 452              ### store what we found for this module
 453              $Cache{$module} = \@sorted;
 454  
 455              ### best matching filehandle ###
 456              return $sorted[0][1];
 457          } );
 458      }
 459  }
 460  
 461  ### XXX copied from C::I::Utils, so there's no circular require here!
 462  sub _vcmp {
 463      my ($x, $y) = @_;
 464      s/_//g foreach $x, $y;
 465      return $x <=> $y;
 466  }
 467  
 468  =pod
 469  
 470  =head1 DEBUG
 471  
 472  Since this module does C<Clever Things> to your search path, it might
 473  be nice sometimes to figure out what it's doing, if things don't work
 474  as expected. You can enable a debug trace by calling the module like
 475  this:
 476  
 477      use CPANPLUS::inc 'DEBUG';
 478  
 479  This will show you what C<CPANPLUS::inc> is doing, which might look
 480  something like this:
 481  
 482      CPANPLUS::inc: Found match for 'Params::Check' in
 483      '/opt/lib/perl5/site_perl/5.8.3' with version '0.07'
 484      CPANPLUS::inc: Found match for 'Params::Check' in
 485      '/my/private/lib/CPANPLUS/inc' with version '0.21'
 486      CPANPLUS::inc: Best match for 'Params::Check' is found in
 487      '/my/private/lib/CPANPLUS/inc' with version '0.21'
 488  
 489  =head1 CAVEATS
 490  
 491  This module has 2 major caveats, that could lead to unexpected
 492  behaviour. But currently I don't know how to fix them, Suggestions
 493  are much welcomed.
 494  
 495  =over 4
 496  
 497  =item On multiple C<use lib> calls, our coderef may not be the first in @INC
 498  
 499  If this happens, although unlikely in most situations and not happening
 500  when calling the shell directly, this could mean that a lower (too low)
 501  versioned module is loaded, which might cause failures in the
 502  application.
 503  
 504  =item Non-directories in @INC
 505  
 506  Non-directories are right now skipped by CPANPLUS::inc. They could of
 507  course lead us to newer versions of a module, but it's too tricky to
 508  verify if they would. Therefor they are skipped. In the worst case
 509  scenario we'll find the sufficing version bundled with CPANPLUS.
 510  
 511  
 512  =cut
 513  
 514  1;
 515  
 516  # Local variables:
 517  # c-indentation-style: bsd
 518  # c-basic-offset: 4
 519  # indent-tabs-mode: nil
 520  # End:
 521  # vim: expandtab shiftwidth=4:
 522