File Coverage

blib/lib/App/sourcepan.pm
Criterion Covered Total %
statement 18 81 22.2
branch 0 66 0.0
condition 0 3 0.0
subroutine 6 10 60.0
pod 0 3 0.0
total 24 163 14.7


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;