From 690e3e9a39e2691b483474725ee1a17d44231401 Mon Sep 17 00:00:00 2001 From: Justin Davis Date: Sun, 15 Apr 2012 19:03:20 -0400 Subject: Rename the metas/ directory to preps/. This matches the prepkg script name. --- preps/perl.d/perl-dist | 617 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 617 insertions(+) create mode 100755 preps/perl.d/perl-dist (limited to 'preps/perl.d/perl-dist') diff --git a/preps/perl.d/perl-dist b/preps/perl.d/perl-dist new file mode 100755 index 0000000..407403d --- /dev/null +++ b/preps/perl.d/perl-dist @@ -0,0 +1,617 @@ +#!/usr/bin/env perl + +use warnings 'FATAL' => 'all'; +use strict; + +my $PROG = 'preps/perl.d/perl-dist'; +my $PBPROG = 'perl-pkgbuild'; + +sub DBG {} +if(exists $ENV{'GENDBG'}){ + no warnings 'redefine'; + *DBG = sub { print STDERR "$PROG: DBG: ", @_ }; +} + +package Convert; + +*DBG = *main::DBG; + +use Module::CoreList; +use LWP::UserAgent qw(); +use YAML::XS qw(); +use version qw(); + +# Match unpredictible package names . +my %OVERRIDE = + ('libwww-perl' => 'perl-libwww', + 'aceperl' => 'perl-ace', + 'mod_perl' => 'mod_perl', + 'glade-perl-two' => 'perl-glade-two', + 'Gnome2-GConf' => 'gconf-perl', + 'Gtk2-GladeXML' => 'glade-perl', + 'Glib' => 'glib-perl', + 'Gnome2' => 'gnome-perl', + 'Gnome2-VFS' => 'gnome-vfs-perl', + 'Gnome2-Canvas' => 'gnomecanvas-perl', + 'Gnome2-GConf' => 'gconf-perl', + 'Gtk2' => 'gtk2-perl', + 'Cairo' => 'cairo-perl', + 'Pango' => 'pango-perl', + 'Perl-Critic' => 'perl-critic', + 'Perl-Tidy' => 'perl-tidy', + 'App-Ack' => 'ack', + 'TermReadKey' => 'perl-term-readkey'); + +sub dist2pkg +{ + my($name, $ver) = @_; + return dist_pkgname($name), dist_pkgver($ver); +} + +# Copied from CPANPLUS::Dist::Arch +sub dist_pkgname +{ + my($distname) = @_; + + return $OVERRIDE{$distname} if(exists $OVERRIDE{$distname}); + + # Package names should be lowercase and consist of alphanumeric + # characters only (and hyphens!)... + $distname = lc $distname; + $distname =~ tr/_+/--/; + $distname =~ tr/-a-z0-9//cd; # Delete all other chars + $distname =~ tr/-/-/s; + + # Delete leading or trailing hyphens... + $distname =~ s/\A-//; + $distname =~ s/-\z//; + + die qq{Dist name '$distname' completely violates packaging standards} + if(length $distname == 0); + + # Don't prefix the package with perl- if it IS perl... + $distname = "perl-$distname" unless($distname eq 'perl'); + + return $distname; +} + +sub dist_pkgver +{ + my($version) = @_; + + # Remove developer versions because pacman has no special logic + # to handle comparing them to regular versions such as perl uses. + $version =~ s/_[^_]+\z//; + + # Package versions should be numbers and decimal points only... + $version =~ tr/-_/../; + $version =~ tr/0-9.//cd; + + $version =~ tr/././s; + $version =~ s/^[.]|[.]$//g; + + return $version; +} + +#---HELPER FUNCTION--- +# Decide if the dist. is named after the module. +sub _ismainmod +{ + my($mod_name, $dist_name) = @_; + + $mod_name =~ tr/:/-/s; + return lc($mod_name) eq lc($dist_name); +} + +#---HELPER FUNCTION--- +# Merges the right-hand deps into the left-hand deps. +sub _merge +{ + my($left_deps, $right_deps) = @_; + + MERGE_LOOP: + while(my($pkg, $ver) = each %$right_deps){ + if($left_deps->{$pkg}){ + my $leftver = version->parse($left_deps->{$pkg}); + my $rightver = version->parse($ver); + next MERGE_LOOP if $leftver > $rightver; + } + $left_deps->{$pkg} = $ver; + } + + return; +} + +#---HELPER FUNCTION--- +# Merge duplicate deps into $left always storing the greatest version there. +sub _mergedups +{ + my($left, $right) = @_; + + for my $name (keys %$left){ + my $rver = delete $right->{$name} or next; + my $lver = $left->{$name}; + my $lvo = ($lver ? version->parse($lver) : 0); + my $rvo = ($rver ? version->parse($rver) : 0); + $left->{$name} = ($lvo > $rvo ? $lvo : $rvo); + } + + return; +} + +sub _filterdeps(&$) +{ + my($fsub, $deps) = @_; + my %fed; + + my @pkgs = keys(%$deps); + for my $dname (grep { $fsub->() } @pkgs){ + my $dver = delete $deps->{$dname}; + $fed{$dname} = $dver if(defined $dver); + } + + return \%fed; +} + +#---HELPER FUNCTION--- +sub _yankcheckers +{ + _filterdeps { /^perl-pod-coverage$|^perl-test-/ } $_[0] +} + +#---HELPER FUNCTION--- +# Converts a decimal perl version (like $]) into the dotted decimal +# form that the official ArchLinux perl package uses. +sub _perldepver +{ + my($perlver) = @_; + + # Fix perl-style vstrings which have a leading "v". + return $perlver if($perlver =~ s/\Av//); + return $perlver unless($perlver =~ /\A(\d+)[.](\d{3})(\d{1,3})\z/); + + # Re-apply the missing trailing zeroes. + my $patch = $3; + $patch .= q{0} x (3 - length $patch); + return sprintf('%d.%d.%d', $1, $2, $patch); +} + +#---PUBLIC FUNCNTION--- +# Translates CPAN module dependencies into ArchLinux package dependencies. +sub _reqs2deps +{ + my($prereqs) = @_; + my(@mods, %pkgdeps); + + # Filter out deps on 'perl' and any core modules that we can. + while(my ($name, $ver) = each(%$prereqs)) { + DBG("requires $name $ver\n"); + my $cver = $Module::CoreList::version{$]}{$name}; + + if($name eq 'perl') { + $pkgdeps{'perl'} = _perldepver($ver); + }elsif($cver){ + DBG("perl core has $name $cver\n"); + my $vobj = eval { version->parse($ver) }; + $cver = version->parse($cver); + if($vobj > $cver){ + push @mods, $name; + } + }else{ + push @mods, $name; + } + } + + my %dists = _distsofmods(@mods); + while(my ($mod, $dist) = each %dists) { + DBG("$mod is provided by $dist\n"); + my $pkgname = dist_pkgname($dist); + my $ver = $prereqs->{$mod}; + + # If the module is not named after the distribution, ignore its + # version which might not match the distribution. + undef $ver unless(_ismainmod($mod, $dist)); + + # If two module prereqs are in the same CPAN distribution then + # the version required for the main module will override. + # (because versions specified for other modules in the dist + # are 0) + $pkgdeps{$pkgname} ||= ($ver ? dist_pkgver($ver) : 0); + DBG("depends on $pkgname>=$pkgdeps{$pkgname}\n"); + } + + return \%pkgdeps; +} + +sub prereqs +{ + my($pkgname, $prereqs) = @_; + + # maps perl names for different dependencies to ArchLinux's names + my %namemap = ('configure' => 'makedepends', + 'build' => 'makedepends', + 'test' => 'checkdepends', + 'runtime' => 'depends', + ); + + my %pkgdeps; + while (my($perl, $arch) = each(%namemap)) { + my $reqs = $prereqs->{$perl}{'requires'}; + my $deps; $deps = _reqs2deps($reqs) if($reqs); + + next unless(keys %$deps); + if($pkgdeps{$arch}){ + _merge($pkgdeps{$arch}, $deps); + }else{ + $pkgdeps{$arch} = $deps; + } + } + + # ArchLinux now has a separate array for dependencies that we only + # need for checking (aka "testing"). Older perl METAs do not + # have this separated. Force any test modules to be checkdepends. + if(!$pkgdeps{'checkdepends'} && $pkgname !~ /\Aperl-test-/){ + my $checkdeps = {}; + for(qw/makedepends depends/){ + _merge($checkdeps, _yankcheckers($pkgdeps{$_})) + } + $pkgdeps{'checkdepends'} = $checkdeps; + } + + # We at least require perl, if nothing else. + unless(grep { scalar keys %$_ > 0 } values %pkgdeps){ + $pkgdeps{'depends'}{'perl'} = 0; + } + + _mergedups(@pkgdeps{'makedepends', 'checkdepends'}); + _mergedups(@pkgdeps{'depends', 'makedepends'}); + + # Convert all deps into arrays of strings. + for my $deptype (keys(%pkgdeps)){ + $pkgdeps{$deptype} = _stringify($pkgdeps{$deptype}); + } + + return \%pkgdeps; +} + +#---HELPER FUNCTION--- +sub _stringify +{ + my($deps) = @_; + + my @depstrs; + for my $pkg (sort keys %$deps){ + my $ver = $deps->{$pkg}; + my $str = ($ver eq '0' ? $pkg : "$pkg>=$ver"); + push @depstrs, $str; + } + + return \@depstrs; +} + +sub _distsofmods +{ + my(@mods) = @_; + + return () if(@mods == 0); + @mods = _nocore(@mods); + + my $var = _vardir(); + open my $fh, '<', "$var/cpanmods" + or die "$PROG: failed to open $var/cpanmods: $!"; + + my %mods = map { ($_ => 1) } @mods; + my %dists; + local $/ = ''; + + RECLOOP: + while(my $rec = <$fh>){ + last RECLOOP unless(keys %mods > 0); + + my($dist, @mvs) = split(/\n/, $rec); + MODLOOP: + for(@mvs){ + my($m) = split; + my $fnd = delete($mods{$m}) or next; + $dists{$m} = $dist; + } + } + + my @lost = keys %mods; + return %dists unless(@lost); + + for my $m (@lost){ + print STDERR "$PROG: failed to find module $m\n"; + } + exit 1; +} + +sub _nocore +{ + my(@mods) = @_; + + my $path = _vardir() . '/coremods'; + unless(-f $path){ + print STDERR "$PROG: error: $path is missing. +****************************************************************************** + You must generate it with genpkg's metas/perl.d/scrapecore script. Run it + against the source distribution of perl that is currently being packaged. +****************************************************************************** +"; + exit 1; + } + open my $if, '<', $path or die "$PROG: open $path: $!"; + + my %mods = map { ($_ => 1) } @mods; + while(<$if>){ + my($m) = split; + delete $mods{$m}; + } + + close $if; + return keys %mods; +} + +sub _vardir +{ + return $ENV{'PKGVAR'} + or die "$PROG: PKGVAR env variable is unset\n"; +} + +#----------------------------------------------------------------------------- + +package main; + +use File::Basename qw(basename dirname); +use File::Spec::Functions qw(catfile catdir rel2abs); +use File::Find qw(find); + +use JSON::XS qw(decode_json); # for META.json +use YAML::XS (); # for META.yml +use Pod::Select (); # search POD for description + +sub printdata +{ + my($pbvars) = @_; + print "options\n!emptydirs\n\n"; + printmeta($pbvars); + return; +} + +sub writepb +{ + my($ddir) = @_; + my $dtype = (-f "$ddir/Build.PL" ? "MB" : "MM"); + if(system $PBPROG => $dtype){ + return $? >> 8; + }else{ + return 0; + } +} + +sub main +{ + my $distpath = shift or die "Usage: $PROG [path to cpan dist file]\n"; + $distpath = rel2abs($distpath); + my $dir = dirname($distpath); + my $file = basename($distpath); + my $info = distinfo($file); + + chsrcdir(catdir($dir, 'src'), $file); + my $distdir = extractdist($file); + + my $meta = loadmeta($distdir); + my $desc = $meta->{'abstract'}; + if(!$desc || $desc eq '~' || $desc eq 'unknown'){ + $meta->{'abstract'} = distdesc($distdir, $info->{'mod'}); + } + + my($name, $ver) = Convert::dist2pkg(@{$info}{'name', 'ver'}); + my $deps = Convert::prereqs($name, $meta->{'prereqs'}); + + my %pbvars = + ('pkgver' => $ver, + 'pkgdesc' => $meta->{'abstract'}, + 'arch' => (xsdist($distdir) ? ['i686', 'x86_64'] : 'any'), + 'distdir' => $distdir, + %$deps, + ); + + chdir $dir or die "chdir: $!"; + + my $ret = writepb($dir); + if($ret){ + print STDERR "$PROG: failed to write PKGBUILD: error $ret\n"; + return 1; + } + + printdata(\%pbvars); + return 0; +} + +# Create the src/ directory and tarball symlink. Then chdir into it. + +sub chsrcdir +{ + my($srcdir, $distfile) = @_; + + if(-e $srcdir){ + system 'rm' => ('-fr', $srcdir); + die "failed to rm $srcdir\n" unless($? == 0); + } + mkdir $srcdir or die "mkdir $srcdir: $!"; + chdir $srcdir or die "chdir $srcdir: $!"; + unless(-f $distfile) { + symlink(catfile('..', $distfile), $distfile) + or die "symlink $distfile: $!"; + } + + return $srcdir; +} + +sub distinfo +{ + my($distfile) = @_; + + my @c = split /-/, $distfile; + my $ver = pop @c; + my $name = join q{-}, @c; + my $mod = $name; + $mod =~ s/-/::/g; + return { 'name' => $name, 'ver' => $ver, 'mod' => $mod }; +} + +sub extractdist +{ + my($file) = @_; + + system 'bsdtar' => ('-xf', $file); + die "$PROG: bsdtar failed to extract $file\n" unless($? == 0); + + opendir my $srcdir, '.' or die "opendir: $!"; + my @dirs = grep { -d $_ && !/\A[.]/ } readdir $srcdir; + closedir $srcdir; + + die "$PROG: many dirs (@dirs) inside the tarball $file\n" if(@dirs > 1); + die "$PROG: no dirs found in tarball $file\n" if(@dirs == 0); + return $dirs[0]; +} + +sub printmeta +{ + my($pbvars) = @_; + while(my($name, $val) = each %$pbvars) { + if(!defined $val || $val eq q{}) { + warn "$PROG: warning: $name is undefined\n"; + $val = q{}; + } + print $name, "\n"; + print "$_\n" for (ref $val ? @$val : $val); + print "\n"; + } + + # TODO: autodetect license type + printf("license\n%s\n\n", join "\n", qw/PerlArtistic GPL/); +} + +sub loadmeta +{ + my($distdir) = @_; + + for my $metaext (qw/json yml/){ + my $path = "$distdir/META.$metaext"; + next unless(-f $path); + + open my $metafh, '<', $path or die "open: $!"; + my $meta = do { local $/; <$metafh> }; + close $metafh; + + $meta = ($metaext eq 'json' ? decode_json($meta) : + $metaext eq 'yml' ? YAML::XS::Load($meta) : + die "internal error: unknown \$metaext: $metaext"); + + upgrademeta($meta); + return $meta; + } + + return undef; +} + +sub upgrademeta +{ + my($meta) = @_; + + return if(exists $meta->{'prereqs'}); + + my $prereqs; + $prereqs->{'configure'}{'requires'} + = delete $meta->{'configure_requires'}; + $prereqs->{'build'}{'requires'} = delete($meta->{'build_requires'}); + $prereqs->{'runtime'}{'requires'} = delete($meta->{'requires'}); + + $meta->{'prereqs'} = $prereqs; + return; +} + +sub xsdist +{ + my($dir) = @_; + my $isxs; + find({ 'wanted' => sub { $isxs = 1 if(/[.]xs$/) }, 'no_chdir' => 1 }, + $dir); + return $isxs; +} + +#----------------------------------------------------------------------------- + +sub distdesc +{ + my($dir, $modname) = @_; + return _poddesc($dir, $modname) || _readmedesc($dir, $modname); +} + +sub _poddesc +{ + my($dir, $modname) = @_; + + my $podselect = Pod::Select->new; + $podselect->select('NAME'); + + my $modpath = $modname; $modpath =~ s{::}{/}g; + my $moddir = dirname($modpath); + my $modfile = basename($modpath); + + # First check under lib/ for a "properly" pathed module, with + # nested directories. Then search desperately for a .pm file that + # matches the module's last name component. + + my @possible = glob("$dir/{lib/,}{$moddir/,}$modfile.{pod,pm}"); + + PODSEARCH: + for my $podpath (@possible){ + next PODSEARCH unless(-f $podpath); + + # Read the NAME section of the POD into a scalar. + my $namesect = q{}; + open my $podfile, '<', $podpath or next PODSEARCH; + open my $podout, '>', \$namesect or die "open: $!"; + + $podselect->parse_from_filehandle($podfile, $podout); + + close $podfile; + close $podout or die "close: $!"; + + next PODSEARCH unless($namesect); + + # Remove formatting codes. + $namesect =~ s{ [IBCLEFSXZ] <(.*?)> }{$1}gxms; + $namesect =~ s{ [IBCLEFSXZ] <<(.*?)>> }{$1}gxms; + + # The short desc is on a line beginning with 'Module::Name - ' + return $1 if($namesect =~ / ^ \s* $modname [ -]+ ([^\n]+) /xms); + } + + return undef; +} + +#---HELPER FUNCTION--- +sub _readmedesc +{ + my($dir, $modname) = @_; + + my $path = catfile($dir, 'README'); + return undef unless(-f $path); + open my $fh, '<', $path or die "open: $!"; + + while(<$fh>){ + chomp; + next unless((/\ANAME/ ... /\A[A-Z]+/) + && / \A \s* ${modname} [\s\-]+ (.+) \z /x); + return $1; + } + + close $fh; + return undef; +} + +exit main(@ARGV); -- cgit v1.2.3-24-g4f1b