Thread: [Module-build-general] [PATCH] ./Build ppd codebase=...

SourceForge Headquarters 1320 Columbia Street Suite 310 San Diego, CA 92101 +1 (858) 422-6466

This patch adds support a "Build ppd" action, along with tests for it.
The PPD generating code is mostly from EU::MM_Unix in the 6.10_03 distro,
except that I don't add the OS or ARCHITECTURE tags unless the module
includes XS, though I really don't know if that's right.

I also updated a few attribute names based on the spec at
http://www.xav.com/perl/site/lib/XML/PPD.html

The patch also refactors several bits of code so that the ACTION_ppd
method didn't have too much cut'n'pasted code in it.

It adds two new properties, 'author' and 'abstract', though the latter can
be determined by looking at a module's docs if it isn't given.

There's no docs in the patch, but I'd be happy to do that if the patch is
accepted.

Patch after sig.


-dave

/*=======================
House Absolute Consulting
www.houseabsolute.com
=======================*/


? t/XSTest/lib/XSTest.bs
? t/XSTest/lib/XSTest.c
Index: lib/Module/Build/Base.pm
===================================================================
RCS file: /cvsroot/module-build/Module-Build/lib/Module/Build/Base.pm,v
retrieving revision 1.97
diff -u -r1.97 Base.pm

--- lib/Module/Build/Base.pm	24 Apr 2003 16:23:52 -0000	1.97
+++ lib/Module/Build/Base.pm	24 Apr 2003 20:27:00 -0000
@@ -198,6 +198,9 @@
        verbose
        c_source
        autosplit
+
+       author
+       abstract
       );

   sub valid_property { exists $valid_properties{$_[1]} }
@@ -436,10 +439,7 @@
   my %status = (need => $spec);

   if ($modname eq 'perl') {
-    # Check the current perl interpreter
-    # It's much more convenient to use $] here than $^V, but 'man
-    # perlvar' says I'm not supposed to.  Bloody tyrant.
-    $status{have} = $^V ? $self->perl_version_to_float(sprintf "%vd", $^V) : $];
+    $status{have} = $self->_find_perl_version;

   } else {
     my $file = $self->find_module_by_name($modname, \@INC);
@@ -455,12 +455,7 @@
     }
   }

