[Module-build-general] [PATCH] ./Build ppd codebase=...
Status: Beta
Brought to you by:
kwilliams
Menu
▾
▴
[Module-build-general] [PATCH] ./Build ppd codebase=...
|
From: Dave R. <au...@ur...> - 2003-04-24 20:32:03
|
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/\"/"/g; + $_[1] =~ s/&/&/g; + $_[1] =~ s/</</g; + $_[1] =~ s/>/>/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 $@, ''; |
