diff options
Diffstat (limited to 'libre-testing/perl/patchprov')
| -rwxr-xr-x | libre-testing/perl/patchprov | 260 |
1 files changed, 260 insertions, 0 deletions
diff --git a/libre-testing/perl/patchprov b/libre-testing/perl/patchprov new file mode 100755 index 000000000..183feb3ca --- /dev/null +++ b/libre-testing/perl/patchprov @@ -0,0 +1,260 @@ +#!/usr/bin/perl +## +## Name: +## patchprov +## +## Description: +## Patch the provides list in the perl package PKGBUILD. Scan the appropriate +## directories under the perl source tree for directories containing dists +## similar to CPAN dists. Search the files in the distributions for VERSION +## strings, which are perl expressions. Filters these version strings through +## the perl interpreter, then transform the dist. names and versions into +## package names and versions. Finally, we cut out the "provides" array from the +## PKGBUILD and replace it with the newer version. +## +## Usage: +## patchprov [path to perl source tree] [path to PKGBUILD] +## +## Caveats: +## The path code is not platform independent and will only work in POSIX. +## +## Changelog: +## 06/10/14 JD Rewrite from scratch for perl 5.20.0 and ArchLinux. +## +## Authors: +## Justin "juster" Davis <jrcd83@gmail.com> +## + +use warnings; +use strict; + +sub err +{ + print STDERR "patchprov: error: @_\n"; + exit 1; +} + +## Extract the dist. name from its containing directory. +sub path_dist +{ + my($path) = @_; + $path =~ s{^.*/}{}; + return $path; +} + +## Create a path like $path/lib/Foo/Bar.pm for Foo::Bar. +sub lib_modpath +{ + my($path, $modname) = @_; + $modname =~ s{::}{/}g; + return "$path/lib/$modname.pm"; +} + +## Create a path to a file in the containing directory, named after +## the last segment of the module name, with suffix attached. +sub dumb_modpath +{ + my($path, $modname, $suffix) = @_; + $modname =~ s{^.*::}{}; + return "$path/$modname$suffix"; +} + +## Find a source file contained in the directory that we can scrape the +## perl versions string from. +my %distmods = ( + 'PathTools' => 'Cwd', + 'Scalar-List-Utils' => 'List::Util', + 'IO-Compress' => 'IO::Compress::Gzip', +); +sub dist_srcpath +{ + my($path) = @_; + my $distname = path_dist($path); + my $modname; + if(exists $distmods{$distname}){ + $modname = $distmods{$distname}; + }else{ + $modname = $distname; + $modname =~ s/-/::/g; + } + my @srcpaths = ( + lib_modpath($path, $modname), + dumb_modpath($path, $modname, '.pm'), + dumb_modpath($path, $modname, '_pm.PL'), + dumb_modpath($path, '__'.$modname.'__', '.pm'), + "$path/VERSION", # for podlators + ); + for my $src (@srcpaths){ + return $src if(-f $src); + } + return undef; +} + +## Scrape the version string for the module file or Makefile.PL. +sub scrape_verln +{ + my($srcpath) = @_; + open my $fh, '<', $srcpath or die "open: $!"; + while(my $ln = <$fh>){ + if($ln =~ s/^.*VERSION *=>? *//){ + close $fh; + return $ln; + } + } + close $fh; + err("failed to find VERSION in $srcpath"); +} + +## Scrape the version string from the module source file. +sub scrape_modver +{ + my($srcpath) = @_; + return scrape_verln($srcpath); +} + +## Scrape the version string from the Makefile.PL. (for libnet) +sub scrape_mkplver +{ + my($srcpath) = @_; + my $verln = scrape_verln($srcpath); + $verln =~ s/,/;/; + return $verln; +} + +## Scrape the version string from a file inside the dist dir. +sub distpath_ver +{ + my($distpath) = @_; + my $srcpath = dist_srcpath($distpath); + my $mkplpath = "$distpath/Makefile.PL"; + if(defined $srcpath){ + return scrape_modver($srcpath); + }elsif(-f $mkplpath){ + return scrape_mkplver($mkplpath); + }else{ + err("failed to scrape version from $distpath"); + } +} + +## Search the base path for the dist dirs and extract their respective +## version strings. +sub find_distvers +{ + my($basepath) = @_; + opendir my $dh, $basepath or die "opendir: $!"; + my @dirs = grep { -d $_ } map { "$basepath/$_" } grep { !/^[.]/ } readdir $dh; + closedir $dh; + + my @distvers; + for my $dpath (@dirs){ + push @distvers, [ path_dist($dpath), distpath_ver($dpath) ]; + } + return @distvers; +} + +## Maps an aref of dist name/perl version strings (perl expressions) to +## a package name and version string suitable for a PKGBUILD. +sub pkgspec +{ + my($dist, $ver) = @$_; + $dist =~ tr/A-Z/a-z/; + $ver = eval $ver; + return "perl-$dist=$ver"; +} + +## Searches the perl source dir provided for a list of packages which +## correspond to the core distributions bundled within in. +sub perlcorepkgs +{ + my($perlpath) = @_; + my @dirs = ("$perlpath/cpan", "$perlpath/dist"); + my @provs; + for my $d (@dirs){ + if(!-d $d){ + err("$d is not a valid directory"); + } + push @provs, map pkgspec, find_distvers($d); + } + return @provs; +} + +## Formats the provided lines into a neatly formatted bash array. The first arg +## is the name of the bash variable to assign it to. +sub basharray +{ + my $vname = shift; + + ## Sort entries and surround with quotes. + my @lns = sort map { qq{'$_'} } @_; + $lns[0] = "$vname=($lns[0]"; + + ## Indent lines for OCD geeks. + if(@lns > 1){ + my $ind = length($vname) + 2; + splice @lns, 1, @lns-1, + map { (' ' x $ind) . $_ } @lns[1 .. $#lns]; + } + + $lns[$#lns] .= ')'; + return map { "$_\n" } @lns; +} + +## Patch the PKGBUILD at the given path with a new provides array, overwriting +## the old one. +sub patchpb +{ + my $pbpath = shift; + open my $fh, '<', $pbpath or die "open: $!"; + my @lines = <$fh>; + close $fh; + + my($i, $j); + for($i = 0; $i < @lines; $i++){ + last if($lines[$i] =~ /^provides=/); + } + if($i == @lines){ + err("failed to find provides array in PKGBUILD"); + } + for($j = $i; $j < @lines; $j++){ + last if($lines[$j] =~ /[)]/); + } + if($j == @lines){ + err("failed to find end of provides array"); + } + + splice @lines, $i, $j-$i+1, + basharray('provides', grep { !/win32|next/ } @_); + + ## Avoid corrupting the existing PKGBUILD in case of a crash, etc. + if(-f "$pbpath.$$"){ + err("pbpath.$$ temporary file already exists, please remove it."); + } + open $fh, '>', "$pbpath.$$" or die "open: $!"; + print $fh @lines; + close $fh or die "close: $!"; + rename "$pbpath.$$", "$pbpath" or die "rename: $!"; + + return; +} + +## Program entrypoint. +sub main +{ + if(@_ < 2){ + print STDERR "usage: $0 [perl source path] [PKGBUILD path]\n"; + exit 2; + } + my($perlpath, $pbpath) = @_; + if(!-f $pbpath){ + err("$pbpath is not a valid file."); + }elsif(!-d $perlpath){ + err("$perlpath is not a valid directory."); + }else{ + patchpb($pbpath, perlcorepkgs($perlpath)); + } + exit 0; +} + +main(@ARGV); + +# EOF |