--- /dev/null
+#
+#
+# Copyright (c) 2008 Marcus Huewe
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License version 2 as
+# published by the Free Software Foundation.
+#
+# 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 (see the file COPYING); if not, write to the
+# Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+#
+################################################################
+#
+# The Download on Demand Metadata Parser for deb md files ("Packages" files)
+#
+
+package Meta;
+
+use strict;
+use warnings;
+use Meta::Rpmmd;
+use Meta::Debmd;
+
+sub parse {
+ my ($fn, $type, $opts) = @_;
+ return Meta::Debmd::parse($fn, $opts) if $type eq 'debmd';
+ return Meta::Rpmmd::parse($fn, $opts) if $type eq 'rpmmd';
+}
+
+1;
--- /dev/null
+#
+#
+# Copyright (c) 2008 Marcus Huewe
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License version 2 as
+# published by the Free Software Foundation.
+#
+# 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 (see the file COPYING); if not, write to the
+# Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+#
+################################################################
+#
+# The Download on Demand Metadata Parser for deb md files ("Packages" files)
+#
+
+package Meta::Debmd;
+use strict;
+use warnings;
+use Data::Dumper;
+
+my %tagmap = (
+ 'Package' => 'name',
+ 'Version' => 'version',
+ 'Provides' => 'provides',
+ 'Depends' => 'requires',
+ 'Pre-Depends' => 'requires',
+ 'Filename' => 'path',
+ 'Source' => 'source',
+ 'Architecture' => 'arch',
+);
+
+sub parse {
+ my $fn = shift;
+
+ my %packs = ();
+ my $cur = {};
+ open(F, '<', $fn) or die("open: $!\n");
+ while (<F>) {
+ chomp;
+ next unless /^(Package|Version|Provides|Depends|Pre-Depends|Filename|Source|Architecture|Size):\s(.*)/;
+ my ($tag, $what) = ($1, $2);
+ if ($tag =~ /^[\w-]*Depends|Provides/) {
+ my @m = $what =~ /([^\s,]+)(\s[^,]*)?[\s,]*/g;
+ my @l = ();
+ while (@m) {
+ my ($pack, $vers) = splice(@m, 0, 2);
+ $pack .= $vers if defined $vers;
+ push @l, $pack;
+ }
+ # stolen from the Build/Deb.pm
+ s/\(([^\)]*)\)/$1/g for @l;
+ s/<</</g for @l;
+ s/>>/>/g for @l;
+
+ push @{$cur->{$tagmap{$tag}}}, @l;
+ next;
+ }
+ # Size is the last entry in a package section
+ if ($tag eq 'Size') {
+ $cur->{'id'} = "-1/$what/-1";
+ $cur->{'hdrmd5'} = 0;
+ my $rel = exists $cur->{'release'} ? "-$cur->{'release'}" : '';
+ push @{$cur->{'provides'}}, "$cur->{'name'} = $cur->{'version'}$rel";
+ $cur->{'requires'} = [] unless exists $cur->{'requires'};
+ $cur->{'source'} = $cur->{'name'} unless exists $cur->{'source'};
+ $packs{$cur->{'name'}} = $cur;
+ $cur = {};
+ next;
+ }
+ $cur->{$tagmap{$tag}} = $what;
+ if ($tag eq 'Version') {
+ # stolen from Build/Deb.pm
+ if ($what =~ /^(.*)-(.*?)$/) {
+ $cur->{'version'} = $1;
+ $cur->{'release'} = $2;
+ }
+ }
+ }
+ close(F);
+ return \%packs;
+}
+
+1;
--- /dev/null
+#
+#
+# Copyright (c) 2008 Marcus Huewe
+# Copyright (c) 2008 Martin Mohring
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License version 2 as
+# published by the Free Software Foundation.
+#
+# 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 (see the file COPYING); if not, write to the
+# Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+#
+################################################################
+#
+# The Download on Demand Metadata Parser for rpm md files ("primary.xml" files)
+#
+
+package Meta::Rpmmd;
+use strict;
+use warnings;
+use XML::Parser;
+
+sub parse {
+ my ($fn, $opts) = @_;
+ my $h = rpmmdhandler->new(@{$opts->{'arch'}});
+ my $p = XML::Parser->new(Handlers => {
+ Start => sub { return $h->start_handler(@_); },
+ End => sub { return $h->end_handler(@_); },
+ Char => sub { return $h->char_handler(@_); },
+ }, ErrorContext => 2);
+ eval {
+ $p->parsefile($fn);
+ };
+ die("parse: $@") if $@;
+ return $h->getrepodata();
+}
+
+1;
+
+package rpmmdhandler;
+use strict;
+use warnings;
+use Data::Dumper;
+
+sub new {
+ my ($class, @arch) = @_;
+ my $self = {};
+ $self->{'repodata'} = {};
+ $self->{'pack'} = {};
+ $self->{'arch'} = [ @arch ]; # XXX: are there cases where we want to mix i586 and i686?
+ $self->{'reqprov'} = ();
+ $self->{'curchar'} = '';
+ $self->{'attrs'} = [ qw(version location rpm:entry size) ];
+ $self->{'chars'} = [ qw(name arch rpm:sourcerpm) ];
+ return bless($self, $class);
+}
+
+sub addversrel {
+ my ($self, $attrs) = @_;
+ $self->{'pack'}->{'version'} = $attrs->{'ver'};
+ $self->{'pack'}->{'release'} = $attrs->{'rel'};
+}
+
+sub addreqprov {
+ my ($self, $attrs) = @_;
+ my %flags = ( 'EQ' => '=', 'LE' => '<=', 'GE' => '>=', 'LT' => '<', 'GT' => '>' );
+ my $name = $attrs->{'name'};
+ unless ($name =~ /^(rpmlib\(|\/)/) {
+ $name .= exists $attrs->{'flags'} ? " $flags{$attrs->{'flags'}} " : "";
+ $name .= exists $attrs->{'epoch'} ? "$attrs->{'epoch'}:" : "";
+ $name .= exists $attrs->{'ver'} ? $attrs->{'ver'} : "";
+ $name .= exists $attrs->{'rel'} ? "-$attrs->{'rel'}" : "";
+ push @{$self->{'reqprov'}}, $name;
+ }
+}
+
+sub addlocation {
+ my ($self, $attrs) = @_;
+ $self->{'pack'}->{'path'} = $attrs->{'href'};
+}
+
+sub addsize {
+ my ($self, $attrs) = @_;
+ $self->{'pack'}->{'id'} = "-1/$attrs->{'package'}/-1"; # XXX: the <time /> tag provides time etc. but do we really need it?
+}
+
+sub getrepodata {
+ my ($self) = @_;
+ return $self->{'repodata'};
+}
+
+# XML::Parser handlers
+
+sub start_handler {
+ my ($self, $e, $name, %attrs) = @_;
+ $self->{'pack'}->{'hdrmd5'} = "0" if $name eq 'package';
+ return unless grep { $name eq $_ } @{$self->{'attrs'}};
+ $self->addversrel(\%attrs) if $name eq 'version';
+ $self->addreqprov(\%attrs) if $name eq 'rpm:entry';
+ $self->addlocation(\%attrs) if $name eq 'location';
+ $self->addsize(\%attrs) if $name eq 'size';
+}
+
+sub end_handler {
+ my %cando = (
+ 'armv4l' => ['arm', 'armel', 'noarch'],
+ 'armv5el' => ['arm', 'armel', 'armv5el', 'noarch'],
+ 'ppc' => ['ppc', 'noarch'],
+ 'ppc64' => ['ppc', 'ppc64', 'noarch'],
+ 'sh4' => ['sh4', 'noarch'],
+ 'ia64' => ['ia64', 'noarch'],
+ 's390' => ['s390', 'noarch'],
+ 's390x' => ['s390', 's390x', 'noarch'],
+ 'sparc' => ['sparc', 'noarch'],
+ 'sparc64' => ['sparc', 'sparc64', 'noarch'],
+ 'mips' => ['mips', 'noarch'],
+ 'mips64' => ['mips', 'mips64', 'noarch'],
+ 'i586' => [ 'i386', 'i486', 'i586', 'noarch'],
+ 'i686' => [ 'i386', 'i486', 'i586', 'i686', 'noarch'],
+ 'x86_64' => ['x86_64', 'noarch'],
+ );
+ my ($self, $e, $name) = @_;
+ if (grep { $name eq $_ } @{$self->{'chars'}}) {
+ $name = 'source' if $name eq 'rpm:sourcerpm';
+ $self->{'pack'}->{$name} = $self->{'curchar'};
+ $self->{'curchar'} = '';
+ }
+ if ($name =~ /rpm:(provides|requires)/) {
+ $name =~ s/rpm://;
+ $self->{'pack'}->{$name} = $self->{'reqprov'};
+ $self->{'reqprov'} = ();
+ } elsif ($name =~ /rpm:(obsoletes|supplements|conflicts)/) {
+ $self->{'reqprov'} = ();
+ }
+ $self->{'repodata'}->{$self->{'pack'}->{'name'}} = $self->{'pack'} if $name eq 'package' && grep { $self->{'pack'}->{'arch'} eq $_ } @{$self->{'arch'}}, @{$cando{@{$self->{'arch'}}[0]}};
+ $self->{'pack'} = {} if $name eq 'package';
+}
+
+sub char_handler {
+ my ($self, $e, $text) = @_;
+ return unless grep { $e->{'Context'}[-1] eq $_ } @{$self->{'chars'}};
+ my $tag = $e->{'Context'}[-1];
+ if ($tag eq 'rpm:sourcerpm') {
+ $tag = 'source';
+ # stolen from Build/Rpm.pm
+ $text =~ s/-[^-]*-[^-]*\.[^\.]*\.rpm//;
+ }
+ $self->{'curchar'} .= $text;
+}
+
+1;