File Coverage

blib/lib/Test/Smoke/Patcher.pm
Criterion Covered Total %
statement 148 174 85.0
branch 59 90 65.5
condition 16 32 50.0
subroutine 14 14 100.0
pod 7 7 100.0
total 244 317 76.9


line stmt bran cond sub pod time code
1             package Test::Smoke::Patcher;
2 3     3   246749 use strict;
  3         8  
  3         123  
3              
4 3     3   28 use vars qw( $VERSION @EXPORT );
  3         5  
  3         207  
5             $VERSION = '0.012';
6              
7 3     3   21 use base 'Exporter';
  3         10  
  3         372  
8 3     3   22 use File::Spec;
  3         21  
  3         69  
9 3     3   14 use Cwd;
  3         8  
  3         271  
10              
11 3     3   30 use Test::Smoke::Util qw( get_regen_headers );
  3         7  
  3         7442  
12              
13             @EXPORT = qw( &TRY_REGEN_HEADERS );
14              
15             sub MAX_FLAG_COUNT () { 16 }
16             sub ALL_FLAGS () { (2**MAX_FLAG_COUNT) - 1 }
17             sub TRY_REGEN_HEADERS () { 1 }
18              
19             my %CONFIG = (
20             df_ddir => File::Spec->rel2abs( cwd ),
21             df_fdir => undef,
22             df_pfile => undef,
23             df_patchbin => 'patch',
24             df_popts => '', # '-p1' is added in call_patch()
25             df_flags => 0,
26             df_regen => 1, # regen => set/unset TRY_REGEN_HEADERS in flags
27             df_oldpatch => 0,
28             df_v => 0,
29              
30             valid_type => { single => 1, multi => 1 },
31             single => [qw( pfile patchbin popts flags regen oldpatch )],
32             multi => [qw( pfile patchbin popts flags regen oldpatch )],
33             );
34              
35             =head1 NAME
36              
37             Test::Smoke::Patcher - OO interface to help patching the source-tree
38              
39             =head1 SYNOPSIS
40              
41             use Test::Smoke::Patcher;
42              
43             my $patcher = Test::Smoke::Patcher->new( single => {
44             ddir => $build_dir,
45             pfile => $patch,
46             popts => '-p1',
47             v => 1, # 0..2
48             });
49             $patcher->patch;
50              
51             or
52              
53             my $patcher = Test::Smoke::Patcher->new( multi => {
54             ddir => $buildir,
55             pfile => $patch_info,
56             v => 1, #0..2
57             });
58             $patcher->patch;
59              
60             =head1 DESCRIPTION
61              
62             Okay, you will need a working B program, which I believe is available
63             for most platforms perl runs on.
64              
65             There are two ways to initialise the B object.
66              
67             =over 4
68              
69             =item B mode
70              
71             The B attribute is a pointer to a I patch.
72             There are four (4) ways to specify that patch.
73              
74             =over 4
75              
76             =item I
77              
78             The scalar holds the complete patch as literal text.
79              
80             =item I
81              
82             The array holds a list of lines (with newlines) that make up the
83             patch as literal text (C<< $patch = join "", @$array_ref >>).
84              
85             =item I
86              
87             You passed an opened filehandle to a file containing the patch.
88              
89             =item I
90              
91             If none of the above apply, it is assumed you passed a filename.
92             Relative paths are rooted at the builddir (B attribute).
93              
94             =back
95              
96             =item B mode
97              
98             The B attribute is a pointer to a recource that contains filenames
99             of patches.
100             The format of this recource is one filename per line optionally followed
101             by a semi-colon (;) and switches for the patch program.
102              
103             The patch-resource can also be specified in four (4) ways.
104              
105             =over 4
106              
107             =item I
108              
109             =item I
110              
111             =item I
112              
113             =item I
114              
115             =back
116              
117             =back
118              
119             =head2 TRY_REGEN_HEADERS
120              
121             Constant: 1
122              
123             =head2 MAX_FLAG_COUNT
124              
125             Constant: 16
126              
127             =head2 ALL_FLAGS
128              
129             Constant: 2**MAX_FLAG_COUNT) - 1
130              
131             =head1 METHODS
132              
133             =over 4
134              
135             =cut
136              
137             =item Test::Smoke::Patcher->new( $type => \%args );
138              
139             C crates the object. Valid types are B and B.
140             Valid keys for C<%args>:
141              
142             * ddir: the build directory
143             * fdir: the intermediate forest dir (preferred)
144             * pfile: path to either the patch (single) or a textfile (multi)
145             * popts: options to pass to 'patch' (-p1)
146             * patchbin: full path to the patch binary (patch)
147             * regen: flag to set/unset the TRY_REGEN_HEADERS flag
148             * v: verbosity 0..2
149              
150             =cut
151              
152             sub new {
153 14     14 1 12147 my $proto = shift;
154 14   33     215 my $class = ref $proto || $proto;
155              
156 14         91 my $type = lc shift;
157 14 50 33     220 unless ( $type && exists $CONFIG{valid_type}->{ $type } ) {
158 0 0       0 defined $type or $type = 'undef';
159 0         0 require Carp;
160 0         0 Carp::croak( "Invalid Patcher-type: '$type'" );
161             }
162              
163 14 50       134 my %args_raw = @_ ? UNIVERSAL::isa( $_[0], 'HASH' ) ? %{ $_[0] } : @_ : ();
  14 50       232  
164              
165             my %args = map {
166 14         156 ( my $key = $_ ) =~ s/^-?(.+)$/lc $1/e;
  52         581  
  52         312  
167 52         433 ( $key => $args_raw{ $_ } );
168             } keys %args_raw;
169              
170             my %fields = map {
171 126 100       537 my $value = exists $args{$_} ? $args{ $_ } : $CONFIG{ "df_$_" };
172 126         695 ( $_ => $value )
173 14         105 } ( v => ddir => fdir => @{ $CONFIG{ $type } } );
  14         97  
174             $fields{pdir} = File::Spec->rel2abs(
175             defined $fields{fdir} ? $fields{fdir} : $fields{ddir}
176 14 100       935 );
177 14         69 $fields{ptype} = $type;
178 14 50       51 if ($fields{regen}) {
179 14         49 $fields{flags} = ($fields{flags} | TRY_REGEN_HEADERS) & ALL_FLAGS;
180             }
181             else {
182 0         0 $fields{flags} = ($fields{flags} & ~TRY_REGEN_HEADERS) & ALL_FLAGS;
183             }
184              
185 14         336 bless { %fields }, $class;
186             }
187              
188             =item Test::Smoke::Patcher->config( $key[, $value] )
189              
190             C is an interface to the package lexical C<%CONFIG>,
191             which holds all the default values for the C arguments.
192              
193             With the special key B this returns a reference
194             to a hash holding all the default values.
195              
196             =cut
197              
198             sub config {
199 2     2 1 4176 my $dummy = shift;
200              
201 2         18 my $key = lc shift;
202              
203 2 100       16 if ( $key eq 'all_defaults' ) {
204             my %default = map {
205 1         16 my( $pass_key ) = $_ =~ /^df_(.+)/;
  9         27  
206 9         39 ( $pass_key => $CONFIG{ $_ } );
207             } grep /^df_/ => keys %CONFIG;
208 1         11 return \%default;
209             }
210              
211 1 50       29 return undef unless exists $CONFIG{ "df_$key" };
212              
213 1 50       11 $CONFIG{ "df_$key" } = shift if @_;
214              
215 1         11 return $CONFIG{ "df_$key" };
216             }
217              
218             =item $patcher->patch
219              
220             C is a simple dispatcher.
221              
222             =cut
223              
224             sub patch {
225 10     10 1 773 my $self = shift;
226              
227 10         111 my $method = "patch_$self->{ptype}";
228 10         123 my $ret = $self->$method( @_ );
229 10   33     342 $ret &&= $self->perl_regen_headers;
230              
231 10 100       79 if ( $self->{fdir} ) { # This is a forest setup, re-sync
232 1         10 require Test::Smoke::Syncer;
233             my %options = (
234             hdir => $self->{fdir},
235             ddir => $self->{ddir},
236             v => $self->{v},
237 1         36 );
238 1         43 my $resync = Test::Smoke::Syncer->new( hardlink => %options );
239 1         44 $resync->sync;
240             }
241 10         138 return $ret;
242             }
243              
244             =item perl_regen_headers( )
245              
246             Try to run F if the flag is set.
247              
248             =cut
249              
250             sub perl_regen_headers {
251 10     10 1 49 my $self = shift;
252 10 50       86 return 1 unless $self->{flags} & TRY_REGEN_HEADERS;
253              
254 10         353 my $regen_headers = get_regen_headers( $self->{pdir} );
255             my $regen_perly = $self->{perly}
256 10 100       134 ? qq|$^X "| . File::Spec->catfile( $self->{pdir}, 'regen_perly.pl' ).
257             qq|"|
258             : "";
259 10         170 my @regens = grep $_ => ( $regen_headers, $regen_perly );
260 10         106 for my $regen ( @regens ) {
261 2         9480 my $cwd = cwd;
262 2 50       109 chdir $self->{pdir} or return;
263 2         30 local *RUN_REGEN;
264 2 50       8765 if ( open RUN_REGEN, "$regen |" ) {
265 2 50       55 $self->{v} and print "Started [$regen]\n";
266 2         170647 while ( ) {
267 0 0       0 $self->{v} and print;
268             }
269 2 50       121 close RUN_REGEN or do {
270 0         0 require Carp;
271 0         0 Carp::carp( "Error while running [$regen]" );
272 0         0 return;
273             };
274             } else {
275 0         0 require Carp;
276 0         0 Carp::carp( "Could not fork [$regen]" );
277 0         0 return;
278             }
279 2         93 chdir $cwd;
280             }
281 10         183 return 1;
282             }
283              
284             =item $patcher->patch_single( )
285              
286             C checks if the B attribute is a plain scalar
287             or a ref to a scalar, array, glob. In the first case this is taken to
288             be a filename. A GLOB-ref is a filehandle, the other two are taken to
289             be literal content.
290              
291             =cut
292              
293             sub patch_single {
294 22     22 1 34908 my $self = shift;
295              
296 22   66     312 my $pfile = shift || $self->{pfile};
297              
298 22         132 local *PATCH;
299 22         122 my $content;
300 22 100       229 if ( ref $pfile eq 'SCALAR' ) {
    100          
    100          
301 9         37 $content = $$pfile;
302 9   50     196 $self->{pfinfo} ||= 'internal content';
303             } elsif ( ref $pfile eq 'ARRAY' ) {
304 1         29 $content = join "", @$pfile;
305 1   50     22 $self->{pfinfo} ||= 'internal content';
306             } elsif ( ref $pfile eq 'GLOB' ) {
307 1         32 *PATCH = *$pfile;
308 1         11 $content = do { local $/; };
  1         24  
  1         63  
309 1   50     27 $self->{pfinfo} ||= 'file content';
310             } else {
311             my $full_name = File::Spec->file_name_is_absolute( $pfile )
312 11 50       499 ? $pfile : File::Spec->rel2abs( $pfile, $self->{pdir} );
313              
314 11         77 $self->{pfinfo} = $full_name;
315 11 50       628 open PATCH, "< $full_name" or do {
316 0         0 require Carp;
317 0         0 Carp::croak( "Cannot open '$full_name': $!" );
318             };
319 11         49 $content = do { local $/; };
  11         144  
  11         445  
320 11         183 close PATCH;
321             }
322              
323 22 50       143 $self->{v} and print "Get patch from $self->{pfinfo}\n";
324 22         209 $self->call_patch( \$content, @_ );
325             }
326              
327             =item $patcher->patch_multi( )
328              
329             C checks the B attribute is a plain scalar
330             or a ref to a scalar, array, glob. In the first case this is taken to
331             be a filename. A GLOB-ref is a filehandle, the other two are taken to
332             be literal content.
333              
334             =cut
335              
336             sub patch_multi {
337 6     6 1 11925 my $self = shift;
338              
339 6   66     82 my $pfile = shift || $self->{pfile};
340              
341 6         45 local *PATCHES;
342 6         22 my @patches;
343 6 100       90 if ( ref $pfile eq 'SCALAR' ) {
    100          
    100          
344 1         13 @patches = split /\n/, $$pfile;
345 1   50     28 $self->{pfinfo} ||= 'internal content';
346             } elsif ( ref $pfile eq 'ARRAY' ) {
347 1         8 chomp( @patches = @$pfile );
348 1   50     8 $self->{pfinfo} ||= 'internal content';
349             } elsif ( ref $pfile eq 'GLOB' ) {
350 1         32 *PATCHES = *$pfile;
351 1         45 chomp( @patches = );
352 1   50     24 $self->{pfinfo} ||= 'file content';
353             } else {
354             my $full_name = File::Spec->file_name_is_absolute( $pfile )
355 3 50       85 ? $pfile : File::Spec->rel2abs( $pfile, $self->{pdir} );
356 3         28 $self->{pfinfo} = $full_name;
357 3 50       159 open PATCHES, "< $full_name" or do {
358 0         0 require Carp;
359 0         0 Carp::croak( "Cannot open '$self->{pfile}': $!" );
360             };
361 3         119 chomp( @patches = );
362 3         63 close PATCHES;
363             }
364              
365 6 50       58 $self->{v} and print "Get patchinfo from $self->{pfinfo}\n";
366              
367 6         19 my $ok = 1;
368 6         38 foreach my $patch ( @patches ) {
369 17 100       182 next if $patch =~ /^\s*[#]/;
370 10 50       132 next if $patch =~ /^\s*$/;
371 10 100       53 if ( $patch =~ /^\s*!\s*perly$/ ) {
372 1         24 $self->{perly} = 1;
373 1         12 next;
374             }
375 9         91 my( $filename, $switches, $descr ) = split /\s*;\s*/, $patch, 3;
376 9 50       39 $descr = $descr ? $descr . " ($filename)" : $filename;
377 9         26 eval { $self->patch_single( $filename, $switches, $descr ) };
  9         64  
378 9 50       154 if ( $@ ) {
379 0         0 require Carp;
380 0         0 Carp::carp( "[$filename] $@" );
381 0         0 $ok = 0;
382             }
383             }
384 6         91 return $ok;
385             }
386              
387             =item $self->_make_opts( $switches )
388              
389             C<_make_opts()> just creates a string of options to pass to the
390             B program. Some implementations of patch do not grog '-u',
391             so be careful!
392              
393             =cut
394              
395             sub _make_opts {
396 23     23   4698 my $self = shift;
397 23         227 @_ = grep defined $_ => @_;
398 23 100       182 my $switches = @_ ? join " ", @_ : "";
399              
400 23   100     295 my $opts = $switches || $self->{popts} || "";
401 23 100       154 $opts .= " -p1" unless $opts =~ /-[a-zA-Z]*p\d/;
402             # $opts .= " -b" unless $opts =~ /-[a-zA-Z]*b/i;
403 23 50 33     98 $opts .= " --verbose" if $self->{v} > 1 && !$self->{oldpatch};
404              
405 23         138 return $opts;
406             }
407              
408             =item $patcher->call_patch( $ref_to_content )
409              
410             C opens a pipe to the B program and prints
411             C<< $$ref_to_content >> to it. It will Carp::croak() on any error!
412              
413             =cut
414              
415             sub call_patch {
416 22     22 1 113 my( $self, $ref_to_content, $switches, $descr ) = @_;
417              
418 22         85 local *PATCHBIN;
419              
420 22         166 my $opts = $self->_make_opts( $switches );
421              
422 22 50       5812 my $redir = $self->{v} ? "" : ">" . File::Spec->devnull . " 2>&1";
423              
424 22         118820 my $cwd = cwd();
425 22 50       862 chdir $self->{pdir} or do {
426 0         0 require Carp;
427 0         0 Carp::croak( "Cannot chdir($self->{pdir}): $!" );
428             };
429              
430             # patch is verbose enough if $self->{v} == 1
431 22 50       165 $self->{v} > 1 and
432             print "[$self->{pfinfo}] | $self->{patchbin} $opts $redir\n";
433              
434 22 50       90349 if ( open PATCHBIN, "| $self->{patchbin} $opts $redir" ) {
435 22         421 binmode PATCHBIN;
436 22         1021 print PATCHBIN $$ref_to_content;
437 22 50       99040 close PATCHBIN or do {
438 0         0 require Carp;
439 0         0 Carp::croak( "Error while patching from '$self->{pfinfo}': $!" );
440             };
441             } else {
442 0         0 require Carp;
443 0         0 Carp::croak( "Cannot fork ($self->{patchbin}): $!" );
444             }
445              
446             # Add a line to patchlevel.h if $descr
447 22 100       382 if ( defined $descr ) {
448 10         473 require Test::Smoke::Util;
449 10         384 Test::Smoke::Util::set_local_patch( $self->{pdir}, $descr );
450             }
451              
452 22 50       1748 chdir $cwd or do {
453 0           require Carp;
454 0           Carp::croak( "Cannot chdir($cwd) back: $!" );
455             };
456             }
457              
458             =back
459              
460             =head1 SEE ALSO
461              
462             L, L
463              
464             =head1 COPYRIGHT
465              
466             (c) 2002-2003, All rights reserved.
467              
468             * Abe Timmerman
469              
470             This library is free software; you can redistribute it and/or modify
471             it under the same terms as Perl itself.
472              
473             See:
474              
475             =over 4
476              
477             =item * http://www.perl.com/perl/misc/Artistic.html
478              
479             =item * http://www.gnu.org/copyleft/gpl.html
480              
481             =back
482              
483             This program is distributed in the hope that it will be useful,
484             but WITHOUT ANY WARRANTY; without even the implied warranty of
485             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
486              
487             =cut