File Coverage

blib/lib/Portable/Dist.pm
Criterion Covered Total %
statement 126 133 94.7
branch 15 26 57.6
condition 7 21 33.3
subroutine 21 21 100.0
pod 0 8 0.0
total 169 209 80.8


line stmt bran cond sub pod time code
1             package Portable::Dist;
2              
3             =pod
4              
5             =head1 NAME
6              
7             Portable::Dist - Modify a Perl distribution to make it portable
8              
9             =head1 DESCRIPTION
10              
11             The L family of modules provides functionality that allows
12             Perl to operate from arbitrary and variable paths.
13              
14             B is used to apply the necesary modifications to an
15             existing Perl distribution to convert it to a Portable Perl.
16              
17             =head2 Portability Warning
18              
19             This module is designed for use only on a distribution that is not
20             currently in use. Thus, you should not execute the modification
21             process using the distribution you wish to modify.
22              
23             This module is also currently only designed to run on Windows (to
24             support the production of Strawberry Perl Portable and other
25             Perl::Dist-related distributions).
26              
27             If you wish to use this module for other operating systems, please
28             contact the author.
29              
30             =head1 METHODS
31              
32             =cut
33              
34 2     2   70152 use 5.008;
  2         16  
35 2     2   12 use strict;
  2         3  
  2         52  
36 2     2   12 use Carp ();
  2         4  
  2         24  
37 2     2   10 use File::Spec ();
  2         3  
  2         44  
38 2     2   11 use File::Path ();
  2         5  
  2         47  
39 2     2   919 use File::Slurper qw(read_text write_text);
  2         28038  
  2         119  
40 2     2   1389 use File::Find::Rule ();
  2         17017  
  2         61  
41 2     2   1029 use File::IgnoreReadonly ();
  2         8212  
  2         55  
42 2     2   1029 use Params::Util '_STRING';
  2         7849  
  2         174  
43              
44             our $VERSION = '1.07';
45              
46 2     2   15 use constant MSWin32 => ( $^O eq 'MSWin32' );
  2         4  
  2         163  
47              
48 2         14 use Object::Tiny qw{
49             perl_root
50             perl_bin
51             perl_lib
52             perl_sitelib
53             perl_vendorlib
54             perl_sitebin
55             perl_vendorbin
56             pl2bat
57             config_pm
58             cpan_config
59             file_homedir
60             file_homedir_v
61             minicpan_dir
62             minicpan_conf
63 2     2   919 };
  2         607  
