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