summaryrefslogtreecommitdiff
path: root/libre-testing/perl/patchprov
blob: 183feb3cafe0e98f48e878f292ccd5f5af6d99a3 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
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