File Coverage

blib/lib/Parse/Deb/Control.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             package Parse::Deb::Control;
2              
3             =head1 NAME
4              
5             Parse::Deb::Control - parse and manipulate F in a controlable way
6              
7             =head1 SYNOPSIS
8              
9             Print out all "Package:" values lines
10              
11             use Parse::Deb::Control;
12              
13             my $parser = Parse::Deb::Control->new($control_txt);
14             my $parser = Parse::Deb::Control->new(['path', 'to', 'debian', 'control']);
15             my $parser = Parse::Deb::Control->new($fh);
16            
17             foreach my $para ($parser->get_paras('Package')) {
18             print $para->{'Package'}, "\n";
19             }
20              
21             or
22              
23             foreach my $entry ($parser->get_keys('Package')) {
24             print ${$entry->{'value'}}, "\n";
25             }
26              
27             Modify "Maintainer:"
28              
29             my $mantainer = 'someone@new';
30              
31             my $parser = Parse::Deb::Control->new($control_txt);
32             foreach my $para ($parser->get_paras(qw{ Maintainer })) {
33             $para->{'Maintainer'} =~ s/^ (\s*) (\S.*) $/ $maintainer\n/xms;
34             }
35              
36             or
37            
38             my $parser = Parse::Deb::Control->new($control_txt);
39             foreach my $src_pkg ($parser->get_keys(qw{ Maintainer })) {
40             ${$src_pkg->{'value'}} =~ s/^ (\s*) (\S.*) $/ $maintainer\n/xms;
41             }
42              
43             and
44              
45             print $parser->control;
46              
47             =head1 DESCRIPTION
48              
49             This modules helps to automate changes in F file. It
50             tries hard to preserve the original structure so that diff on input and
51             output can be made and it will be clear what was changed. There are 2 checks.
52             First when original F file processed it is generated
53             back and compared to the original. The program dies if those two doesn't
54             match. After making changes and creating new file. The result is parsed
55             again and the same check is applied to make sure the file will be still
56             parseable.
57              
58             See also L for alternative.
59              
60             =cut
61              
62 1     1   84308 use warnings;
  1         2  
  1         33  
63 1     1   3 use strict;
  1         2  
  1         36  
64              
65             our $VERSION = '0.04';
66              
67 1     1   4 use base 'Class::Accessor::Fast';
  1         5  
  1         913  
68              
69 1     1   5098 use Storable 'dclone';
  1         3906  
  1         97  
70 1     1   919 use List::MoreUtils 'any';
  1         1161  
  1         234  
71 1     1   343 use IO::Any;
  0            
  0            
