File Coverage

blib/lib/Debian/Control/Stanza.pm
Criterion Covered Total %
statement 16 18 88.8
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 22 24 91.6


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Debian::Control::Stanza - single stanza of Debian source package control file
4              
5             =head1 SYNOPSIS
6              
7             package Binary;
8             use base 'Debian::Control::Stanza';
9             use constant fields => qw( Package Depends Conflicts );
10              
11             1;
12              
13             =head1 DESCRIPTION
14              
15             Debian::Control::Stanza ins the base class for
16             L and L
17             classes.
18              
19             =cut
20              
21             package Debian::Control::Stanza;
22              
23             require v5.10.0;
24              
25 7     7   33728541 use strict;
  7         19  
  7         262  
26 7     7   41 use warnings;
  7         14  
  7         492  
27              
28             our $VERSION = '0.71';
29              
30 7     7   123 use base qw( Class::Accessor Tie::IxHash );
  7         19  
  7         7622  
31              
32 7     7   65594 use Carp qw(croak);
  7         25  
  7         329  
33 7     7   4097 use Debian::Control::Stanza::CommaSeparated;
  7         23  
  7         111  
34 7     7   4095 use Debian::Dependencies;
  0            
  0            
35              
36             =head1 FIELDS
37              
38             Stanza fields are to be defined in the class method I. Typically this
39             can be done like:
40              
41             use constant fields => qw( Foo Bar Baz );
42              
43             Fields that are to contain dependency lists (as per L
44             method below) are automatically converted to instances of the
45             L class.
46              
47             =cut
48              
49             use constant fields => ();
50              
51             sub import {
52             my( $class ) = @_;
53              
54             $class->mk_accessors( $class->fields );
55             }
56              
57             use overload '""' => \&as_string;
58              
59             =head1 CONSTRUCTOR
60              
61             =over
62              
63             =item new
64              
65             =item new( { field => value, ... } )
66              
67             Creates a new L object and optionally initializes it
68             with the supplied data. The object is hashref based and tied to L.
69              
70             You may use dashes for initial field names, but these will be converted to
71             underscores:
72              
73             my $s = Debian::Control::Stanza::Source( {Build-Depends => "perl"} );
74             print $s->Build_Depends;
75              
76             =back
77              
78             =cut
79              
80             sub new {
81             my $class = shift;
82             my $init = shift || {};
83              
84             my $self = Tie::IxHash->new;
85              
86             bless $self, $class;
87              
88             while( my($k,$v) = each %$init ) {
89             $k =~ s/-/_/g;
90             $self->can($k)
91             or croak "Invalid field given ($k)";
92             $self->$k($v);
93             }
94              
95             # initialize any dependency lists with empty placeholders
96             # same for comma-separated lists
97             for( $self->fields ) {
98             if ( $self->is_dependency_list($_) and not $self->$_ ) {
99             $self->$_( Debian::Dependencies->new );
100             }
101             elsif ( $self->is_comma_separated($_) and not $self->$_ ) {
102             $self->$_( Debian::Control::Stanza::CommaSeparated->new );
103             }
104             }
105              
106              
107             return $self;
108             }
109              
110             =head1 METHODS
111              
112             =over
113              
114             =item is_dependency_list($field)
115              
116             Returns true if I<$field> contains a list of dependencies. By default returns true for the following fields:
117              
118             =over
119              
120             =item Build_Depends
121              
122             =item Build_Depends_Indep
123              
124             =item Build_Conflicts
125              
126             =item Build_Conflicts_Indep
127              
128             =item Depends
129              
130             =item Conflicts
131              
132             =item Enhances
133              
134             =item Replaces
135              
136             =item Breaks
137              
138             =item Pre_Depends
139              
140             =item Recommends
141              
142             =item Suggests
143              
144             =back
145              
146             =cut
147              
148             our %dependency_list = map(
149             ( $_ => 1 ),
150             qw( Build-Depends Build-Depends-Indep Build-Conflicts Build-Conflicts-Indep
151             Depends Conflicts Enhances Replaces Breaks Pre-Depends Recommends Suggests ),
152             );
153              
154             sub is_dependency_list {
155             my( $self, $field ) = @_;
156              
157             $field =~ s/_/-/g;
158              
159             return exists $dependency_list{$field};
160             }
161              
162             =item is_comma_separated($field)
163              
164             Returns true if the given field is to contain a comma-separated list of values.
165             This is used in stringification, when considering where to wrap long lines.
166              
167             By default the following fields are flagged to contain such lists:
168              
169             =over
170              
171             =item All fields that contain dependencies (see above)
172              
173             =item Uploaders
174              
175             =item Provides
176              
177             =back
178              
179             =cut
180              
181             our %comma_separated = map(
182             ( $_ => 1 ),
183             keys %dependency_list,
184             qw( Uploaders Provides ),
185             );
186              
187             sub is_comma_separated {
188             my( $self, $field ) = @_;
189              
190             $field =~ s/_/-/g;
191              
192             return exists $comma_separated{$field};
193             }
194              
195             =item get($field)
196              
197             Overrides the default get method from L with L's
198             FETCH.
199              
200             =cut
201              
202             sub get {
203             my( $self, $field ) = @_;
204              
205             $field =~ s/_/-/g;
206              
207             return $self->FETCH($field);
208             }
209              
210             =item set( $field, $value )
211              
212             Overrides the default set method from L with L's
213             STORE. In the process, converts I<$value> to an instance of the
214             L class if I<$field> is to contain dependency list (as
215             determined by the L method).
216              
217             =cut
218              
219             sub set {
220             my( $self, $field, $value ) = @_;
221              
222             chomp($value);
223              
224             $field =~ s/_/-/g;
225              
226             $value = Debian::Dependencies->new($value)
227             if not ref($value) and $self->is_dependency_list($field);
228              
229             $value = Debian::Control::Stanza::CommaSeparated->new($value)
230             if not ref($value) and $self->is_comma_separated($field);
231              
232             return $self->STORE( $field, $value );
233             }
234              
235             =item as_string([$width])
236              
237             Returns a string representation of the object. Ready to be printed into a
238             real F file. Used as a stringification operator.
239              
240             Fields that are comma-separated use one line per item, except if they are like
241             C<${some:Field}>, in which case they are wrapped at I<$width>th column.
242             I<$width> defaults to 80.
243              
244             =cut
245              
246             use Text::Wrap ();
247              
248             sub as_string
249             {
250             my ( $self, $width ) = @_;
251             $width //= 80;
252              
253             my @lines;
254              
255             $self->Reorder( map{ ( my $s = $_ ) =~ s/_/-/g; $s } $self->fields );
256              
257             for my $k ( $self->Keys ) {
258             # We don't' want the internal fields showing in the output
259             next if $k =~ /^-/; # _ in field names is replaced with dashes
260             my $v = $self->FETCH($k);
261             next unless defined($v);
262             next if $self->is_dependency_list($k) and "$v" eq "";
263             next if $self->is_comma_separated($k) and "$v" eq "";
264              
265             my $line;
266              
267             if ( $self->is_comma_separated($k) ) {
268             # FIXME: this relies on $v being sorted
269             my ( @pre_dollar, @dollar, @post_dollar );
270             for ( @$v ) {
271             if ( /^\$\{.+}$/ ) {
272             push @dollar, $_;
273             }
274             elsif (@dollar) {
275             push @post_dollar, $_;
276             }
277             else {
278             push @pre_dollar, $_;
279             }
280             }
281              
282             if ( @pre_dollar ) {
283             $line = "$k: " . join( ",\n ", @pre_dollar );
284             local $Text::Warp::break = qr/, /;
285             local $Text::Warp::columns = $width;
286             local $Text::Wrap::separator = ",\n";
287             local $Text::Wrap::huge = 'overflow';
288             $line .= Text::Wrap::wrap( ' ', ' ', join( ', ', @dollar ) );
289             }
290             else {
291             local $Text::Warp::break = qr/, /;
292             local $Text::Warp::columns = $width;
293             local $Text::Wrap::separator = ",\n";
294             local $Text::Wrap::huge = 'overflow';
295             $line
296             = Text::Wrap::wrap( "$k: ", ' ', join( ', ', @dollar ) );
297             }
298              
299             $line = join( ",\n ", $line, @post_dollar );
300             }
301             else {
302             $line = "$k: $v";
303             }
304              
305             push @lines, $line if $line;
306             }
307              
308             return join( "\n", @lines ) . "\n";
309             }
310              
311             =back
312              
313             =head1 COPYRIGHT & LICENSE
314              
315             Copyright (C) 2009 Damyan Ivanov L
316              
317             This program is free software; you can redistribute it and/or modify it under
318             the terms of the GNU General Public License version 2 as published by the Free
319             Software Foundation.
320              
321             This program is distributed in the hope that it will be useful, but WITHOUT ANY
322             WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
323             PARTICULAR PURPOSE.
324              
325             =cut
326              
327             1;