-  my @conditions;
-  if ($spec =~ /^\s*([\w.]+)\s*$/) { # A plain number, maybe with dots, letters, and underscores
-    @conditions = (">= $spec");
-  } else {
-    @conditions = split /\s*,\s*/, $spec;
-  }
+  my @conditions = $self->_parse_conditions($spec);

   foreach (@conditions) {
     unless ( /^\s*  (<=?|>=?|==|!=)  \s*  ([\w.]+)  \s*$/x ) {
@@ -481,6 +476,24 @@
   return \%status;
 }

+sub _find_perl_version {
+  my ($self) = @_;
+  # Check the current perl interpreter
+  # It's much more convenient to use $] here than $^V, but 'man
+  # perlvar' says I'm not supposed to.  Bloody tyrant.
+  return $^V ? $self->perl_version_to_float(sprintf "%vd", $^V) : $];
+}
+
+sub _parse_conditions {
+  my($self, $spec) = @_;
+
+  if ($spec =~ /^\s*([\w.]+)\s*$/) { # A plain number, maybe with dots, letters, and underscores
+    return (">= $spec");
+  } else {
+    return split /\s*,\s*/, $spec;
+  }
+}
+
 # I wish I could set $! to a string, but I can't, so I use $@
 sub check_installed_version {
   my ($self, $modname, $spec) = @_;
@@ -611,7 +624,12 @@
   my ($action, %args);
   foreach (@_) {
     if ( /^(\w+)=(.*)/ ) {
-      $args{$1} = $2;
+      if ( exists $args{$1} ) {
+        $args{$1} = [ $args{$1} ] unless ref $args{$1};
+        push @{$args{$1}}, $2;
+      } else {
+        $args{$1} = $2;
+      }
     } elsif ( /^(\w+)$/ ) {
       die "Error: multiple build actions given: '$action' and '$1'" if $action;
       $action = $1;
@@ -1070,6 +1088,152 @@
   require ExtUtils::Manifest;  # ExtUtils::Manifest is not warnings clean.
   local ($^W, $ExtUtils::Manifest::Quiet) = (0,1);
   ExtUtils::Manifest::mkmanifest();
+}
+
+# This code is mostly borrowed from ExtUtils::MM_Unix 6.10_03, with a
+# few tweaks based on the PPD spec at
+# http://www.xav.com/perl/site/lib/XML/PPD.html
+sub ACTION_ppd {
+  my ($self) = @_;
+
+  unless (exists $self->{args}{codebase}) {
+    warn "Cannot create a PPD file unless codebase argument is given\n";
+    return;
+  }
+
+  $self->find_version;
+  my $version = $self->_ppd_version($self->{properties}{dist_version});
+
+  my $abstract = $self->{properties}{abstract};
+
+  unless (defined $abstract) {
+    $abstract = $self->_parse_abstract($self->{properties}{dist_version_from});
+  }
+
+  $abstract = '' unless defined $abstract;
+
+  my $author =
+    defined $self->{properties}{author} ? $self->{properties}{author} : '';
+
+  $self->_simple_xml_escape($_) for ($abstract, $author);
+
+  # could add <LICENSE HREF=...> tag if we knew what the URLs were for
+  # various licenses
+  my $ppd = sprintf(<<'EOF', $self->{properties}{dist_name}, $version, $self->{properties}{dist_name}, $abstract, $author);
+<SOFTPKG NAME="%s" VERSION="%s">
+    <TITLE>%s</TITLE>
+    <ABSTRACT>%s</ABSTRACT>
+    <AUTHOR>%s</AUTHOR>
+    <IMPLEMENTATION>
+EOF
+
+  foreach my $type (qw(requires recommends build_requires)) {
+    while (my ($modname, $spec) = each %{$self->{properties}{$type}}) {
+      next if $modname eq 'perl';
+
+      my $min_version = '0.0';
+      foreach my $c ($self->_parse_conditions($spec)) {
+        my ($op, $version) = $c =~ /^\s*  (<=?|>=?|==|!=)  \s*  ([\w.]+)  \s*$/x;
+
+        # This is a nasty hack because it fails if there is no >= op
+        if ($op eq '>=') {
+          $min_version = $version;
+          last;
+        }
+      }
+
+      $modname =~ s/::/-/g;
+
+      # Another hack because we treat everything as a plain dependency
+      $ppd .= sprintf(<<'EOF', $modname, $self->_ppd_version($min_version));
+        <DEPENDENCY NAME="%s" VERSION="%s" />
+EOF
+
+    }
+  }
+
+  # We only include these tags if this module involves XS, on the
+  # assumption that pure Perl modules will work on any OS.  PERLCORE,
+  # unfortunately, seems to indicate that a module works with _only_
+  # that version of Perl, and so is only appropriate when a module
+  # uses XS.
+  if (@{$self->find_xs_files}) {
+    my $perl_version = $self->_ppd_version($self->_find_perl_version);
+    $ppd .= sprintf(<<'EOF', $perl_version, $^O, $self->{config}{archname});
+        <PERLCORE VERSION="%s" />
+        <OS VALUE="%s" />
+        <ARCHITECTURE NAME="%s" />
+EOF
+  }
+
+  foreach my $codebase (ref $self->{args}{codebase} ?
+                        @{$self->{args}{codebase}} :
+                        $self->{args}{codebase} ) {
+    $self->_simple_xml_escape($codebase);
+    $ppd .= sprintf(<<'EOF', $codebase);
+        <CODEBASE HREF="%s" />
+EOF
+  }
+
+  $ppd .= <<'EOF';
+    </IMPLEMENTATION>
+</SOFTPKG>
+EOF
+
+  my $ppd_file = "$self->{properties}{dist_name}.ppd";
+  my $fh = IO::File->new(">$ppd_file")
+    or die "Cannot write to $ppd_file: $!";
+  print $fh $ppd;
+  close $fh;
+
+  $self->add_to_cleanup($ppd_file);
+}
+
+sub _parse_abstract {
+    my($self, $file) = @_;
+
+    my $result;
+    local $/ = "\n";
+
+    my $fh = IO::File->new("<$file")
+      or die "Could not open $file: $!";
+
+    my $package = $self->{properties}{dist_name};
+    $package =~ s/-/::/g;
+
+    my $inpod = 0;
+    while (<$fh>) {
+      $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
+
+      next unless $inpod;
+
+      chomp;
+
+      next unless /^($package\s-\s)(.*)/;
+
+      $result = $2;
+      last;
+    }
+    close $fh;
+
+    return $result;
+}
+
+sub _ppd_version {
+  my ($self, $version) = @_;
+
+  # generates something like "0,18,0,0"
+  return join ',', (split(/\./, $version), (0)x4)[0..3];
+}
+
+sub _simple_xml_escape {
+  my ($self) = @_;
+
+  $_[1] =~ s/\n/\\n/sg;
+  $_[1] =~ s/\"/&quot;/g;
+  $_[1] =~ s/&/&amp;/g;
+  $_[1] =~ s/</&lt;/g;
+  $_[1] =~ s/>/&gt;/g;
 }

 sub dist_dir {
Index: t/runthrough.t
===================================================================
RCS file: /cvsroot/module-build/Module-Build/t/runthrough.t,v
retrieving revision 1.17
diff -u -r1.17 runthrough.t
--- t/runthrough.t	24 Apr 2003 16:24:35 -0000	1.17
+++ t/runthrough.t	24 Apr 2003 20:27:00 -0000
@@ -1,5 +1,7 @@
+use strict;
+
 use Test;
-BEGIN { plan tests => 17 }
+BEGIN { plan tests => 18 }
 use Module::Build;
 use File::Spec;
 use File::Path;
@@ -20,6 +22,9 @@
 chdir $goto or die "can't chdir to $goto: $!";

 my $build = new Module::Build( module_name => 'Sample', scripts => [ 'script' ],
+                               requires    => {'Module::Build' => 0.05},
+                               author      => 'Sample Author',
+                               abstract    => 'Sample Abstract',
 			       license => 'perl' );
 ok $build;

@@ -101,6 +106,28 @@

   ok $first_line ne "#!perl -w\n";
 }
+
+{
+  $build->dispatch('ppd', args => {codebase => '/path/to/codebase'});
+
+  my $ppd = slurp('Sample.ppd');
+
+  # This test is quite a hack since with XML you don't really want to
+  # do a strict string comparison, but absent an XML parser it's the
+  # best we can do.
+  ok $ppd, <<'EOF';
+<SOFTPKG NAME="Sample" VERSION="0,01,0,0">
+    <TITLE>Sample</TITLE>
+    <ABSTRACT>Sample Abstract</ABSTRACT>
+    <AUTHOR>Sample Author</AUTHOR>
+    <IMPLEMENTATION>
+        <DEPENDENCY NAME="Module-Build" VERSION="0,05,0,0" />
+        <CODEBASE HREF="/path/to/codebase" />
+    </IMPLEMENTATION>
+</SOFTPKG>
+EOF
+}
+

 eval {$build->dispatch('realclean')};
 ok $@, '';
Index: t/xs.t
===================================================================
RCS file: /cvsroot/module-build/Module-Build/t/xs.t,v
retrieving revision 1.5
diff -u -r1.5 xs.t
--- t/xs.t	24 Feb 2003 18:23:20 -0000	1.5
+++ t/xs.t	24 Apr 2003 20:27:00 -0000
@@ -4,12 +4,15 @@
 use Test;

 print("1..0 # Skipped: no compiler found\n"), exit(0) unless have_compiler();
-plan tests => 7;
+plan tests => 8;

+use Config;
 use Module::Build;
 use File::Spec;
 ok(1);

+require File::Spec->catfile('t', 'common.pl');
+
 ######################### End of black magic.

 # Pretend we're in the t/XSTest/ subdirectory
@@ -19,6 +22,7 @@
 my $m = new Module::Build
   (
    module_name => 'XSTest',
+   author      => 'XSTest Author',
   );
 ok(1);

@@ -31,6 +35,31 @@
 # We can't be verbose in the sub-test, because Test::Harness will think that the output is for the top-level test.
 eval {$m->dispatch('test')};
 ok $@, '';
+
+{
+  $m->dispatch('ppd', args => {codebase => '/path/to/codebase-xs'});
+
+  my $ppd = slurp('XSTest.ppd');
+
+  my $perl_version = $m->_ppd_version($m->_find_perl_version);
+
+  # This test is quite a hack since with XML you don't really want to
+  # do a strict string comparison, but absent an XML parser it's the
+  # best we can do.
+  ok $ppd, <<"EOF";
+<SOFTPKG NAME="XSTest" VERSION="0,01,0,0">
+    <TITLE>XSTest</TITLE>
+    <ABSTRACT>Perl extension for blah blah blah</ABSTRACT>
+    <AUTHOR>XSTest Author</AUTHOR>
+    <IMPLEMENTATION>
+        <PERLCORE VERSION="$perl_version" />
+        <OS VALUE="$^O" />
+        <ARCHITECTURE NAME="$Config{archname}" />
+        <CODEBASE HREF="/path/to/codebase-xs" />
+    </IMPLEMENTATION>
+</SOFTPKG>
+EOF
+}

 eval {$m->dispatch('realclean')};
 ok $@, '';




Thread: [Module-build-general] [PATCH] ./Build ppd codebase=...

module-build-general