File Coverage

blib/lib/Module/Release.pm
Criterion Covered Total %
statement 353 398 88.6
branch 107 140 76.4
condition 17 28 60.7
subroutine 79 82 96.3
pod 52 52 100.0
total 608 700 86.8


line stmt bran cond sub pod time code
1 22     22   310936 use v5.16;
  22         86  
2              
3             package Module::Release;
4              
5             =encoding utf8
6              
7             =head1 NAME
8              
9             Module::Release - Automate software releases
10              
11             =head1 SYNOPSIS
12              
13             use Module::Release;
14              
15             my $release = Module::Release->new( %params );
16              
17             # call methods to automate your release process
18             $release->check_vcs;
19             ...
20              
21             =cut
22              
23 22     22   148 use strict;
  22         48  
  22         659  
24              
25 22     22   132 use warnings;
  22         41  
  22         815  
26 22     22   139 no warnings;
  22         60  
  22         1555  
27              
28             our $VERSION = '2.128';
29              
30 22     22   152 use Carp qw(carp croak);
  22         45  
  22         1522  
31 22     22   159 use File::Basename qw(dirname);
  22         61  
  22         1784  
32 22     22   159 use File::Spec;
  22         54  
  22         769  
33 22     22   135 use Scalar::Util qw(blessed);
  22         50  
  22         76695  
