]> git.deb.at Git - deb/packages.git/blob - lib/Parse/DebControl.pm
Packages::Dispatcher: Don't issue bogus 406 errors for index
[deb/packages.git] / lib / Parse / DebControl.pm
1 package Parse::DebControl;
2
3 ###########################################################
4 #       Parse::DebControl - Parse debian-style control
5 #               files (and other colon key-value fields)
6 #
7 #       Copyright 2003 - Jay Bonci <jaybonci@cpan.org>
8 #       Licensed under the same terms as perl itself
9 #
10 ###########################################################
11
12 use strict;
13 use IO::Scalar;
14
15 use vars qw($VERSION);
16 $VERSION = '1.8';
17
18 sub new {
19         my ($class, $debug) = @_;
20         my $this = {};
21
22         my $obj = bless $this, $class;
23         if($debug)
24         {
25                 $obj->DEBUG();
26         }
27         return $obj;
28 };
29
30 sub parse_file {
31         my ($this, $filename, $options) = @_;
32         unless($filename)
33         {
34                 $this->_dowarn("parse_file failed because no filename parameter was given");
35                 return;
36         }       
37
38         my $fh;
39         unless(open($fh,"$filename"))
40         {
41                 $this->_dowarn("parse_file failed because $filename could not be opened for reading");
42                 return;
43         }
44         
45         return $this->_parseDataHandle($fh, $options);
46 };
47
48 sub parse_mem {
49         my ($this, $data, $options) = @_;
50
51         unless($data)
52         {
53                 $this->_dowarn("parse_mem failed because no data was given");
54                 return;
55         }
56
57         my $IOS = new IO::Scalar \$data;
58
59         unless($IOS)
60         {
61                 $this->_dowarn("parse_mem failed because IO::Scalar creation failed.");
62                 return;
63         }
64
65         return $this->_parseDataHandle($IOS, $options);
66
67 };
68
69 sub write_file {
70         my ($this, $filenameorhandle, $dataorarrayref, $options) = @_;
71
72         unless($filenameorhandle)
73         {
74                 $this->_dowarn("write_file failed because no filename or filehandle was given");
75                 return;
76         }
77
78         unless($dataorarrayref)
79         {
80                 $this->_dowarn("write_file failed because no data was given");
81                 return;
82         }
83
84         my $handle = $this->_getValidHandle($filenameorhandle, $options);
85
86         unless($handle)
87         {
88                 $this->_dowarn("write_file failed because we couldn't negotiate a valid handle");
89                 return;
90         }
91
92         my $arrayref = $this->_makeArrayref($dataorarrayref);
93
94         my $string = $this->_makeControl($arrayref);
95         $string ||= "";
96         
97         print $handle $string;
98         close $handle;
99
100         return length($string);
101 }
102
103 sub write_mem {
104         my ($this, $dataorarrayref, $options) = @_;
105
106         unless($dataorarrayref)
107         {
108                 $this->_dowarn("write_mem failed because no data was given");
109                 return;
110         }
111
112         my $arrayref = $this->_makeArrayref($dataorarrayref);
113
114         my $string = $this->_makeControl($arrayref);
115
116         return $string;
117 }
118
119 sub DEBUG
120 {
121         my($this, $verbose) = @_;
122         $verbose = 1 unless(defined($verbose) and int($verbose) == 0);
123         $this->{_verbose} = $verbose;
124         return;
125
126 }
127
128 sub _getValidHandle {
129         my($this, $filenameorhandle, $options) = @_;
130
131         if(ref $filenameorhandle eq "GLOB")
132         {
133                 unless($filenameorhandle->opened())
134                 {
135                         $this->_dowarn("Can't get a valid filehandle to write to, because that is closed");
136                         return;
137                 }
138
139                 return $filenameorhandle;
140         }else
141         {
142                 my $openmode = ">>";
143                 $openmode=">" if $options->{clobberFile};
144                 $openmode=">>" if $options->{appendFile};
145
146                 my $handle;
147
148                 unless(open $handle,"$openmode$filenameorhandle")
149                 {
150                         $this->_dowarn("Couldn't open file: $openmode$filenameorhandle for writing");
151                         return;
152                 }
153
154                 return $handle;
155         }
156 }
157
158 sub _makeArrayref {
159         my ($this, $dataorarrayref) = @_;
160
161         if(ref $dataorarrayref eq "ARRAY")
162         {
163                 return $dataorarrayref;
164         }else{
165                 return [$dataorarrayref];
166         }
167 }
168
169 sub _makeControl
170 {
171         my ($this, $dataorarrayref) = @_;
172         
173         my $str;
174
175         foreach my $stanza(@$dataorarrayref)
176         {
177                 foreach my $key(keys %$stanza)
178                 {
179                         $stanza->{$key} ||= "";
180
181                         my @lines = split("\n", $stanza->{$key});
182                         if (@lines) {
183                                 $str.="$key\: ".(shift @lines)."\n";
184                         } else {
185                                 $str.="$key\:\n";
186                         }
187
188                         foreach(@lines)
189                         {
190                                 if($_ eq "")
191                                 {
192                                         $str.=" .\n";
193                                 }
194                                 else{
195                                         $str.=" $_\n";
196                                 }
197                         }
198
199                 }
200
201                 $str ||= "";
202                 $str.="\n";
203         }
204
205         chomp($str);
206         return $str;
207         
208 }
209
210 sub _parseDataHandle
211 {
212         my ($this, $handle, $options) = @_;
213
214         my $structs;
215
216         unless($handle)
217         {
218                 $this->_dowarn("_parseDataHandle failed because no handle was given. This is likely a bug in the module");
219                 return;
220         }
221
222         my $data = $this->_getReadyHash($options);
223
224         my $linenum = 0;
225         my $lastfield = "";
226
227         foreach my $line (<$handle>)
228         {
229                 #Sometimes with IO::Scalar, lines may have a newline at the end
230                 chomp $line;
231
232                 if($options->{stripComments}){
233                         next if $line =~ /^\s*\#/;
234                         $line =~ s/\#.*// 
235                 }
236
237                 $linenum++;
238                 if($line =~ /^[^\t\s]/)
239                 {
240                         #we have a valid key-value pair
241                         if($line =~ /(.*?)\s*\:\s*(.*)$/)
242                         {
243                                 my $key = $1;
244                                 my $value = $2;
245
246                                 if($options->{discardCase})
247                                 {
248                                         $key = lc($key);
249                                 }
250
251                                 unless($options->{verbMultiLine})
252                                 {
253                                         $value =~ s/[\s\t]+$//;
254                                 }
255
256                                 $data->{$key} = $value;
257
258
259                                 if ($options->{verbMultiLine} 
260                                         && (($data->{$lastfield} || "") =~ /\n/o)){
261                                         $data->{$lastfield} .= "\n";
262                                 }
263
264                                 $lastfield = $key;
265                         }else{
266                                 $this->_dowarn("Parse error on line $linenum of data; invalid key/value stanza");
267                                 return $structs;
268                         }
269
270                 }elsif($line =~ /^([\t\s])(.*)/)
271                 {
272                         #appends to previous line
273
274                         unless($lastfield)
275                         {
276                                 $this->_dowarn("Parse error on line $linenum of data; indented entry without previous line");
277                                 return $structs;
278                         }
279                         if($options->{verbMultiLine}){
280                                 $data->{$lastfield}.="\n$1$2";
281                         }elsif($2 eq "." ){
282                                 $data->{$lastfield}.="\n";
283                         }else{
284                                 my $val = $2;
285                                 $val =~ s/[\s\t]+$//;
286                                 $data->{$lastfield}.="\n$val";
287                         }
288
289                 }elsif($line =~ /^[\s\t]*$/){
290                         if ($options->{verbMultiLine} 
291                             && ($data->{$lastfield} =~ /\n/o)) {
292                             $data->{$lastfield} .= "\n";
293                         }
294                         if(keys %$data > 0){
295                                 push @$structs, $data;
296                         }
297                         $data = $this->_getReadyHash($options);
298                         $lastfield = "";
299                 }else{
300                         $this->_dowarn("Parse error on line $linenum of data; unidentified line structure");
301                         return $structs;
302                 }
303
304         }
305
306         if(keys %$data > 0)
307         {
308                 push @$structs, $data;
309         }
310
311         return $structs;
312 }
313
314 sub _getReadyHash
315 {
316         my ($this, $options) = @_;
317         my $data;
318
319         if($options->{useTieIxHash})
320         {
321                 eval("use Tie::IxHash");
322                 if($@)
323                 {
324                         $this->_dowarn("Can't use Tie::IxHash. You need to install it to have this functionality");
325                         return;
326                 }
327                 tie(%$data, "Tie::IxHash");
328                 return $data;
329         }
330
331         return {};
332 }
333
334 sub _dowarn
335 {
336         my ($this, $warning) = @_;
337
338         if($this->{_verbose})
339         {
340                 warn "DEBUG: $warning";
341         }
342
343         return;
344 }
345
346
347 1;
348
349 __END__
350
351 =head1 NAME
352
353 Parse::DebControl - Easy OO parsing of debian control-like files
354
355 =head1 SYNOPSIS
356
357         use Parse::DebControl
358
359         $parser = new Parse::DebControl;
360
361         $data = $parser->parse_mem($control_data, %options);
362         $data = $parser->parse_file('./debian/control', %options);
363
364         $writer = new Parse::DebControl;
365
366         $string = $writer->write_mem($singlestanza);
367         $string = $writer->write_mem([$stanza1, $stanza2]);
368
369         $writer->write_file($filename, $singlestanza, %options);
370         $writer->write_file($filename, [$stanza1, $stanza2], %options);
371
372         $writer->write_file($handle, $singlestanza, %options);
373         $writer->write_file($handle, [$stanza1, $stanza2], %options);
374
375         $parser->DEBUG();
376
377 =head1 DESCRIPTION
378
379         Parse::DebControl is an easy OO way to parse debian control files and 
380         other colon separated key-value pairs. It's specifically designed
381         to handle the format used in Debian control files, template files, and
382         the cache files used by dpkg.
383
384         For basic format information see:
385         http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-controlsyntax
386
387         This module does not actually do any intelligence with the file content
388         (because there are a lot of files in this format), but merely handles
389         the format. It can handle simple control files, or files hundreds of lines 
390         long efficiently and easily.
391
392 =head2 Class Methods
393
394 =over 4
395
396 =item * C<new()>
397
398 =item * C<new(I<$debug>)>
399
400 Returns a new Parse::DebControl object. If a true parameter I<$debug> is 
401 passed in, it turns on debugging, similar to a call to C<DEBUG()> (see below);
402
403 =back
404
405 =over 4
406
407 =item * C<parse_file($control_filename,I<%options>)>
408
409 Takes a filename as a scalar. Will parse as much as it can, 
410 warning (if C<DEBUG>ing is turned on) on parsing errors. 
411
412 Returns an array of hashes, containing the data in the control file, split up
413 by stanza.  Stanzas are deliniated by newlines, and multi-line fields are
414 expressed as such post-parsing.  Single periods are treated as special extra
415 newline deliniators, per convention.  Whitespace is also stripped off of lines
416 as to make it less-easy to make mistakes with hand-written conf files).
417
418 The options hash can take parameters as follows. Setting the string to true
419 enables the option.
420
421         useTieIxHash - Instead of an array of regular hashes, uses Tie::IxHash-
422                 based hashes
423         discardCase  - Remove all case items from keys (not values)             
424         stripComments - Remove all commented lines in standard #comment format
425         verbMultiLine - Keep the description AS IS, and no not collapse leading
426                 spaces or dots as newlines. This also keeps whitespace from being
427                 stripped off the end of lines.
428
429 =back
430
431 =over 4
432
433 =item * C<parse_mem($control_data, I<%options>)>
434
435 Similar to C<parse_file>, except takes data as a scalar. Returns the same
436 array of hashrefs as C<parse_file>. The options hash is the same as 
437 C<parse_file> as well; see above.
438
439 =back
440
441 =over 4
442
443 =item * C<write_file($filename, $data, I<%options>)>
444
445 =item * C<write_file($handle, $data>
446
447 =item * C<write_file($filename, [$data1, $data2, $data3], I<%options>)>
448
449 =item * C<write_file($handle, [$data, $data2, $data3])>
450
451 This function takes a filename or a handle and writes the data out.  The 
452 data can be given as a single hash(ref) or as an arrayref of hash(ref)s. It
453 will then write it out in a format that it can parse. The order is dependant
454 on your hash sorting order. If you care, use Tie::IxHash.  Remember for 
455 reading back in, the module doesn't care.
456
457 The I<%options> hash can contain one of the following two items:
458
459         appendFile  - (default) Write to the end of the file
460         clobberFile - Overwrite the file given.
461
462 Since you determine the mode of your filehandle, passing it an options hash
463 obviously won't do anything; rather, it is ignored.
464
465 This function returns the number of bytes written to the file, undef 
466 otherwise.
467
468 =back
469
470 =over 4
471
472 =item * C<write_mem($data)>
473
474 =item * C<write_mem([$data1,$data2,$data3])>;
475
476 This function works similarly to the C<write_file> method, except it returns
477 the control structure as a scalar, instead of writing it to a file.  There
478 is no I<%options> for this file (yet);
479
480 =back
481
482 =over 4
483
484 =item * C<DEBUG()>
485
486 Turns on debugging. Calling it with no paramater or a true parameter turns
487 on verbose C<warn()>ings.  Calling it with a false parameter turns it off.
488 It is useful for nailing down any format or internal problems.
489
490 =back
491
492 =head1 CHANGES
493
494 B<Version 1.7> - July 11th, 2003
495
496 =over 4
497
498 =item * By default, we now strip off whitespace unless verbMultiLine is in place.  This makes sense for things like conf files where trailing whitespace has no meaning. Thanks to pudge for reporting this.
499
500 =back
501
502 B<Version 1.7> - June 25th, 2003
503
504 =over 4
505
506 =item * POD documentation error noticed again by Frank Lichtenheld
507
508 =item * Also by Frank, applied a patch to add a "verbMultiLine" option so that we can hand multiline fields back unparsed.
509
510 =item * Slightly expanded test suite to cover new features
511
512 =back
513
514 B<Version 1.6.1> - June 9th, 2003
515
516 =over 4
517
518 =item * POD cleanups noticed by Frank Lichtenheld. Thank you, Frank.
519
520 =back
521
522 B<Version 1.6> - June 2nd, 2003
523
524 =over 4
525
526 =item * Cleaned up some warnings when you pass in empty hashrefs or arrayrefs
527
528 =item * Added stripComments setting
529
530 =item * Cleaned up POD errors
531
532 =back
533
534 B<Version 1.5> - May 8th, 2003
535
536 =over 4
537
538 =item * Added a line to quash errors with undef hashkeys and writing
539
540 =item * Fixed the Makefile.PL to straighten up DebControl.pm being in the wrong dir
541
542 =back
543
544 B<Version 1.4> - April 30th, 2003
545
546 =over 4
547
548 =item * Removed exports as they were unnecessary. Many thanks to pudge, who pointed this out.
549
550 =back
551
552 B<Version 1.3> - April 28th, 2003
553
554 =over 4
555
556 =item * Fixed a bug where writing blank stanzas would throw a warning.  Fix found and supplied by Nate Oostendorp.
557
558 =back
559
560 B<Version 1.2b> - April 25th, 2003
561
562 Fixed:
563
564 =over 4
565
566 =item * A bug in the test suite where IxHash was not disabled in 40write.t. Thanks to Jeroen Latour from cpan-testers for the report.
567
568 =back
569
570 B<Version 1.2> - April 24th, 2003
571
572 Fixed:
573
574 =over 4
575
576 =item * A bug in IxHash support where multiple stanzas might be out of order
577
578 =back
579
580 B<Version 1.1> - April 23rd, 2003
581
582 Added:
583
584 =over 4
585
586 =item * Writing support
587
588 =item * Tie::IxHash support
589
590 =item * Case insensitive reading support
591
592 =back
593
594 * B<Version 1.0> - April 23rd, 2003
595
596 =over 4
597
598 =item * This is the initial public release for CPAN, so everything is new.
599
600 =back
601
602 =head1 BUGS
603
604 The module will let you parse otherwise illegal key-value pairs and pairs with spaces. Badly formed stanzas will do things like overwrite duplicate keys, etc.  This is your problem.
605
606 =head1 TODO
607
608 Change the name over to the Debian:: namespace, probably as Debian::ControlFormat.  This will happen as soon as the project that uses this module reaches stability, and we can do some minor tweaks.
609
610 =head1 COPYRIGHT
611
612 Parse::DebControl is copyright 2003 Jay Bonci E<lt>jaybonci@cpan.orgE<gt>.
613 This program is free software; you can redistribute it and/or modify it under
614 the same terms as Perl itself.
615
616 =cut