72             use Carp;
73              
74             =head1 PROPERTIES
75              
76             _control_src
77             structure
78              
79             =cut
80              
81             __PACKAGE__->mk_accessors(qw{
82             _control_src
83             structure
84             });
85              
86             =head1 METHODS
87              
88             =head2 new()
89              
90             Object constructor. Accepts anythign L->read() does to get
91             F from.
92              
93             =cut
94              
95             sub new {
96             my $class = shift;
97             my $what = shift || '';
98             my $self = $class->SUPER::new({});
99            
100             $self->_control_src(IO::Any->read($what));
101              
102             return $self;
103             }
104              
105             =head2 content()
106              
107             Returns content of the F. The return value is an array
108             ref holding hashes representing control file paragraphs.
109              
110             =cut
111              
112             sub content {
113             my $self = shift;
114             my $content = $self->{'content'};
115              
116             return $content
117             if defined $content;
118            
119             my @structure = ();
120             my @content = ();
121             my $last_value = undef;
122             my $last_para = undef;
123             my $control_txt = '';
124            
125             my $line_number = 0;
126             my $control_src = $self->_control_src;
127             while (my $line = <$control_src>) {
128             $line_number++;
129             $control_txt .= $line;
130            
131             # if the line is empty it's the end of control paragraph
132             if ($line =~ /^\s*$/) {
133             $last_value = undef;
134             push @structure, $line;
135             if (defined $last_para) {
136             push @content, $last_para;
137             $last_para = undef;
138             }
139             next;
140             }
141            
142             # line starting with white space
143             if ($line =~ /^\s/) {
144             die 'not previous value to append "'.$line.'" to (line '.$line_number.')'
145             if not defined $last_value;
146             ${$last_value} .= $line;
147             next;
148             }
149            
150             # line starting with # are comments
151             if ($line =~ /^#/) {
152             push @structure, $line;
153             next;
154             }
155            
156             # other should be key/value lines
157             if ($line =~ /^([^:]+):(.*$)/xms) {
158             my ($key, $value) = ($1, $2);
159             push @structure, $key;
160             $last_para->{$key} = $value;
161             $last_value = \($last_para->{$key});
162             next;
163             }
164            
165             croak 'unrecognized format "'.$line.'" (line '.$line_number.')';
166             }
167             push @content, $last_para
168             if defined $last_para;
169            
170             $self->{'content'} = \@content;
171             $self->structure(\@structure);
172              
173             # for debugging
174             # use File::Slurp 'write_file';
175             # write_file('xxx1', $control_txt);
176             # write_file('xxx2', $self->control);
177            
178             croak 'control reconstruction failed, send your "control" file attached to bug report :-)'
179             if $control_txt ne $self->_control;
180            
181             return \@content;
182             }
183              
184              
185             =head2 control
186              
187             Returns text representation of a F constructed from
188             C<<$self->content>> and C<<$self->structure>>.
189              
190             =cut
191              
192             sub control {
193             my $self = shift;
194            
195             my $control_txt = $self->_control;
196            
197             # run through parser again to test if future parsing will be successful
198             eval {
199             my $parser = Parse::Deb::Control->new($control_txt)->content;
200             };
201             if ($@) {
202             die 'generating and parsing back failed ("'.$@.'"), this is probably a bug. attach your control file and manipulations you did to the bug report :)'
203             }
204            
205             return $control_txt;
206             }
207              
208             sub _control {
209             my $self = shift;
210            
211             my $control_txt = '';
212             my @content = @{$self->content};
213             return $control_txt
214             if not @content;
215            
216             my %cur_para = %{shift @content};
217            
218             # loop through the control file structure
219             foreach my $structure_key (@{$self->structure}) {
220             # just add comment lines
221             if ($structure_key =~ /^#/) {
222             $control_txt .= $structure_key;
223             next;
224             }
225            
226             if ($structure_key =~ /^\s*$/) {
227             # loop throug new keys and add them
228             foreach my $key (sort keys %cur_para) {
229             $control_txt .= $key.':'.(delete $cur_para{$key});
230             }
231            
232             # add the space
233             $control_txt .= $structure_key;
234            
235             %cur_para = ();
236             next;
237             }
238            
239             # get next paragraph if empty
240             %cur_para = %{shift @content}
241             if not %cur_para;
242            
243             my $value = delete $cur_para{$structure_key};
244             $control_txt .= $structure_key.':'.$value
245             if $value;
246             }
247             # loop throug new keys and add them
248             foreach my $key (sort keys %cur_para) {
249             $control_txt .= $key.':'.(delete $cur_para{$key});
250             }
251            
252             return $control_txt;
253             }
254              
255             =head2 get_keys
256              
257             Parameters are the requested keys from F. Returns array
258             of key/values of matching keys. Ex.
259              
260             {
261             'key' => 'Package',
262             'value' => \"perl",
263             'para' => { ... one item from $self->content array ... },
264             }
265              
266             Note that value is a pointer to scalar value so that it can be easyly
267             modified if needed.
268              
269             =cut
270              
271             sub get_keys {
272             my $self = shift;
273             my @wanted = @_;
274            
275             my @content = @{$self->content};
276              
277             my @wanted_keys;
278             foreach my $para (@content) {
279             foreach my $key (keys %{$para}) {
280             if (any { $_ eq $key } @wanted) {
281             push @wanted_keys, {
282             'key' => $key,
283             'value' => \$para->{$key},
284             'para' => $para,
285             };
286             }
287             }
288             }
289            
290             return @wanted_keys;
291             }
292              
293             =head2 get_paras
294              
295             Returns a paragraphs that has key(s) passed as argument.
296              
297             =cut
298              
299             sub get_paras {
300             my $self = shift;
301             my @wanted = @_;
302            
303             my @keys = $self->get_keys(@wanted);
304             return
305             map { $_->{'para'} }
306             @keys
307             ;
308             }
309              
310             1;
311              
312              
313             __END__