added, at the beginning of the oo rewrite

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 <joey@kitenet.net>
+
+=cut
+
+1

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 <joey@kitenet.net>
+
+=cut
+
+1

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 <joey@kitenet.net>
+
+=cut
+
+1