64              
65              
66              
67              
68              
69             #####################################################################
70             # Constructor and Accessors
71              
72             sub new {
73 1     1 0 17912 my $self = shift->SUPER::new(@_);
74              
75             # Check params
76 1 50       37 unless ( _DIRECTORY($self->perl_root) ) {
77 0         0 Carp::croak("Missing or invalid perl_root directory");
78             }
79              
80 1   33     31 $self->{perl_bin} ||= File::Spec->catdir( $self->perl_root, 'bin' );
81 1 50       30 unless ( _DIRECTORY($self->perl_bin) ) {
82 0         0 Carp::croak("Missing or invalid perl_bin directory");
83             }
84              
85 1   33     28 $self->{perl_lib} ||= File::Spec->catdir( $self->perl_root, 'lib' );
86 1 50       68 unless ( _DIRECTORY($self->perl_lib) ) {
87 0         0 Carp::croak("Missing or invalid perl_lib directory");
88             }
89              
90 1   33     29 $self->{perl_sitelib} ||= File::Spec->catdir( $self->perl_root, 'site', 'lib' );
91 1 50       28 unless ( _DIRECTORY($self->perl_sitelib) ) {
92 0         0 Carp::croak("Missing or invalid perl_sitelib directory");
93             }
94              
95 1   33     26 $self->{perl_vendorlib} ||= File::Spec->catdir( $self->perl_root, 'vendor', 'lib' );
96 1 50       27 unless ( _DIRECTORY($self->perl_sitelib) ) {
97 0         0 Carp::croak("Missing or invalid perl_vendorlib directory");
98             }
99              
100 1   33     28 $self->{perl_sitebin} ||= File::Spec->catdir( $self->perl_root, 'site', 'bin' );
101             #unless ( _DIRECTORY($self->perl_sitebin) ) {
102             # Carp::croak("Missing or invalid perl_sitebin directory");
103             #}
104              
105 1   33     31 $self->{perl_vendorbin} ||= File::Spec->catdir( $self->perl_root, 'vendor', 'bin' );
106             #unless ( _DIRECTORY($self->perl_sitebin) ) {
107             # Carp::croak("Missing or invalid perl_vendorbin directory");
108             #}
109              
110             # Find some particular files
111 1         26 $self->{pl2bat} = File::Spec->catfile( $self->perl_bin, 'pl2bat.bat' );
112 1         27 $self->{config_pm} = File::Spec->catfile( $self->perl_lib, 'Config.pm' );
113 1         28 $self->{cpan_config} = File::Spec->catfile( $self->perl_lib, 'CPAN', 'Config.pm' );
114 1         26 $self->{file_homedir} = File::Spec->catfile( $self->perl_sitelib, 'File', 'HomeDir.pm' );
115 1         38 $self->{file_homedir_v} = File::Spec->catfile( $self->perl_vendorlib, 'File', 'HomeDir.pm' );
116 1         29 $self->{minicpan_dir} = File::Spec->catfile( $self->perl_vendorlib, 'CPAN' );
117 1         25 $self->{minicpan_conf} = File::Spec->catfile( $self->minicpan_dir, 'minicpan.conf' );
118              
119 1         13 return $self;
120             }
121              
122             sub run {
123 1     1 0 4852 my $self = shift;
124              
125             # Modify the files we need to hack
126 1         5 $self->modify_config;
127 1         16 $self->modify_cpan_config;
128 1         9 $self->modify_file_homedir;
129              
130             # Create the minicpan configuration file
131 1         9 $self->create_minicpan_conf;
132              
133             # Convert all existing batch files to portable
134 1         4 $self->modify_batch_files;
135              
136             # Modify pl2bat so new batch files get created properly
137 1         4 $self->modify_pl2bat;
138              
139 1         11 return 1;
140             }
141              
142              
143              
144              
145              
146             #####################################################################
147             # Modification Functions
148              
149             # Apply modifications to Config.pm
150             sub modify_config {
151 1     1 0 2 my $self = shift;
152 1         23 my $file = $self->config_pm;
153 1         6 my $append = <<'END_PERL';
154             eval {
155             require Portable;
156             Portable->import('Config');
157             };
158              
159             1;
160             END_PERL
161              
162             # Apply the change to the file
163 1         10 my $guard = File::IgnoreReadonly->new( $file );
164 1         49 my $content = read_text($file);
165 1         130 $content .= $append;
166 1         7 write_text($file, $content);
167              
168 1         241 return 1;
169             }
170              
171             # Apply modifications to CPAN::Config
172             sub modify_cpan_config {
173 1     1 0 3 my $self = shift;
174 1         26 my $file = $self->cpan_config;
175 1         5 my $append = <<'END_PERL';
176             eval {
177             require Portable;
178             Portable->import('CPAN');
179             };
180             END_PERL
181              
182             # Apply the change to the file
183 1         7 my $guard = File::IgnoreReadonly->new( $file );
184 1         43 my $content = read_text($file);
185 1         101 $content =~ s/\n1;/$append\n\n1;/;
186 1         6 write_text($file, $content);
187              
188 1         148 return 1;
189             }
190              
191             # Apply modifications to File::HomeDir
192             sub modify_file_homedir {
193 1     1 0 3 my $self = shift;
194 1         1 my $file;
195 1         15 my $append = <<'END_PERL';
196             eval {
197             require Portable;
198             Portable->import('HomeDir');
199             };
200             END_PERL
201              
202 1 50       27 if (-f $self->file_homedir_v) {
203 0         0 $file = $self->file_homedir_v;
204             } else {
205 1         37 $file = $self->file_homedir;
206             }
207              
208             # Apply the change to the file
209 1         10 my $guard = File::IgnoreReadonly->new( $file );
210 1         46 my $content = read_text($file);
211 1         121 $content =~ s/\n1;/$append\n\n1;/;
212 1         5 write_text($file, $content);
213              
214 1         145 return 1;
215             }
216              
217             # Create the minicpan configuration file
218             sub create_minicpan_conf {
219 1     1 0 3 my $self = shift;
220 1         26 my $dir = $self->minicpan_dir;
221 1         20 my $file = $self->minicpan_conf;
222              
223             # Create the directory
224 1         385 File::Path::mkpath( $dir, { verbose => 0 } );
225              
226             # Write the file
227 1 50       21 my $guard = -f $file ? File::IgnoreReadonly->new( $file ) : 0;
228 1         6 write_text(
229             $file,
230             "class: CPAN::Mini::Portable\n".
231             "skip_perl: 1\n".
232             "no_conn_cache: 1\n"
233             );
234              
235             # Make the file readonly
236 1         142 if ( MSWin32 ) {
237             require Win32::File::Object;
238             Win32::File::Object->new( $file, 1 )->readonly(1);
239             } else {
240 1         9 require File::chmod;
241 1         5 File::chmod::chmod( 'a-w', $file );
242             }
243              
244 1         395 return 1;
245             }
246              
247             # Modify existing batch files
248             sub modify_batch_files {
249 1     1 0 2 my $self = shift;
250 1         3 my @files;
251 1         9 push @files, File::Find::Rule->name('*.bat')->file->in($self->perl_bin);
252 1 50       1250 push @files, File::Find::Rule->name('*.bat')->file->in($self->perl_sitebin) if -d $self->perl_sitebin;
253 1 50       48 push @files, File::Find::Rule->name('*.bat')->file->in($self->perl_vendorbin) if -d $self->perl_vendorbin;
254 1 50       25 unless ( @files ) {
255 0         0 Carp::croak("Failed to find any batch files");
256             }
257              
258             # Process the files
259 1         4 foreach my $file ( @files ) {
260             # Apply the change to the file
261 4         459 my $guard = File::IgnoreReadonly->new( $file );
262 4         155 my $content = read_text($file);
263 4         505 $content =~ s/([\r\n])(perl )(-x[^\r\n]*)/$1 . _perl_cmd($3)/sge;
  4         13  
264 4         98 $content =~ s/(#line )(\d+)/$1 . ($2+14)/e; # we have added extra 14 lines
  2         24  
265 4         14 write_text($file, $content);
266             }
267              
268 1         287 return 1;
269             }
270              
271             sub modify_pl2bat {
272 1     1 0 3 my $self = shift;
273 1         25 my $file = $self->pl2bat;
274              
275             # Apply the change to the file
276 1         9 my $guard = File::IgnoreReadonly->new( $file );
277 1         41 my $content = read_text($file);
278 1         241 $content =~ s/\bperl \$OPT\{'(a|o|n)'\}/_perl_cmd('$OPT{\'' . $1 .'\'}', 1, 1)/esg;
  3         14  
279 1         7 write_text($file, $content);
280              
281 1         1373 return 1;
282             }
283              
284             #####################################################################
285             # Support Functions
286              
287             sub _DIRECTORY {
288 5 50 33 5   158 (defined _STRING($_[0]) and -d $_[0]) ? $_[0] : undef;
289             }
290              
291             sub _perl_cmd {
292 7     7   19 my ($arg, $tab, $quote) = @_;
293 7         11 my $rv = <<'MARKER';
294             IF EXIST "%~dp0perl.exe" (
295             "%~dp0perl.exe" XXX_XXX
296             ) ELSE IF EXIST "%~dp0..\..\bin\perl.exe" (
297             "%~dp0..\..\bin\perl.exe" XXX_XXX
298             ) ELSE (
299             perl XXX_XXX
300             )
301             MARKER
302 7         30 $rv =~ s/XXX_XXX/$arg/sg;
303 7 100       59 $rv =~ s/([\%\\])/\\$1/sg if $quote;
304 7 100       49 $rv =~ s/([\r\n]+)/$1\t/sg if $tab;
305 7         87 return $rv;
306             }
307              
308             1;
309              
310             =pod
311              
312             =head1 SUPPORT
313              
314             Bugs should be reported via the CPAN bug tracker.
315              
316             L
317              
318             For other issues, or commercial support, contact the author.
319              
320             =head1 AUTHOR
321              
322             Adam Kennedy Eadamk@cpan.orgE
323              
324             =head1 SEE ALSO
325              
326             L, L, L
327              
328             =head1 COPYRIGHT
329              
330             Copyright 2008 - 2011 Adam Kennedy.
331              
332             This program is free software; you can redistribute
333             it and/or modify it under the same terms as Perl itself.
334              
335             The full text of the license can be found in the
336             LICENSE file included with this module.
337              
338             =cut