[Summary view] [Print] [Text view]

   1  package Module::Build::PPMMaker;
   2  
   3  use strict;
   4  use vars qw($VERSION);
   5  $VERSION = '0.2808_01';
   6  $VERSION = eval $VERSION;
   7  
   8  # This code is mostly borrowed from ExtUtils::MM_Unix 6.10_03, with a
   9  # few tweaks based on the PPD spec at
  10  # http://www.xav.com/perl/site/lib/XML/PPD.html
  11  
  12  # The PPD spec is based on <http://www.w3.org/TR/NOTE-OSD>
  13  
  14  sub new {
  15    my $package = shift;
  16    return bless {@_}, $package;
  17  }
  18  
  19  sub make_ppd {
  20    my ($self, %args) = @_;
  21    my $build = delete $args{build};
  22  
  23    my @codebase;
  24    if (exists $args{codebase}) {
  25      @codebase = ref $args{codebase} ? @{$args{codebase}} : ($args{codebase});
  26    } else {
  27      my $distfile = $build->ppm_name . '.tar.gz';
  28      print "Using default codebase '$distfile'\n";
  29      @codebase = ($distfile);
  30    }
  31  
  32    my %dist;
  33    foreach my $info (qw(name author abstract version)) {
  34      my $method = "dist_$info";
  35      $dist{$info} = $build->$method() or die "Can't determine distribution's $info\n";
  36    }
  37    $dist{version} = $self->_ppd_version($dist{version});
  38  
  39    $self->_simple_xml_escape($_) foreach $dist{abstract}, @{$dist{author}};
  40  
  41    # TODO: could add <LICENSE HREF=...> tag if we knew what the URLs were for
  42    # various licenses
  43    my $ppd = <<"PPD";
  44  <SOFTPKG NAME=\"$dist{name}\" VERSION=\"$dist{version}\">
  45      <TITLE>$dist{name}</TITLE>
  46      <ABSTRACT>$dist{abstract}</ABSTRACT>
  47  @{[ join "\n", map "    <AUTHOR>$_</AUTHOR>", @{$dist{author}} ]}
  48      <IMPLEMENTATION>
  49  PPD
  50  
  51    # TODO: We could set <IMPLTYPE VALUE="PERL" /> or maybe
  52    # <IMPLTYPE VALUE="PERL/XS" /> ???
  53  
  54    # We don't include recommended dependencies because PPD has no way
  55    # to distinguish them from normal dependencies.  We don't include
  56    # build_requires dependencies because the PPM installer doesn't
  57    # build or test before installing.  And obviously we don't include
  58    # conflicts either.
  59    
  60    foreach my $type (qw(requires)) {
  61      my $prereq = $build->$type();
  62      while (my ($modname, $spec) = each %$prereq) {
  63        next if $modname eq 'perl';
  64  
  65        my $min_version = '0.0';
  66        foreach my $c ($build->_parse_conditions($spec)) {
  67          my ($op, $version) = $c =~ /^\s*  (<=?|>=?|==|!=)  \s*  ([\w.]+)  \s*$/x;
  68  
  69          # This is a nasty hack because it fails if there is no >= op
  70          if ($op eq '>=') {
  71            $min_version = $version;
  72            last;
  73          }
  74        }
  75  
  76        # Another hack - dependencies are on modules, but PPD expects
  77        # them to be on distributions (I think).
  78        $modname =~ s/::/-/g;
  79  
  80        $ppd .= sprintf(<<'EOF', $modname, $self->_ppd_version($min_version));
  81          <DEPENDENCY NAME="%s" VERSION="%s" />
  82  EOF
  83  
  84      }
  85    }
  86  
  87    # We only include these tags if this module involves XS, on the
  88    # assumption that pure Perl modules will work on any OS.  PERLCORE,
  89    # unfortunately, seems to indicate that a module works with _only_
  90    # that version of Perl, and so is only appropriate when a module
  91    # uses XS.
  92    if (keys %{$build->find_xs_files}) {
  93      my $perl_version = $self->_ppd_version($build->perl_version);
  94      $ppd .= sprintf(<<'EOF', $perl_version, $^O, $self->_varchname($build->config) );
  95          <PERLCORE VERSION="%s" />
  96          <OS NAME="%s" />
  97          <ARCHITECTURE NAME="%s" />
  98  EOF
  99    }
 100  
 101    foreach my $codebase (@codebase) {
 102      $self->_simple_xml_escape($codebase);
 103      $ppd .= sprintf(<<'EOF', $codebase);
 104          <CODEBASE HREF="%s" />
 105  EOF
 106    }
 107  
 108    $ppd .= <<'EOF';
 109      </IMPLEMENTATION>
 110  </SOFTPKG>
 111  EOF
 112  
 113    my $ppd_file = "$dist{name}.ppd";
 114    my $fh = IO::File->new(">$ppd_file")
 115      or die "Cannot write to $ppd_file: $!";
 116    print $fh $ppd;
 117    close $fh;
 118  
 119    return $ppd_file;
 120  }
 121  
 122  sub _ppd_version {
 123    my ($self, $version) = @_;
 124  
 125    # generates something like "0,18,0,0"
 126    return join ',', (split(/\./, $version), (0)x4)[0..3];
 127  }
 128  
 129  sub _varchname {  # Copied from PPM.pm
 130    my ($self, $config) = @_;
 131    my $varchname = $config->{archname};
 132    # Append "-5.8" to architecture name for Perl 5.8 and later
 133    if (defined($^V) && ord(substr($^V,1)) >= 8) {
 134      $varchname .= sprintf("-%d.%d", ord($^V), ord(substr($^V,1)));
 135    }
 136    return $varchname;
 137  }
 138  
 139  {
 140    my %escapes = (
 141           "\n" => "\\n",
 142           '"' => '&quot;',
 143           '&' => '&amp;',
 144           '>' => '&gt;',
 145           '<' => '&lt;',
 146          );
 147    my $rx = join '|', keys %escapes;
 148    
 149    sub _simple_xml_escape {
 150      $_[1] =~ s/($rx)/$escapes{$1}/go;
 151    }
 152  }
 153  
 154  1;
 155  __END__
 156  
 157  
 158  =head1 NAME
 159  
 160  Module::Build::PPMMaker - Perl Package Manager file creation
 161  
 162  
 163  =head1 SYNOPSIS
 164  
 165    On the command line, builds a .ppd file:
 166    ./Build ppd
 167  
 168  
 169  =head1 DESCRIPTION
 170  
 171  This package contains the code that builds F<.ppd> "Perl Package
 172  Description" files, in support of ActiveState's "Perl Package
 173  Manager".  Details are here:
 174  L<http://aspn.activestate.com/ASPN/Downloads/ActivePerl/PPM/>
 175  
 176  
 177  =head1 AUTHOR
 178  
 179  Dave Rolsky <autarch@urth.org>, Ken Williams <kwilliams@cpan.org>
 180  
 181  
 182  =head1 COPYRIGHT
 183  
 184  Copyright (c) 2001-2006 Ken Williams.  All rights reserved.
 185  
 186  This library is free software; you can redistribute it and/or
 187  modify it under the same terms as Perl itself.
 188  
 189  
 190  =head1 SEE ALSO
 191  
 192  perl(1), Module::Build(3)
 193  
 194  =cut