File Coverage

blib/lib/Debian/Rules.pm
Criterion Covered Total %
statement 58 100 58.0
branch 17 64 26.5
condition 10 42 23.8
subroutine 9 12 75.0
pod 8 8 100.0
total 102 226 45.1


line stmt bran cond sub pod time code
1             package Debian::Rules;
2              
3 2     2   854468 use strict;
  2         20  
  2         201  
4 2     2   27 use warnings;
  2         4  
  2         362  
5              
6             our $VERSION = '0.82';
7              
8             =head1 NAME
9              
10             Debian::Rules - handy manipulation of debian/rules
11              
12             =head1 SYNOPSIS
13              
14             my $r = Debian::Rules->new('debian/rules');
15              
16             my $r = Debian::Rules->new( { filename => 'debian/rules' } );
17              
18             $r->is_dhtiny && print "Using the latest and greatest\n";
19             $r->is_quiltified && print "quilt rules the rules\n";
20              
21             # file contents changed externally
22             $r->parse;
23              
24             $r->add_quilt;
25             $r->drop_quilt;
26              
27             $r->write; # or undef($r);
28              
29              
30             =head1 DESCRIPTION
31              
32             Some times, one needs to know whether F uses the L
33             tiny variant, or whether it is integrated with L. Debian::Rules
34             provides facilities to check this, as well as adding/removing quilt
35             integration.
36              
37             Modified contents are written to file either vie the L method, or when
38             the object reference goes out of scope (via DESTROY).
39              
40             =head1 CONSTRUCTOR
41              
42             C is the standard L constructor, with the exception that
43             if only one, non-reference argument is provided, it is treated as a value for
44             the L field.
45              
46             If a file name is given, the constructor calls L to read the file
47             contents into memory.
48              
49             One of B or B is mandatory.
50              
51             =head1 FIELDS
52              
53             =over
54              
55             =item filename
56              
57             Contains the file name of the rules file.
58              
59             =item lines
60              
61             Reference to an array pointing to the rules file. Initialized by L.
62              
63             =back
64              
65             =cut
66              
67 2     2   146 use base 'Class::Accessor';
  2         7  
  2         2637  
