From: Frank Lichtenheld Date: Wed, 1 Feb 2006 14:26:41 +0000 (+0000) Subject: Include some stuff from the old pages we will need anyway X-Git-Tag: switch-to-templates~227 X-Git-Url: https://git.deb.at/w?a=commitdiff_plain;h=08f111d6668d5278a64d304fbc3bae6be86e6a94;p=deb%2Fpackages.git Include some stuff from the old pages we will need anyway --- diff --git a/lib/Deb/Versions.pm b/lib/Deb/Versions.pm new file mode 100644 index 0000000..4e0d99b --- /dev/null +++ b/lib/Deb/Versions.pm @@ -0,0 +1,167 @@ +# +# Deb::Versions +# $Id$ +# +# Copyright 2003, 2004 Frank Lichtenheld +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# + +=head1 NAME + +Deb::Versions - compare Versions of Debian packages + +=head1 SYNOPSIS + + use Deb::Versions + + my $res = version_cmp( "1:0.2.2-2woody1", "1:0.2.3-7" ); + + my @sorted = version_sort( "1:0.2.2-2woody1", "1:0.2.3-7", "2:0.1.1" ); + +=head1 DESCRIPTION + +This module allows you to compare version numbers like defined +in the Debian policy, section 5.6.11 (L). + +It provides two functions: + +=over 4 + +=item * + +version_cmp() gets two version strings as parameters and returns +-1, if the first is lower than the second, 0 if equal, 1 if greater. +You can use this function as first parameter for the sort() function. + +=item * + +version_sort() is just an usefull abbrevation for + + sort { version_cmp( $b, $a ) } @_; + +=back + +=head1 EXPORTS + +By default, Deb::Versions exports version_cmp() and version_sort(). + +=cut + +package Deb::Versions; + +use strict; +use Exporter; + +our @ISA = qw( Exporter ); +our @EXPORT = qw( version_cmp version_sort ); + +our $VERSION = v1.0.0; + +sub version_cmp { + my ( $ver1, $ver2 ) = @_; + + my ( $e1, $e2, $u1, $u2, $d1, $d2 ); + my $re = qr/^(?:(\d+):)?([\w.+:~-]+?)(?:-([\w+.~]+))?$/; + if ( $ver1 =~ $re ) { + ( $e1, $u1, $d1 ) = ( $1, $2, $3 ); + $e1 ||= 0; + } else { + warn "This seems not to be a valid version number:" + . "<$ver1>\n"; + return -1; + } + if ( $ver2 =~ $re ) { + ( $e2, $u2, $d2 ) = ( $1, $2, $3 ); + $e2 ||= 0; + } else { + warn "This seems not to be a valid version number:" + . "<$ver2>\n"; + return 1; + } + +# warn "D: <$e1><$u1><$d1> <=> <$e2><$u2><$d2>\n"; + + my $res = ($e1 <=> $e2); + return $res if $res; + $res = _cmp_part ( $u1, $u2 ); + return $res if $res; + $res = _cmp_part ( $d1, $d2 ); + return $res; +} + +sub version_sort { + return sort { version_cmp( $b, $a ) } @_; +} + +sub _cmp_part { + my ( $v1, $v2 ) = @_; + my $r; + + while ( $v1 && $v2 ) { + $v1 =~ s/^(\D*)//o; + my $sp1 = $1; + $v2 =~ s/^(\D*)//o; + my $sp2 = $1; +# warn "$sp1 cmp $sp2 = "._lcmp( $sp1,$sp2)."\n"; + if ( $r = _lcmp( $sp1, $sp2 ) ) { + return $r; + } + $v1 =~ s/^(\d*)//o; + my $np1 = $1 || 0; + $v2 =~ s/^(\d*)//o; + my $np2 = $1 || 0; +# warn "$np1 <=> $np2 = ".($np1 <=> $np2)."\n"; + if ( $r = ($np1 <=> $np2) ) { + return $r; + } + } + if ( $v1 || $v2 ) { + return $v1 ? 1 : -1; + } + + return 0; +} + +sub _lcmp { + my ( $v1, $v2 ) = @_; + + for ( my $i = 0; $i < length( $v1 ); $i++ ) { + my ( $n1, $n2 ) = ( ord( substr( $v1, $i, 1 ) ), + ord( substr( $v2, $i, 1 ) ) ); + $n1 += 256 if $n1 < 65; # letters sort earlier than non-letters + $n1 = -1 if $n1 == 126; # '~' sorts earlier than everything else + $n2 += 256 if $n2 < 65; + $n2 = -1 if $n2 == 126; + if ( my $r = ($n1 <=> $n2) ) { + return $r; + } + } + return length( $v1 ) <=> length( $v2 ); +} + +1; +__END__ + +=head1 COPYRIGHT + +Copyright 2003, 2004 Frank Lichtenheld + +This file is distributed under the terms of the GNU Public +License, Version 2. See the source code for more details. + +=head1 SEE ALSO + +Debian policy diff --git a/lib/Parse/DebControl.pm b/lib/Parse/DebControl.pm new file mode 100644 index 0000000..43daa39 --- /dev/null +++ b/lib/Parse/DebControl.pm @@ -0,0 +1,616 @@ +package Parse::DebControl; + +########################################################### +# Parse::DebControl - Parse debian-style control +# files (and other colon key-value fields) +# +# Copyright 2003 - Jay Bonci +# Licensed under the same terms as perl itself +# +########################################################### + +use strict; +use IO::Scalar; + +use vars qw($VERSION); +$VERSION = '1.8'; + +sub new { + my ($class, $debug) = @_; + my $this = {}; + + my $obj = bless $this, $class; + if($debug) + { + $obj->DEBUG(); + } + return $obj; +}; + +sub parse_file { + my ($this, $filename, $options) = @_; + unless($filename) + { + $this->_dowarn("parse_file failed because no filename parameter was given"); + return; + } + + my $fh; + unless(open($fh,"$filename")) + { + $this->_dowarn("parse_file failed because $filename could not be opened for reading"); + return; + } + + return $this->_parseDataHandle($fh, $options); +}; + +sub parse_mem { + my ($this, $data, $options) = @_; + + unless($data) + { + $this->_dowarn("parse_mem failed because no data was given"); + return; + } + + my $IOS = new IO::Scalar \$data; + + unless($IOS) + { + $this->_dowarn("parse_mem failed because IO::Scalar creation failed."); + return; + } + + return $this->_parseDataHandle($IOS, $options); + +}; + +sub write_file { + my ($this, $filenameorhandle, $dataorarrayref, $options) = @_; + + unless($filenameorhandle) + { + $this->_dowarn("write_file failed because no filename or filehandle was given"); + return; + } + + unless($dataorarrayref) + { + $this->_dowarn("write_file failed because no data was given"); + return; + } + + my $handle = $this->_getValidHandle($filenameorhandle, $options); + + unless($handle) + { + $this->_dowarn("write_file failed because we couldn't negotiate a valid handle"); + return; + } + + my $arrayref = $this->_makeArrayref($dataorarrayref); + + my $string = $this->_makeControl($arrayref); + $string ||= ""; + + print $handle $string; + close $handle; + + return length($string); +} + +sub write_mem { + my ($this, $dataorarrayref, $options) = @_; + + unless($dataorarrayref) + { + $this->_dowarn("write_mem failed because no data was given"); + return; + } + + my $arrayref = $this->_makeArrayref($dataorarrayref); + + my $string = $this->_makeControl($arrayref); + + return $string; +} + +sub DEBUG +{ + my($this, $verbose) = @_; + $verbose = 1 unless(defined($verbose) and int($verbose) == 0); + $this->{_verbose} = $verbose; + return; + +} + +sub _getValidHandle { + my($this, $filenameorhandle, $options) = @_; + + if(ref $filenameorhandle eq "GLOB") + { + unless($filenameorhandle->opened()) + { + $this->_dowarn("Can't get a valid filehandle to write to, because that is closed"); + return; + } + + return $filenameorhandle; + }else + { + my $openmode = ">>"; + $openmode=">" if $options->{clobberFile}; + $openmode=">>" if $options->{appendFile}; + + my $handle; + + unless(open $handle,"$openmode$filenameorhandle") + { + $this->_dowarn("Couldn't open file: $openmode$filenameorhandle for writing"); + return; + } + + return $handle; + } +} + +sub _makeArrayref { + my ($this, $dataorarrayref) = @_; + + if(ref $dataorarrayref eq "ARRAY") + { + return $dataorarrayref; + }else{ + return [$dataorarrayref]; + } +} + +sub _makeControl +{ + my ($this, $dataorarrayref) = @_; + + my $str; + + foreach my $stanza(@$dataorarrayref) + { + foreach my $key(keys %$stanza) + { + $stanza->{$key} ||= ""; + + my @lines = split("\n", $stanza->{$key}); + if (@lines) { + $str.="$key\: ".(shift @lines)."\n"; + } else { + $str.="$key\:\n"; + } + + foreach(@lines) + { + if($_ eq "") + { + $str.=" .\n"; + } + else{ + $str.=" $_\n"; + } + } + + } + + $str ||= ""; + $str.="\n"; + } + + chomp($str); + return $str; + +} + +sub _parseDataHandle +{ + my ($this, $handle, $options) = @_; + + my $structs; + + unless($handle) + { + $this->_dowarn("_parseDataHandle failed because no handle was given. This is likely a bug in the module"); + return; + } + + my $data = $this->_getReadyHash($options); + + my $linenum = 0; + my $lastfield = ""; + + foreach my $line (<$handle>) + { + #Sometimes with IO::Scalar, lines may have a newline at the end + chomp $line; + + if($options->{stripComments}){ + next if $line =~ /^\s*\#/; + $line =~ s/\#.*// + } + + $linenum++; + if($line =~ /^[^\t\s]/) + { + #we have a valid key-value pair + if($line =~ /(.*?)\s*\:\s*(.*)$/) + { + my $key = $1; + my $value = $2; + + if($options->{discardCase}) + { + $key = lc($key); + } + + unless($options->{verbMultiLine}) + { + $value =~ s/[\s\t]+$//; + } + + $data->{$key} = $value; + + + if ($options->{verbMultiLine} + && (($data->{$lastfield} || "") =~ /\n/o)){ + $data->{$lastfield} .= "\n"; + } + + $lastfield = $key; + }else{ + $this->_dowarn("Parse error on line $linenum of data; invalid key/value stanza"); + return $structs; + } + + }elsif($line =~ /^([\t\s])(.*)/) + { + #appends to previous line + + unless($lastfield) + { + $this->_dowarn("Parse error on line $linenum of data; indented entry without previous line"); + return $structs; + } + if($options->{verbMultiLine}){ + $data->{$lastfield}.="\n$1$2"; + }elsif($2 eq "." ){ + $data->{$lastfield}.="\n"; + }else{ + my $val = $2; + $val =~ s/[\s\t]+$//; + $data->{$lastfield}.="\n$val"; + } + + }elsif($line =~ /^[\s\t]*$/){ + if ($options->{verbMultiLine} + && ($data->{$lastfield} =~ /\n/o)) { + $data->{$lastfield} .= "\n"; + } + if(keys %$data > 0){ + push @$structs, $data; + } + $data = $this->_getReadyHash($options); + $lastfield = ""; + }else{ + $this->_dowarn("Parse error on line $linenum of data; unidentified line structure"); + return $structs; + } + + } + + if(keys %$data > 0) + { + push @$structs, $data; + } + + return $structs; +} + +sub _getReadyHash +{ + my ($this, $options) = @_; + my $data; + + if($options->{useTieIxHash}) + { + eval("use Tie::IxHash"); + if($@) + { + $this->_dowarn("Can't use Tie::IxHash. You need to install it to have this functionality"); + return; + } + tie(%$data, "Tie::IxHash"); + return $data; + } + + return {}; +} + +sub _dowarn +{ + my ($this, $warning) = @_; + + if($this->{_verbose}) + { + warn "DEBUG: $warning"; + } + + return; +} + + +1; + +__END__ + +=head1 NAME + +Parse::DebControl - Easy OO parsing of debian control-like files + +=head1 SYNOPSIS + + use Parse::DebControl + + $parser = new Parse::DebControl; + + $data = $parser->parse_mem($control_data, %options); + $data = $parser->parse_file('./debian/control', %options); + + $writer = new Parse::DebControl; + + $string = $writer->write_mem($singlestanza); + $string = $writer->write_mem([$stanza1, $stanza2]); + + $writer->write_file($filename, $singlestanza, %options); + $writer->write_file($filename, [$stanza1, $stanza2], %options); + + $writer->write_file($handle, $singlestanza, %options); + $writer->write_file($handle, [$stanza1, $stanza2], %options); + + $parser->DEBUG(); + +=head1 DESCRIPTION + + Parse::DebControl is an easy OO way to parse debian control files and + other colon separated key-value pairs. It's specifically designed + to handle the format used in Debian control files, template files, and + the cache files used by dpkg. + + For basic format information see: + http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-controlsyntax + + This module does not actually do any intelligence with the file content + (because there are a lot of files in this format), but merely handles + the format. It can handle simple control files, or files hundreds of lines + long efficiently and easily. + +=head2 Class Methods + +=over 4 + +=item * C + +=item * C)> + +Returns a new Parse::DebControl object. If a true parameter I<$debug> is +passed in, it turns on debugging, similar to a call to C (see below); + +=back + +=over 4 + +=item * C)> + +Takes a filename as a scalar. Will parse as much as it can, +warning (if Cing is turned on) on parsing errors. + +Returns an array of hashes, containing the data in the control file, split up +by stanza. Stanzas are deliniated by newlines, and multi-line fields are +expressed as such post-parsing. Single periods are treated as special extra +newline deliniators, per convention. Whitespace is also stripped off of lines +as to make it less-easy to make mistakes with hand-written conf files). + +The options hash can take parameters as follows. Setting the string to true +enables the option. + + useTieIxHash - Instead of an array of regular hashes, uses Tie::IxHash- + based hashes + discardCase - Remove all case items from keys (not values) + stripComments - Remove all commented lines in standard #comment format + verbMultiLine - Keep the description AS IS, and no not collapse leading + spaces or dots as newlines. This also keeps whitespace from being + stripped off the end of lines. + +=back + +=over 4 + +=item * C)> + +Similar to C, except takes data as a scalar. Returns the same +array of hashrefs as C. The options hash is the same as +C as well; see above. + +=back + +=over 4 + +=item * C)> + +=item * C + +=item * C)> + +=item * C + +This function takes a filename or a handle and writes the data out. The +data can be given as a single hash(ref) or as an arrayref of hash(ref)s. It +will then write it out in a format that it can parse. The order is dependant +on your hash sorting order. If you care, use Tie::IxHash. Remember for +reading back in, the module doesn't care. + +The I<%options> hash can contain one of the following two items: + + appendFile - (default) Write to the end of the file + clobberFile - Overwrite the file given. + +Since you determine the mode of your filehandle, passing it an options hash +obviously won't do anything; rather, it is ignored. + +This function returns the number of bytes written to the file, undef +otherwise. + +=back + +=over 4 + +=item * C + +=item * C; + +This function works similarly to the C method, except it returns +the control structure as a scalar, instead of writing it to a file. There +is no I<%options> for this file (yet); + +=back + +=over 4 + +=item * C + +Turns on debugging. Calling it with no paramater or a true parameter turns +on verbose Cings. Calling it with a false parameter turns it off. +It is useful for nailing down any format or internal problems. + +=back + +=head1 CHANGES + +B - July 11th, 2003 + +=over 4 + +=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. + +=back + +B - June 25th, 2003 + +=over 4 + +=item * POD documentation error noticed again by Frank Lichtenheld + +=item * Also by Frank, applied a patch to add a "verbMultiLine" option so that we can hand multiline fields back unparsed. + +=item * Slightly expanded test suite to cover new features + +=back + +B - June 9th, 2003 + +=over 4 + +=item * POD cleanups noticed by Frank Lichtenheld. Thank you, Frank. + +=back + +B - June 2nd, 2003 + +=over 4 + +=item * Cleaned up some warnings when you pass in empty hashrefs or arrayrefs + +=item * Added stripComments setting + +=item * Cleaned up POD errors + +=back + +B - May 8th, 2003 + +=over 4 + +=item * Added a line to quash errors with undef hashkeys and writing + +=item * Fixed the Makefile.PL to straighten up DebControl.pm being in the wrong dir + +=back + +B - April 30th, 2003 + +=over 4 + +=item * Removed exports as they were unnecessary. Many thanks to pudge, who pointed this out. + +=back + +B - April 28th, 2003 + +=over 4 + +=item * Fixed a bug where writing blank stanzas would throw a warning. Fix found and supplied by Nate Oostendorp. + +=back + +B - April 25th, 2003 + +Fixed: + +=over 4 + +=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. + +=back + +B - April 24th, 2003 + +Fixed: + +=over 4 + +=item * A bug in IxHash support where multiple stanzas might be out of order + +=back + +B - April 23rd, 2003 + +Added: + +=over 4 + +=item * Writing support + +=item * Tie::IxHash support + +=item * Case insensitive reading support + +=back + +* B - April 23rd, 2003 + +=over 4 + +=item * This is the initial public release for CPAN, so everything is new. + +=back + +=head1 BUGS + +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. + +=head1 TODO + +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. + +=head1 COPYRIGHT + +Parse::DebControl is copyright 2003 Jay Bonci Ejaybonci@cpan.orgE. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut diff --git a/lib/Parse/DebianChangelog.pm b/lib/Parse/DebianChangelog.pm new file mode 100644 index 0000000..b843f14 --- /dev/null +++ b/lib/Parse/DebianChangelog.pm @@ -0,0 +1,1256 @@ +# +# Parse::DebianChangelog +# +# Copyright 1996 Ian Jackson +# Copyright 2005 Frank Lichtenheld +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +# + +=head1 NAME + +Parse::DebianChangelog - parse Debian changelogs and output them in other formats + +=head1 SYNOPSIS + + use Parse::DebianChangelog; + + my $chglog = Parse::DebianChangelog->init( { infile => 'debian/changelog', + HTML => { outfile => 'changelog.html' } ); + $chglog->html; + + # the following is semantically equivalent + my $chglog = Parse::DebianChangelog->init(); + $chglog->parse( { infile => 'debian/changelog' } ); + $chglog->html( { outfile => 'changelog.html' } ); + + my $changes = $chglog->dpkg_str( { since => '1.0-1' } ); + print $changes; + +=head1 DESCRIPTION + +Parse::DebianChangelog parses Debian changelogs as described in the Debian +policy (version 3.6.2.1 at the time of this writing). See section +L<"SEE ALSO"> for locations where to find this definition. + +The parser tries to ignore most cruft like # or /* */ style comments, +CVS comments, vim variables, emacs local variables and stuff from +older changelogs with other formats at the end of the file. +NOTE: most of these are ignored silently currently, there is no +parser error issued for them. This should become configurable in the +future. + +Beside giving access to the details of the parsed file via the +L<"data"> method, Parse::DebianChangelog also supports converting these +changelogs to various other formats. These are currently: + +=over 4 + +=item dpkg + +Format as known from L. All requested entries +(see L<"METHODS"> for an explanation what this means) are returned in +the usual Debian control format, merged in one stanza, ready to be used +in a F<.changes> file. + +=item rfc822 + +Similar to the C format, but the requested entries are returned +as one stanza each, i.e. they are not merged. This is probably the format +to use if you want a machine-usable representation of the changelog. + +=item xml + +Just a simple XML dump of the changelog data. Without any schema or +DTD currently, just some made up XML. The actual format might still +change. Comments and Improvements welcome. + +=item html + +The changelog is converted to a somewhat nice looking HTML file with +some nice features as a quick-link bar with direct links to every entry. +NOTE: This is not very configurable yet and was specifically designed +to be used on L. This is planned to be +changed until version 1.0. + +=back + +=head2 METHODS + +=cut + +package Parse::DebianChangelog; + +use strict; +use warnings; + +use Fcntl qw( :flock ); +use English; +use Date::Parse; +use Parse::DebianChangelog::Util qw( :all ); +use Parse::DebianChangelog::Entry; + +our $VERSION = '1.0'; + +=pod + +=head3 init + +Creates a new object instance. Takes a reference to a hash as +optional argument, which is interpreted as configuration options. +There are currently no supported general configuration options, but +see the other methods for more specific configuration options which +can also specified to C. + +If C or C are specified (see L), C +is called from C. If a fatal error is encountered during parsing +(e.g. the file can't be opened), C will not return a +valid object but C! + +=cut + +sub init { + my $classname = shift; + my $config = shift || {}; + my $self = {}; + bless( $self, $classname ); + + $config->{verbose} = 1 if $config->{debug}; + $self->{config} = $config; + + $self->init_filters; + $self->reset_parse_errors; + + if ($self->{config}{infile} || $self->{config}{instring}) { + defined($self->parse) or return undef; + } + + return $self; +} + +=pod + +=head3 reset_parse_errors + +Can be used to delete all information about errors ocurred during +previous L runs. Note that C also calls this method. + +=cut + +sub reset_parse_errors { + my ($self) = @_; + + $self->{errors}{parser} = []; +} + +sub _do_parse_error { + my ($self, $file, $line_nr, $error, $line) = @_; + shift; + + push @{$self->{errors}{parser}}, [ @_ ]; + + $file = substr $file, 0, 20; + unless ($self->{config}{quiet}) { + if ($line) { + warn "WARN: $file(l$NR): $error\nLINE: $line\n"; + } else { + warn "WARN: $file(l$NR): $error\n"; + } + } +} + +=pod + +=head3 get_parse_errors + +Returns all error messages from the last L run. +If called in scalar context returns a human readable +string representation. If called in list context returns +an array of arrays. Each of these arrays contains + +=over 4 + +=item 1. + +the filename of the parsed file or C if a string was +parsed directly + +=item 2. + +the line number where the error occurred + +=item 3. + +an error description + +=item 4. + +the original line + +=back + +NOTE: This format isn't stable yet and may change in later versions +of this module. + +=cut + +sub get_parse_errors { + my ($self) = @_; + + if (wantarray) { + return @{$self->{errors}{parser}}; + } else { + my $res = ""; + foreach my $e (@{$self->{errors}{parser}}) { + if ($e->[3]) { + $res .= "WARN: $e->[0](l$e->[1]): $e->[2]\nLINE: $e->[3]\n"; + } else { + $res .= "WARN: $e->[0](l$e->[1]): $e->[2]\n"; + } + } + return $res; + } +} + +sub _do_fatal_error { + my ($self, @msg) = @_; + + $self->{errors}{fatal} = "@msg"; + warn "FATAL: @msg\n" unless $self->{config}{quiet}; +} + +=pod + +=head3 get_error + +Get the last non-parser error (e.g. the file to parse couldn't be opened). + +=cut + +sub get_error { + my ($self) = @_; + + return $self->{errors}{fatal}; +} + +=pod + +=head3 parse + +Parses either the file named in configuration item C or the string +saved in configuration item C. +Accepts a hash ref as optional argument which can contain configuration +items. + +Returns C in case of error (e.g. "file not found", B parse +errors) and the object if successful. If C was returned, you +can get the reason for the failure by calling the L method. + +=cut + +sub parse { + my ($self, $config) = @_; + + foreach my $c (keys %$config) { + $self->{config}{$c} = $config->{$c}; + } + + my ($fh, $file); + if ($file = $self->{config}{infile}) { + open $fh, '<', $file or do { + $self->_do_fatal_error( "can't open file $file: $!" ); + return undef; + }; + flock $fh, LOCK_SH or do { + $self->_do_fatal_error( "can't lock file $file: $!" ); + return undef; + }; + } elsif (my $string = $self->{config}{instring}) { + eval { require IO::String }; + if ($@) { + $self->_do_fatal_error( "can't load IO::String: $@" ); + return undef; + } + $fh = IO::String->new( $string ); + $file = 'String'; + } else { + $self->_do_fatal_error( 'no changelog file specified' ); + return undef; + } + + $self->reset_parse_errors; + + $self->{data} = []; + +# based on /usr/lib/dpkg/parsechangelog/debian + my $expect='first heading'; + my $entry = Parse::DebianChangelog::Entry->init(); + my $blanklines = 0; + my $unknowncounter = 1; # to make version unique, e.g. for using as id + + while (<$fh>) { + s/\s*\n$//; +# printf(STDERR "%-39.39s %-39.39s\n",$expect,$_); + if (m/^(\w[-+0-9a-z.]*) \(([^\(\) \t]+)\)((\s+[-0-9a-z]+)+)\;/i) { + unless ($expect eq 'first heading' + || $expect eq 'next heading or eof') { + $entry->{ERROR} = [ $file, $NR, + "found start of entry where expected $expect", "$_" ]; + $self->_do_parse_error(@{$entry->{ERROR}}); + } + unless ($entry->is_empty) { + $entry->{'Closes'} = find_closes( $entry->{Changes} ); +# print STDERR, Dumper($entry); + push @{$self->{data}}, $entry; + $entry = Parse::DebianChangelog::Entry->init(); + } + { + $entry->{'Source'} = $1; + $entry->{'Version'} = $2; + $entry->{'Header'} = $_; + ($entry->{'Distribution'} = $3) =~ s/^\s+//; + $entry->{'Changes'} = $entry->{'Urgency_Comment'} = ''; + $entry->{'Urgency'} = $entry->{'Urgency_LC'} = 'unknown'; + } + (my $rhs = $POSTMATCH) =~ s/^\s+//; + my %kvdone; +# print STDERR "RHS: $rhs\n"; + for my $kv (split(/\s*,\s*/,$rhs)) { + $kv =~ m/^([-0-9a-z]+)\=\s*(.*\S)$/i || + $self->_do_parse_error($file, $NR, "bad key-value after \`;': \`$kv'"); + my $k = ucfirst $1; + my $v = $2; + $kvdone{$k}++ && $self->_do_parse_error($file, $NR, + "repeated key-value $k"); + if ($k eq 'Urgency') { + $v =~ m/^([-0-9a-z]+)((\s+.*)?)$/i || + $self->_do_parse_error($file, $NR, + "badly formatted urgency value", + $v); + $entry->{'Urgency'} = $1; + $entry->{'Urgency_LC'} = lc($1); + $entry->{'Urgency_Comment'} = $2 || ''; + } elsif ($k =~ m/^X[BCS]+-/i) { + # Extensions - XB for putting in Binary, + # XC for putting in Control, XS for putting in Source + $entry->{$k}= $v; + } else { + $self->_do_parse_error($file, $NR, + "unknown key-value key $k - copying to XS-$k"); + $entry->{ExtraFields}{"XS-$k"} = $v; + } + } + $expect= 'start of change data'; + $blanklines = 0; + } elsif (m/^(;;\s*)?Local variables:/io) { + last; # skip Emacs variables at end of file + } elsif (m/^vim:/io) { + last; # skip vim variables at end of file + } elsif (m/^\$\w+:.*\$/o) { + next; # skip stuff that look like a CVS keyword + } elsif (m/^\# /o) { + next; # skip comments, even that's not supported + } elsif (m,^/\*.*\*/,o) { + next; # more comments + } elsif (m/^(\w+\s+\w+\s+\d{1,2} \d{1,2}:\d{1,2}:\d{1,2}\s+[\w\s]*\d{4})\s+(.*)\s+(<|\()(.*)(\)|>)/o + || m/^(\w+\s+\w+\s+\d{1,2},?\s*\d{4})\s+(.*)\s+(<|\()(.*)(\)|>)/o + || m/^(\w[-+0-9a-z.]*) \(([^\(\) \t]+)\)\;?/io + || m/^([\w.+-]+)(-| )(\S+) Debian (\S+)/io + || m/^Changes from version (.*) to (.*):/io + || m/^Changes for [\w.+-]+-[\w.+-]+:?$/io + || m/^Old Changelog:$/io + || m/^(?:\d+:)?[\w.+~-]+:?$/o) { + # save entries on old changelog format verbatim + # we assume the rest of the file will be in old format once we + # hit it for the first time + $self->{oldformat} = "$_\n"; + $self->{oldformat} .= join "", <$fh>; + } elsif (m/^\S/) { + $self->_do_parse_error($file, $NR, + "badly formatted heading line", "$_"); + } elsif (m/^ \-\- (.*) <(.*)>( ?)((\w+\,\s*)?\d{1,2}\s+\w+\s+\d{4}\s+\d{1,2}:\d\d:\d\d\s+[-+]\d{4}(\s+\([^\\\(\)]\))?)$/o) { + $expect eq 'more change data or trailer' || + $self->_do_parse_error($file, $NR, + "found trailer where expected $expect", "$_"); + if ($3 ne ' ') { + $self->_do_parse_error($file, $NR, + "badly formatted trailer line", "$_"); + } + $entry->{'Trailer'} = $_; + $entry->{'Maintainer'} = "$1 <$2>" unless $entry->{'Maintainer'}; + unless($entry->{'Date'} && $entry->{'Timestamp'}) { + $entry->{'Date'} = $4; + $entry->{'Timestamp'} = str2time($4) + or $self->_do_parse_error( $file, $NR, "couldn't parse date $4" ); + } + $expect = 'next heading or eof'; + } elsif (m/^ \-\-/) { + $entry->{ERROR} = [ $file, $NR, + "badly formatted trailer line", "$_" ]; + $self->_do_parse_error(@{$entry->{ERROR}}); +# $expect = 'next heading or eof' +# if $expect eq 'more change data or trailer'; + } elsif (m/^\s{2,}(\S)/) { + $expect eq 'start of change data' + || $expect eq 'more change data or trailer' + || do { + $self->_do_parse_error($file, $NR, + "found change data where expected $expect", "$_"); + if (($expect eq 'next heading or eof') + && !$entry->is_empty) { + # lets assume we have missed the actual header line + $entry->{'Closes'} = find_closes( $entry->{Changes} ); +# print STDERR, Dumper($entry); + push @{$self->{data}}, $entry; + $entry = Parse::DebianChangelog::Entry->init(); + $entry->{Source} = + $entry->{Distribution} = $entry->{Urgency} = + $entry->{Urgency_LC} = 'unknown'; + $entry->{Version} = 'unknown'.($unknowncounter++); + $entry->{Urgency_Comment} = ''; + $entry->{ERROR} = [ $file, $NR, + "found change data where expected $expect", "$_" ]; + } + }; + $entry->{'Changes'} .= (" \n" x $blanklines)." $_\n"; + if (!$entry->{'Items'} || ($1 eq '*')) { + $entry->{'Items'} ||= []; + push @{$entry->{'Items'}}, "$_\n"; + } else { + $entry->{'Items'}[-1] .= (" \n" x $blanklines)." $_\n"; + } + $blanklines = 0; + $expect = 'more change data or trailer'; + } elsif (!m/\S/) { + next if $expect eq 'start of change data' + || $expect eq 'next heading or eof'; + $expect eq 'more change data or trailer' + || $self->_do_parse_error($file, $NR, + "found blank line where expected $expect"); + $blanklines++; + } else { + $self->_do_parse_error($file, $NR, "unrecognised line", "$_"); + ($expect eq 'start of change data' + || $expect eq 'more change data or trailer') + && do { + # lets assume change data if we expected it + $entry->{'Changes'} .= (" \n" x $blanklines)." $_\n"; + if (!$entry->{'Items'}) { + $entry->{'Items'} ||= []; + push @{$entry->{'Items'}}, "$_\n"; + } else { + $entry->{'Items'}[-1] .= (" \n" x $blanklines)." $_\n"; + } + $blanklines = 0; + $expect = 'more change data or trailer'; + $entry->{ERROR} = [ $file, $NR, "unrecognised line", "$_" ]; + }; + } + } + + $expect eq 'next heading or eof' + || do { + $entry->{ERROR} = [ $file, $NR, "found eof where expected $expect" ]; + $self->_do_parse_error( @{$entry->{ERROR}} ); + }; + unless ($entry->is_empty) { + $entry->{'Closes'} = find_closes( $entry->{Changes} ); + push @{$self->{data}}, $entry; + } + + if ($self->{config}{infile}) { + close $fh or do { + $self->_do_fatal_error( "can't close file $file: $!" ); + return undef; + }; + } + +# use Data::Dumper; +# print Dumper( $self ); + + return $self; +} + +=pod + +=head3 data + +C returns an array (if called in list context) or a reference +to an array of Parse::DebianChangelog::Entry objects which each +represent one entry of the changelog. + +This is currently merely a placeholder to enable users to get to the +raw data, expect changes to this API in the near future. + +This method supports the common output options described in +section L<"COMMON OUTPUT OPTIONS">. + +=cut + +sub data { + my ($self, $config) = @_; + + my $data = $self->{data}; + if ($config) { + $self->{config}{DATA} = $config if $config; + $data = $self->_data_range( $config ) or return undef; + } + return @$data if wantarray; + return $data; +} + +sub __sanity_check_range { + my ( $data, $from, $to, $since, $until, $start, $end ) = @_; + + if (($$start || $$end) && ($$from || $$since || $$to || $$until)) { + warn( "you can't combine 'count' or 'offset' with any other range option\n" ); + $$from = $$since = $$to = $$until = ''; + } + if ($$from && $$since) { + warn( "you can only specify one of 'from' and 'since'\n" ); + $$from = ''; + } + if ($$to && $$until) { + warn( "you can only specify one of 'to' and 'until'\n" ); + $$to = ''; + } + if ($data->[0]{Version} eq $$since) { + warn( "'since' option specifies most recent version\n" ); + $$since = ''; + } + if ($data->[$#{$data}]{Version} eq $$until) { + warn( "'until' option specifies oldest version\n" ); + $$until = ''; + } + $$start = 0 if $$start < 0; + return if $$start > $#$data; + $$end = $#$data if $$end > $#$data; + return if $$end < 0; + $$end = $$start if $$end < $$start; + #TODO: compare versions + return 1; +} + +sub _data_range { + my ($self, $config) = @_; + + my $data = $self->data or return undef; + + return [ @$data ] if $config->{all}; + + my $since = $config->{since} || ''; + my $until = $config->{until} || ''; + my $from = $config->{from} || ''; + my $to = $config->{to} || ''; + my $count = $config->{count} || 0; + my $offset = $config->{offset} || 0; + + return if $offset and not $count; + if ($offset > 0) { + $offset -= ($count < 0); + } elsif ($offset < 0) { + $offset = $#$data + ($count > 0) + $offset; + } else { + $offset = $#$data if $count < 0; + } + my $start = my $end = $offset; + $start += $count+1 if $count < 0; + $end += $count-1 if $count > 0; + + return unless __sanity_check_range( $data, \$from, \$to, + \$since, \$until, + \$start, \$end ); + + + unless ($from or $to or $since or $until or $start or $end) { + return [ @$data ] if $config->{default_all} and not $count; + return [ $data->[0] ]; + } + + return [ @{$data}[$start .. $end] ] if $start or $end; + + my @result; + + my $include = 1; + $include = 0 if $to or $until; + foreach (@$data) { + my $v = $_->{Version}; + $include = 1 if $v eq $to; + last if $v eq $since; + + push @result, $_ if $include; + + $include = 1 if $v eq $until; + last if $v eq $from; + } + + return \@result; +} + +=pod + +=head3 dpkg + +(and B) + +C returns a hash (in list context) or a hash reference +(in scalar context) where the keys are field names and the values are +field values. The following fields are given: + +=over 4 + +=item Source + +package name (in the first entry) + +=item Version + +packages' version (from first entry) + +=item Distribution + +target distribution (from first entry) + +=item Urgency + +urgency (highest of all printed entries) + +=item Maintainer + +person that created the (first) entry + +=item Date + +date of the (first) entry + +=item Closes + +bugs closed by the entry/entries, sorted by bug number + +=item Changes + +content of the the entry/entries + +=back + +C returns a stringified version of this hash which should look +exactly like the output of L. The fields are +ordered like in the list above. + +Both methods only support the common output options described in +section L<"COMMON OUTPUT OPTIONS">. + +=head3 dpkg_str + +See L. + +=cut + +our ( %FIELDIMPS, %URGENCIES ); +BEGIN { + my $i=100; + grep($FIELDIMPS{$_}=$i--, + qw(Source Version Distribution Urgency Maintainer Date Closes + Changes)); + $i=1; + grep($URGENCIES{$_}=$i++, + qw(low medium high critical emergency)); +} + +sub dpkg { + my ($self, $config) = @_; + + $self->{config}{DPKG} = $config if $config; + + $config = $self->{config}{DPKG} || {}; + my $data = $self->_data_range( $config ) or return undef; + + my %f; + foreach my $field (qw( Urgency Source Version + Distribution Maintainer Date )) { + $f{$field} = $data->[0]{$field}; + } + + $f{Changes} = get_dpkg_changes( $data->[0] ); + $f{Closes} = [ @{$data->[0]{Closes}} ]; + + my $first = 1; my $urg_comment = ''; + foreach my $entry (@$data) { + $first = 0, next if $first; + + my $oldurg = $f{Urgency} || ''; + my $oldurgn = $URGENCIES{$f{Urgency}} || -1; + my $newurg = $entry->{Urgency_LC} || ''; + my $newurgn = $URGENCIES{$entry->{Urgency_LC}} || -1; + $f{Urgency} = ($newurgn > $oldurgn) ? $newurg : $oldurg; + $urg_comment .= $entry->{Urgency_Comment}; + + $f{Changes} .= "\n .".get_dpkg_changes( $entry ); + push @{$f{Closes}}, @{$entry->{Closes}}; + } + + $f{Closes} = join " ", sort { $a <=> $b } @{$f{Closes}}; + $f{Urgency} .= $urg_comment; + + return %f if wantarray; + return \%f; +} + +sub dpkg_str { + return data2rfc822( scalar dpkg(@_), \%FIELDIMPS ); +} + +=pod + +=head3 rfc822 + +(and B) + +C returns an array of hashes (in list context) or a reference +to this array (in scalar context) where each hash represents one entry +in the changelog. For the format of such a hash see the description +of the L<"dpkg"> method (while ignoring the remarks about which +values are taken from the first entry). + +C returns a stringified version of this hash which looks +similar to the output of dpkg-parsechangelog but instead of one +stanza the output contains one stanza for each entry. + +Both methods only support the common output options described in +section L<"COMMON OUTPUT OPTIONS">. + +=head3 rfc822_str + +See L. + +=cut + +sub rfc822 { + my ($self, $config) = @_; + + $self->{config}{RFC822} = $config if $config; + + $config = $self->{config}{RFC822} || {}; + my $data = $self->_data_range( $config ) or return undef; + my @out_data; + + foreach my $entry (@$data) { + my %f; + foreach my $field (qw( Urgency Source Version + Distribution Maintainer Date )) { + $f{$field} = $entry->{$field}; + } + + $f{Urgency} .= $entry->{Urgency_Comment}; + $f{Changes} = get_dpkg_changes( $entry ); + $f{Closes} = join " ", sort { $a <=> $b } @{$entry->{Closes}}; + push @out_data, \%f; + } + + return @out_data if wantarray; + return \@out_data; +} + +sub rfc822_str { + return data2rfc822_mult( scalar rfc822(@_), \%FIELDIMPS ); +} + +sub __version2id { + my $version = shift; + $version =~ s/[^\w.:-]/_/go; + return "version$version"; +} + +=pod + +=head3 xml + +(and B) + +C converts the changelog to some free-form (i.e. there is neither +a DTD or a schema for it) XML. + +The method C is an alias for C. + +Both methods support the common output options described in +section L<"COMMON OUTPUT OPTIONS"> and additionally the following +configuration options (as usual to give +in a hash reference as parameter to the method call): + +=over 4 + +=item outfile + +directly write the output to the file specified + +=back + +=head3 xml_str + +See L. + +=cut + +sub xml { + my ($self, $config) = @_; + + $self->{config}{XML} = $config if $config; + $config = $self->{config}{XML} || {}; + $config->{default_all} = 1 unless exists $config->{all}; + my $data = $self->_data_range( $config ) or return undef; + my %out_data; + $out_data{Entry} = []; + + require XML::Simple; + import XML::Simple qw( :strict ); + + foreach my $entry (@$data) { + my %f; + foreach my $field (qw( Urgency Source Version + Distribution Closes )) { + $f{$field} = $entry->{$field}; + } + foreach my $field (qw( Maintainer Changes )) { + $f{$field} = [ $entry->{$field} ]; + } + + $f{Urgency} .= $entry->{Urgency_Comment}; + $f{Date} = { timestamp => $entry->{Timestamp}, + content => $entry->{Date} }; + push @{$out_data{Entry}}, \%f; + } + + my $xml_str; + my %xml_opts = ( SuppressEmpty => 1, KeyAttr => {}, + RootName => 'Changelog' ); + $xml_str = XMLout( \%out_data, %xml_opts ); + if ($config->{outfile}) { + open my $fh, '>', $config->{outfile} or return undef; + flock $fh, LOCK_EX or return undef; + + print $fh $xml_str; + + close $fh or return undef; + } + + return $xml_str; +} + +sub xml_str { + return xml(@_); +} + +=pod + +=head3 html + +(and B) + +C converts the changelog to a HTML file with some nice features +such as a quick-link bar with direct links to every entry. The HTML +is generated with the help of HTML::Template. If you want to change +the output you should use the default template provided with this module +as a base and read the documentation of HTML::Template to understand +how to edit it. + +The method C is an alias for C. + +Both methods support the common output options described in +section L<"COMMON OUTPUT OPTIONS"> and additionally the following +configuration options (as usual to give +in a hash reference as parameter to the method call): + +=over 4 + +=item outfile + +directly write the output to the file specified + +=item template + +template file to use, defaults to +/usr/share/libparse-debianchangelog-perl/default.tmpl. +NOTE: The plan is to provide a configuration file for the module +later to be able to use sane defaults here. + +=item style + +path to the CSS stylesheet to use (a default might be specified +in the template and will be honoured, see the default template +for an example) + +=item print_style + +path to the CSS stylesheet to use for printing (see the notes for +C