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 / Make.pm < prev    next >
Encoding:
Perl POD Document  |  2004-01-10  |  41.8 KB  |  1,471 lines
  1. package PPM::Make;
  2. use strict;
  3. #use warnings;
  4. use PPM::Make::Util qw(:all);
  5. use Config::IniFiles;
  6. use Cwd;
  7. use Pod::Find qw(pod_find contains_pod);
  8. use File::Basename;
  9. use File::Path;
  10. use File::Find;
  11. use File::Copy;
  12. use Config;
  13. use CPAN;
  14. use Net::FTP;
  15. use LWP::Simple qw(getstore is_success);
  16. require File::Spec;
  17. use Pod::Html;
  18. use Safe;
  19. use YAML qw(LoadFile);
  20.  
  21. our ($VERSION);
  22. $VERSION = '0.68';
  23.  
  24. my $protocol = $PPM::Make::Util::protocol;
  25. my $ext = $PPM::Make::Util::ext;
  26. my $no_case = 0;
  27. my $html = 'blib/html';
  28.  
  29. sub new {
  30.   my ($class, %opts) = @_;
  31.  
  32.   die "\nInvalid option specification" unless check_opts(%opts);
  33.   
  34.   $opts{zip} = 1 if ($opts{binary} and $opts{binary} =~ /\.zip$/);
  35.  
  36.   my ($arch, $os) = arch_and_os($opts{arch}, $opts{os}, $opts{noas});
  37.   my $has = what_have_you($opts{program}, $arch, $os);
  38.   
  39.   my %cfg;
  40. #  $opts{no_cfg} = 1 if $opts{install};
  41.   unless ($opts{no_cfg}) {
  42.     if (my $file = get_cfg_file()) {
  43.       %cfg = read_cfg($file, $arch) or die "\nError reading config file";
  44.     }
  45.   }  
  46.   my $opts = %cfg ? merge_opts(\%cfg, \%opts) : \%opts;
  47.  
  48.   $no_case = 1 if defined $opts->{no_case};
  49.   my $self = {
  50.           opts => $opts || {},
  51.           cwd => '',
  52.           has => $has,
  53.           args => {},
  54.           ppd => '',
  55.           archive => '',
  56.               prereq_pm => {},
  57.           file => '',
  58.           version => '',
  59.               use_mb => '',
  60.           ARCHITECTURE => $arch,
  61.           OS => $os,
  62.          };
  63.   bless $self, $class;
  64. }
  65.  
  66. sub check_opts {
  67.   my %opts = @_;
  68.   my %legal = 
  69.     map {$_ => 1} qw(force ignore binary zip remove program cpan
  70.                      dist script exec os arch arch_sub add no_as vs upload
  71.                      no_case no_cfg vsr vsp);
  72.   foreach (keys %opts) {
  73.     next if $legal{$_};
  74.     warn "Unknown option '$_'\n";
  75.     return;
  76.   }
  77.  
  78.   if (defined $opts{add}) {
  79.     unless (ref($opts{add}) eq 'ARRAY') {
  80.       warn "Please supply an ARRAY reference to 'add'";
  81.       return;
  82.     }
  83.   }
  84.  
  85.   if (defined $opts{program} and my $progs = $opts{program}) {
  86.     unless (ref($progs) eq 'HASH') {
  87.       warn "Please supply a HASH reference to 'program'";
  88.       return;
  89.     }
  90.     my %ok = map {$_ => 1} qw(zip unzip tar gzip make);
  91.     foreach (keys %{$progs}) {
  92.       next if $ok{$_};
  93.       warn "Unknown program option '$_'\n";
  94.       return;
  95.     }
  96.   }
  97.   
  98.   if (defined $opts{upload} and my $upload = $opts{upload}) {
  99.     unless (ref($upload) eq 'HASH') {
  100.       warn "Please supply an HASH reference to 'upload'";
  101.       return;
  102.     }
  103.     my %ok = map {$_ => 1} qw(ppd ar host user passwd);
  104.     foreach (keys %{$upload}) {
  105.       next if $ok{$_};
  106.       warn "Unknown upload option '$_'\n";
  107.       return;
  108.     }
  109.   }
  110.   return 1;
  111. }
  112.  
  113. sub arch_and_os {
  114.   my ($opt_arch, $opt_os, $opt_noas) = @_;
  115.  
  116.   my ($arch, $os);
  117.   if (defined $opt_arch) {
  118.     $arch = ($opt_arch eq "") ? undef : $opt_arch;
  119.   }
  120.   else {
  121.     $arch = $Config{archname};
  122.     unless ($opt_noas) {
  123.       if (length($^V) && ord(substr($^V, 1)) >= 8) {
  124.     $arch .= sprintf("-%d.%d", ord($^V), ord(substr($^V, 1)));
  125.       }
  126.     }
  127.   }
  128.   if (defined $opt_os) {
  129.     $os = ($opt_os eq "") ? undef : $opt_os;
  130.   }
  131.   else {
  132.     $os = $Config{osname};
  133.   }
  134.   return ($arch, $os);
  135. }
  136.  
  137. sub get_cfg_file {
  138.   my $file;
  139.   if (defined $ENV{PPM_CFG} and my $env = $ENV{PPM_CFG}) {
  140.     if (-e $env) {
  141.       $file = $env;
  142.     }
  143.     else {
  144.       warn qq{Cannot find '$env' from \$ENV{PPM_CFG}};
  145.     }
  146.   }
  147.   else {
  148.     my $home = (WIN32 ? '/.ppmcfg' : "$ENV{HOME}/.ppmcfg");
  149.     $file = $home if (-e $home);
  150.   }
  151.   return $file;
  152. }
  153.  
  154. sub read_cfg {
  155.   my ($file, $arch) = @_;
  156.   my $default = 'default';
  157.   my $cfg = Config::IniFiles->new(-file => $file, -default => $default);
  158.   my @p;
  159.   push @p, $cfg->Parameters($default) if ($cfg->SectionExists($default));
  160.   push @p, $cfg->Parameters($arch) if ($cfg->SectionExists($arch));
  161.   unless (@p > 1) {
  162.     warn "No default or section for $arch found";
  163.     return;
  164.   }
  165.   
  166.   my $on = qr!^(on|yes)$!;
  167.   my $off = qr!^(off|no)$!;
  168.   my %legal_progs = map {$_ => 1} qw(tar gzip make perl);
  169.   my %legal_upload = map {$_ => 1} qw(ppd ar host user passwd); 
  170.   my (%cfg, %programs, %upload);
  171.   foreach (@p) {
  172.     my $val = $cfg->val($arch, $_);
  173.     $val = 1 if ($val =~ /$on/i);
  174.     if ($val =~ /$off/i) {
  175.       delete $cfg{$_};
  176.       next;
  177.     }
  178.     if ($_ eq 'add') {
  179.       $cfg{$_} = [split ' ', $val];
  180.       next;
  181.     }
  182.     if ($legal_progs{$_}) {
  183.       $programs{$_} = $val;
  184.     }
  185.     elsif ($legal_upload{$_}) {
  186.       $upload{$_} = $val;
  187.     }
  188.     else {
  189.       $cfg{$_} = $val;
  190.     }
  191.   }
  192.   $cfg{program} = \%programs if %programs;
  193.   $cfg{upload} = \%upload if %upload;
  194.   return check_opts(%cfg) ? %cfg : undef;
  195. }
  196.  
  197. # merge two hashes, assuming the second one takes precedence 
  198. # over the first in the case of duplicate keys
  199. sub merge_opts {
  200.   my ($h1, $h2) = @_;
  201.   my %opts = (%{$h1}, %{$h2});
  202.   if (defined $h1->{add} or defined $h2->{add}) {
  203.     my @a;
  204.     push @a, @{$h1->{add}} if $h1->{add};
  205.     push @a, @{$h2->{add}} if $h2->{add};
  206.     my %add = map {$_ => 1} @a;
  207.     $opts{add} = [keys %add];
  208.   }
  209.   for (qw(program upload)) {
  210.     next unless (defined $h1->{$_} or defined $h2->{$_});
  211.     my %h = ();
  212.     if (defined $h1->{$_}) {
  213.       if (defined $h2->{$_}) {
  214.     %h = (%{$h1->{$_}}, %{$h2->{$_}});
  215.       }
  216.       else {
  217.     %h = %{$h1->{$_}};
  218.       }
  219.     }
  220.     else {
  221.       %h = %{$h2->{$_}};     
  222.     }
  223.     $opts{$_} = \%h;
  224.   }
  225.   return \%opts;
  226. }
  227.  
  228. sub make_ppm {
  229.   my $self = shift;
  230.   die 'No software available to make a zip archive'
  231.      if ($self->{opts}->{zip} and not $self->{has}->{zip});
  232.   my $dist = $self->{opts}->{dist};
  233.   if ($dist) {
  234.     my $build_dir = $PPM::Make::Util::build_dir;
  235.     chdir $build_dir or die "Cannot chdir to $build_dir: $!";
  236. #    print "Working directory: $build_dir\n"; 
  237.     die $ERROR unless ($dist = fetch_file($dist, no_case => $no_case));
  238. #      if ($dist =~ m!$protocol! 
  239. #          or $dist =~ m!^\w/\w\w/! or $dist !~ m!$ext!);
  240.     print "Extracting files from $dist ....\n";
  241.     my $name = $self->extract_dist($dist, $build_dir);
  242.     chdir $name or die "Cannot chdir to $name: $!";
  243.     $self->{file} = $dist;
  244.   }
  245.   die "Need a Makefile.PL or Build.PL to build"
  246.     unless (-f 'Makefile.PL' or -f 'Build.PL');
  247.   my $force = $self->{opts}->{force};
  248.   $self->{cwd} = cwd;
  249.   print "Working directory: $self->{cwd}\n";
  250.   my $mb = -e 'Build.PL';
  251.   $self->{mb} = $mb;
  252.   die "This distribution requires Module::Build to build" 
  253.     if ($mb and not HAS_MB);
  254.   $self->check_script() if $self->{opts}->{script};
  255.   $self->check_files() if $self->{opts}->{add};
  256.   $self->adjust_binary() if $self->{opts}->{arch_sub};
  257.   $self->build_dist() 
  258.     unless (-d 'blib' and (-f 'Makefile' or ($mb and -f 'Build')) 
  259.             and not $force);
  260.   $self->parse_yaml if (-e 'META.yml');
  261.   if ($mb) {
  262.     $self->parse_build();
  263.   }
  264.   else {
  265. #    $self->parse_makepl();
  266.     $self->parse_make()
  267.         unless ($self->{args}->{NAME} and $self->{args}->{AUTHOR});
  268.   }
  269.   $self->abstract();
  270.   $self->author();
  271.   $self->{version} = ($self->{args}->{VERSION} ||
  272.                       parse_version($self->{args}->{VERSION_FROM}) ) 
  273.     or warn "Could not extract version information";
  274.   $self->make_html() unless (-d 'blib/html' and not $force);
  275.   $dist = $self->make_dist();
  276.   $self->make_ppd($dist);
  277. #  if ($self->{opts}->{install}) {
  278. #    die 'Must have the ppm utility to install' unless HAS_PPM;
  279. #    $self->ppm_install();
  280. #  }
  281.   $self->make_cpan() if $self->{opts}->{cpan};
  282.   if (defined $self->{opts}->{upload}) {
  283.     die 'Please specify the location to place the ppd file'
  284.       unless $self->{opts}->{upload}->{ppd}; 
  285.     $self->upload_ppm();
  286.   }
  287. }
  288.  
  289. sub check_script {
  290.   my $self = shift;
  291.   my $script = $self->{opts}->{script};
  292.   return if ($script =~ m!$protocol!);
  293.   my ($name, $path, $suffix) = fileparse($script, '\..*');
  294.   my $file = $name . $suffix;
  295.   $self->{opts}->{script} = $file;
  296.   return if (-e $file);
  297.   copy($script, $file) or die "Copying $script to $self->{cwd} failed: $!";
  298. }
  299.  
  300. sub check_files {
  301.   my $self = shift;
  302.   my @entries = ();
  303.   foreach my $file (@{$self->{opts}->{add}}) {
  304.     my ($name, $path, $suffix) = fileparse($file, '\..*');
  305.     my $entry = $name . $suffix;
  306.     push @entries, $entry;
  307.     next if (-e $entry);
  308.     copy($file, $entry) or die "Copying $file to $self->{cwd} failed: $!";
  309.   }
  310.   $self->{opts}->{add} = \@entries if @entries;
  311. }
  312.  
  313. sub extract_dist {
  314.   my ($self, $file, $build_dir) = @_;
  315.  
  316.   my $has = $self->{has};
  317.   my ($tar, $gzip, $unzip) = @$has{qw(tar gzip unzip)};
  318.  
  319.   my ($name, $path, $suffix) = fileparse($file, $ext);
  320.   if (-d "$build_dir/$name") {
  321.       rmtree("$build_dir/$name", 1, 0) 
  322.           or die "rmtree of $name failed: $!";
  323.   }
  324.  EXTRACT: {
  325.     if ($suffix eq '.zip') {
  326.       ($unzip eq 'Archive::Zip') && do {
  327.     my $arc = Archive::Zip->new();
  328.         die "Read of $file failed" unless $arc->read($file) == AZ_OK();
  329.     $arc->extractTree();
  330.     last EXTRACT;
  331.       };
  332.       ($unzip) && do {
  333.     my @args = ($unzip, $file);
  334.     print "@args\n";
  335.     system(@args) == 0 or die "@args failed: $?";
  336.     last EXTRACT;
  337.       };
  338.  
  339.     }
  340.     else {
  341.       ($tar eq 'Archive::Tar') && do {
  342.     my $arc = Archive::Tar->new($file, 1);
  343.     $arc->extract($arc->list_files);
  344.     last EXTRACT;
  345.       };
  346.       ($tar and $gzip) && do {
  347.     my @args = ($gzip, '-dc', $file, '|', $tar, 'xvf', '-');
  348.     print "@args\n";
  349.     system(@args) == 0 or die "@args failed: $?";
  350.     last EXTRACT;
  351.       };
  352.     }
  353.     die "Cannot extract $file";
  354.   }
  355.   return $name;
  356. }
  357.  
  358. sub adjust_binary {
  359.   my $self = shift;
  360.   my $binary = $self->{opts}->{binary};
  361.   my $archname = $self->{ARCHITECTURE};
  362.   return unless $archname;
  363.   if ($binary) {
  364.     if ($binary =~ m!$ext!) {
  365.       if ($binary =~ m!/!) {
  366.     $binary =~ s!(.*?)([\w\-]+)$ext!$1$archname/$2$3!;
  367.       }
  368.       else {
  369.     $binary = $archname . '/' . $binary;
  370.       }
  371.     }
  372.     else {
  373.       $binary =~ s!/$!!;
  374.       $binary .= '/' . $archname . '/';    
  375.     }
  376.   }
  377.   else {
  378.     $binary = $archname . '/';
  379.   }
  380.   $self->{opts}->{binary} = $binary;
  381. }
  382.  
  383. sub build_dist {
  384.   my $self = shift;
  385.   my $binary = $self->{opts}->{binary};
  386.   my $script = $self->{opts}->{script};
  387.   my $exec = $self->{opts}->{exec};
  388.  
  389.   my $has = $self->{has};
  390.   my ($make, $perl) = @$has{qw(make perl)};
  391.   my $mb = $self->{mb};
  392.  
  393.   my $makepl = $mb ? 'Build.PL' : 'Makefile.PL';
  394.   my @args = ($perl, $makepl);
  395.   if (not $mb and my $makepl_arg = $CPAN::Config->{makepl_arg}) {
  396.     push @args, (split ' ', $makepl_arg);
  397.   }
  398.   print "@args\n";
  399.   system(@args) == 0 or die qq{@args failed: $?};
  400.  
  401. #  if ($mb) {
  402. #    my $file = 'Build.PL';
  403. #    unless (my $r = do $file) {
  404. #      die "Can't parse $file: $@" if $@;
  405. #      die "Can't do $file: $!" unless defined $r;
  406. #      die "Can't run $file" unless $r;
  407. #    }
  408. #  }
  409. #  else {
  410. #    $self->write_makefile();
  411. #  }
  412.  
  413.   my $build = 'Build';
  414.   @args = $mb ? ($perl, $build) : ($make);
  415.   if (not $mb and my $make_arg = $CPAN::Config->{make_arg}) {
  416.     push @args, (split ' ', $make_arg);
  417.   }
  418.   print "@args\n";
  419.   system(@args) == 0 or die "@args failed: $?";
  420.  
  421.   @args = $mb ? ($perl, $build, 'test') : ($make, 'test');
  422.   print "@args\n";
  423.   unless (system(@args) == 0) {
  424.     die "@args failed: $?" unless $self->{opts}->{ignore};
  425.     warn "@args failed: $?";
  426.   }
  427.   return 1;
  428. }
  429.  
  430. sub parse_build {
  431.   my $self = shift;
  432.   my $bp = '_build/build_params';
  433. #  open(my $fh, $bp) or die "Couldn't open $bp: $!";
  434. #  my @lines = <$fh>;
  435. #  close $fh;
  436. #  my $content = join "\n", @lines;
  437. #  my $c = new Safe();
  438. #  my $r = $c->reval($content);
  439. #  if ($@) {
  440. #    warn "Eval of $bp failed: $@";
  441. #    return;
  442. #  }
  443.   my $file = $self->{cwd} . '/_build/build_params';
  444.   my $r;
  445.   unless ($r = do $file) {
  446.     die "Can't parse $file: $@" if $@;
  447.     die "Can't do $file: $!" unless defined $r;
  448.     die "Can't run $file" unless $r;
  449.   }
  450.   
  451.   my $props = $r->[2];
  452.   my %r = ( NAME => $props->{module_name},
  453.             DISTNAME => $props->{dist_name},
  454.             VERSION => $props->{dist_version},
  455.             VERSION_FROM => $props->{dist_version_from},
  456.             PREREQ_PM => $props->{requires},
  457.             AUTHOR => $props->{dist_author},
  458.             ABSTRACT => $props->{dist_abstract},
  459.           );
  460.   foreach (keys %r) {
  461.       next unless $r{$_};
  462.       $self->{args}->{$_} ||= $r{$_};
  463.   }
  464.   return 1;
  465. }
  466.  
  467. sub parse_yaml {
  468.   my $self = shift;
  469.   my $props = LoadFile('META.yml');
  470.   my %r = ( NAME => $props->{name},
  471.             DISTNAME => $props->{distname},
  472.             VERSION => $props->{version},
  473.             VERSION_FROM => $props->{version_from},
  474.             PREREQ_PM => $props->{requires},
  475.             AUTHOR => $props->{author},
  476.             ABSTRACT => $props->{abstract},
  477.           );
  478.   foreach (keys %r) {
  479.     next unless $r{$_};
  480.     $self->{args}->{$_} ||= $r{$_};
  481.   }
  482.   return 1;
  483. }
  484.  
  485. sub parse_makepl {
  486.   my $self = shift;
  487.   open(my $fh, 'Makefile.PL') or die "Couldn't open Makefile.PL: $!";
  488.   my @lines = <$fh>;
  489.   close $fh;
  490.   my $makeargs;
  491.   my $content = join "\n", @lines;
  492.   $content =~ s!\r!!g;
  493.   $content =~ m!WriteMakefile(\s*\(.*?\bNAME\b.*?\))\s*;!s;
  494.   unless ($makeargs = $1) {
  495.     warn "Couldn't extract WriteMakefile args";
  496.     return;
  497.   }
  498.  
  499.   my $c = new Safe();
  500.   my %r = $c->reval($makeargs);
  501.   if ($@) {
  502.     warn "Eval of Makefile.PL failed: $@";
  503.     return;
  504.   }
  505.   unless ($r{NAME}) {
  506.     warn "Cannot determine NAME in Makefile.PL";
  507.     return;
  508.   }
  509.   foreach (keys %r) {
  510.       next unless $r{$_};
  511.       $self->{args}->{$_} ||= $r{$_};
  512.   }
  513.   return 1;
  514. }
  515.  
  516. sub parse_make {
  517.   my $self = shift;
  518.   my $flag = 0;
  519.   my @wanted = qw(NAME DISTNAME ABSTRACT ABSTRACT_FROM AUTHOR 
  520.                   VERSION VERSION_FROM PREREQ_PM);
  521.   my $re = join '|', @wanted;
  522.   my @lines;
  523.   open(my $fh, 'Makefile') or die "Couldn't open Makefile: $!";
  524.   while (<$fh>) {
  525.     if (not $flag and /MakeMaker Parameters/) {
  526.       $flag = 1;
  527.       next;
  528.     }
  529.     next unless $flag;
  530.     last if /MakeMaker post_initialize/;
  531.     next unless /$re/;
  532.     chomp;
  533.     s/^#*\s+// or next;
  534.     push @lines, $_;
  535.   }
  536.   close($fh);
  537.   my $make = join ',', @lines;
  538.   $make = '(' . $make . ')';
  539.   my $c = new Safe();
  540.   my %r = $c->reval($make);
  541.   die "Eval of Makefile failed: $@" if ($@);
  542.   die 'Cannot determine NAME in Makefile' unless $r{NAME};
  543.   for (@wanted) {
  544.     next unless $r{$_};
  545.     $self->{args}->{$_} ||= $r{$_};
  546.   }
  547.   return 1;
  548. }
  549.  
  550. sub write_makefile {
  551.   my $self = shift;
  552.   my $r;
  553.   my $cwd = $self->{cwd};
  554.   my $file = 'Makefile.PL';
  555.  MAKE: {
  556.     local @ARGV;
  557.     if (my $makepl_arg = $CPAN::Config->{makepl_arg}) {
  558.       push @ARGV, (split ' ', $makepl_arg);
  559.     }
  560.     unless ($r = do "$cwd/$file") {
  561.       die "Can't parse $file: $@" if $@;
  562.       die "Can't do $file: $!" unless defined $r;
  563.       die "Can't run $file" unless $r;
  564.     }
  565.   }
  566.   my @wanted = qw(NAME DISTNAME ABSTRACT ABSTRACT_FROM AUTHOR 
  567.                   VERSION VERSION_FROM PREREQ_PM);
  568.   my %wanted;
  569.   foreach (@wanted) {
  570.     next unless defined $r->{$_};
  571.     $wanted{$_} = $r->{$_};
  572.   }
  573.   $self->{args} = $r;
  574.   return 1;
  575. }
  576.  
  577. sub abstract {
  578.   my $self = shift;
  579.   my $args = $self->{args};
  580.   unless ($args->{ABSTRACT}) {
  581.     if (my $abstract = $self->guess_abstract()) {
  582.       warn "Setting ABSTRACT to '$abstract'\n";
  583.       $self->{args}->{ABSTRACT} = $abstract;
  584.     }
  585.     else {
  586.       warn "Please check ABSTRACT in the ppd file\n";
  587.     }
  588.   }
  589. }
  590.  
  591. sub guess_abstract {
  592.   my $self = shift;
  593.   my $args = $self->{args};
  594.   my $cwd = $self->{cwd};
  595.   my $result;
  596.   for my $guess(qw(ABSTRACT_FROM VERSION_FROM)) {
  597.     if (my $file = $args->{$guess}) {
  598.       print "Trying to get ABSTRACT from $file ...\n";
  599.       $result = parse_abstract($args->{NAME}, $file);
  600.       return $result if $result;
  601.     }
  602.   }
  603.   my ($hit, $guess);
  604.   for my $ext (qw(pm pod)) {
  605.     if ($args->{NAME} =~ /-|:/) {
  606.       ($guess = $args->{NAME}) =~ s!.*[-:](.*)!$1.$ext!;
  607.     }
  608.     else {
  609.       $guess = $args->{NAME} . ".$ext";
  610.     }
  611.     finddepth(sub{$_ eq $guess && ($hit = $File::Find::name) 
  612.             && ($hit !~ m!blib/!)}, $cwd);
  613.     next unless (-f $hit);
  614.     print "Trying to get ABSTRACT from $hit ...\n";
  615.     $result = parse_abstract($args->{NAME}, $hit);
  616.     return $result if $result;
  617.   }
  618.   return;
  619. }
  620.  
  621. sub parse_abstract {
  622.   my ($package, $file) = @_;
  623.   my $basename = basename($file, qr/\.\w+$/);
  624.   (my $stripped = $basename) =~ s!\.\w+$!!;
  625.   (my $trans = $package) =~ s!-!::!g;
  626.   my $result;
  627.   my $inpod = 0;
  628.   open(my $fh, $file) or die "Couldn't open $file: $!";
  629.   while (<$fh>) {
  630.     $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
  631.     next if !$inpod;
  632.     chop;
  633.     next unless /^\s*($package|$basename|$stripped|$trans)\s+--*\s+(.*)/;
  634.     $result = $2;
  635.     last;
  636.   }
  637.   close($fh);
  638.   chomp($result);
  639.   return $result;
  640. }
  641.  
  642. sub author {
  643.   my $self = shift;
  644.   my $args = $self->{args};
  645.   unless ($args->{AUTHOR}) {
  646.     if (my $author = $self->guess_author()) {
  647.       $self->{args}->{AUTHOR} = $author;
  648.     }
  649.     else {
  650.       warn "Please check AUTHOR in the ppd file\n";
  651.     }
  652.   }
  653. }
  654.  
  655. sub guess_author {
  656.   my $self = shift;
  657.   my $args = $self->{args};
  658.   if (HAS_CPAN) {
  659.     (my $mod = $args->{NAME}) =~ s!-!::!g;
  660.     print "Trying to get AUTHOR from CPAN.pm ...\n";
  661.     my $module = CPAN::Shell->expand('Module', $mod);
  662.     unless ($module) {
  663.       for (qw(VERSION_FROM ABSTRACT_FROM)) {
  664.         if (my $from = $args->{$_}) {
  665.           $from =~ s!^lib/!!;
  666.           $from =~ s!\.pm$!!;
  667.           $from =~ s!/!::!g;
  668.           last if $module = CPAN::Shell->expand('Module', $from);
  669.         }
  670.       }
  671.     }
  672.     return unless $module;
  673.     return unless (my $userid = $module->cpan_userid);
  674.     return unless (my $author = CPAN::Shell->expand('Author', $userid));
  675.     my $auth_string = $author->fullname;
  676.     my $email = $author->email;
  677.     $auth_string .= ' <' . $email . '>' if $email;
  678.     if ($auth_string) {
  679.       warn qq{Setting AUTHOR to "$auth_string"\n};
  680.       return $auth_string;
  681.     }
  682.   }
  683.   my $cwd = $self->{cwd};
  684.   my $result;
  685.   if (my $version_from = $args->{VERSION_FROM}) {
  686.     print "Trying to get AUTHOR from $version_from ...\n";
  687.     if ($result = parse_author($version_from)) {
  688.       warn qq{Setting AUTHOR to "$result" (may require editing)\n};
  689.       return $result;
  690.     }
  691.   }
  692.   my ($hit, $guess);
  693.   for my $ext (qw(pm pod)) {
  694.     if ($args->{NAME} =~ /-|:/) {
  695.       ($guess = $args->{NAME}) =~ s!.*[-:](.*)!$1.$ext!;
  696.     }
  697.     else {
  698.       $guess = $args->{NAME} . ".$ext";
  699.     }
  700.     finddepth(sub{$_ eq $guess && ($hit = $File::Find::name) 
  701.             && ($hit !~ m!blib/!)}, $cwd);
  702.     next unless (-f $hit);
  703.     print "Trying to get AUTHOR from $hit ...\n";
  704.     if ($result = parse_author($hit)) {
  705.       warn qq{Setting AUTHOR to "$result" (may require editing)\n};
  706.       return $result;
  707.     }
  708.   }
  709.   return;
  710. }
  711.  
  712. sub parse_author {
  713.   my $file = shift;
  714.   open(my $fh, $file) or die "Couldn't open $file: $!";
  715.   my @author;
  716.   local $_;
  717.   while (<$fh>) {
  718.     next unless /^=head1\s+AUTHOR/ ... /^=/;
  719.     next if /^=/;
  720.     push @author, $_;
  721.   }
  722.   close $fh;
  723.   return unless @author;
  724.   my $author = join '', @author;
  725.   $author =~ s/^\s+|\s+$//g;
  726.   return $author;
  727. }
  728.  
  729. sub make_html {
  730.   my $self = shift;
  731.   my $args = $self->{args};
  732.   my $cwd = $self->{cwd};
  733.   unless (-d $html) {
  734.     mkpath($html, 1, 0755) or die "Couldn't mkdir $html: $!";
  735.   }
  736.   my %pods = pod_find({-verbose => 1}, "$cwd/blib/");
  737.   if (-d "$cwd/blib/script/") {
  738.     finddepth( sub 
  739.            {$pods{$File::Find::name} = 
  740.           "script::" . basename($File::Find::name) 
  741.             if (-f $_ and not /\.bat$/ and contains_pod($_));
  742.           }, "$cwd/blib/script");
  743.   }
  744.  
  745.   foreach my $pod (keys %pods){
  746.     my @dirs = split /::/, $pods{$pod};
  747.     my $isbin = shift @dirs eq 'script';
  748.  
  749.     (my $infile = File::Spec->abs2rel($pod)) =~ s!^\w+:!!;
  750.     $infile =~ s!\\!/!g;
  751.     my $outfile = (pop @dirs) . '.html';
  752.  
  753.     my @rootdirs  = $isbin? ('bin') : ('site', 'lib');
  754.     (my $path2root = "../" x (@rootdirs+@dirs)) =~ s|/$||;
  755.     
  756.     (my $fulldir = File::Spec->catfile($html, @rootdirs, @dirs)) =~ s!\\!/!g;
  757.     unless (-d $fulldir){
  758.       mkpath($fulldir, 1, 0755) 
  759.     or die "Couldn't mkdir $fulldir: $!";  
  760.     }
  761.     ($outfile = File::Spec->catfile($fulldir, $outfile)) =~ s!\\!/!g;
  762.     
  763.     my $htmlroot = "$path2root/site/lib";
  764.     my $podroot = "$cwd/blib";
  765.     my $podpath = join ":" => map { $podroot . '/' . $_ }  
  766.       ($isbin ? qw(bin lib) : qw(lib));
  767.     (my $package = $pods{$pod}) =~ s!^(lib|script)::!!;
  768.     my $abstract = parse_abstract($package, $infile);
  769.     my $title =  $abstract ? "$package - $abstract" : $package;
  770.     my @opts = (
  771.         '--header',
  772.         "--title=$title",
  773.         "--infile=$infile",
  774.         "--outfile=$outfile",
  775.         "--podroot=$podroot",
  776.         "--htmlroot=$htmlroot",
  777.         "--css=$path2root/Active.css",
  778.            );
  779.     print "pod2html @opts\n";
  780.     pod2html(@opts);# or warn "pod2html @opts failed: $!";
  781.   }
  782.   ###################################
  783. }
  784.  
  785. sub make_dist {
  786.   my $self = shift;
  787.   my $args = $self->{args};
  788.   my $has = $self->{has};
  789.   my ($tar, $gzip, $zip) = @$has{qw(tar gzip zip)};
  790.   my $force_zip = $self->{opts}->{zip};
  791.   my $binary = $self->{opts}->{binary};
  792.   my $name;
  793.   if ($binary and $binary =~ /$ext/) {
  794.     ($name = $binary) =~ s!.*/(.*)$ext!$1!;
  795.   }
  796.   else {
  797.     $name = $args->{DISTNAME} || $args->{NAME};
  798.     $name  =~ s!::!-!g;
  799.   }
  800.  
  801.   $name .= "-$self->{version}" 
  802.       if ( ($self->{opts}->{vs} or $self->{opts}->{vsr}) and $self->{version});
  803.  
  804.   my $is_Win32 = (not $self->{OS} or $self->{OS} =~ /Win32/i 
  805.           or not $self->{ARCHITECTURE} or
  806.           $self->{ARCHITECTURE} =~ /Win32/i);
  807.  
  808.   my $script = $self->{opts}->{script};
  809.   my $script_is_external = $script ? ($script =~ /$protocol/) : '';
  810.   my @files;
  811.   if ($self->{opts}->{add}) {
  812.     @files = @{$self->{opts}->{add}};
  813.   }
  814.  
  815.   my $arc = $force_zip ? ($name . '.zip') : ($name . '.tar.gz');
  816. #  unless ($self->{opts}->{force}) {
  817. #    return $arc if (-f $arc);
  818. #  }
  819.   unlink $arc if (-e $arc);
  820.  
  821.  DIST: {
  822.     ($tar eq 'Archive::Tar' and not $force_zip) && do {
  823.       $name .= '.tar.gz';
  824.       my @f;
  825.       my $arc = Archive::Tar->new();
  826.       if ($is_Win32) {
  827.           finddepth(sub { push @f, $File::Find::name
  828.                               unless $File::Find::name =~ m!blib/man\d!;
  829.                           print $File::Find::name,"\n"}, 'blib');
  830.       }
  831.       else {
  832.     finddepth(sub {push @f, $File::Find::name; 
  833.                print $File::Find::name,"\n"}, 'blib');
  834.       }
  835.       if ($script and not $script_is_external) {
  836.     push @f, $script;
  837.     print "$script\n";
  838.       }
  839.       if (@files) {
  840.     push @f, @files;
  841.     print join "\n", @files;
  842.       }
  843.       $arc->add_files(@f);
  844.       $arc->write($name, 1);
  845.       last DIST;
  846.     };
  847.     ($tar and $gzip and not $force_zip) && do {
  848.       $name .= '.tar';
  849.       my @args = ($tar, 'cvf', $name);
  850.  
  851.       if ($is_Win32) {
  852.     my @f;
  853.         finddepth(sub { 
  854.                        push @f, $File::Find::name
  855.                           if $File::Find::name =~ m!blib/man\d!;},
  856.                              'blib');
  857.     for (@f) {
  858.       push @args, "--exclude", $_;
  859.     }
  860.       }
  861.  
  862.       push @args, 'blib';
  863.  
  864.       if ($script and not $script_is_external) {
  865.     push @args, $script;
  866.       }
  867.       if (@files) {
  868.     push @args, @files;
  869.       }
  870.       print "@args\n";
  871.       system(@args) == 0 or die "@args failed: $?";
  872.       @args = ($gzip, $name);
  873.       print "@args\n";
  874.       system(@args) == 0 or die "@args failed: $?";
  875.       $name .= '.gz';
  876.       last DIST;
  877.     };
  878.     ($zip eq 'Archive::Zip') && do {
  879.       $name .= '.zip';
  880.       my $arc = Archive::Zip->new();
  881.       if ($is_Win32) {
  882.         die "zip of blib failed" unless $arc->addTree('blib', 'blib',
  883.                      sub{$_ !~ m!blib/man\d/! && print "$_\n";}) == AZ_OK();
  884.       }
  885.       else {
  886.         die "zip of blib failed" unless $arc->addTree('blib', 'blib', 
  887.                               sub{print "$_\n";}) == AZ_OK();
  888.       }
  889.       if ($script and not $script_is_external) {
  890.         die "zip of $script failed"
  891.            unless $arc->addTree($script, $script) == AZ_OK();
  892.     print "$script\n";
  893.       }
  894.       if (@files) {
  895.     for (@files) {
  896.           die "zip of $_ failed" unless $arc->addTree($_, $_) == AZ_OK();
  897.       print "$_\n";
  898.     }
  899.       }
  900.       die "Writing to $name failed" 
  901.     unless $arc->writeToFileNamed($name) == AZ_OK();
  902.       last DIST;
  903.     };
  904.     ($zip) && do {
  905.       $name .= '.zip';
  906.       my @args = ($zip, '-r', $name, 'blib');
  907.       if ($script and not $script_is_external) {
  908.     push @args, $script;
  909.     print "$script\n";
  910.       }
  911.       if (@files) {
  912.     push @args, @files;
  913.     print join "\n", @files;
  914.       }
  915.       if ($is_Win32) {
  916.     my @f;
  917.         finddepth(sub {
  918.                        push @f, $File::Find::name
  919.                           unless $File::Find::name =~ m!blib/man\d!;},
  920.                              'blib');
  921.     for (@f) {
  922.       push @args, "-x", $_;
  923.     }
  924.       }
  925.       
  926.       print "@args\n";
  927.       system(@args) == 0 or die "@args failed: $?";
  928.       last DIST;
  929.     };
  930.     die "Cannot make archive for $name";
  931.   }
  932.   return $name;
  933. }
  934.  
  935. sub make_ppd {
  936.   my ($self, $dist) = @_;
  937.   my $has = $self->{has};
  938.   my ($make, $perl) = @$has{qw(make perl)};
  939.   my $binary = $self->{opts}->{binary};
  940.   if ($binary) {
  941.     unless ($binary =~ /$ext/) {
  942.       $binary =~ s!/$!!;
  943.       $binary .= '/' . $dist;
  944.     }
  945.   }
  946.  
  947.   (my $name = $dist) =~ s!$ext!!;
  948.   if ($self->{opts}->{vsr} and not $self->{opts}->{vsp}) {
  949.      $name =~ s/-$self->{version}//;
  950.   }
  951.   if ($self->{opts}->{vsp} and $name !~ m/-$self->{version}/) {
  952.      $name .= "-$self->{version}";
  953.   }
  954.   my $ppd = $name . '.ppd';
  955.   my $args = $self->{args};
  956.   my $os = $self->{OS};
  957.   my $arch = $self->{ARCHITECTURE};
  958.   my $d;
  959.   
  960.   $d->{SOFTPKG}->{NAME} = $d->{TITLE} = $name;
  961.   $d->{SOFTPKG}->{VERSION} = cpan2ppd_version($self->{version});  
  962.   $d->{OS}->{NAME} = $os if $os;
  963.   $d->{ARCHITECTURE}->{NAME} = $arch if $arch;
  964.   $d->{ABSTRACT} = $args->{ABSTRACT};
  965.   $d->{AUTHOR} = $args->{AUTHOR};
  966.   $d->{CODEBASE}->{HREF} = $binary || $dist;
  967.   ($self->{archive} = $d->{CODEBASE}->{HREF}) =~ s!.*/(.*)!$1!;
  968.  
  969.   if ( my $script = $self->{opts}->{script}) {
  970.     if (my $exec = $self->{opts}->{exec}) {
  971.       $d->{INSTALL}->{EXEC} = $exec;
  972.     }
  973.     if ($script =~ m!$protocol!) {
  974.       $d->{INSTALL}->{HREF} = $script;
  975.       (my $name = $script) =~ s!.*/(.*)!$1!;
  976.       $d->{INSTALL}->{SCRIPT} = $name;
  977.     }
  978.     else {
  979.       $d->{INSTALL}->{SCRIPT} = $script;
  980.     }
  981.   }
  982.   
  983.   foreach my $dp (keys %{$args->{PREREQ_PM}}) {
  984.     next if is_core($dp);
  985.     my $results = mod_search($dp, no_case => 0, partial => 0);
  986.     next unless (defined $results->{$dp});
  987.     my $dist = file_to_dist($results->{$dp}->{cpan_file});
  988.     next if (not $dist or $dist =~ m!^perl$! or $dist =~ m!^Test!);
  989.     $self->{prereq_pm}->{$dist} = 
  990.       $d->{PREREQ_PM}->{$dist} = cpan2ppd_version($args->{PREREQ_PM}->{$dp});
  991.   }
  992.  
  993.   foreach (qw(OS ARCHITECTURE)) {
  994.     delete $d->{$_}->{NAME} unless $self->{$_};
  995.   }
  996.   
  997.   print_ppd($d, $ppd);
  998.   $self->{ppd} = $ppd;
  999. }
  1000.  
  1001. sub print_ppd {
  1002.   my ($d, $fn) = @_;
  1003.   open (my $fh, ">$fn") or die "Couldn't write to $fn: $!";
  1004.   my $title = html_escape($d->{TITLE});
  1005.   my $abstract = html_escape($d->{ABSTRACT});
  1006.   my $author = html_escape($d->{AUTHOR});
  1007.   print $fh <<"END";
  1008. <SOFTPKG NAME=\"$d->{SOFTPKG}->{NAME}\" VERSION=\"$d->{SOFTPKG}->{VERSION}\">
  1009. \t<TITLE>$title</TITLE>
  1010. \t<ABSTRACT>$abstract</ABSTRACT>
  1011. \t<AUTHOR>$author</AUTHOR>
  1012. \t<IMPLEMENTATION>
  1013. END
  1014.   
  1015.   foreach (keys %{$d->{PREREQ_PM}}) {
  1016.     print $fh 
  1017.       qq{\t\t<DEPENDENCY NAME="$_" VERSION="$d->{PREREQ_PM}->{$_}" />\n};
  1018.   }
  1019.   foreach (qw(OS ARCHITECTURE)) {
  1020.     next unless $d->{$_}->{NAME};
  1021.     print $fh qq{\t\t<$_ NAME="$d->{$_}->{NAME}" />\n};
  1022.   }
  1023.   
  1024.   if (my $script = $d->{INSTALL}->{SCRIPT}) {
  1025.     my $install = 'INSTALL';
  1026.     if (my $exec = $d->{INSTALL}->{EXEC}) {
  1027.       $install .= qq{ EXEC="$exec"};
  1028.     }
  1029.     if (my $href = $d->{INSTALL}->{HREF}) {
  1030.       $install .= qq{ HREF="$href"};
  1031.     }
  1032.     print $fh qq{\t\t<$install>$script</INSTALL>\n};
  1033.   }
  1034.   
  1035.   print $fh qq{\t\t<CODEBASE HREF="$d->{CODEBASE}->{HREF}" />\n};
  1036.   
  1037.   print $fh qq{\t</IMPLEMENTATION>\n</SOFTPKG>\n};
  1038.   $fh->close;
  1039.  
  1040. }
  1041.  
  1042. sub make_cpan {
  1043.   my $self = shift;
  1044.   my ($ppd, $archive) = ($self->{ppd}, $self->{archive});
  1045.   my %seen;
  1046.   my $man = 'MANIFEST';
  1047.   my $copy = $man . '.orig';
  1048.   unless (-e $copy) {
  1049.     rename($man, $copy) or die "Cannot rename $man: $!";
  1050.   }
  1051.   open(my $orig, $copy) or die "Cannot read $copy: $!";
  1052.   open(my $new, ">$man") or die "Cannot open $man for writing: $!";
  1053.   while (<$orig>) {
  1054.     $seen{ppd}++ if $_ =~ /$ppd/;
  1055.     $seen{archive}++ if $_ =~ /$archive/;
  1056.     print $new $_;
  1057.   }
  1058.   close $orig;
  1059.   print $new "\n$ppd\n" unless $seen{ppd};
  1060.   print $new "$archive\n" unless $seen{archive};
  1061.   close $new;
  1062.   my @args = ($self->{has}->{make}, 'dist');
  1063.   print "@args\n";
  1064.   system(@args) == 0 or die qq{system @args failed: $?};
  1065.   return;
  1066. }
  1067.  
  1068. sub upload_ppm {
  1069.   my $self = shift;
  1070.   my ($ppd, $archive) = ($self->{ppd}, $self->{archive});
  1071.   my $upload = $self->{opts}->{upload};
  1072.   my $ppd_loc = $upload->{ppd};
  1073.   my $ar_loc = $self->{opts}->{arch_sub} ?
  1074.     $self->{ARCHITECTURE} : $upload->{ar} || $ppd_loc;
  1075.   if (not File::Spec->file_name_is_absolute($ar_loc)) {
  1076.     ($ar_loc = File::Spec->catdir($ppd_loc, $ar_loc)) =~ s!\\!/!g;
  1077.   }
  1078.  
  1079.   if (my $host = $upload->{host}) {
  1080.     my ($user, $passwd) = ($upload->{user}, $upload->{passwd});
  1081.     die "Must specify a username and password to log into $host"
  1082.       unless ($user and $passwd);
  1083.     my $ftp = Net::FTP->new($host) or die "Cannot connect to $host";
  1084.     $ftp->login($user, $passwd) or die "Login for user $user failed";
  1085.     $ftp->cwd($ppd_loc) or die "cwd to $ppd_loc failed";
  1086.     $ftp->ascii;
  1087.     $ftp->put($ppd) or die "Cannot upload $ppd";
  1088.     $ftp->cwd($ar_loc) or die "cwd to $ar_loc failed";
  1089.     $ftp->binary;
  1090.     $ftp->put($archive) or die "Cannot upload $archive";
  1091.     $ftp->quit;
  1092.   }
  1093.   else {
  1094.     copy($ppd, "$ppd_loc/$ppd") 
  1095.       or die "Cannot copy $ppd to $ppd_loc: $!";
  1096.     unless (-d $ar_loc) {
  1097.         mkdir $ar_loc or die "Cannot mkdir $ar_loc: $!";
  1098.     }
  1099.     copy($archive, "$ar_loc/$archive") 
  1100.       or die "Cannot copy $archive to $ar_loc: $!";
  1101.   }
  1102. }
  1103.  
  1104. 1;
  1105.  
  1106. __END__
  1107.  
  1108. =head1 NAME
  1109.  
  1110. PPM::Make - Make a ppm package from a CPAN distribution
  1111.  
  1112. =head1 SYNOPSIS
  1113.  
  1114.   my $ppm = PPM::Make->new( [options] );
  1115.   $ppm->make_ppm();
  1116.  
  1117. =head1 DESCRIPTION
  1118.  
  1119. See the supplied C<make_ppm> script for a command-line interface.
  1120.  
  1121. This module automates somewhat some of the steps needed to make
  1122. a I<ppm> (Perl Package Manager) package from a CPAN distribution.
  1123. It attempts to fill in the I<ABSTRACT> and I<AUTHOR> attributes of 
  1124. F<Makefile.PL>, if these are not supplied, and also uses C<pod2html> 
  1125. to generate a set of html documentation. It also adjusts I<CODEBASE> 
  1126. of I<package.ppd> to reflect the generated I<package.tar.gz> 
  1127. or I<package.zip> archive. Such packages are suitable both for 
  1128. local installation via
  1129.  
  1130.   C:\.cpan\build\package_src> ppm install
  1131.  
  1132. and for distribution via a repository.
  1133.  
  1134. Options can be given as some combination of key/value
  1135. pairs passed to the I<new()> constructor (described below) 
  1136. and those specified in a configuration file.
  1137. This file can either be that given by the value of
  1138. the I<PPM_CFG> environment variable or, if not set,
  1139. a file called F<.ppmcfg> at the top-level
  1140. directory (on Win32) or under I<HOME> (on Unix).
  1141. If the I<no_cfg> argument is passed into C<new()>,
  1142. this file will be ignored.
  1143.  
  1144. The configuration file is of an INI type. If a section
  1145. I<default> is specified as
  1146.  
  1147.   [ default ]
  1148.   option1 = value1
  1149.   option2 = value2
  1150.  
  1151. these values will be used as the default. Architecture-specific
  1152. values may be specified within their own section:
  1153.  
  1154.   [ MSWin32-x86-multi-thread-5.8 ]
  1155.   option1 = new_value1
  1156.   option3 = value3
  1157.  
  1158. In this case, an architecture specified as
  1159. I<MSWin32-x86-multi-thread-5.8> within PPM::Make will
  1160. have I<option1 = new_value1>, I<option2 = value2>,
  1161. and I<option3 = value3>, while any other architecture
  1162. will have I<option1 = value1> and I<option2 = value2>.
  1163. Options specified within the configuration file
  1164. can be overridden by passing the option into
  1165. the I<new()> method of PPM::Make.
  1166.  
  1167. Valid options that may be specified within the 
  1168. configuration file are those of PPM::Make, described below. 
  1169. For the I<program> and I<upload> options (which take hash references),
  1170. the keys (make, zip, unzip, tar, gzip),
  1171. or (ppd, ar, host, user, passwd), respectively,
  1172. should be specified. For binary options, a value
  1173. of I<yes|on> in the configuration file will be interpreted
  1174. as true, while I<no|off> will be interpreted as false.
  1175.  
  1176. =head2 OPTIONS
  1177.  
  1178. The available options accepted by the I<new> constructor are
  1179.  
  1180. =over
  1181.  
  1182. =item no_cfg => 1
  1183.  
  1184. If specified, do not attempt to read a F<.ppmcfg> configuration
  1185. file.
  1186.  
  1187. =item dist => value
  1188.  
  1189. If I<dist> is not specified, it will be assumed that one
  1190. is working inside an already unpacked source directory,
  1191. and the ppm distribution will be built from there. A value 
  1192. for I<dist> will be interpreted either as a CPAN-like source
  1193. distribution to fetch and build, or as a module name,
  1194. in which case I<CPAN.pm> will be used to infer the
  1195. corresponding distribution to grab.
  1196.  
  1197. =item no_case => boolean
  1198.  
  1199. If I<no_case> is specified, a case-insensitive search
  1200. of a module name will be performed.
  1201.  
  1202. =item binary => value
  1203.  
  1204. The value of I<binary> is used in the I<BINARY_LOCATION>
  1205. attribute passed to C<perl Makefile.PL>, and arises in
  1206. setting the I<HREF> attribute of the I<CODEBASE> field
  1207. in the ppd file.
  1208.  
  1209. =item arch_sub => boolean
  1210.  
  1211. Setting this option will insert the value of C<$Config{archname}>
  1212. (or the value of the I<arch> option, if given)
  1213. as a relative subdirectory in the I<HREF> attribute of the 
  1214. I<CODEBASE> field in the ppd file.
  1215.  
  1216. =item script => value
  1217.  
  1218. The value of I<script> is used in the I<PPM_INSTALL_SCRIPT>
  1219. attribute passed to C<perl Makefile.PL>, and arises in
  1220. setting the value of the I<INSTALL> field in the ppd file.
  1221. If this begins with I<http://> or I<ftp://>, so that the
  1222. script is assumed external, this will be
  1223. used as the I<HREF> attribute for I<INSTALL>.
  1224.  
  1225. =item exec => value
  1226.  
  1227. The value of I<exec> is used in the I<PPM_INSTALL_EXEC>
  1228. attribute passed to C<perl Makefile.PL>, and arises in
  1229. setting the I<EXEC> attribute of the I<INSTALL> field
  1230. in the ppd file. 
  1231.  
  1232. =item  add => \@files
  1233.  
  1234. The specified array reference contains a list of files
  1235. outside of the F<blib> directory to be added to the archive. 
  1236.  
  1237. =item zip => boolean
  1238.  
  1239. By default, a I<.tar.gz> distribution will be built, if possible. 
  1240. Giving I<zip> a true value forces a I<.zip> distribution to be made.
  1241.  
  1242. =item force => boolean
  1243.  
  1244. If a F<blib/> directory is detected, it will be assumed that
  1245. the distribution has already been made. Setting I<force> to
  1246. be a true value forces remaking the distribution.
  1247.  
  1248. =item ignore => boolean
  1249.  
  1250. If when building and testing a distribution, failure of any
  1251. supplied tests will be treated as a fatal error. Setting
  1252. I<ignore> to a true value causes failed tests to just
  1253. issue a warning.
  1254.  
  1255. =item os => value
  1256.  
  1257. If this option specified, the value, if present, will be used instead 
  1258. of the default for the I<NAME> attribute of the I<OS> field of the ppd 
  1259. file. If a value of an empty string is given, the I<OS> field will not 
  1260. be included in the  ppd file.
  1261.  
  1262. =item arch => value
  1263.  
  1264. If this option is specified, the value, if present, will be used instead 
  1265. of the default for the I<NAME> attribute of the I<ARCHITECTURE> field of 
  1266. the ppd file. If a value of an empty string is given, the 
  1267. I<ARCHITECTURE> field will not be included in the ppd file.
  1268.  
  1269. =item remove => boolean
  1270.  
  1271. If specified, the directory used to build the ppm distribution
  1272. (with the I<dist> option) will be removed after a successful install.
  1273.  
  1274. =item cpan => boolean
  1275.  
  1276. If specified, a distribution will be made using C<make dist>
  1277. which will include the I<ppd> and I<archive> file.
  1278.  
  1279. =item program => { p1 => '/path/to/q1', p2 => '/path/to/q2', ...}
  1280.  
  1281. This option specifies that C</path/to/q1> should be used
  1282. for program C<p1>, etc., rather than the ones PPM::Make finds. The
  1283. programs specified can be one of C<tar>, C<gzip>, C<zip>, C<unzip>,
  1284. or C<make>.
  1285.  
  1286. =item no_as => boolean
  1287.  
  1288. Beginning with Perl-5.8, Activestate adds the Perl version number to
  1289. the NAME of the ARCHITECTURE tag in the ppd file. This option
  1290. will make a ppd file I<without> this practice.
  1291.  
  1292. =item vs => boolean
  1293.  
  1294. This option, if enabled, will add a version string 
  1295. (based on the VERSION reported in the ppd file) to the 
  1296. ppd and archive filenames.
  1297.  
  1298. =item vsr => boolean
  1299.  
  1300. This option, if enabled, will add a version string 
  1301. (based on the VERSION reported in the ppd file) to the 
  1302. archive filename.
  1303.  
  1304. =item vsp => boolean
  1305.  
  1306. This option, if enabled, will add a version string 
  1307. (based on the VERSION reported in the ppd file) to the 
  1308. ppd filename.
  1309.  
  1310. =item upload => {key1 => val1, key2 => val2, ...}
  1311.  
  1312. If given, this option will copy the ppd and archive files
  1313. to the specified locations. The available options are
  1314.  
  1315. =over
  1316.  
  1317. =item ppd => $path_to_ppd_files
  1318.  
  1319. This is the location where the ppd file should be placed,
  1320. and must be given as an absolute pathname.
  1321.  
  1322. =item ar => $path_to_archive_files
  1323.  
  1324. This is the location where the archive file should be placed.
  1325. This may either be an absolute pathname or a relative one,
  1326. in which case it is interpreted to be relative to that
  1327. specified by I<ppd>. If this is not given, and yet I<ppd>
  1328. is specified, then this defaults, first of all, to the
  1329. value of I<arch_sub>, if given, or else to the value
  1330. of I<ppd>.
  1331.  
  1332. =item host => $hostname
  1333.  
  1334. If specified, an ftp transfer to the specified host is
  1335. done, with I<ppd> and I<ar> as described above.
  1336.  
  1337. =item user => $username
  1338.  
  1339. This specifies the user name to login as when transferring
  1340. via ftp.
  1341.  
  1342. =item passwd => $passwd
  1343.  
  1344. This is the associated password to use for I<user>
  1345.  
  1346. =back
  1347.  
  1348. =back
  1349.  
  1350. =head2 STEPS
  1351.  
  1352. The steps to make the PPM distribution are as follows. 
  1353.  
  1354. =over
  1355.  
  1356. =item determine available programs
  1357.  
  1358. For building and making the distribution, certain
  1359. programs will be needed. For unpacking and making 
  1360. I<.tar.gz> files, either I<Archive::Tar> and I<Compress::Zlib>
  1361. must be installed, or a C<tar> and C<gzip> program must
  1362. be available. For unpacking and making I<.zip> archives,
  1363. either I<Archive::Zip> must be present, or a C<zip> and
  1364. C<unzip> program must be available. Finally, a C<make>
  1365. program must be present.
  1366.  
  1367. =item fetch and unpack the distribution
  1368.  
  1369. If I<dist> is specified, the corresponding file is
  1370. fetched (by I<LWP::Simple>, if a I<URL> is specified).
  1371. If I<dist> appears to be a module name, the associated
  1372. distribution is determined by I<CPAN.pm>. The distribution
  1373. is then unpacked.
  1374.  
  1375. =item build the distribution
  1376.  
  1377. If needed, or if specied by the I<force> option, the
  1378. distribution is built by the usual
  1379.  
  1380.   C:\.cpan\build\package_src> perl Makefile.PL
  1381.   C:\.cpan\build\package_src> nmake
  1382.   C:\.cpan\build\package_src> nmake test
  1383.  
  1384. procedure. A failure in any of the tests will be considered
  1385. fatal unless the I<ignore> option is used. Additional
  1386. arguments to these commands present in either I<CPAN::Config>
  1387. or present in the I<binary> option to specify I<BINARY_LOCATION>
  1388. in F<Makefile.PL> will be added.
  1389.  
  1390. =item parse Makefile.PL
  1391.  
  1392. Some information contained in the I<WriteMakefile> attributes
  1393. of F<Makefile.PL> is then extracted.
  1394.  
  1395. =item parse Makefile
  1396.  
  1397. If certain information in F<Makefile.PL> can't be extracted,
  1398. F<Makefile> is tried.
  1399.  
  1400. =item determining the ABSTRACT
  1401.  
  1402. If an I<ABSTRACT> or I<ABSTRACT_FROM> attribute in F<Makefile.PL> 
  1403. is not given, an attempt is made to extract an abstract from the 
  1404. pod documentation of likely files.
  1405.  
  1406. =item determining the AUTHOR
  1407.  
  1408. If an I<AUTHOR> attribute in F<Makefile.PL> is not given,
  1409. an attempt is made to get the author information using I<CPAN.pm>.
  1410.  
  1411. =item HTML documentation
  1412.  
  1413. C<pod2html> is used to generate a set of html documentation.
  1414. This is placed under the F<blib/html/site/lib/> subdirectory, 
  1415. which C<ppm install> will install into the user's html tree.
  1416.  
  1417. =item Make the PPM distribution
  1418.  
  1419. A distribution file based on the contents of the F<blib/> directory
  1420. is then made. If possible, this will be a I<.tar.gz> file,
  1421. unless suitable software isn't available or if the I<zip>
  1422. option is used, in which case a I<.zip> archive is made, if possible.
  1423.  
  1424. =item adjust the PPD file
  1425.  
  1426. The F<package_name.ppd> file generated by C<nmake ppd> will
  1427. be edited appropriately. This includes filling in the 
  1428. I<ABSTRACT> and I<AUTHOR> fields, if needed and possible,
  1429. and also filling in the I<CODEBASE> field with the 
  1430. name of the generated archive file. This will incorporate
  1431. a possible I<binary> option used to specify
  1432. the I<HREF> attribute of the I<CODEBASE> field. 
  1433. Two routines are used in doing this - C<parse_ppd>, for
  1434. parsing the ppd file, and C<print_ppd>, for generating
  1435. the modified file.
  1436.  
  1437. =item upload the ppm files
  1438.  
  1439. If the I<upload> option is specified, the ppd and archive
  1440. files will be copied to the given locations.
  1441.  
  1442. =back
  1443.  
  1444. =head1 REQUIREMENTS
  1445.  
  1446. As well as the needed software for unpacking and
  1447. making I<.tar.gz> and I<.zip> archives, and a C<make>
  1448. program, it is assumed in this that I<CPAN.pm> is 
  1449. available and already configured, either site-wide or
  1450. through a user's F<$HOME/.cpan/CPAN/MyConfig.pm>.
  1451.  
  1452. Although the examples given above had a Win32 flavour,
  1453. like I<PPM>, no assumptions on the operating system are 
  1454. made in the module. 
  1455.  
  1456. =head1 COPYRIGHT
  1457.  
  1458. This program is copyright, 2003, by Randy Kobes <randy@theoryx5.uwinnipeg.ca>.
  1459. It is distributed under the same terms as Perl itself.
  1460.  
  1461. =head1 SEE ALSO
  1462.  
  1463. L<make_ppm> for a command-line interface for making
  1464. ppm packages, L<ppm_install> for a command line interface
  1465. for installing CPAN packages via C<ppm>, L<tk-ppm> for
  1466. a Tk graphical interface to C<ppm> and the install utility
  1467. of PPM::Make, L<PPM::Make::Install>, and L<PPM>.
  1468.  
  1469. =cut
  1470.  
  1471.