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 / Install.pm < prev    next >
Encoding:
Perl POD Document  |  2004-01-10  |  6.5 KB  |  229 lines
  1. package PPM::Make::Install;
  2. use strict;
  3. use PPM::Make;
  4. use base qw(PPM::Make);
  5. use PPM::Make::Util qw(:all);
  6. use Config;
  7. use Cwd;
  8. our ($VERSION);
  9. $VERSION = '0.68';
  10.  
  11. sub new {
  12.   my ($class, %opts) = @_;
  13.  
  14.   die "\nInvalid option specification" unless check_opts(%opts);
  15.   die "Must have the ppm utility to install" unless HAS_PPM;
  16.   my $arch = $Config{archname};
  17.   my $os = $Config{osname};
  18.   if (length($^V) && ord(substr($^V, 1)) >= 8) {
  19.     $arch .= sprintf("-%d.%d", ord($^V), ord(substr($^V, 1)));
  20.   }
  21.   my $has = what_have_you($opts{program}, $arch, $os);
  22.   my $self = {
  23.           opts => \%opts || {},
  24.           cwd => '',
  25.           has => $has,
  26.           args => {},
  27.           ppd => '',
  28.           archive => '',
  29.               prereq_pm => {},
  30.           file => '',
  31.           version => '',
  32.               use_mb => '',
  33.           ARCHITECTURE => $arch,
  34.           OS => $os,
  35.          };
  36.   bless $self, $class;
  37. }
  38.  
  39. sub check_opts {
  40.   my %opts = @_;
  41.   my %legal = 
  42.     map {$_ => 1} qw(force ignore dist program upgrade remove no_case);
  43.   foreach (keys %opts) {
  44.     next if $legal{$_};
  45.     warn "Unknown option '$_'\n";
  46.     return;
  47.   }
  48.  
  49.   if (defined $opts{program} and my $progs = $opts{program}) {
  50.     unless (ref($progs) eq 'HASH') {
  51.       warn "Please supply a HASH reference to 'program'";
  52.       return;
  53.     }
  54.     my %ok = map {$_ => 1} qw(zip unzip tar gzip make);
  55.     foreach (keys %{$progs}) {
  56.       next if $ok{$_};
  57.       warn "Unknown program option '$_'\n";
  58.       return;
  59.     }
  60.   }  
  61.   return 1;
  62. }
  63.  
  64. sub make_ppm {
  65.   my $self = shift;
  66.   my $dist = $self->{opts}->{dist};
  67.   if ($dist) {
  68.     my $build_dir = $PPM::Make::Util::build_dir;
  69.     chdir $build_dir or die "Cannot chdir to $build_dir: $!";
  70.     print "Working directory: $build_dir\n"; 
  71.     unless ($dist = fetch_file($dist, no_case => $self->{opts}->{no_case}, 
  72.                                partial => 0)) {
  73.       die $ERROR;
  74.     }
  75. #      if ($dist =~ m!$protocol! 
  76. #          or $dist =~ m!^\w/\w\w/! or $dist !~ m!$ext!);
  77.     print "Extracting files from $dist ....\n";
  78.     my $name = $self->extract_dist($dist, $build_dir);
  79.     chdir $name or die "Cannot chdir to $name: $!";
  80.     $self->{file} = $dist;
  81.   }
  82.   die "Need a Makefile.PL or Build.PL to build"
  83.     unless (-f 'Makefile.PL' or -f 'Build.PL');
  84.   $self->{cwd} = cwd;
  85.   my $mb = -e 'Build.PL';
  86.   $self->{mb} = $mb;
  87.   my $force = $self->{opts}->{force};
  88.   die "This distribution requires Module::Build to build" 
  89.     if ($mb and not HAS_MB);
  90.   $self->build_dist() 
  91.       unless (-d 'blib' and (-f 'Makefile' or ($mb and -f 'Build') )
  92.               and not $force);
  93.   $self->parse_yaml if (-e 'META.yml');
  94.   if ($mb) {
  95.     $self->parse_build();
  96.   }
  97.   else {
  98. #    $self->parse_makepl();
  99.     $self->parse_make() unless $self->{args}->{NAME};
  100.   }
  101.   $self->abstract();
  102.   $self->author();
  103.   $self->{version} = ($self->{args}->{VERSION} ||
  104.                       parse_version($self->{args}->{VERSION_FROM}) ) 
  105.     or warn "Could not extract version information";
  106.   $self->make_html() unless (-d 'blib/html' and not $force);
  107.   $dist = $self->make_dist();
  108.   $self->make_ppd($dist);
  109. }
  110.  
  111. sub ppm_install {
  112.   my $self = shift;
  113.   my $cwd = $self->{cwd};
  114.   (my $package = $self->{ppd}) =~ s!\.ppd$!!;
  115.   my $version = $self->{version};
  116.   my $status = 
  117.     package_status($package, cpan2ppd_version($version));
  118.   die "Version $version of $package is already installed"
  119.     if $status == 1;
  120.   if ($status == 0 and not $self->{opts}->{upgrade}) {
  121.     die qq{Specify the upgrade switch to upgrade $package.};
  122.   }
  123.   print "Installing $package ...\n";
  124.   if ($status == -1) {
  125.     PPM::InstallPackage(package => $package,
  126.                         location => $cwd) 
  127.         or die "Could not install $package: $PPM::PPMERR";
  128.   }
  129.   else {
  130.     PPM::UpgradePackage(package => $package,
  131.                         location => $cwd) 
  132.         or die "Could not install $package: $PPM::PPMERR";    
  133.   }
  134. #  my @args = ('ppm', 'install', $self->{ppd});
  135. #  print "@args\n";
  136. #  system(@args) == 0 or warn "Can't install $self->{ppd}: $?";
  137.   return unless $self->{opts}->{remove};
  138.   my $file = $self->{file};
  139.   unless ($file) {
  140.     warn "Cannot clean files unless a distribution is specified";
  141.     return;
  142.   }
  143.   if (-f "../$file") {
  144.     print "Removing $cwd/../$file ....\n";
  145.     unlink "$cwd/../$file" or warn "Cannot unlink $cwd/../$file: $!";
  146.   }
  147.   chdir('..') or die "Cannot move up one directory: $!";
  148.   if (-d $cwd) {
  149.     print "Removing $cwd ...\n";
  150.     rmtree($cwd) or warn "Cannot remove $cwd: $!";
  151.   }
  152. }
  153.  
  154. 1;
  155.  
  156. __END__
  157.  
  158. =head1 NAME
  159.  
  160. PPM::Make::Install - build and install a distribution via ppm
  161.  
  162. =head1 SYNOPSIS
  163.  
  164.   my $ppm = PPM::Make::Install->new(%opts);
  165.   $ppm->make_ppm();
  166.   $ppm->ppm_install();
  167.  
  168. =head1 DESCRIPTION
  169.  
  170. C<PPM::Make::Install> is used to build a PPM (Perl Package Manager) 
  171. distribution from a CPAN source distribution and then install it with 
  172. the C<ppm> utility. See L<PPM::Make> for a discussion of details on
  173. how the ppm package is built. Available options are
  174.  
  175. =over
  176.  
  177. =item ignore => 1
  178.  
  179. By default, C<PPM::Make::Install>, when building the distribution,
  180. will die if all tests do not pass. Turning on this option
  181. instructs the module to ignore any test failures.
  182.  
  183. =item remove => 1
  184.  
  185. If specified, the directory used to build the ppm distribution
  186. will be removed after a successful install.
  187.  
  188. =item force => 1
  189.  
  190. By default, if C<PPM::Make::Install> detects a F<blib/> directory,
  191. it will assume the distribution has already been made, and
  192. will not remake it. This option forces remaking the distribution.
  193.  
  194. =item no_case => 1
  195.  
  196. If specified, module searches will be performed in a case-insensitive
  197. manner.
  198.  
  199. =item upgrade => 1
  200.  
  201. Will do an upgrade of the specified package, if applicable.
  202.  
  203. =item dist => value
  204.  
  205. A value for I<dist> will be interpreted either as a CPAN-like source
  206. distribution to fetch and build, or as a module name,
  207. in which case I<CPAN.pm> will be used to infer the
  208. corresponding distribution to grab.
  209.  
  210. =item program => { p1 => '/path/to/q1', p2 => '/path/to/q2', ...}
  211.  
  212. This option specifies that C</path/to/q1> should be used
  213. for program C<p1>, etc., rather than the ones PPM::Make finds. The
  214. programs specified can be one of C<tar>, C<gzip>, C<zip>, C<unzip>,
  215. or C<make>.
  216.  
  217. =back
  218.  
  219. =head1 COPYRIGHT
  220.  
  221. This program is copyright, 2003, by Randy Kobes <randy@theoryx5.uwinnipeg.ca>.
  222. It is distributed under the same terms as Perl itself.
  223.  
  224. =head1 SEE ALSO
  225.  
  226. L<PPM::Make>, and L<PPM>.
  227.  
  228. =cut
  229.