File Coverage

blib/lib/DhMakePerl/Command/refresh.pm
Criterion Covered Total %
statement 9 9 100.0
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 12 12 100.0


line stmt bran cond sub pod time code
1             package DhMakePerl::Command::refresh;
2              
3             =head1 NAME
4              
5             DhMakePerl::Command::refresh - dh-make-perl refresh implementation
6              
7             =head1 DESCRIPTION
8              
9             This module implements the I command of L.
10              
11             =cut
12              
13 1     1   2419140 use strict; use warnings;
  1     1   16  
  1         98  
  1         14  
  1         2  
  1         162  
14              
15             our $VERSION = '0.84';
16              
17 1     1   57 use base 'DhMakePerl::Command::Packaging';
  1         2  
  1         1034  
18             use Debian::Control::FromCPAN;
19             use Debian::WNPP::Query ();
20             use File::Spec::Functions qw(catfile);
21             use Tie::File;
22              
23             =head1 METHODS
24              
25             =over
26              
27             =item execute
28              
29             Provides I command implementation.
30              
31             =cut
32              
33             sub execute {
34             my $self = shift;
35              
36             $self->main_dir( $ARGV[0] || '.' );
37             print "Engaging refresh mode in " . $self->main_dir . "\n"
38             if $self->cfg->verbose;
39              
40             if ( not $self->cfg->_explicitly_set->{'source-format'}
41             and -e ( my $f = catfile( $self->debian_file('source'), 'format' ) ) )
42             {
43             open( my $fh, '<', $f ) or die "open($f): $!";
44             my $present = <$fh>;
45             close $fh;
46              
47             chomp($present) if $present;
48             if ($present) {
49             $self->cfg->source_format($present);
50             print "Detected source format: $present\n"
51             if $self->cfg->verbose;
52             }
53             }
54              
55             $self->control->read( $self->debian_file('control') );
56             $self->fill_maintainer;
57             $self->process_meta;
58             $self->extract_basic(); # also detects arch-dep package
59              
60             $self->extract_docs if $self->cfg->only->{docs};
61             $self->extract_examples if $self->cfg->only->{examples};
62             print "Found docs: @{ $self->docs }\n"
63             if @{ $self->docs } and $self->cfg->verbose;
64             print "Found examples: @{ $self->examples }\n"
65             if @{ $self->examples } and $self->cfg->verbose;
66              
67             if ( $self->cfg->only->{only} ) {
68             $self->create_rules;
69             $self->create_compat( $self->debian_file('compat') );
70             }
71              
72             if ( $self->cfg->only->{examples} ) {
73             $self->update_file_list( examples => $self->examples );
74             }
75              
76             if ( $self->cfg->only->{docs} ) {
77             $self->update_file_list( docs => $self->docs );
78             }
79              
80             if ( $self->cfg->only->{copyright} ) {
81             $self->backup_file( $self->debian_file('copyright') );
82             $self->create_copyright( $self->debian_file('copyright') );
83             }
84              
85             if ( $self->cfg->only->{control} ) {
86             my $control = $self->control;
87             if ( -e catfile( $self->debian_file('patches'), 'series' )
88             and $self->cfg->source_format ne '3.0 (quilt)' )
89             {
90             $self->add_quilt($control);
91             }
92             else {
93             $self->drop_quilt($control);
94             }
95              
96             $self->write_source_format(
97             catfile( $self->debian_dir, 'source', 'format' ) );
98              
99             $self->discover_dependencies;
100              
101             $self->discover_utility_deps($control);
102             $control->prune_perl_deps();
103              
104             $self->backup_file( $self->debian_file('control') );
105             $control->write( $self->debian_file('control') );
106             }
107              
108             print "--- Done\n" if $self->cfg->verbose;
109             return 0;
110             }
111              
112             =item add_quilt( $control )
113              
114             Plugs quilt into F and F. Depends on
115             F being in L three-liner format. Also adds debian/README.source
116             documenting quilt usage.
117              
118             =cut
119              
120             sub add_quilt {
121             my( $self, $control ) = @_;
122              
123             $self->read_rules;
124              
125             $self->rules->add_quilt;
126              
127             # README.source
128             my $quilt_mini_doc = <
129             This package uses quilt for managing all modifications to the upstream
130             source. Changes are stored in the source package as diffs in
131             debian/patches and applied during the build.
132              
133             See /usr/share/doc/quilt/README.source for a detailed explaination.
134             EOF
135              
136             my $readme = $self->debian_file('README.source');
137             my $quilt_already_documented = 0;
138             my $readme_source_exists = -e $readme;
139             if($readme_source_exists) {
140             my @readme;
141             tie @readme, 'Tie::File', $readme
142             or die "Unable to tie '$readme': $!";
143              
144             for( @readme ) {
145             if( m{quilt/README.source} ) {
146             $quilt_already_documented = 1;
147             last;
148             }
149             }
150             }
151              
152             print "README.source already documents quilt\n"
153             if $quilt_already_documented and $self->cfg->verbose;
154              
155             unless($quilt_already_documented) {
156             my $fh;
157             open( $fh, '>>', $readme )
158             or die "Unable to open '$readme' for writing: $!";
159              
160             print $fh "\n\n" if $readme_source_exists;
161             print $fh $quilt_mini_doc;
162             close $fh;
163             }
164             }
165              
166             =item drop_quilt( $control )
167              
168             removes quilt from F. Expects that
169             L<|add_quilt> was used to add quilt to F.
170              
171             If F exists, references to quilt are removed from it (and
172             the file removed if empty after that).
173              
174             Both L style (C) and old-fashioned (C<$(QUILT_STAMPFN)>
175             target dependency) are supported.
176              
177             =cut
178              
179             sub drop_quilt {
180             my( $self, $control ) = @_;
181              
182             $self->read_rules;
183              
184             $self->rules->drop_quilt;
185              
186             # README.source
187             my $readme = $self->debian_file('README.source');
188              
189             if( -e $readme ) {
190             my @readme;
191             tie @readme, 'Tie::File', $readme
192             or die "Unable to tie '$readme': $!";
193              
194             my( $start, $end );
195             for( my $i = 0; defined( $_ = $readme[$i] ); $i++ ) {
196             if( m{^This package uses quilt } ) {
197             $start = $i;
198             next;
199             }
200              
201             if( defined($start)
202             and m{^See /usr/share/doc/quilt/README.source} ) {
203             $end = $i;
204             last;
205             }
206             }
207              
208             if( defined($start) and defined($end) ) {
209             print "Removing references to quilt from README.source\n"
210             if $self->cfg->verbose;
211              
212             splice @readme, $start, $end-$start+1;
213              
214             # file is now empty?
215             if( join( '', @readme ) =~ /^\s*$/ ) {
216             unlink $readme
217             or die "unlink($readme): $!";
218             }
219             }
220             }
221             }
222              
223             =back
224              
225             =cut
226              
227             1;
228              
229             =head1 COPYRIGHT & LICENSE
230              
231             =over
232              
233             =item Copyright (C) 2008, 2009, 2010 Damyan Ivanov
234              
235             =item Copyright (C) 2010, 2014 gregor herrmann
236              
237             =back
238              
239             This program is free software; you can redistribute it and/or modify it under
240             the terms of the GNU General Public License version 2 as published by the Free
241             Software Foundation.
242              
243             This program is distributed in the hope that it will be useful, but WITHOUT ANY
244             WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
245             PARTICULAR PURPOSE. See the GNU General Public License for more details.
246              
247             You should have received a copy of the GNU General Public License along with
248             this program; if not, write to the Free Software Foundation, Inc., 51 Franklin
249             Street, Fifth Floor, Boston, MA 02110-1301 USA.
250              
251             =cut
252