34              
35             my %Loaded_mixins = ( );
36              
37             =head1 DESCRIPTION
38              
39             C automates your software release process. It started as
40             a script that automated my release process, so it has bits to
41             talk to PAUSE (CPAN) and SourceForge, and to use C and
42             C. Other people have extended this in other modules under the same
43             namespace so you can use C, C, and many other things.
44              
45             The methods represent a step in the release process. Some of them check a
46             condition (e.g. all tests pass) and die if that doesn't work.
47             C doesn't let you continue if something is wrong. Once
48             you have checked everything, use the upload features to send your files
49             to the right places.
50              
51             The included C script is a good starting place. Don't be afraid to
52             edit it for your own purposes.
53              
54             =head2 Configuration
55              
56             C looks at several sources for configuration information.
57              
58             =head3 Perl setup
59              
60             C looks at C to get the values it needs for
61             certain operations.
62              
63             =over 4
64              
65             =item make
66              
67             The name of the program to run for the C steps
68              
69             =back
70              
71             =head3 Environment variables
72              
73             =over 4
74              
75             =item PERL
76              
77             Use this value as the perl interpreter, otherwise use the value in C<$^X>.
78              
79             =item RELEASE_DEBUG
80              
81             Do you want debugging output? Set this to a true value
82              
83             =item CPAN_PASS
84              
85             Your CPAN password. If you don't set this and you want to upload to
86             PAUSE, you should be prompted for it.
87              
88             =back
89              
90             =head3 C<.releaserc>
91              
92             C looks for either C<.releaserc> or C in
93             the current working directory. It reads that with
94             C to get these values:
95              
96             =over 4
97              
98             =item cpan_user
99              
100             Your PAUSE user id.
101              
102             =item cpan_pass
103              
104             Your PAUSE password, but don't use this. Put it in the environment
105             variable.
106              
107             =item http_proxy
108              
109             =item https_proxy
110              
111             =item ignore_prereqs
112              
113             A whitespace separated list of modules for C to ignore.
114             But, don't use C. It was not a good idea.
115              
116             =item makefile_PL
117              
118             The name of the file to run as F. The default is
119             C<"Makefile.PL">, but you can set it to C<"Build.PL"> to use a
120             C-based system.
121              
122             If this is set to C<"Build.PL">, this his will also cause
123             C to use C instead of
124             C.
125              
126             =item makefile
127              
128             The name of the file created by C above. The default is
129             C<"Makefile">, but you can set it to C<"Build"> for
130             C-based systems.
131              
132             =item module_name
133              
134             C tries to guess the module name from the distro name, but if
135             you don't like that, set the module name in the config file.
136              
137             =back
138              
139             =head2 Methods
140              
141             If you don't like what any of these methods do, override them in a subclass.
142              
143             =over 4
144              
145             =item new()
146              
147             Create the C object. It reads the configuration
148             and initializes everything.
149              
150             =cut
151              
152             sub new {
153 19     19 1 279889 my( $class, %params ) = @_;
154              
155 19         67 my $self = bless {}, $class;
156              
157 19         96 my $config = $self->_read_configuration;
158              
159 18         103 $self->init( $config, %params );
160              
161 18         335 return $self;
162             }
163              
164              
165             =item init()
166              
167             Set up the C object. By default, it expects something
168             using MakeMaker, but if it sees a F it configures itself for
169             C.
170              
171             The values in the configuration file override any settings here, so if you
172             have both a F and a F then you can override the
173             C preference by setting the C and C
174             configuration values.
175              
176             =cut
177              
178             sub init {
179 18     18 1 62 my( $self, $config, %params ) = @_;
180              
181 18         86 $self->_set_defaults( %params );
182              
183             # $config comes in as a parameter
184 18         381 $self->_process_configuration( $config );
185              
186             # defer $self->_set_up_web_client;
187              
188 18         418 1;
189             }
190              
191 36 50   36   1041 sub _select_config_file_name { -e ".releaserc" ? ".releaserc" : "releaserc" }
192              
193             sub _set_defaults {
194 18     18   137 require Config;
195 18         7176 require IO::Null;
196              
197 18         8558 my( $self, %params ) = @_;
198              
199             my $defaults = {
200             'Makefile.PL' => 'Makefile.PL',
201             'Makefile' => 'Makefile',
202             make => $Config::Config{make},
203             manifest => 'MANIFEST',
204             debug => $ENV{RELEASE_DEBUG} || 0,
205             local_file => undef,
206             remote_file => undef,
207             input_fh => *STDIN{IO},
208             output_fh => *STDOUT{IO},
209             debug_fh => *STDERR{IO},
210 18   100     1788 null_fh => IO::Null->new(),
211             quiet => 0,
212             devnull => File::Spec->devnull,
213             ignore_prereqs => '',
214             module_name => undef,
215             %params,
216             };
217              
218 18         695 foreach my $key ( keys %$defaults ) {
219 270         492 $self->{$key} = $defaults->{$key};
220             }
221              
222 18         108 $self->set_perl( $^X );
223 18         375 $self->add_a_perl( $^X );
224              
225             # setup for Module::Build. This is a kludge. There isn't a
226             # programmatic interface to Makemaker, and I don't want to
227             # treat Makemaker and Module::Build differently. I'm stuck
228             # with a fancy shell script.
229 18 50       813 if( -e 'Build.PL' ) {
230 0         0 $self->{'make'} = File::Spec->catfile(qw{. Build});
231 0         0 $self->{'Makefile.PL'} = 'Build.PL';
232 0         0 $self->{'Makefile'} = '_build';
233             }
234 18         1518 1;
235             }
236              
237             sub _read_configuration {
238 19     19   8429 require ConfigReader::Simple;
239              
240             # NOTE: I have to read the configuration to see if I should
241             # call the subclass, but I haven't called init yet.
242             # Don't set up anything in _read_configuration!
243 19         53780 my $self = shift;
244              
245 19         106 my $conf_file = $self->_select_config_file_name;
246              
247             # Read the configuration
248 19 100       374 $self->_die( "Could not find conf file $conf_file\n" )
249             unless -e $conf_file;
250 18         178 my $config = $self->{config} = ConfigReader::Simple->new( $conf_file );
251 18 50       3298 $self->_die( "Could not get configuration data\n" ) unless ref $config;
252              
253 18         55 $config;
254             }
255              
256             sub _process_configuration {
257 18     18   131 my $self = shift;
258              
259             # Figure out options
260 18 50       227 $self->{cpan} = $self->config->cpan_user eq '' ? 0 : 1;
261              
262             {
263 18         1211 my @pairs = (
  18         369  
264             [ qw(Makefile.PL makefile_PL) ],
265             [ qw(Makefile makefile) ],
266             [ qw(make make) ],
267             [ qw(module_name module_name) ],
268             );
269              
270 18         180 foreach my $pair ( @pairs ) {
271 72         600 my( $key, $config ) = @$pair;
272              
273 72 50       289 $self->{$key} = $self->config->get($config)
274             if $self->config->exists($config);
275             }
276             }
277              
278 18         196 my @required = qw( );
279              
280 18         99 my $ok = 1;
281 18         194 for( @required ) {
282 0 0       0 unless( length $self->config->$_() ) {
283 0         0 $ok = 0;
284 0         0 $self->_warn( "Missing configuration data: $_; Aborting!\n" );
285             }
286             }
287 18 50       142 $self->_die( "Missing configuration data" ) unless $ok;
288              
289 18 50       185 if( $self->config->perls ) {
290 0         0 my @paths = split /:/, $self->config->perls;
291              
292 0         0 foreach my $path ( @paths ) {
293 0         0 $self->add_a_perl( $path );
294             }
295             }
296             }
297              
298             sub _handle_subclass {
299 0     0   0 my( $self, $subclass, %params ) = @_;
300              
301              
302             # This is a bit tricky. We have to be able to use the subclass, but
303             # we don't know if it is defined or not. It might be in a .pm file
304             # we haven't loaded, it might be in another file the user already
305             # loaded, or the user might have defined it inline inside
306             # the script. We'll try loading it if it fails can()
307 0 0       0 unless( eval { $subclass->can( 'new' ) } ) {
  0         0  
308             # I don't care if this fails because loading the file
309             # might not be the problem
310 0         0 eval { require File::Spec->catfile( split '::', $subclass ) . '.pm' };
  0         0  
311             }
312              
313             # If it's not defined by now, we're screwed and we give up
314             $self->_die( "$subclass does not have a new()!" )
315 0 0       0 unless eval { $subclass->can( 'new' ) };
  0         0  
316              
317 0         0 my $new_self = eval { $subclass->new( %params ) };
  0         0  
318 0         0 my $at = $@;
319              
320 0 0       0 return $new_self if blessed $new_self;
321              
322 0         0 $self->_die( "Could not create object with $subclass: $at!" );
323             }
324              
325              
326             =item load_mixin( MODULE )
327              
328             EXPERIMENTAL!!
329              
330             Load MODULE through require (so no importing), without caring what it does.
331             My intent is that MODULE adds methods to the C namespace
332             so a release object can see it. This should probably be some sort of
333             delegation.
334              
335             Added in 1.21
336              
337             =cut
338              
339             sub load_mixin {
340 3     3 1 8 my( $self, $module ) = @_;
341              
342 3 100       9 return 1 if $self->mixin_loaded( $module );
343              
344 2     1   4 { local $^W = 0; eval "use $module" };
  2         8  
  2         107  
  1         8  
  1         2  
  1         52  
345              
346 2 100       15 $self->_die( "Could not load [$module]! $@" ) if $@;
347              
348 1         9 ++$Loaded_mixins{ $module };
349             }
350              
351             =item loaded_mixins
352              
353             Returns a list of the loaded mixins
354              
355             Added in 1.21
356              
357             =cut
358              
359 1     1 1 6 sub loaded_mixins { keys %Loaded_mixins }
360              
361             =item mixin_loaded( MODULE )
362              
363             Returns true if the mixin class is loaded
364              
365             =cut
366              
367 7     7 1 2182 sub mixin_loaded { exists $Loaded_mixins{ $_[1] } }
368              
369             =back
370              
371             =head2 Methods for configuration and settings
372              
373             =over 4
374              
375             =item config
376              
377             Get the configuration object. By default this is a C
378             object;
379              
380             =cut
381              
382 119     119 1 4347 sub config { $_[0]->{config} }
383              
384             =item local_file( FILENAME )
385              
386             Returns or sets the name of the local distribution file. You can use
387             the literal argument C to clear the value.
388              
389             =cut
390              
391             sub local_file {
392 40 100   40 1 1796 $_[0]->{local_file} = $_[1] if @_ > 1;
393              
394 40         250 $_[0]->{local_file};
395             }
396              
397             =item remote_file
398              
399             Returns the name of the file on the remote side. You can use the
400             literal argument C to clear the value.
401              
402             =cut
403              
404             sub remote_file {
405 53 100   53 1 130 $_[0]->{remote_file} = $_[1] if @_ > 1;
406              
407 53         394 $_[0]->{remote_file};
408             }
409              
410             =back
411              
412             =head2 Methods for multiple perl testing
413              
414             =over 4
415              
416             =item set_perl
417              
418             Set the current path for the perl binary that C should
419             use for general tasks. This is not related to the list of perls used to
420             test multiple binaries unless you use one of those binaries to set a new
421             value.
422              
423             If PATH looks like a perl binary, C uses it as the new setting
424             for perl and returns the previous value.
425              
426             Added in 1.21.
427              
428             =cut
429              
430             sub set_perl {
431 20     20 1 645 my( $self, $path ) = @_;
432              
433             # resolve a path, especially on Windows, like
434             # C:\STRAWB~1\perl\bin\perl.exe
435 20 100       96 unless( my $version = $self->_looks_like_perl( $path ) ) {
436 1         408 $self->_die( "Does not look like a perl [$path]" );
437             }
438              
439 19         410 my $old_perl = $self->get_perl;
440              
441 19         335 $self->{perl} = $path;
442              
443 19         173 $old_perl;
444             }
445              
446             sub _looks_like_perl {
447 42     42   17767 my( $self, $path ) = @_;
448              
449             # resolve a path, especially on Windows, like
450             # C:\STRAWB~1\perl\bin\perl.exe
451 42 50       331 return 1 if $path =~ /\bperl.exe\z/;
452              
453 42         324088 my $version = `$path -e "print \$\]" 2>&1`;
454              
455 42 100       3918 $version =~ m/^\d+\.[\d_]+$/ ? $version : ();
456             }
457              
458             =item get_perl
459              
460             Returns the current path for the perl binary that C should
461             use for general tasks. This is not related to the list of perls used to
462             test multiple binaries.
463              
464             Added in 1.21.
465              
466             =cut
467              
468 23     23 1 5578 sub get_perl { $_[0]->{perl} }
469              
470             =item perls()
471              
472             Return the list of perl binaries Module::Release will use to test the
473             distribution.
474              
475             Added in 1.21.
476              
477             =cut
478              
479             sub perls {
480 9     9 1 1713 my $self = shift;
481              
482 9         23 my @perls = keys %{$self->{perls}};
  9         53  
483 9         87 $self->_debug( "perls at the start [@perls]" );
484              
485             # Sort them
486             @perls =
487 6         20 map { $_->[0] }
488 0 0 0     0 sort { $a->[2] <=> $b->[2] || $a->[3] <=> $b->[3] || $a->[0] cmp $b->[0] }
489 6         25 map { [ $_->[0], ( $_->[1] =~ m/(perl5\.(?|([0-9]{3})_?([0-9]{2})|([0-9]{1,2})\.([0-9]+)))/) ] }
490 6         92 map { [ $_, (m{.*/(.*)}) ] }
491 9         48 grep { -x $_ }
  6         157  
492             @perls;
493              
494 9         65 $self->_debug( "perls after filtering [@perls]" );
495 9         55 $self->_debug( "Testing with " . @perls . " perls" );
496              
497 9         54 return @perls;
498             }
499              
500             =item add_a_perl( PATH )
501              
502             Add a perl binary to the list of perls to use for testing. If PATH
503             is not executable or cannot run C, this method returns
504             nothing and does not add PATH. Otherwise, it returns true. If the
505             same path was already in the list, it returns true but does not
506             create a duplicate.
507              
508             Added in 1.21.
509              
510             =cut
511              
512             sub add_a_perl {
513 22     22 1 4511 my( $self, $path ) = @_;
514              
515 22 100       438 return 1 if exists $self->{perls}{$path};
516              
517 21 100       1287 unless( -x $path ) {
518 1 50 33     33 if( $path =~ m/[*?[]/ && $self->config->allow_glob_in_perls ) {
519 0         0 $self->add_a_perl( $_ ) for glob $path;
520             }
521             else {
522 1         15 $self->_warn( "$path is not executable" );
523             }
524 1         5 return;
525             }
526              
527 20         233 my $version = $self->_looks_like_perl( $path );
528              
529 20 100       618 unless( $version ) {
530 1         46 $self->_warn( "$path does not appear to be perl!" );
531 1         19 return;
532             }
533              
534 19         556 return $self->{perls}{$path} = $version;
535             }
536              
537             =item remove_a_perl( PATH )
538              
539             Delete PATH from the list of perls used for testing
540              
541             Added in 1.21.
542              
543             =cut
544              
545             sub remove_a_perl {
546 2     2 1 2883 my( $self, $path ) = @_;
547              
548 2         9 return delete $self->{perls}{$path}
549             }
550              
551             =item reset_perls
552              
553             Reset the list of perl interpreters to just the one running C.
554              
555             Added in 1.21.
556              
557             =cut
558              
559             sub reset_perls {
560 1     1 1 596 my $self = shift;
561              
562 1         10 $self->{perls} = {};
563              
564 1         10 return $self->{perls}{$^X} = $];
565             }
566              
567              
568             =item input_fh
569              
570             Return the value of input_fh.
571              
572             =cut
573              
574             sub input_fh {
575 1     1 1 4 return $_[0]->{input_fh};
576             }
577              
578             =item output_fh
579              
580             If quiet is off, return the value of output_fh. If output_fh is not
581             set, return STDOUT. If quiet is on, return the value of null_fh.
582              
583             =cut
584              
585             sub output_fh {
586             $_[0]->quiet
587             ?
588             $_[0]->null_fh
589             :
590             ( $_[0]->{output_fh} || *STDOUT{IO} )
591 94 100 100 94 1 283 }
592              
593             =item null_fh
594              
595             Return the null filehandle. So far that's something set up in C and I
596             haven't provided a way to set it. Any subclass can make their C
597             return whatever they like.
598              
599             =cut
600              
601             sub null_fh {
602 132     132 1 4239 require IO::Null;
603 132   66     9887 $_[0]->{null_fh} //= IO::Null->new;
604             }
605              
606             =item quiet
607              
608             Get the value of quiet mode (true or false).
609              
610             =item turn_quiet_on
611              
612             Turn on quiet mode
613              
614             =item turn_quiet_off
615              
616             Turn off quiet mode
617              
618             =cut
619              
620 11     11 1 8001 sub turn_quiet_on { $_[0]->{quiet} = 1 }
621 13     13 1 19904 sub turn_quiet_off { $_[0]->{quiet} = 0 }
622              
623 105     105 1 4602 sub quiet { $_[0]->{quiet} }
624              
625             =item debug
626              
627             Get the value of the debugging flag (true or false).
628              
629             =item turn_debug_on
630              
631             Turn on debugging
632              
633             =item turn_debug_off
634              
635             Turn off debugging
636              
637             =item debug_fh
638              
639             If debugging is on, return the value of debug_fh. If debug_fh is not
640             set, return STDERR. If debugging is off, return the value of null_fh.
641              
642             =cut
643              
644 7     7 1 1875 sub turn_debug_on { $_[0]->{debug} = 1 }
645 5     5 1 1344 sub turn_debug_off { $_[0]->{debug} = 0 }
646              
647 114     114 1 5418 sub debug { $_[0]->{debug} }
648              
649             sub debug_fh {
650 107 100   107 1 1970 if( $_[0]->debug ) {
651             $_[0]->{debug_fh} || *STDERR{IO}
652 15 100       101 }
653             else {
654 92         244 $_[0]->null_fh
655             }
656             }
657              
658             =back
659              
660             =head2 Methods for building
661              
662             =over 4
663              
664             =item clean
665              
666             Run `make realclean`
667              
668             =cut
669              
670             sub clean {
671 3     3 1 6562 my $self = shift;
672 3         10 $self->_print( "Cleaning directory... " );
673              
674 3 100       57 unless( -e $self->{Makefile} ) {
675 2         16 $self->_print( " no $self->{Makefile}---skipping\n" );
676 2         16 return;
677             }
678              
679 1         10 $self->run( "$self->{make} realclean 2>&1" );
680              
681 1         5 $self->_print( "done\n" );
682             }
683              
684             =item distclean
685              
686             Run `make distclean`
687              
688             =cut
689              
690             sub distclean {
691 3     3 1 6198 my $self = shift;
692 3         9 $self->_print( "Cleaning directory... " );
693              
694 3 100       52 unless( -e $self->{Makefile} ) {
695 2         14 $self->_print( " no $self->{Makefile}---skipping\n" );
696 2         15 return;
697             }
698              
699 1         45 $self->run( "$self->{make} distclean 2>&1" );
700              
701 1         5 $self->_print( "done\n" );
702             }
703              
704              
705             =item build_makefile()
706              
707             Runs `perl Makefile.PL 2>&1`.
708              
709             This step ensures that we start off fresh and pick up any changes in
710             C.
711              
712             =cut
713              
714             sub build_makefile {
715 9     9 1 6219 my $self = shift;
716 9         22 $self->_print( "Recreating make file... " );
717              
718 9 100       175 unless( -e $self->{'Makefile.PL'} ) {
719 2         13 $self->_print( " no $self->{'Makefile.PL'}---skipping\n" );
720 2         12 return;
721             }
722              
723 7         52 $self->run( "$self->{perl} $self->{'Makefile.PL'} 2>&1" );
724              
725 7         28 $self->_print( "done\n" );
726             }
727              
728             =item make()
729              
730             Run a plain old `make`.
731              
732             =cut
733              
734             sub make {
735 3     3 1 6268 my $self = shift;
736 3         10 $self->_print( "Running make... " );
737              
738 3 100       47 unless( -e $self->{'Makefile'} )
739             {
740 2         30 $self->_print( " no $self->{'Makefile'}---skipping\n" );
741 2         14 return;
742             }
743              
744 1         16 my $tests = $self->run( "$self->{make} 2>&1" );
745              
746 1         9 $self->_print( "done\n" );
747             }
748              
749             =item test()
750              
751             Run `make test`. If any tests fail, it dies.
752              
753             =cut
754              
755             sub test {
756 5     5 1 6264 my $self = shift;
757 5         16 $self->_print( "Checking make test... " );
758              
759 5 100       83 unless( -e $self->{'Makefile'} ) {
760 2         13 $self->_print( " no $self->{'Makefile'}---skipping\n" );
761 2         15 return;
762             }
763              
764 3         45 my $tests = $self->run( "$self->{make} test 2>&1" );
765              
766 3 100       31 unless ($tests =~ m/All tests successful/) {
767 2 50       8 if( $self->debug ) { # from H.Merijn Brand
768 0         0 my $prove = File::Spec->catfile(
769             dirname( $self->get_perl ),
770             'prove'
771             );
772              
773 0 0       0 if( -x $prove ) {
    0          
774             my $prove_out =
775             join "\n\n",
776 0         0 map { scalar qx"$prove -wvb $_" }
  0         0  
777             ($tests =~ m{^(t/\w+\.t)\s+[0-9]+}gm);
778 0         0 $prove_out =~ s/^.*\r//gm;
779 0         0 $self->_warn( $prove_out );
780             }
781             elsif( $self->debug ) {
782 0         0 $self->_print( "prove [$prove] was not executable!" );
783             }
784             }
785              
786 2         11 $self->_die( "\nERROR: Tests failed!\n$tests\n\nAborting release\n" )
787             }
788              
789 1         5 $self->_print( "all tests pass\n" );
790             }
791              
792             =item dist()
793              
794             Run `make dist`. As a side effect determines the distribution
795             name if not set on the command line.
796              
797             =cut
798              
799             sub dist {
800 6     6 1 3191 my $self = shift;
801 6         18 $self->_print( "Making dist...\n" );
802              
803 6         30 $self->build_makefile;
804              
805 6         35 my $messages = $self->run( "$self->{make} dist 2>&1 < $self->{devnull}" );
806 6         35 $self->_debug( "messages are [$messages]\n" );
807              
808             # If the distro isn't already set, try to guess it
809 6 100       16 unless( $self->local_file ) {
810 4         12 $self->_debug( ", guessing local distribution name\n" );
811 4         21 my( $guess ) = $messages =~ /(?:\s|')(\S+\.tar)/;
812 4         14 $self->_debug( "guessed [$guess]\n" );
813 4         13 $self->local_file( $guess );
814              
815 4 100       9 $self->_die( "Couldn't guess distname from dist output\n" )
816             unless $self->local_file;
817              
818 2         6 $self->local_file( $self->local_file() . '.gz' );
819 2         8 $self->remote_file( $self->local_file );
820             }
821              
822             # local_file should exist now
823 4 100       10 $self->_die( "Local file '$self->{local_file}' does not exist\n" )
824             unless -f $self->local_file;
825              
826 1         7 $self->_print( "Done making dist\n" );
827             }
828              
829             =item disttest
830              
831             Run `make disttest`. If the tests fail, it dies.
832              
833             =cut
834              
835             sub disttest {
836 6     6 1 6059 my $self = shift;
837              
838 6         26 $self->_print( "Checking make disttest... " );
839              
840 6 100       107 unless( -e $self->{'Makefile'} ) {
841 3         19 $self->_print( " no $self->{'Makefile'}---skipping\n" );
842 3         35 return;
843             }
844              
845 3         18 my $tests = $self->run( "$self->{make} disttest 2>&1" );
846              
847 3 100       26 $self->_die( "\nERROR: Tests failed!\n$tests\n\nAborting release\n" )
848             unless $tests =~ /All tests successful/;
849              
850 1         4 $self->_print( "all tests pass\n" );
851             }
852              
853             =item dist_test
854              
855             This was the old name for the method, but was inconsistent with
856             other method names. It still works, but is deprecated and will
857             give a warning.
858              
859             =cut
860              
861             sub dist_test {
862 1     1 1 4733 $_[0]->_warn( "dist_test is deprecated. Use disttest instead." );
863              
864 1         113 goto &disttest;
865             }
866              
867             =item dist_version
868              
869             Return the distribution version ( set in dist() )
870              
871             =cut
872              
873             sub _parse_version {
874 18     18   44 my( $self ) = @_;
875 22     22   272 no warnings 'uninitialized';
  22         55  
  22         6156  
876              
877 18 100       54 $self->_die( "Can't get dist_version! It's not set (did you run dist first?)" )
878             unless defined $self->remote_file;
879              
880 17 100       40 my( $version_str, $vee, $version, $dev ) = $self->remote_file
881             =~ / ( (v?) ([\d.]+) (?: _ (\d+) )? ) (?:\. (?: tar \. gz | zip ) )? $/xi
882             or return { components => [], string => '', multipart => 0 };
883              
884 15         80 my @components = split /[.]/, $version;
885 15         33 my $count = @components;
886              
887 15   100     68 my $multipart = length($vee) || ($count > 2);
888              
889 15         134 my $hash = {
890             components => \@components,
891             count => $count,
892             string => $version_str,
893             vee => lc $vee,
894             version => $version,
895             v_version => lc($vee) . $version,
896             dev => $dev,
897             multipart => $multipart,
898             };
899              
900 22     22   14941 $self->_debug( Dumper( $self->remote_file, $hash ) ); use Data::Dumper;
  22         180796  
  22         7492  
  15         39  
901              
902 15         48 return $hash;
903             }
904              
905             sub dist_version {
906 18     18 1 22509 my( $self ) = @_;
907              
908 18         59 my $v = $self->_parse_version;
909              
910 17 100       107 if( $v->{multipart} ) {
    100          
    100          
911 9         26 $self->_debug( "Choosing multipart version" );
912             # This is a multi-part version
913             # We assume that version.pm is available if multi-part
914             # versions are in use.
915             eval {
916 9         859 require version;
917             }
918 9 50       16 or do { # Fall back to using $version_str verbatim
919 0         0 warn $@;
920 0         0 return $v->{version_str};
921             };
922              
923             # There are pre- and post-0.77 versions of version.pm.
924             # The former are deprecated, but I assume we must
925             # gracefully use what we have available.
926 9 50       2169 eval {
927 9         18 my $string = $v->{v_version};
928 9 50       225 $v->{version} = version->VERSION >= 0.77 ?
929             version->parse ($string)->normal : # latest and best
930             ''.version->new($string) ; # legacy
931 9         50 1;
932             }
933             or
934             $self->_die( "Couldn't parse version '$v->{string}' from '".
935             $self->remote_file. "': $@");
936              
937 9         56 return $v->{version};
938             }
939             elsif( $v->{count} == 1 ) {
940 1         5 $self->_debug( "Choosing single component version" );
941             # some versions might be a single number, such as those
942             # that use dates as integers with no dot.
943 1         10 return $v->{components}[0];
944             }
945             elsif( $v->{string} =~ /(\d+) \. (\d+)(_\d+)? $/x ) {
946 5         20 $self->_debug( "Choosing major.minor_dev? version" );
947             # Else, use the older implementation for backward-compatibility
948             # Note the lack of an initial ^ matcher is deliberate.
949 5         28 my( $major, $minor, $dev ) = ( $1, $2, $3 );
950 5         20 return $self->dist_version_format( $major, $minor, $dev );
951             }
952             else {
953 2         7 $self->_debug( "Unhandled version" );
954 2         9 return '';
955             }
956             }
957              
958             =item dist_version_format
959              
960             Return the distribution version ( set in dist() )
961              
962             # XXX make this configurable
963              
964             =cut
965              
966             sub dist_version_format {
967 22     22   207 no warnings 'uninitialized';
  22         49  
  22         44792  
968 7     7 1 3370 my $self = shift;
969 7         23 my( $major, $minor, $dev ) = @_;
970              
971 7         88 sprintf "%s.%s%s", $major, $minor, $dev;
972             }
973              
974             =item module_name
975              
976             Returns the module name. This either takes it from the config file
977             or tries to guess it from the distro name.
978              
979             =cut
980              
981             sub module_name {
982 0     0 1 0 my $self = shift;
983 0 0       0 return $self->{module_name} if $self->{module_name};
984              
985 0         0 my $name = $self->local_file;
986 0         0 $self->_debug( "Guessing name. Local file is <$name>\n" );
987              
988 0         0 $name =~ s/-\d.*//g;
989 0         0 $name =~ s/-/::/g;
990 0         0 $self->_debug( "Guessing name. Module name is <$name>\n" );
991              
992 0         0 $self->{module_name} = $name;
993             }
994              
995             =item check_manifest
996              
997             Run `make manifest` and report anything it finds. If it gives output,
998             die. You should check C to ensure it has the things it needs.
999             If files that shouldn't show up do, put them in MANIFEST.SKIP.
1000              
1001             Since `make manifest` takes care of things for you, you might just have
1002             to re-run your release script.
1003              
1004             =cut
1005              
1006             # _check_output_lines - for command output with one message per line.
1007             # The message hash identifies the first part of the line and serves
1008             # as a category for the message. If a line doesn't matter, don't put
1009             # it's pattern in the message hash.
1010             #
1011             # Prints a summary of what it found. The message is the hash value
1012             # for that output type.
1013             #
1014             # returns the number of interesting things it found, but that's it.
1015             sub _check_output_lines {
1016 2     2   6 my $self = shift;
1017 2         4 my( $message_hash, $message ) = @_;
1018              
1019 2         5 my %state;
1020 2         15 foreach my $state ( keys %$message_hash ) {
1021 4         82 $state{$state} = [ $message =~ /^\Q$state\E\s+(.+)/gm ];
1022             }
1023              
1024 2         6 my $rule = "-" x 50;
1025 2         4 my $count = 0;
1026              
1027 2         9 foreach my $key ( sort keys %state ) {
1028 4         9 my $list = $state{$key};
1029 4 100       13 next unless @$list;
1030              
1031 2         4 $count += @$list;
1032              
1033 2         13 local $" = "\n\t";
1034 2         14 $self->_print( "\n\t$message_hash->{$key}\n\t$rule\n\t@$list\n" );
1035             }
1036              
1037 2         8 return $count;
1038             }
1039              
1040             sub check_manifest {
1041 2     2 1 3489 my $self = shift;
1042              
1043 2         20 $self->_print( "Checking state of MANIFEST... " );
1044              
1045 2         20 my $manifest = $self->run( "$self->{make} manifest 2>&1" );
1046              
1047 2         22 my %message = (
1048             "Removed from MANIFEST:" => 'These files were removed from MANIFEST',
1049             "Added to MANIFEST:" => 'These files were added to MANIFEST',
1050             );
1051              
1052 2         13 my $count = $self->_check_output_lines( \%message, $manifest );
1053              
1054 2 100       12 $self->_die( "\nERROR: Manifest was not up-to-date ($count files).\n" )
1055             if $count;
1056              
1057 1         5 $self->_print( "MANIFEST up-to-date\n" );
1058             }
1059              
1060             =item manifest_name
1061              
1062             Return the name of the manifest file, probably F.
1063              
1064             =item manifest
1065              
1066             This is the old name for manifest_name. It still works but is
1067             deprecated.
1068              
1069             =cut
1070              
1071 7     7 1 4731 sub manifest_name { 'MANIFEST' }
1072              
1073             sub manifest {
1074 1     1 1 2188 $_[0]->_warn( "manifest is deprecated. Use manifest_name" );
1075 1         110 &manifest_name
1076             }
1077              
1078             =item files_in_manifest
1079              
1080             Return the filenames in the manifest file as a list.
1081              
1082             =cut
1083              
1084             sub files_in_manifest {
1085 3     3 1 713 my $self = shift;
1086              
1087 3         866 require ExtUtils::Manifest;
1088              
1089             # I want to use ExtUtils::Manifest so it automatically
1090             # follows the right MANIFEST rules, but I have to adapt
1091             # it's output to my output. Annoying, for sure.
1092 3         9784 my $hash = do {
1093             local $SIG{'__WARN__'} = sub {
1094 1     1   66 my $message = shift;
1095 1 50       15 if( $message =~ m/Debug: (.*)/ ) {
1096 0         0 $self->_debug( $1 );
1097             }
1098             else {
1099 1         6 $self->_die( "files_in_manifest: could not open file\n" );
1100             }
1101 3         44 };
1102              
1103 3         12 ExtUtils::Manifest::maniread( $self->manifest_name );
1104             };
1105              
1106 2         309 sort keys %$hash;
1107             }
1108              
1109             =item check_vcs
1110              
1111             =item vcs_tag
1112              
1113             =item make_vcs_tag
1114              
1115             Note: these methods were formerly "cvs", but are now "vcs" for
1116             Version Control System.
1117              
1118             This is a placeholder method which should be implemented in a mixin
1119             module. Try installing Module::Release::CVS, Module::Release::SVN,
1120             or Module::Release::Git and then loading them in your script. The
1121             default C script does this for you by checking for the
1122             special directories for those source systems.
1123              
1124             Previous to version 1.24, these methods were implemented in this
1125             module to support CVS. They are now in Module::Release::CVS as a
1126             separate module.
1127              
1128             =cut
1129              
1130             sub check_vcs {
1131 1     1 1 1924 $_[0]->_die( "check_vcs must be implemented in a mixin class" );
1132             }
1133              
1134              
1135             sub vcs_tag {
1136 1     1 1 382 $_[0]->_die( "vcs_tag must be implemented in a mixin class" );
1137             }
1138              
1139             sub make_vcs_tag {
1140 1     1 1 352 $_[0]->_die( "make_vcs_tag must be implemented in a mixin class" );
1141             }
1142              
1143             =item touch( FILES )
1144              
1145             Set the modification times of each file in FILES to the current time. It
1146             tries to open the file for writing and immediately closing it, as well as
1147             using utime. It checks that the access and modification times were
1148             updated.
1149              
1150             Returns the number of files which it successfully touched.
1151              
1152             =cut
1153              
1154             sub touch {
1155 4     4 1 19110 my( $self, @files ) = @_;
1156              
1157 4         14 my $time = time;
1158              
1159 4         12 my $count = 0;
1160 4         38 foreach my $file ( @files ) {
1161 11 100       182 unless( -f $file ) {
1162 1         23 $self->_warn( "$file is not a plain file" );
1163 1         158 next;
1164             }
1165              
1166 10 50       373 open my( $fh ), ">>", $file
1167             or $self->_warn( "Could not open file [$file] for writing: $!" );
1168 10         85 close $file;
1169              
1170 10         124 utime( $time, $time, $file );
1171              
1172             # check that it actually worked
1173 10 100       135 unless( 2 == grep { $_ == $time } (stat $file)[8,9] ) {
  20         80  
1174 3         26 $self->_warn( "$file did not set utimes." );
1175 3         283 next;
1176             }
1177              
1178 7         89 $count++;
1179             }
1180              
1181 4         33 $count;
1182             }
1183              
1184             =item touch_all_in_manifest
1185              
1186             Runs touch on all of the files in MANIFEST.
1187              
1188             =cut
1189              
1190 1     1 1 5028 sub touch_all_in_manifest { $_[0]->touch( $_[0]->files_in_manifest ) }
1191              
1192             =back
1193              
1194             =head2 Methods for uploading
1195              
1196             =over 4
1197              
1198             =item should_upload_to_pause
1199              
1200             Should I upload to PAUSE? If C and C are set,
1201             go for it.
1202              
1203             =cut
1204              
1205             sub should_upload_to_pause {
1206 0     0 1 0 $_[0]->_debug( "Checking if I should upload\n" );
1207 0   0     0 my $answer = !!( $_[0]->config->cpan_user && $_[0]->config->cpan_pass );
1208 0         0 $_[0]->_debug( "The answer is [$answer]\n" );
1209 0         0 $answer;
1210             }
1211              
1212             =item check_for_passwords
1213              
1214             Get passwords for CPAN.
1215              
1216             =cut
1217              
1218             sub check_for_passwords {
1219 3 100 66 3 1 5608 if( my $pass = $_[0]->config->cpan_user && $_[0]->get_env_var( "CPAN_PASS" ) ) {
1220 1         19 $_[0]->config->set( 'cpan_pass', $pass );
1221             }
1222              
1223 3         57 $_[0]->_debug( "CPAN pass is " . $_[0]->config->cpan_pass . "\n" );
1224             }
1225              
1226             =item get_changes()
1227              
1228             Read and parse the F file. This is pretty specific, so
1229             you may well want to overload it.
1230              
1231             =cut
1232              
1233             sub get_changes {
1234 3 100   3 1 250 open my $fh, '<:encoding(UTF-8)', 'Changes' or return '';
1235              
1236 2         321 my $data = <$fh>; # get first line
1237              
1238 2         28 while( <$fh> ) {
1239 4 100       33 last if /^\S/;
1240 2         9 $data .= $_;
1241             }
1242              
1243 2         65 return $data;
1244             }
1245              
1246             =item show_recent_contributors()
1247              
1248             Show recent contributors before creating/extending Changes.
1249              
1250             This output relies upon the method C having been
1251             implemented in the relevant mixin for your version control system.
1252              
1253             =cut
1254              
1255             sub show_recent_contributors {
1256 2     2 1 5268 my $self = shift;
1257 2 100       22 return unless $self->can( 'get_recent_contributors' );
1258 1         11 my @contributors = $self->get_recent_contributors;
1259 1 50       22 $self->_print("Contributors since last release:\n") if @contributors;
1260 1         10 $self->_print( "\t", $_, "\n" ) for @contributors;
1261             }
1262              
1263             =item get_release_date()
1264              
1265             Return a string representing the current date and time (in UTC) in the
1266             L format so that it can be added directly to the
1267             Changes file.
1268              
1269             =cut
1270              
1271             sub get_release_date {
1272 2     2 1 2676 state $rc = require Time::Piece;
1273 2         11087 return Time::Piece->gmtime->datetime . 'Z';
1274             }
1275              
1276             =item run
1277              
1278             Run a command in the shell.
1279              
1280             =item run_error
1281              
1282             Returns true if the command ran successfully, and false otherwise. Use
1283             this function in any other method that calls run to figure out what to
1284             do when a command doesn't work. You may want to handle that yourself.
1285              
1286             =cut
1287              
1288 6     6   24 sub _run_error_reset { $_[0]->{_run_error} = 0 }
1289 2     2   22 sub _run_error_set { $_[0]->{_run_error} = 1 }
1290 3     3 1 1990 sub run_error { $_[0]->{_run_error} }
1291              
1292             sub run {
1293 5     5 1 8863 my( $self, $command ) = @_;
1294              
1295 5         63 $self->_run_error_reset;
1296              
1297 5         125 $self->_debug( "$command\n" );
1298 5 100       23 $self->_die( "Didn't get a command!" ) unless defined $command;
1299              
1300 3 100       7030 open my($fh), "-|", "$command" or $self->_die( "Could not open command [$command]: $!" );
1301 2         172 $fh->autoflush;
1302              
1303 2         474 my $output = '';
1304 2         15 my $buffer = '';
1305 2         43 local $| = 1;
1306              
1307 2 50       49 my $readlen = $self->debug ? 1 : 256;
1308              
1309 2         6758 while( read $fh, $buffer, $readlen ) {
1310 1         41 $output .= $_;
1311 1         57 $self->_debug( $_, $buffer );
1312 1         8 $output .= $buffer;
1313             }
1314              
1315 2         41 $self->_debug( $self->_dashes, "\n" );
1316              
1317 2 100       93 unless( close $fh ) {
1318 1         21 $self->_run_error_set;
1319 1         32 $self->_warn( "Command [$command] didn't close cleanly: $?" );
1320             }
1321              
1322 2         293 return $output;
1323             }
1324              
1325             =item get_env_var
1326              
1327             Get an environment variable or prompt for it
1328              
1329             =cut
1330              
1331             sub get_env_var {
1332 6     6 1 8606 my ($self, $field) = @_;
1333              
1334             # Check for an explicit argument passed
1335 6 100       117 return $self->{lc $field} if defined $self->{lc $field};
1336              
1337 5         18 my $pass = $ENV{$field};
1338              
1339 5 100 100     58 return $pass if defined( $pass ) && length( $pass );
1340              
1341 3         19 $self->_print( "$field is not set. Enter it now: " );
1342 3 100       28 if ($field eq 'CPAN_PASS') {
1343             # don't echo passwords to the screen
1344 1         989 require Term::ReadKey;
1345 1         2753 local $| = 1;
1346 1         5 Term::ReadKey::ReadMode('noecho');
1347 1         37 $pass = $self->_slurp;
1348 1         8 Term::ReadKey::ReadMode('restore');
1349             }
1350             else {
1351 2         14 $pass = $self->_slurp;
1352             }
1353 3         40 chomp $pass;
1354              
1355 3 100 66     47 return $pass if defined( $pass ) && length( $pass );
1356              
1357 1         18 $self->_debug( "$field not supplied. Aborting...\n" );
1358             }
1359              
1360             =back
1361              
1362             =head2 Methods for developers
1363              
1364             =over
1365              
1366             =item _print( LIST )
1367              
1368             Send the LIST to whatever is in output_fh, or to STDOUT. If you set
1369             output_fh to a null filehandle, output goes nowhere.
1370              
1371             =cut
1372              
1373 74     74   2602 sub _print { print { $_[0]->output_fh } @_[1..$#_] }
  74         190  
1374              
1375             =item _slurp
1376              
1377             Read a line from whatever is in input_fh and return it.
1378              
1379             =cut
1380              
1381             sub _slurp {
1382 1     1   1334 my $fh = $_[0]->input_fh;
1383 1         16 return <$fh>;
1384             }
1385              
1386             =item _dashes()
1387              
1388             Use this for a string representing a line in the output. Since it's a
1389             method you can override it if you like.
1390              
1391             =cut
1392              
1393 3     3   1017 sub _dashes { "-" x 73 }
1394              
1395             =item _debug( LIST )
1396              
1397             Send the LIST to whatever is in debug_fh, or to STDERR. If you aren't
1398             debugging, debug_fh should return a null filehandle.
1399              
1400             =cut
1401 22     22   249 use Carp qw(carp);
  22         53  
  22         4179  
1402             sub _debug {
1403 87     87   3272 my $self = shift;
1404              
1405 87         272 my $debug_fh = $self->debug_fh;
1406              
1407 87         306 print { $debug_fh } @_;
  87         475  
1408             }
1409              
1410              
1411             #eval { print { shift->debug_fh } @_; 1 } or carp "Failure in _debug: [@_] [$@]" }
1412              
1413             =item _die( LIST )
1414              
1415             =cut
1416              
1417 23     23   5070 sub _die { croak @_[1..$#_] }
1418              
1419             =item _warn( LIST )
1420              
1421             =cut
1422              
1423 11 100   11   1608 sub _warn { carp @_[1..$#_] unless $_[0]->quiet }
1424              
1425             =back
1426              
1427             =head1 TO DO
1428              
1429             * What happened to my Changes munging?
1430              
1431             =head1 CREDITS
1432              
1433             Ken Williams turned my initial release(1) script into the present
1434             module form.
1435              
1436             Andy Lester handled the maintenance while I was on my Big Camping
1437             Trip. He applied patches from many authors.
1438              
1439             Andreas König suggested changes to make it work better with PAUSE.
1440              
1441             Chris Nandor helped with figuring out the broken SourceForge stuff.
1442              
1443             H.Merijn Brand has contributed many patches and features.
1444              
1445             =head1 SOURCE AVAILABILITY
1446              
1447             This source is in GitHub
1448              
1449             https://github.com/briandfoy/module-release
1450              
1451             =head1 AUTHOR
1452              
1453             brian d foy, C<< >>
1454              
1455             =head1 COPYRIGHT AND LICENSE
1456              
1457             Copyright © 2007-2021, brian d foy C<< >>. All rights reserved.
1458              
1459             This program is free software; you can redistribute it and/or modify
1460             it under the Artistic License 2.0.
1461              
1462             =cut
1463              
1464             1;