#!/usr/bin/env perl use warnings 'FATAL' => 'all'; use strict; my $PROG = 'perl-dist'; package Convert; 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)) { my $cver = $Module::CoreList::version{$]}{$name}; if($name eq 'perl') { $pkgdeps{'perl'} = _perldepver($ver); }elsif($cver && !$ver || version->parse($ver) > version->parse($cver)){ # Only add deps for core modules if we need a higher # version than what is in the core for our perl interpreter. ; }else{ push @mods, $name; } } my %dists = _distsofmods(@mods); while(my ($mod, $dist) = each %dists) { 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); } 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 = {}; _merge($checkdeps, _yankcheckers($pkgdeps{$_})) for(qw/makedepends depends/); $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; if(@lost){ for my $m (@lost){ print STDERR "$PROG: failed to find module $m\n"; } exit 1; } return %dists; } sub _nocore { my (@mods) = @_; my $path = _vardir() . '/coremods'; 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); 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 use Digest::MD5 (); # for md5sums & sha512sums use Digest::SHA (); sub main { my $distpath = shift() or die "Usage: $PROG [path to cpan dist file]\n"; my $dir = dirname($distpath); my $file = basename($distpath); my $info = distinfo($file); chsrcdir(catdir($dir, 'src'), $file); $dir = extractdist($file); my $meta = loadmeta($dir); my $desc = $meta->{'abstract'}; if(!$desc || $desc eq '~' || $desc eq 'unknown') { $meta->{'abstract'} = distdesc($dir, $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($dir) ? ['i686', 'x86_64'] : 'any'), 'md5sums' => md5sums($file), 'sha512sums' => sha512sums($file), 'distdir' => $dir, %$deps, ); # Since this is a perl distribution, use the perl-pkg template. printf("template\nperl-pkg %s\n\n", (-f "$dir/Build.PL" ? "MB" : "MM")); print("options\n!emptydirs\n\n"); printmeta(\%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) == 0 or die "failed to rm $srcdir\n"; } 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; } #----------------------------------------------------------------------------- sub md5sums { return [ map { open(my $fh, '<', $_) or die "open: $!"; my $md5 = Digest::MD5->new()->addfile($fh)->hexdigest; } @_ ] } sub sha512sums { return [ map { my $sha = Digest::SHA->new(512)->addfile($_)->hexdigest; } @_ ] } exit main(@ARGV);