mirror of
https://github.com/Project-OSS-Revival/alien.git
synced 2026-04-24 14:00:17 +00:00
added, at the beginning of the oo rewrite
This commit is contained in:
joey
228
Alien/Package.pm
Normal file
228
Alien/Package.pm
Normal file
@@ -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
|
||||
188
Alien/Package/Deb.pm
Normal file
188
Alien/Package/Deb.pm
Normal file
@@ -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
|
||||
154
Alien/Package/Rpm.pm
Normal file
154
Alien/Package/Rpm.pm
Normal file
@@ -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
|
||||
Reference in New Issue
Block a user