68              
69             __PACKAGE__->mk_accessors(
70             qw(filename lines _is_dhtiny _is_quiltified _parsed));
71              
72             sub new {
73 3     3 1 1298 my $class = shift;
74              
75 3         7 my @params = @_;
76              
77             # allow single argument to be treated as filename
78 3 50 33     19 @params = { filename => $params[0] }
79             if @params == 1 and not ref( $params[0] );
80              
81 3         16 my $self = $class->SUPER::new(@params);
82              
83 3 50 33     36 $self->filename or $self->lines or die "'filename' or 'lines' is mandatory";
84              
85 3 50       72 $self->lines( [] ) unless $self->lines;
86              
87 3 50       26 $self->read if $self->filename;
88              
89 3         28 return $self;
90             }
91              
92             =head1 METHODS
93              
94             =over
95              
96             =item parse
97              
98             Parses the rules file and stores its findings for later use. Called
99             automatically by L and L. The result of the parsing
100             is cached and subsequent calls to C use the cache. To force cache
101             refresh (for example if the contents of the file have been changed), call
102             C again.
103              
104             =cut
105              
106             sub parse {
107 2     2 1 22 my $self = shift;
108              
109 2         6 $self->_is_dhtiny(0);
110 2         28 $self->_is_quiltified(0);
111              
112 2         17 for ( my $i = 1; $i < @{ $self->lines }; $i++ ) {
  4         27  
113 3 50 66     33 if ( $self->lines->[$i] =~ /^%:/
      66        
114 2         25 and $i + 1 < @{ $self->lines }
115             and $self->lines->[ $i + 1 ] =~ /^\tdh .*\$\@/ )
116             {
117 2         45 $self->_is_dhtiny(1);
118              
119 2 100       19 if ( $self->lines->[ $i + 1 ] =~ /--with[ =]quilt/ ) {
120 1         11 $self->_is_quiltified(1);
121 1         8 last;
122             }
123             }
124             }
125              
126 2         14 $self->_parsed(1);
127             }
128              
129             =item is_dhtiny
130              
131             Returns true if the contents of the rules file seem to use the so called
132             I variant offered by L. Tiny rules are detected by the
133             presence of the following two lines:
134              
135             %:
136             dh $@
137              
138             (any options on the C command line ignored).
139              
140             =cut
141              
142             sub is_dhtiny {
143 2     2 1 841 my $self = shift;
144              
145 2 50       7 $self->parse unless $self->_parsed;
146              
147 2         17 return $self->_is_dhtiny;
148             }
149              
150             =item is_quiltified
151              
152             Returns true if the contents of the rules file indicate that L is
153             used. Various styles of C integration are detected:
154              
155             =over
156              
157             =item dh --with=quilt
158              
159             =item F with C<< $(QUILT_STAMPFN) >> and C targets.
160              
161             =back
162              
163             =cut
164              
165             sub is_quiltified {
166 1     1 1 358 my $self = shift;
167              
168 1 50       4 $self->parse unless $self->_parsed;
169              
170 1         12 return $self->_is_quiltified;
171             }
172              
173             =item add_quilt
174              
175             Integrates L into the rules. For L I rules (as
176             determined by L) C<--with=quilt> is added to every C
177             invocation. For the more traditional variant, quilt is integrated via
178             F and its C<< $(QUILT_STAMPFN) >> and C targets.
179              
180             =cut
181              
182             sub add_quilt {
183 0     0 1 0 my $self = shift;
184              
185 0 0       0 return if $self->is_quiltified;
186              
187 0         0 my $lines = $self->lines;
188              
189 0 0       0 if ( $self->is_dhtiny) {
190 0         0 for (@$lines) {
191              
192             # add --with=quilt to every dh call
193 0 0       0 s/(?<=\s)dh /dh --with=quilt /
194             unless /--with[= ]quilt/; # unless it is already there
195             }
196             }
197             else {
198              
199             # non-dhtiny
200 0 0       0 splice @$lines, 1, 0,
201             ( '', 'include /usr/share/quilt/quilt.make' )
202             unless grep /quilt\.make/, @$lines;
203              
204 0 0       0 push @$lines,
205             '',
206             'override_dh_auto_configure: $(QUILT_STAMPFN)',
207             "\tdh_auto_configure"
208             unless grep /QUILT_STAMPFN/, @$lines;
209              
210 0 0       0 push @$lines, '', 'override_dh_auto_clean: unpatch',
211             "\tdh_auto_clean"
212             unless grep /override_dh_auto_clean:.*unpatch/, @$lines;
213             }
214             }
215              
216             =item drop_quilt
217              
218             Removes L integration. Both L I style (C
219             --with=quilt>) and traditional (C<< $(QUILT_STAMPFN) >> and C)
220             approaches are detected and removed.
221              
222             =cut
223              
224             sub drop_quilt {
225 2     2 1 365 my $self = shift;
226              
227 2         5 my $lines = $self->lines;
228              
229             # look for the quilt include line and remove it and the previous empty one
230 2         21 for ( my $i = 1; $i < @$lines; $i++ ) {
231 8 50       25 if ( $lines->[$i] eq 'include /usr/share/quilt/quilt.make' ) {
232 0         0 splice @$lines, $i, 1;
233              
234             # collapse two sequencial empty lines
235             # NOTE: this won't work if the include statement was the last line
236             # in the rules, but this is highly unlikely
237 0 0 0     0 splice( @$lines, $i, 1 )
      0        
238             if $i < @$lines
239             and $lines->[$i] eq ''
240             and $lines->[ $i - 1 ] eq '';
241              
242 0         0 last;
243             }
244             }
245              
246             # remove the QUILT_STAMPFN dependency override
247 2         6 for ( my $i = 1; $i < @$lines; $i++ ) {
248 8 0 33     28 if ( $lines->[$i] eq ''
      33        
      0        
249             and $lines->[ $i + 1 ] eq
250             'override_dh_auto_configure: $(QUILT_STAMPFN)'
251             and $lines->[ $i + 2 ] eq "\tdh_auto_configure"
252             and $lines->[ $i + 3 ] eq '' )
253             {
254 0         0 splice @$lines, $i, 3;
255 0         0 last;
256             }
257             }
258              
259             # also remove $(QUILT_STAMPFN) as a target dependency
260             # note that the override_dh_auto_configure is handled above because in that
261             # case the whole makefile snipped is to be removed
262             # Here we deal with the more generic cases
263 2         7 for ( my $i = 1; $i < @$lines; $i++ ) {
264 8         20 $lines->[$i] =~ s{
265             ^ # at the beginning of the line
266             ([^\s:]+): # target name, followed by a colon
267             (.*) # any other dependencies
268             \$\(QUILT_STAMPFN\) # followed by $(QUILT_STAMPFN)
269             }{$1:$2}x;
270             }
271              
272             # remove unpatch dependency in clean
273 2         16 for ( my $i = 1; $i < @$lines; $i++ ) {
274 8 0 33     49 if ( $lines->[$i] eq 'override_dh_auto_clean: unpatch'
      0        
      33        
275             and $lines->[ $i + 1 ] eq "\tdh_auto_clean"
276             and ( $i + 2 > $#$lines or $lines->[ $i + 2 ] !~ /^\t/ ) )
277             {
278 0         0 splice @$lines, $i, 2;
279              
280             # At this point there may be an extra empty line left.
281             # Remove an empty line after the removed target
282             # Or any trailing empty line (if the target was at EOF)
283 0 0       0 if ( $i > $#$lines ) {
    0          
284 0 0       0 $#$lines-- if $lines->[-1] eq ''; # trim trailing empty line
285             }
286             elsif ( $lines->[$i] eq '' ) {
287 0         0 splice( @$lines, $i, 1 );
288             }
289              
290 0         0 last;
291             }
292             }
293              
294             # similarly to the $(QUILT_STAMPFN) stripping, here we process a general
295             # ependency on the 'unpatch' rule
296 2         6 for ( my $i = 1; $i < @$lines; $i++ ) {
297 8         16 $lines->[$i] =~ s{
298             ^ # at the beginning of the line
299             ([^\s:]+): # target name, followed by a colon
300             (.*) # any other dependencies
301             unpatch # followed by 'unpatch'
302             }{$1:$2}x;
303             }
304              
305             # drop --with=quilt from dh command line
306 2         4 for (@$lines) {
307 10         34 while ( /dh (.*)--with[= ]quilt(.*)\n/ ) {
308 2         6 my ( $before, $after ) = ( $1, $2 );
309 2         4 $after =~ s/\s+$//; # remove trailing spaces
310 2 100       15 $after =~ s/^\s+// if $before =~ /\s$/; # collapse adjascent spaces
311 2 100       23 $before =~ s/\s+$// if $after eq ''; # more trailing spaces
312 2 100       11 $after =~ s/^\s+// if $before eq ''; # extra leading space
313 2         18 s/dh (.*)--with[= ]quilt(.*)\n/dh $before$after\n/;
314             }
315             }
316             }
317              
318             =item read [I]
319              
320             Replaces the current rules content with the content of I. If
321             I is not given, uses the value of the L member.
322              
323             =cut
324              
325             sub read {
326 0     0 1 0 my $self = shift;
327 0   0     0 my $filename = shift // $self->filename;
328              
329 0 0       0 defined($filename) or die "No filename given to read() nor new()";
330              
331 0         0 @{ $self->lines } = ();
  0         0  
332 0         0 $self->_parsed(0);
333              
334 0 0       0 return unless -e $filename;
335              
336 0         0 my $fh;
337 0 0       0 open( $fh, '<', $filename ) or die "open($filename): $!";
338 0         0 while( defined( $_ = <$fh> ) ) {
339 0         0 push @{ $self->lines }, $_;
  0         0  
340             }
341 0         0 close $fh;
342             }
343              
344             =item write [I]
345              
346             Writes the in-memory contents I. If not given, uses the value of the
347             L member.
348              
349             If L points to an empty array, the file is removed.
350              
351             =cut
352              
353             sub write {
354 0     0 1 0 my $self = shift;
355 0   0     0 my $filename = shift // $self->filename;
356              
357 0 0       0 defined($filename) or die "No filename given to write() nor new()";
358              
359 0 0       0 if ( @{ $self->lines } ) {
  0         0  
360 0 0       0 open my $fh, '>', $filename
361             or die "Error opening '$filename': $!";
362              
363 0         0 print $fh $_ for @{ $self->lines };
  0         0  
364              
365 0         0 close $fh;
366             }
367             else {
368 0 0       0 unlink $filename or die "unlink($filename): $!";
369             }
370             }
371              
372             sub DESTROY {
373 3     3   453 my $self = shift;
374              
375 3 50       9 $self->write if $self->filename;
376              
377 3         75 bless $self, 'Class::Accessor'; # chain destruction
378             }
379              
380             =back
381              
382             =head1 COPYRIGHT & LICENSE
383              
384             =over
385              
386             =item Copyright (C) 2009, 2010 Damyan Ivanov
387              
388             =item Copyright (C) 2014 gregor herrmann
389              
390             =back
391              
392             This program is free software; you can redistribute it and/or modify it under
393             the terms of the GNU General Public License version 2 as published by the Free
394             Software Foundation.
395              
396             This program is distributed in the hope that it will be useful, but WITHOUT ANY
397             WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
398             PARTICULAR PURPOSE. See the GNU General Public License for more details.
399              
400             You should have received a copy of the GNU General Public License along with
401             this program; if not, write to the Free Software Foundation, Inc., 51 Franklin
402             Street, Fifth Floor, Boston, MA 02110-1301 USA.
403              
404             =cut
405              
406             1;