line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# You may distribute under the terms of either the GNU General Public License |
2
|
|
|
|
|
|
|
# or the Artistic License (the same terms as Perl itself) |
3
|
|
|
|
|
|
|
# |
4
|
|
|
|
|
|
|
# (C) Paul Evans, 2013-2019 -- leonerd@leonerd.org.uk |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
package App::sourcepan; |
7
|
|
|
|
|
|
|
|
8
|
1
|
|
|
1
|
|
543
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
23
|
|
9
|
1
|
|
|
1
|
|
4
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
30
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
our $VERSION = '0.03'; |
12
|
|
|
|
|
|
|
|
13
|
1
|
|
|
1
|
|
717
|
use CPAN; |
|
1
|
|
|
|
|
229675
|
|
|
1
|
|
|
|
|
415
|
|
14
|
1
|
|
|
1
|
|
22
|
use File::Basename qw( basename ); |
|
1
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
82
|
|
15
|
1
|
|
|
1
|
|
11
|
use File::Copy qw( copy ); |
|
1
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
135
|
|
16
|
1
|
|
|
1
|
|
1009
|
use IPC::Run qw(); |
|
1
|
|
|
|
|
28025
|
|
|
1
|
|
|
|
|
946
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
=head1 NAME |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
C - modulino implementation of F |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
=head1 SYNOPSIS |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
This module contains the code to implement the F command. |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
See L for usage information. |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
=cut |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
# TODO: damnit does CPAN::Shell not have a method for this?? |
31
|
|
|
|
|
|
|
sub _split_version |
32
|
|
|
|
|
|
|
{ |
33
|
0
|
|
|
0
|
|
|
shift =~ m/^(.*?)(?:-(\d+[[:digit:].]*))?$/; |
34
|
|
|
|
|
|
|
} |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
sub run |
37
|
|
|
|
|
|
|
{ |
38
|
0
|
|
|
0
|
0
|
|
shift; |
39
|
0
|
|
|
|
|
|
my ( $opts, @items ) = @_; |
40
|
|
|
|
|
|
|
|
41
|
0
|
|
|
|
|
|
my $type = $opts->{type}; |
42
|
|
|
|
|
|
|
|
43
|
0
|
|
|
|
|
|
my %dists; |
44
|
0
|
0
|
|
|
|
|
if( $type eq "module" ) { |
45
|
0
|
|
|
|
|
|
foreach my $module ( CPAN::Shell->expand( Module => @items ) ) { |
46
|
0
|
|
|
|
|
|
my $dist = $module->distribution; |
47
|
0
|
|
|
|
|
|
$dists{$dist->pretty_id} = $dist; |
48
|
|
|
|
|
|
|
} |
49
|
|
|
|
|
|
|
} |
50
|
|
|
|
|
|
|
else { |
51
|
|
|
|
|
|
|
# Dists have full names; search by regexp to match on dist base name |
52
|
0
|
|
|
|
|
|
foreach ( @items ) { |
53
|
0
|
|
|
|
|
|
my ( $basename, $ver ) = _split_version( $_ ); |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
# CPAN::Shell doesn't like a qr//, only a literal string |
56
|
0
|
0
|
|
|
|
|
my $match = defined $ver ? "/\\/$basename-$ver\\./" |
57
|
|
|
|
|
|
|
: "/\\/$basename-\\d+/"; |
58
|
|
|
|
|
|
|
|
59
|
0
|
|
|
|
|
|
my $latestver; |
60
|
0
|
|
|
|
|
|
foreach my $dist ( CPAN::Shell->expand( Distribution => $match ) ) { |
61
|
0
|
|
|
|
|
|
$dists{$dist->pretty_id} = $dist; |
62
|
0
|
|
|
|
|
|
my ( undef, $thisver ) = _split_version $dist->base_id; |
63
|
0
|
0
|
0
|
|
|
|
if( !defined $latestver or $latestver < $thisver ) { |
64
|
0
|
|
|
|
|
|
$latestver = $thisver; |
65
|
|
|
|
|
|
|
} |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
|
68
|
0
|
0
|
|
|
|
|
if( !defined $ver ) { |
69
|
0
|
|
|
|
|
|
foreach ( keys %dists ) { |
70
|
0
|
|
|
|
|
|
my ( $thisname, $thisver ) = _split_version $dists{$_}->base_id; |
71
|
0
|
0
|
|
|
|
|
next if $thisname ne $basename; |
72
|
0
|
0
|
|
|
|
|
next if $thisver == $latestver; |
73
|
0
|
|
|
|
|
|
delete $dists{$_}; |
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
|
} |
78
|
|
|
|
|
|
|
|
79
|
0
|
|
|
|
|
|
foreach my $id ( sort keys %dists ) { |
80
|
0
|
|
|
|
|
|
my $dist = $dists{$id}; |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
# Peeking inside |
83
|
0
|
|
|
|
|
|
$dist->get_file_onto_local_disk; |
84
|
|
|
|
|
|
|
|
85
|
0
|
|
|
|
|
|
my $basename = basename $id; |
86
|
0
|
0
|
|
|
|
|
copy( $dist->{localfile}, $basename ) or die "Cannot copy - $!"; |
87
|
|
|
|
|
|
|
|
88
|
0
|
|
|
|
|
|
print "$id => $basename\n"; |
89
|
|
|
|
|
|
|
|
90
|
0
|
0
|
|
|
|
|
next unless $opts->{extract}; |
91
|
|
|
|
|
|
|
|
92
|
0
|
|
|
|
|
|
my $dirname; |
93
|
|
|
|
|
|
|
|
94
|
0
|
0
|
|
|
|
|
if( $id =~ m/\.tar\.(?:gz|bz2)$/ ) { |
|
|
0
|
|
|
|
|
|
95
|
0
|
0
|
|
|
|
|
my $tarflags = ( $id =~ m/bz2$/ ) ? "xjf" : "xzf"; |
96
|
0
|
0
|
|
|
|
|
system( "tar", $tarflags, $basename ) == 0 or |
97
|
|
|
|
|
|
|
die "Unable to extract - tar failed with exit code $?\n"; |
98
|
|
|
|
|
|
|
|
99
|
0
|
|
|
|
|
|
( $dirname = $basename ) =~ s/\.tar.(?:gz|bz2)$//; |
100
|
0
|
0
|
|
|
|
|
-d $dirname or |
101
|
|
|
|
|
|
|
die "Expected to extract a directory called $dirname\n"; |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
elsif( $id =~ m/\.zip$/ ) { |
104
|
0
|
0
|
|
|
|
|
IPC::Run::run [ "unzip", $basename ], ">/dev/null" or |
105
|
|
|
|
|
|
|
die "Unable to extract - unzip failed with exit code $?\n"; |
106
|
|
|
|
|
|
|
|
107
|
0
|
|
|
|
|
|
( $dirname = $basename ) =~ s/\.zip$//; |
108
|
0
|
0
|
|
|
|
|
-d $dirname or |
109
|
|
|
|
|
|
|
die "Expected to extract a directory called $dirname\n"; |
110
|
|
|
|
|
|
|
} |
111
|
|
|
|
|
|
|
else { |
112
|
0
|
|
|
|
|
|
die "Unsure how to unpack $id\n"; |
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
|
115
|
0
|
0
|
|
|
|
|
if( $opts->{unversioned} ) { |
116
|
0
|
0
|
|
|
|
|
( my $newname = $dirname ) =~ s/-[0-9._]+$// or |
117
|
|
|
|
|
|
|
die "Unable to determine the unversioned name for $dirname\n"; |
118
|
|
|
|
|
|
|
|
119
|
0
|
0
|
|
|
|
|
rename $dirname, $newname or |
120
|
|
|
|
|
|
|
die "Unable to rename $dirname to $newname - $!"; |
121
|
|
|
|
|
|
|
|
122
|
0
|
|
|
|
|
|
$dirname = $newname; |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
|
125
|
0
|
|
|
|
|
|
print "Unpacked $basename to $dirname\n"; |
126
|
|
|
|
|
|
|
|
127
|
0
|
0
|
|
|
|
|
if( my $vc = $opts->{vc_init} ) { |
128
|
0
|
0
|
|
|
|
|
my $code = __PACKAGE__->can( "vc_init_$vc" ) or |
129
|
|
|
|
|
|
|
die "Unsure how to initialise version control system $vc\n"; |
130
|
|
|
|
|
|
|
|
131
|
0
|
0
|
|
|
|
|
$code->( $dirname, |
132
|
|
|
|
|
|
|
id => $id |
133
|
|
|
|
|
|
|
) or exit $?; |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
sub vc_init_bzr |
139
|
|
|
|
|
|
|
{ |
140
|
0
|
|
|
0
|
0
|
|
my ( $dirname, %opts ) = @_; |
141
|
|
|
|
|
|
|
|
142
|
0
|
0
|
|
|
|
|
defined( my $kid = fork() ) or die "Cannot fork - $!"; |
143
|
0
|
0
|
|
|
|
|
return waitpid $kid, 0 if $kid; |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
# In a subprocess |
146
|
0
|
0
|
|
|
|
|
chdir $dirname or die "Cannot chdir $dirname - $!"; |
147
|
|
|
|
|
|
|
|
148
|
0
|
0
|
|
|
|
|
IPC::Run::run( [ "bzr", "init" ] ) or die "Unable to 'bzr init' ($?)\n"; |
149
|
0
|
0
|
|
|
|
|
IPC::Run::run( [ "bzr", "add", "." ] ) or die "Unable to 'bzr add ($?)\n"; |
150
|
0
|
0
|
|
|
|
|
IPC::Run::run( [ "bzr", "commit", "-m", "Imported $opts{id}" ] ) or die "Unable to 'bzr commit' ($?)\n"; |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
sub vc_init_git |
154
|
|
|
|
|
|
|
{ |
155
|
0
|
|
|
0
|
0
|
|
my ( $dirname, %opts ) = @_; |
156
|
|
|
|
|
|
|
|
157
|
0
|
0
|
|
|
|
|
defined( my $kid = fork() ) or die "Cannot fork - $!"; |
158
|
0
|
0
|
|
|
|
|
return waitpid $kid, 0 if $kid; |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
# In a subprocess |
161
|
0
|
0
|
|
|
|
|
chdir $dirname or die "Cannot chdir $dirname - $!"; |
162
|
|
|
|
|
|
|
|
163
|
0
|
0
|
|
|
|
|
IPC::Run::run( [ "git", "init" ] ) or die "Unable to 'git init' ($?)\n"; |
164
|
0
|
0
|
|
|
|
|
IPC::Run::run( [ "git", "add", "." ] ) or die "Unable to 'git add ($?)\n"; |
165
|
0
|
0
|
|
|
|
|
IPC::Run::run( [ "git", "commit", "-m", "Imported $opts{id}" ] ) or die "Unable to 'git commit' ($?)\n"; |
166
|
|
|
|
|
|
|
} |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
=head1 AUTHOR |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
Paul Evans |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
=cut |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
0x55AA; |