- adding download on demand feature to svn trunk (as discussed with ScriptRipper)

  (see http://lists.opensuse.org/opensuse-buildservice/2008-09/msg00025.html for a brief description)
- this is a preliminary version - there are some design issues and some parts need a cleanup
- this shouldn't break any existing code and this feature has to be
  enabled manually
- if there's something you don't like please tell me or fix it or revert it:)

diff --git a/Meta.pm b/Meta.pm
new file mode 100644 (file)
index 0000000..b5fe583
--- /dev/null
+++ b/Meta.pm
@@ -0,0 +1,37 @@
+#
+#
+# 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;

diff --git a/Meta/Debmd.pm b/Meta/Debmd.pm
new file mode 100644 (file)
index 0000000..b43fde8
--- /dev/null
+++ b/Meta/Debmd.pm
@@ -0,0 +1,91 @@
+#
+#
+# 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;

diff --git a/Meta/Rpmmd.pm b/Meta/Rpmmd.pm
new file mode 100644 (file)
index 0000000..732c4ba
--- /dev/null
+++ b/Meta/Rpmmd.pm
@@ -0,0 +1,158 @@
+#
+#
+# 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;