From e142f96f77ad50fc9d32c85aa9f526cd6f96fd13 Mon Sep 17 00:00:00 2001 From: joey Date: Fri, 21 Apr 2000 02:23:53 +0000 Subject: [PATCH] added, at the beginning of the oo rewrite --- Alien/Package.pm | 228 +++++++++++++++++++++++++++++++++++++++++++ Alien/Package/Deb.pm | 188 +++++++++++++++++++++++++++++++++++ Alien/Package/Rpm.pm | 154 +++++++++++++++++++++++++++++ 3 files changed, 570 insertions(+) create mode 100644 Alien/Package.pm create mode 100644 Alien/Package/Deb.pm create mode 100644 Alien/Package/Rpm.pm diff --git a/Alien/Package.pm b/Alien/Package.pm new file mode 100644 index 0000000..3efbc2c --- /dev/null +++ b/Alien/Package.pm @@ -0,0 +1,228 @@ +#!/usr/bin/perl -w + +=head1 NAME + +Alien::Package - an object that represents a package + +=cut + +package Alien::Package; +use strict; +use vars qw($AUTOLOAD); + +=head1 DESCRIPTION + +This is a perl object class that represents a package in an internal format +usable by alien. The package may be a deb, a rpm, a tgz, or a slp package, +etc. Objects in this class hold various fields of metadata from the actual +packages they represent, as well as some fields pointing to the actual +contents of the package. They can also examine an actual package on disk, +and populate those fields. And they can build the actual package using the +data stored in the fields. + +A typical use of this object class will be to instantiate an object from +a class derived from this one, such as Alien::Package::Rpm Feed the object +a rpm file, thus populating all of its fields. Then rebless the object into +the destination class, such as Alien::Package::Deb. Finally, ask the object +to build a package, and the package has been converted. + +=head1 FIELDS + +=over 4 + +=item name + +The package's name. + +=item version + +The package's upstream version. + +=item release + +The package's distribution specific release number. + +=item arch + +The package's architecture, in the format used by Debian. + +=item maintainer + +The package's maintainer. + +=item depends + +The package's dependancies. + +=item group + +The section the package is in. + +=item summary + +A one line description of the package. + +=item description + +A longer description of the package. May contain multiple paragraphs. + +=item copyright + +A short statement of copyright. + +=item distribution + +What distribution family the package originated from. + +=item conffiles + +A reference to a list of all the conffiles in the package. + +=item files + +A reference to a list of all the files in the package. + +=item postinst + +The postinst script of the package. + +=item postrm + +The postrm script of the package. + +=item preinst + +The preinst script of the package. + +=item prerm + +The prerm script of the package. + +=item unpacked_tree + +Points to a directory where the package has been unpacked. + +=item filename + +The filename of the package the object represents. + +=back + +=head1 METHODS + +=over 4 + +=item new + +Returns a new object of this class. Optionally, you can pass in named +parameters that specify the values of any fields in the class. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $this=bless ({@_}, $class); + $this->init; + return $this; +} + +=item init + +This is called by new(). It's a handy place to set fields, etc, without +having to write your own new() method. + +=cut + +sub init {} + +=item read_file + +This method looks at the actual package file the package represents, and +populates all the fields it can from that package file. The filename field +should already be set before this method is called. + +(This is just a stub; child classes should override it to actually do +something.) + +=cut + +sub read_file { + my $this=shift; + my $file=$this->filename; + + if (! -e $file) { + die "`$file' does not exist; cannot read."; + } +} + +=item unpack + +This method unpacks the package into a temporary directory. It sets +unpacked_tree to point to that directory. + +(This is just a stub method that makes a directory below the current +working directory, and sets unpacked_tree to point to it. It should be +overridden by child classes to actually unpack the package as well.) + +=cut + +sub unpack { + my $this=shift; + + my $workdir = $this->name."-".$this->version; + mkdir $workdir, 0755 || + die "unable to mkdir $workdir: $!"; + $this->unpacked_tree($workdir); +} + +=item DESTROY + +When an object is destroyed, it cleans some stuff up. In particular, if the +package was unpacked, it is time now to wipe out the temporary directory. + +=cut + +sub DESTROY { + my $this=shift; + + return if (defined $this->unpacked_tree || $this->unpacked_tree eq ''); + # This should never happen, but it pays to check. + if ($this->unpacked_tree eq '/') { + die "alien internal error: unpacked_tree is set to `/'. Please file a bug report!"; + } + system 'rm', '-rf', $this->unpacked_tree && + die "unable to delete temporary directory `".$this->unpacked_tree."`: $!"; + $this->unpacked_tree(''); +} + +=item AUTOLOAD + +Handles all fields, by creating accessor methods for them the first time +they are accessed. + +=cut + +sub AUTOLOAD { + my $field; + ($field = $AUTOLOAD) =~ s/.*://; + + no strict 'refs'; + *$AUTOLOAD = sub { + my $this=shift; + + return $this->{$field} unless @_; + return $this->{$field}=shift; + }; + goto &$AUTOLOAD; +} + +=back + +=head1 AUTHOR + +Joey Hess + +=cut + +1 diff --git a/Alien/Package/Deb.pm b/Alien/Package/Deb.pm new file mode 100644 index 0000000..2f38c9b --- /dev/null +++ b/Alien/Package/Deb.pm @@ -0,0 +1,188 @@ +#!/usr/bin/perl -w + +=head1 NAME + +Alien::Package::Deb - an object that represents a deb package + +=cut + +package Alien::Package::Deb; +use strict; +use Alien::Package; # perlbug +use base qw(Alien::Package); + +=head1 DESCRIPTION + +This is an object class that represents a deb package. It is derived from +Alien::Package. + +=head1 FIELDS + +=over 4 + +=item have_dpkg_deb + +Set to a true value if dpkg-deb is available. + +=back + +=head1 METHODS + +=over 4 + +=item init + +Sets have_dpkg_deb if dpkg-deb is in the path. + +=cut + +sub init { + my $this=shift; + $this->SUPER::init(@_); + + $this->have_dpkg_deb(''); + foreach (split(/:/,$ENV{PATH})) { + if (-x "$_/dpkg-deb") { + $this->have_dpkg_deb(1); + last; + } + } +} + +=item read_file + +Implement the read_file method to read a deb file. + +This uses either dpkg-deb, if it is present, or ar and tar if it is not. +Using dpkg-deb is a lot more future-proof, but the system may not have it. + +=cut + +sub read_file { + my $this=shift; + $this->SUPER::read_file(@_); + + # Extract the control file from the deb file. + my @control; + if ($this->have_dpkg_deb) { + @control = `dpkg-deb --info $file control`; + } + else { + # It can have one of two names, depending on the tar + # version the .deb was built from. + @control = `ar p $file control.tar.gz | tar Oxzf - control [./]control`; + } + + # Parse control file and extract fields. + my $field; + my %fieldtrans=( + Package => 'name', + Version => 'version', + Architecture => 'arch', + Maintainer => 'maintainer', + Depends => 'depends', + Section => 'group', + Description => 'summary', + ); + for (my $i=0; $i <= $#control; $i++) { + $_ = $control[$i]; + chomp; + if (/^(\w.*?):\s+(.*)/) { + $field=$1; + if (exists $fieldtrans{$field}) { + $field=$fieldtrans{$field}; + $this->$field($2); + } + } + elsif (/^ / && $field eq 'summary') { + # Handle xtended description. + s/^ //g; + $_="" if $_ eq "."; + $this->description($this->description . $_. "\n"); + } + } + + $this->copyright("see /usr/share/doc/".$this->name."/copyright"); + $this->group("unknown") if ! $this->group; + $this->distribution("Debian"); + if ($this->version =~ /(.+)-(.+)/) { + $this->version($1); + $this->release($2); + } + else { + $this->release(1); + } + # Kill epochs. + if ($this->version =~ /\d+:(.*)/) { + $this->version($1); + } + + # Read in the list of conffiles, if any. + my @conffiles; + if ($this->have_dpkg_deb) { + @conffiles=map { chomp; $_ } + `dpkg-deb --info $file conffiles 2>/dev/null`; + } + else { + @conffiles=map { chomp; $_ } + `ar p $file control.tar.gz | tar Oxzf - conffiles 2>/dev/null`; + } + $this->conffiles(\@conffiles); + + # Read in the list of all files. + # Note that tar doesn't supply a leading `/', so we have to add that. + my @filelist; + if ($this->have_dpkg_deb) { + @filelist=map { chomp; s:\./::; "/$_" } + `dpkg-deb --fsys-tarfile $file | tar tf -`; + } + else { + @filelist=map { chomp; s:\./::; "/$_" } + `ar p $file data.tar.gz | tar tzf -`; + } + $this->filelist(\@filelist); + + # Read in the scripts, if any. + foreach my $field (qw{postinst postrm preinst prerm}) { + if ($this->have_dpkg_deb) { + $this->$field(`dpkg-deb --info $file $field 2>/dev/null`); + } + else { + $this->$field(`ar p $file control.tar.gz | tar Oxzf - $field 2>/dev/null`); + } + } + + return 1; +} + +=item unpack + +Implment the unpack method to unpack a deb file. + +=cut + +sub unpack { + my $this=shift; + $this->SUPER::unpack(@_); + + if ($this->have_dpkg_deb) { + system("dpkg-deb -x $file ".$this->unpacked_tree) && + die "Unpacking of `$file' failed: $!"; + } + else { + system ("ar p $file data.tar.gz | (cd ".$this->unpacked_tree."; tar zxpf -)") && + die "Unpacking of `$file' failed: $!"; + } + + return 1; +} + +=back + +=head1 AUTHOR + +Joey Hess + +=cut + +1 diff --git a/Alien/Package/Rpm.pm b/Alien/Package/Rpm.pm new file mode 100644 index 0000000..dbd228b --- /dev/null +++ b/Alien/Package/Rpm.pm @@ -0,0 +1,154 @@ +#!/usr/bin/perl -w + +=head1 NAME + +Alien::Package::Rpm - an object that represents a rpm package + +=cut + +package Alien::Package::Rpm; +use strict; +use Alien::Package; # perlbug +use base qw(Alien::Package); + +=head1 DESCRIPTION + +This is an object class that represents a rpm package. It is derived from +Alien::Package. + +=head1 FIELDS + +=over 4 + +=item prefixes + +Relocatable rpm packages have a prefixes field. + +=item changelogtext + +The text of the changelog + +=head1 METHODS + +=over 4 + +=item read_file + +Implement the read_file method to read a rpm file. + +=cut + +sub read_file { + my $this=shift; + $this->SUPER::read_file(@_); + my $file=$this->filename; + + my %fieldtrans=( + PREIN => 'preinst', + POSTIN => 'postinst', + PREUN => 'prerm', + POSTUN => 'postrm', + ); + + # These fields need no translation except case. + foreach (qw{name version release arch changelogtext summary + description copyright prefixes}) { + $fieldtrans{uc $_}=$_; + } + + # Use --queryformat to pull out all the fields we need. + foreach my $field (keys(%fieldtrans)) { + $_=`LANG=C rpm -qp $file --queryformat \%{$field}`; + $field=$fieldtrans{$field}; + $this->$field($_) if $_ ne '(none)'; + } + + # Fix up the scripts - they are always shell scripts, so make them so. + foreach my $field (qw{preinst postinst prerm postrm}) { + $this->$field("$!/bin/sh\n".$this->field); + } + + # Get the conffiles list. + $this->conffiles([map { chomp; $_ } `rpm -qcp $file`]); + + $this->copyright_extra(scalar `rpm -qpi $file`); + + # Get the filelist. + $this->filelist([map { chomp; $_ } `rpm -qpl $file`]); + + # Sanity check and sanitize fields. + unless (defined $this->summary) { + # Older rpms will have no summary, but will have a + # description. We'll take the 1st line out of the + # description, and use it for the summary. + $this->summary($this->description."\n")=~m/(.*?)\n/m; + + # Fallback. + if (! $this->summary) { + $this->summary('Converted RPM package'); + } + } + unless (defined $this->copyright) { + $this->copyright('unknown'); + } + unless (defined $this->description) { + $this->description($this->summary); + } + if (! defined $this->release || ! defined $this->version || + ! defined $this->name) { + die "Error querying rpm file"; + } + + $this->distribution("Red Hat"); + + return 1; +} + +=item arch + +Set/get arch field. When the arch field is set, some sanitizing is done +first. + +=cut + +sub arch { + my $this=shift; + return $this->{arch} unless @_; + my $arch=shift; + + if ($arch eq 1) { + $arch='i386'; + } + elsif ($arch eq 2) { + $arch='alpha'; + } + elsif ($arch eq 3) { + $arch='sparc'; + } + elsif ($arch eq 6) { + $arch='m68k'; + } + elsif ($arch eq 'noarch') { + $arch='all'; + } + elsif ($arch eq 'ppc') { + $arch='powerpc'; + } + + # Treat 486, 586, etc, as 386. + if ($arch =~ m/i\d86/) { + $arch='i386'; + } + + return $this->{arch}=$arch; +} + +=back + +=head1 AUTHOR + +Joey Hess + +=cut + +1