perl/trunk/patchprov

   1 #!/usr/bin/perl
   2 ##
   3 ## Name:
   4 ## patchprov
   5 ##
   6 ## Description:
   7 ## Patch the provides list in the perl package PKGBUILD. Scan the appropriate
   8 ## directories under the perl source tree for directories containing dists
   9 ## similar to CPAN dists. Search the files in the distributions for VERSION
  10 ## strings, which are perl expressions. Filters these version strings through
  11 ## the perl interpreter, then transform the dist. names and versions into
  12 ## package names and versions. Finally, we cut out the "provides" array from the
  13 ## PKGBUILD and replace it with the newer version.
  14 ##
  15 ## Usage:
  16 ## patchprov [path to perl source tree] [path to PKGBUILD]
  17 ##
  18 ## Caveats:
  19 ## The path code is not platform independent and will only work in POSIX.
  20 ##
  21 ## Changelog:
  22 ## 06/10/14 JD Rewrite from scratch for perl 5.20.0 and ArchLinux.
  23 ##
  24 ## Authors:
  25 ## Justin "juster" Davis <jrcd83@gmail.com>
  26 ##
  27
  28 use warnings;
  29 use strict;
  30
  31 sub err
  32 {
  33     print STDERR "patchprov: error: @_\n";
  34     exit 1;
  35 }
  36
  37 ## Extract the dist. name from its containing directory.
  38 sub path_dist
  39 {
  40     my($path) = @_;
  41     $path =~ s{^.*/}{};
  42     return $path;
  43 }
  44
  45 ## Create a path like $path/lib/Foo/Bar.pm for Foo::Bar.
  46 sub lib_modpath
  47 {
  48     my($path, $modname) = @_;
  49     $modname =~ s{::}{/}g;
  50     return "$path/lib/$modname.pm";
  51 }
  52
  53 ## Create a path to a file in the containing directory, named after
  54 ## the last segment of the module name, with suffix attached.
  55 sub dumb_modpath
  56 {
  57     my($path, $modname, $suffix) = @_;
  58     $modname =~ s{^.*::}{};
  59     return "$path/$modname$suffix";
  60 }
  61
  62 ## Find a source file contained in the directory that we can scrape the
  63 ## perl versions string from.
  64 my %distmods = (
  65     'PathTools' => 'Cwd',
  66     'Scalar-List-Utils' => 'List::Util',
  67     'IO-Compress' => 'IO::Compress::Gzip',
  68 );
  69 sub dist_srcpath
  70 {
  71     my($path) = @_;
  72     my $distname = path_dist($path);
  73     my $modname;
  74     if(exists $distmods{$distname}){
  75         $modname = $distmods{$distname};
  76     }else{
  77         $modname = $distname;
  78         $modname =~ s/-/::/g;
  79     }
  80     my @srcpaths = (
  81         lib_modpath($path, $modname),
  82         dumb_modpath($path, $modname, '.pm'),
  83         dumb_modpath($path, $modname, '_pm.PL'),
  84         dumb_modpath($path, '__'.$modname.'__', '.pm'),
  85         "$path/VERSION", # for podlators
  86     );
  87     for my $src (@srcpaths){
  88         return $src if(-f $src);
  89     }
  90     return undef;
  91 }
  92
  93 ## Scrape the version string for the module file or Makefile.PL.
  94 sub scrape_verln
  95 {
  96     my($srcpath) = @_;
  97     open my $fh, '<', $srcpath or die "open: $!";
  98     while(my $ln = <$fh>){
  99         if($ln =~ s/^.*VERSION *=>? *//){
 100             close $fh;
 101             return $ln;
 102         }
 103     }
 104     close $fh;
 105     err("failed to find VERSION in $srcpath");
 106 }
 107
 108 ## Scrape the version string from the module source file.
 109 sub scrape_modver
 110 {
 111     my($srcpath) = @_;
 112     return scrape_verln($srcpath);
 113 }
 114
 115 ## Scrape the version string from the Makefile.PL. (for libnet)
 116 sub scrape_mkplver
 117 {
 118     my($srcpath) = @_;
 119     my $verln = scrape_verln($srcpath);
 120     $verln =~ s/,/;/;
 121     return $verln;
 122 }
 123
 124 ## Scrape the version string from a file inside the dist dir.
 125 sub distpath_ver
 126 {
 127     my($distpath) = @_;
 128     my $srcpath = dist_srcpath($distpath);
 129     my $mkplpath = "$distpath/Makefile.PL";
 130     if(defined $srcpath){
 131         return scrape_modver($srcpath);
 132     }elsif(-f $mkplpath){
 133         return scrape_mkplver($mkplpath);
 134     }else{
 135         err("failed to scrape version from $distpath");
 136     }
 137 }
 138
 139 ## Search the base path for the dist dirs and extract their respective
 140 ## version strings.
 141 sub find_distvers
 142 {
 143     my($basepath) = @_;
 144     opendir my $dh, $basepath or die "opendir: $!";
 145     my @dirs = grep { -d $_ } map { "$basepath/$_" } grep { !/^[.]/ } readdir $dh;
 146     closedir $dh;
 147
 148     my @distvers;
 149     for my $dpath (@dirs){
 150         push @distvers, [ path_dist($dpath), distpath_ver($dpath) ];
 151     }
 152     return @distvers;
 153 }
 154
 155 ## Maps an aref of dist name/perl version strings (perl expressions) to
 156 ## a package name and version string suitable for a PKGBUILD.
 157 sub pkgspec
 158 {
 159     my($dist, $ver) = @$_;
 160     $dist =~ tr/A-Z/a-z/;
 161     $ver = eval $ver;
 162     return "perl-$dist=$ver";
 163 }
 164
 165 ## Searches the perl source dir provided for a list of packages which
 166 ## correspond to the core distributions bundled within in.
 167 sub perlcorepkgs
 168 {
 169     my($perlpath) = @_;
 170     my @dirs = ("$perlpath/cpan", "$perlpath/dist");
 171     my @provs;
 172     for my $d (@dirs){
 173         if(!-d $d){
 174             err("$d is not a valid directory");
 175         }
 176         push @provs, map pkgspec, find_distvers($d);
 177     }
 178     return @provs;
 179 }
 180
 181 ## Formats the provided lines into a neatly formatted bash array. The first arg
 182 ## is the name of the bash variable to assign it to.
 183 sub basharray
 184 {
 185     my $vname = shift;
 186
 187     ## Sort entries and surround with quotes.
 188     my @lns = sort map { qq{'$_'} } @_;
 189     $lns[0] = "$vname=($lns[0]";
 190
 191     ## Indent lines for OCD geeks.
 192     if(@lns > 1){
 193         my $ind = length($vname) + 2;
 194         splice @lns, 1, @lns-1,
 195             map { (' ' x $ind) . $_ } @lns[1 .. $#lns];
 196     }
 197
 198     $lns[$#lns] .= ')';
 199     return map { "$_\n" } @lns;
 200 }
 201
 202 ## Patch the PKGBUILD at the given path with a new provides array, overwriting
 203 ## the old one.
 204 sub patchpb
 205 {
 206     my $pbpath = shift;
 207     open my $fh, '<', $pbpath or die "open: $!";
 208     my @lines = <$fh>;
 209     close $fh;
 210
 211     my($i, $j);
 212     for($i = 0; $i < @lines; $i++){
 213         last if($lines[$i] =~ /^provides=/);
 214     }
 215     if($i == @lines){
 216         err("failed to find provides array in PKGBUILD");
 217     }
 218     for($j = $i; $j < @lines; $j++){
 219         last if($lines[$j] =~ /[)]/);
 220     }
 221     if($j == @lines){
 222         err("failed to find end of provides array");
 223     }
 224
 225     splice @lines, $i, $j-$i+1,
 226         basharray('provides', grep { !/win32|next/ } @_);
 227
 228     ## Avoid corrupting the existing PKGBUILD in case of a crash, etc.
 229     if(-f "$pbpath.$$"){
 230         err("pbpath.$$ temporary file already exists, please remove it.");
 231     }
 232     open $fh, '>', "$pbpath.$$" or die "open: $!";
 233     print $fh @lines;
 234     close $fh or die "close: $!";
 235     rename "$pbpath.$$", "$pbpath" or die "rename: $!";
 236
 237     return;
 238 }
 239
 240 ## Program entrypoint.
 241 sub main
 242 {
 243     if(@_ < 2){
 244         print STDERR "usage: $0 [perl source path] [PKGBUILD path]\n";
 245         exit 2;
 246     }
 247     my($perlpath, $pbpath) = @_;
 248     if(!-f $pbpath){
 249         err("$pbpath is not a valid file.");
 250     }elsif(!-d $perlpath){
 251         err("$perlpath is not a valid directory.");
 252     }else{
 253         patchpb($pbpath, perlcorepkgs($perlpath));
 254     }
 255     exit 0;
 256 }
 257
 258 main(@ARGV);
 259
 260 # EOF