home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / PAR.pm < prev    next >
Encoding:
Perl POD Document  |  2003-12-17  |  3.2 KB  |  122 lines
  1. # $File: //depot/cpan/Module-Install/lib/Module/Install/PAR.pm $ $Author: autrijus $
  2. # $Revision: #28 $ $Change: 1650 $ $DateTime: 2003/07/29 06:03:27 $ vim: expandtab shiftwidth=4
  3.  
  4. package Module::Install::PAR;
  5. use Module::Install::Base; @ISA = qw(Module::Install::Base);
  6.  
  7. sub par_base {
  8.     my ($self, $base, $file) = @_;
  9.     my $class = ref($self);
  10.     my $inc_class = join('::', @{$self->_top}{qw(prefix name)});
  11.     my $ftp_base;
  12.  
  13.     if (defined $base and length $base) {
  14.         if ($base =~ m!^(([A-Z])[A-Z])[-_A-Z]+\Z!) {
  15.             $self->{mailto} = "$base\@cpan.org";
  16.             $ftp_base = "ftp://ftp.cpan.org/pub/CPAN/authors/id/$2/$1/$base";
  17.             $base = "http://www.cpan.org/authors/id/$2/$1/$base";
  18.         }
  19.         elsif ($base !~ m!^(\w+)://!) {
  20.             die "Cannot recognize path '$base'; please specify an URL or CPAN ID";
  21.         }
  22.         $base .= '/' unless $base =~ m!/\Z!;
  23.         $ftp_base .= '/' unless $ftp_base =~ m!/\Z!;
  24.     }
  25.  
  26.     require Config;
  27.     my $suffix = "$Config::Config{archname}-$Config::Config{version}.par";
  28.  
  29.     unless ($file ||= $self->{file}) {
  30.         my $name    = $self->name or return;
  31.         my $version = $self->version or return;
  32.         $name =~ s!::!-!g;
  33.         $self->{file} = $file = "$name-$version-$suffix";
  34.     }
  35.  
  36.     my $perl = $^X;
  37.     $perl = Win32::GetShortPathName($perl)
  38.         if $perl =~ / / and defined &Win32::GetShortPathName;
  39.  
  40.     $self->preamble(<<"END") if $base;
  41. # --- $class section:
  42.  
  43. all ::
  44. \t\@$perl -M$inc_class -e \"extract_par(q($file))\"
  45.  
  46. END
  47.  
  48.     $self->postamble(<<"END");
  49. # --- $class section:
  50.  
  51. $file: all test
  52. \t\@\$(PERL) -M$inc_class -e \"make_par(q($file))\"
  53.  
  54. par :: $file
  55. \t\@\$(NOOP)
  56.  
  57. par-upload :: $file
  58. \tcpan-upload -verbose $file
  59.  
  60. END
  61.  
  62.     $self->{url} = $base;
  63.     $self->{ftp_url} = $ftp_base;
  64.     $self->{suffix} = $suffix;
  65.  
  66.     return $self;
  67. }
  68.  
  69. sub fetch_par {
  70.     my ($self, $url, $file, $quiet) = @_;
  71.     $url = $self->{url} || $self->par_base($url)->{url};
  72.     $ftp_url = $self->{ftp_url};
  73.     $file ||= $self->{file};
  74.  
  75.     return $file if -f $file or $self->get_file(
  76.         url     => "$url$file",
  77.         ftp_url => "$ftp_url$file"
  78.     );
  79.  
  80.     require Config;
  81.     print << "END" if $self->{mailto} and !$quiet;
  82. *** No installation package available for your architecture.
  83. However, you may wish to generate one with '$Config::Config{make} par' and send
  84. it to <$self->{mailto}>, so other people on the same platform
  85. can benefit from it.
  86. *** Proceeding with normal installation...
  87. END
  88.     return;
  89. }
  90.  
  91. sub extract_par {
  92.     my ($self, $file) = @_;
  93.     return unless -f $file;
  94.  
  95.     if (eval { require Archive::Zip; 1 }) {
  96.         my $zip = Archive::Zip->new;
  97.         return unless $zip->read($file) == Archive::Zip::AZ_OK()
  98.                   and $zip->extractTree('', 'blib/') == Archive::Zip::AZ_OK();
  99.     }
  100.     elsif ($self->can_run('unzip')) {
  101.         return if system(unzip => $file, qw(-d blib));
  102.     }
  103.  
  104.     local *PM_TO_BLIB;
  105.     open PM_TO_BLIB, '> pm_to_blib' or die $!;
  106.     close PM_TO_BLIB;
  107. }
  108.  
  109. sub make_par {
  110.     my ($self, $file) = @_;
  111.     unlink $file if -f $file;
  112.  
  113.     unless ( eval { require PAR::Dist; PAR::Dist->VERSION >= 0.03 } ) {
  114.         warn "Please install PAR::Dist 0.03 or above first.";
  115.         return;
  116.     }
  117.  
  118.     return PAR::Dist::blib_to_par(dist => $file);
  119. }
  120.  
  121. 1;
  122.