mlot/alien
1
0
Fork 0
mirror of https://github.com/Project-OSS-Revival/alien.git synced 2026-04-24 14:00:17 +00:00
Code Issues Packages Projects Releases Wiki Activity

alien (8.88) unstable; urgency=low

Browse Source 
* Ensure that version numbers begin with well, a number, when building a
    deb, otherwise dpkg-deb will refuse to build it.

# imported from the archive
This commit is contained in:
Joey Hess
2012-08-09 14:44:49 -04:00
commit f545de15f5
24 changed files with 6846 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

505
Alien/Package.pm Normal file
View File

@@ -0,0 +1,505 @@
#!/usr/bin/perl -w
=head1 NAME
Alien::Package - an object that represents a package
=cut
package Alien::Package;
use strict;
use vars qw($AUTOLOAD);
our $verbose=0;
=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
These fields are of course really just methods that all act similarly;
allowing a value to be passed in to set them, or simply returning the value
of the field if nothing is passed in. Child classes may override these
fields to process input data, or to format output data. The general rule is
that input data is modified to get things into a package-independant form,
which is how the data is stored in the fields. When the value of a field is
read, it too may be modified before it is returned, to change things into a
form more suitable for the particular type of package.
=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. Only dependencies that should exist on all
target distributions can be put in here though (ie: lsb).
=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 origformat
What format the package was originally in.
=item distribution
What distribution family the package originated from.
=item binary_info
Whatever the package's package tool says when told to display info about
the package.
=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 changelogtext
The text of the changelog
=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 usescripts
Only use the above scripts fields when generating the package if this is set
to a true value.
=item unpacked_tree
Points to a directory where the package has been unpacked.
=item owninfo
If set this will be a reference to a hash, with filename as key, that holds
ownership/group information for files that cannot be represented on the
filesystem. Typically that is because the owners or groups just don't exist
yet. It will be set at unpack time.
=item modeinfo
If set this will be a reference to a hash, with filename as key, that
holds mode information for setuid files that have an entry in owninfo.
It will be set at unpack time.
=back
=head1 METHODS
=over 4
=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 install
Simply installs a package file. The filename is passed.
This has to be overridden in child classes.
=cut
sub install {
my $this=shift;
}
=item test
Test a package file. The filename is passed, should return an array of lines
of test results. Child classses may implement this.
=cut
sub test {
my $this=shift;
return;
}
=item filename
Set/get the filename of the package the object represents.
When it is set, it performs a scan of the file, populating most other
fields with data from it.
(This is just a stub; child classes should override it to actually do
something.)
=cut
sub filename {
my $this=shift;
# set
if (@_) {
$this->{filename} = shift;
$this->scan;
}
return $this->{filename};
}
=item scripts
Returns a list of all non-empty maintainer scripts in the package.
=cut
sub scripts {
my $this=shift;
my @ret;
foreach my $s (qw{postinst postrm preinst prerm}) {
my $val=$this->$s;
push(@ret, $s) if defined $val && length $val;
}
return @ret;
}
=item scan
This method scans the file associated with an object, and populates as many
other fields as it can with data from it.
=cut
sub scan {
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;
$this->do("mkdir $workdir") or
die "unable to mkdir $workdir: $!";
# If the parent directory is suid/sgid, mkdir will make the root
# directory of the package inherit those bits. That is a bad thing,
# so explicitly force perms to 755.
$this->do("chmod 755 $workdir");
$this->unpacked_tree($workdir);
}
=item prep
This method causes the object to prepare a build tree to be used in
building the object. It expects that the unpack method has already been
called. It takes the tree generated by that method, and mangles it somehow,
to produce a suitable build tree.
(This is just a stub method that all child classes should override.)
=cut
sub prep {}
=item cleantree
This method should clean the unpacked_tree of any effects the prep and
build methods might have on it.
=cut
sub cleantree {}
=item revert
This method should ensure that the object is in the same state it was in
before the prep method was called.
=cut
sub revert {}
=item build
This method takes a prepped build tree, and simply builds a package from
it. It should put the package in the current directory, and should return
the filename of the generated package.
(This is just a stub method that all child classes should override.)
=cut
sub build {}
=item incrementrelease
This method should increment the release field of the package by
the specified number.
=cut
sub incrementrelease {
my $this=shift;
my $number=shift;
$^W=0; # Shut of possible "is not numeric" warning.
$this->release($this->release + $number);
$^W=1; # Re-enable warnings.
}
=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;
my $exitcode=$?;
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!";
}
if (-d $this->unpacked_tree) {
# Just in case some dir perms are too screwed up for
# rm to work and we're not running as root. NB: can't
# use xargs
$this->do('find', $this->unpacked_tree, '-type', 'd',
'-exec', 'chmod', '755', '{}', ';');
$this->do('rm', '-rf', $this->unpacked_tree)
or die "unable to delete temporary directory '".$this->unpacked_tree."': $!";
$this->unpacked_tree('');
}
$?=$exitcode;
}
=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 CLASS DATA
=over 4
=item $Alien::Package::verbose
If set to a nonzero value, the shell commands that are run should be output.
If set to a value greater than 1, any output of the commands should also be
output.
=back
=head1 CLASS METHODS
These methods can be called on either an object or on the class itself.
=cut
=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;
$this->$_(shift) while $_=shift; # run named parameters as methods
return $this;
}
=item checkfile
Pass it a filename, and it will return true if it looks like the file is
a package of the type handled by the class.
=cut
sub checkfile {
my $this=shift;
my $file=shift;
return ''; # children override this.
}
=item do
Runs a shell command. Is verbose or not depending on the value of
$Alien::Package::verbose. Returns true if the command succeeds,
false on failure.
=cut
sub do {
my $whatever=shift;
my @command=@_;
if ($Alien::Package::verbose) {
print "\t@command\n";
}
my $pid=fork;
if (!$pid) {
# child
if ($Alien::Package::verbose < 2) {
# just closing it won't do
open(STDOUT, ">/dev/null");
}
exec(@command);
exit 1;
}
else {
# parent
my $ret=(waitpid($pid, 0) > 0);
return ! $ret || ! $?;
}
}
=item runpipe
This is similar to backticks, but honors $Alien::Package::verbose, logging
the command run if asked to. The output of the command is returned.
The first parameter controls what to do on error. If it's true then any
errors from the command will be ignored (and $? will be set). If it's
false, errors will abort alien.
=cut
sub runpipe {
my $whatever=shift;
my $ignoreerror=shift;
my @command=@_;
if ($Alien::Package::verbose) {
print "\t@command\n";
}
if (wantarray) {
my @ret=`@command`;
die "Error executing \"@command\": $!" if ! $ignoreerror && $? ne 0;
if ($Alien::Package::verbose >= 2) {
print @ret;
}
return @ret;
}
else {
my $ret=`@command`;
die "Error executing \"@command\": $!" if ! $ignoreerror && $? ne 0;
if ($Alien::Package::verbose >= 2) {
print $ret."\n";
}
return $ret;
}
}
=back
=head1 AUTHOR
Joey Hess <joey@kitenet.net>
=cut
1

798
Alien/Package/Deb.pm Normal file
View File

@@ -0,0 +1,798 @@
#!/usr/bin/perl -w
=head1 NAME
Alien::Package::Deb - an object that represents a deb package
=cut
package Alien::Package::Deb;
use strict;
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.
=item dirtrans
After the build stage, set to a hash reference of the directories we moved
files from and to, so these moves can be reverted in the cleantree stage.
=item fixperms
If this is set to true, the generated debian/rules will run dh_fixperms.
=back
=head1 METHODS
=over 4
=item init
Sets have_dpkg_deb if dpkg-deb is in the path. I prefer to use dpkg-deb,
if it is available since it is a lot more future-proof.
=cut
sub _inpath {
my $this=shift;
my $program=shift;
foreach (split(/:/,$ENV{PATH})) {
if (-x "$_/$program") {
return 1;
}
}
return '';
}
sub init {
my $this=shift;
$this->SUPER::init(@_);
$this->have_dpkg_deb($this->_inpath('dpkg-deb'));
}
=item checkfile
Detect deb files by their extention.
=cut
sub checkfile {
my $this=shift;
my $file=shift;
return $file =~ m/.*\.u?deb$/;
}
=item install
Install a deb with dpkg. Pass in the filename of the deb to install.
=cut
sub install {
my $this=shift;
my $deb=shift;
my $v=$Alien::Package::verbose;
$Alien::Package::verbose=2;
$this->do("dpkg", "--no-force-overwrite", "-i", $deb)
or die "Unable to install";
$Alien::Package::verbose=$v;
}
=item test
Test a deb with lintian. Pass in the filename of the deb to test.
=cut
sub test {
my $this=shift;
my $deb=shift;
if ($this->_inpath("lintian")) {
# Ignore some lintian warnings that don't matter for
# aliened packages.
return map { s/\n//; $_ }
grep {
! /unknown-section alien/
} $this->runpipe(1, "lintian '$deb'");
}
else {
return "lintian not available, so not testing";
}
}
=item getcontrolfile
Helper method. Pass it the name of a control file, and it will pull it out
of the deb and return it.
=cut
sub getcontrolfile {
my $this=shift;
my $controlfile=shift;
my $file=$this->filename;
if ($this->have_dpkg_deb) {
return $this->runpipe(1, "dpkg-deb --info '$file' $controlfile 2>/dev/null");
}
else {
# Solaris tar doesn't support O
sub tar_out {
my $file = shift;
return "(mkdir /tmp/tar_out.$$ &&".
" cd /tmp/tar_out.$$ &&".
" tar xf - './$file' &&".
" cat '$file'; cd /; rm -rf /tmp/tar_out.$$)";
}
my $getcontrol = "ar -p '$file' control.tar.gz | gzip -dc | ".tar_out($controlfile)." 2>/dev/null";
return $this->runpipe(1, $getcontrol);
}
}
=item scan
Implement the scan method to read a deb file.
=cut
sub scan {
my $this=shift;
$this->SUPER::scan(@_);
my $file=$this->filename;
my @control=$this->getcontrolfile('control');
die "Control file couldn't be read!"
if @control == 0;
# Parse control file and extract fields. Use a translation table
# to map between the debian names and the internal field names,
# which more closely resemble those used by rpm (for historical
# reasons; TODO: change to deb style names).
my $description='';
my $field;
my %fieldtrans=(
Package => 'name',
Version => 'version',
Architecture => 'arch',
Maintainer => 'maintainer',
Section => 'group',
Description => 'summary',
);
for (my $i=0; $i <= $#control; $i++) {
$_ = $control[$i];
chomp;
if (/^(\w.*?):\s+(.*)/) {
# Really old debs might have oddly capitalized
# field names.
$field=ucfirst(lc($1));
if (exists $fieldtrans{$field}) {
$field=$fieldtrans{$field};
$this->$field($2);
}
}
elsif (/^ / && $field eq 'summary') {
# Handle extended description.
s/^ //g;
$_="" if $_ eq ".";
$description.="$_\n";
}
}
$this->description($description);
$this->copyright("see /usr/share/doc/".$this->name."/copyright");
$this->group("unknown") if ! $this->group;
$this->distribution("Debian");
$this->origformat("deb");
$this->binary_info(scalar $this->getcontrolfile('control'));
# Read in the list of conffiles, if any.
my @conffiles;
@conffiles=map { chomp; $_ } $this->getcontrolfile('conffiles');
$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:\./::; "/$_" }
$this->runpipe(0, "dpkg-deb --fsys-tarfile '$file' | tar tf -");
}
else {
@filelist=map { chomp; s:\./::; "/$_" }
$this->runpipe(0, "ar -p '$file' data.tar.gz | gzip -dc | tar tf -");
}
$this->filelist(\@filelist);
# Read in the scripts, if any.
foreach my $field (qw{postinst postrm preinst prerm}) {
$this->$field(scalar $this->getcontrolfile($field));
}
return 1;
}
=item unpack
Implement the unpack method to unpack a deb file.
=cut
sub unpack {
my $this=shift;
$this->SUPER::unpack(@_);
my $file=$this->filename;
if ($this->have_dpkg_deb) {
$this->do("dpkg-deb", "-x", $file, $this->unpacked_tree)
or die "Unpacking of '$file' failed: $!";
}
else {
$this->do("ar -p $file data.tar.gz | gzip -dc | (cd ".$this->unpacked_tree."; tar xpf -)")
or die "Unpacking of '$file' failed: $!";
}
return 1;
}
=item getpatch
This method tries to find a patch file to use in the prep stage. If it
finds one, it returns it. Pass in a list of directories to search for
patches in.
=cut
sub getpatch {
my $this=shift;
my $anypatch=shift;
my @patches;
foreach my $dir (@_) {
push @patches, glob("$dir/".$this->name."_".$this->version."-".$this->release."*.diff.gz");
}
if (! @patches) {
# Try not matching the release, see if that helps.
foreach my $dir (@_) {
push @patches,glob("$dir/".$this->name."_".$this->version."*.diff.gz");
}
if (@patches && $anypatch) {
# Fallback to anything that matches the name.
foreach my $dir (@_) {
push @patches,glob("$dir/".$this->name."_*.diff.gz");
}
}
}
# If we ended up with multiple matches, return the first.
return $patches[0];
}
=item prep
Adds a populated debian directory the unpacked package tree, making it
ready for building. This can either be done automatically, or via a patch
file.
=cut
sub prep {
my $this=shift;
my $dir=$this->unpacked_tree || die "The package must be unpacked first!";
$this->do("mkdir $dir/debian") ||
die "mkdir $dir/debian failed: $!";
# Use a patch file to debianize?
if (defined $this->patchfile) {
# The -f passed to zcat makes it pass uncompressed files
# through without error.
$this->do("zcat -f ".$this->patchfile." | (cd $dir; patch -p1)")
or die "patch error: $!";
# Look for .rej files.
die "patch failed with .rej files; giving up"
if $this->runpipe(1, "find '$dir' -name \"*.rej\"");
$this->do('find', '.', '-name', '*.orig', '-exec', 'rm', '{}', ';');
$this->do("chmod", 755, "$dir/debian/rules");
# It's possible that the patch file changes the debian
# release or version. Parse changelog to detect that.
open (my $changelog, "<$dir/debian/changelog") || return;
my $line=<$changelog>;
if ($line=~/^[^ ]+\s+\(([^)]+)\)\s/) {
my $version=$1;
$version=~s/\s+//; # ensure no whitespace
if ($version=~/(.*)-(.*)/) {
$version=$1;
$this->release($2);
}
$this->version($1);
}
close $changelog;
return;
}
# Automatic debianization.
# Changelog file.
open (OUT, ">$dir/debian/changelog") || die "$dir/debian/changelog: $!";
print OUT $this->name." (".$this->version."-".$this->release.") experimental; urgency=low\n";
print OUT "\n";
print OUT " * Converted from .".$this->origformat." format to .deb by alien version $Alien::Version\n";
print OUT " \n";
if (defined $this->changelogtext) {
my $ct=$this->changelogtext;
$ct=~s/^/ /gm;
print OUT $ct."\n";
}
print OUT "\n";
print OUT " -- ".$this->username." <".$this->email."> ".$this->date."\n";
close OUT;
# Control file.
open (OUT, ">$dir/debian/control") || die "$dir/debian/control: $!";
print OUT "Source: ".$this->name."\n";
print OUT "Section: alien\n";
print OUT "Priority: extra\n";
print OUT "Maintainer: ".$this->username." <".$this->email.">\n";
print OUT "\n";
print OUT "Package: ".$this->name."\n";
print OUT "Architecture: ".$this->arch."\n";
if (defined $this->depends) {
print OUT "Depends: ".join(", ", "\${shlibs:Depends}", $this->depends)."\n";
}
else {
print OUT "Depends: \${shlibs:Depends}\n";
}
print OUT "Description: ".$this->summary."\n";
print OUT $this->description."\n";
close OUT;
# Copyright file.
open (OUT, ">$dir/debian/copyright") || die "$dir/debian/copyright: $!";
print OUT "This package was debianized by the alien program by converting\n";
print OUT "a binary .".$this->origformat." package on ".$this->date."\n";
print OUT "\n";
print OUT "Copyright: ".$this->copyright."\n";
print OUT "\n";
print OUT "Information from the binary package:\n";
print OUT $this->binary_info."\n";
close OUT;
# Conffiles, if any. Note that debhelper takes care of files in /etc.
my @conffiles=grep { $_ !~ /^\/etc/ } @{$this->conffiles};
if (@conffiles) {
open (OUT, ">$dir/debian/conffiles") || die "$dir/debian/conffiles: $!";
print OUT join("\n", @conffiles)."\n";
close OUT;
}
# Use debhelper v7
open (OUT, ">$dir/debian/compat") || die "$dir/debian/compat: $!";
print OUT "7\n";
close OUT;
# A minimal rules file.
open (OUT, ">$dir/debian/rules") || die "$dir/debian/rules: $!";
my $fixpermscomment = $this->fixperms ? "" : "#";
print OUT << "EOF";
#!/usr/bin/make -f
# debian/rules for alien
PACKAGE=\$(shell dh_listpackages)
build:
dh_testdir
clean:
dh_testdir
dh_testroot
dh_clean -d
binary-indep: build
binary-arch: build
dh_testdir
dh_testroot
dh_prep
dh_installdirs
dh_installdocs
dh_installchangelogs
# Copy the packages's files.
find . -maxdepth 1 -mindepth 1 -not -name debian -print0 | \\
xargs -0 -r -i cp -a {} debian/\$(PACKAGE)
#
# If you need to move files around in debian/\$(PACKAGE) or do some
# binary patching, do it here
#
# This has been known to break on some wacky binaries.
# dh_strip
dh_compress
$fixpermscomment dh_fixperms
dh_makeshlibs
dh_installdeb
-dh_shlibdeps
dh_gencontrol
dh_md5sums
dh_builddeb
binary: binary-indep binary-arch
.PHONY: build clean binary-indep binary-arch binary
EOF
close OUT;
$this->do("chmod", 755, "$dir/debian/rules");
if ($this->usescripts) {
foreach my $script (qw{postinst postrm preinst prerm}) {
$this->savescript($script, $this->$script());
}
}
else {
# There may be a postinst with permissions fixups even when
# scripts are disabled.
$this->savescript("postinst", undef);
}
my %dirtrans=( # Note: no trailing slashes on these directory names!
# Move files to FHS-compliant locations, if possible.
'/usr/man' => '/usr/share/man',
'/usr/info' => '/usr/share/info',
'/usr/doc' => '/usr/share/doc',
);
foreach my $olddir (keys %dirtrans) {
if (-d "$dir/$olddir" && ! -e "$dir/$dirtrans{$olddir}") {
# Ignore failure..
my ($dirbase)=$dirtrans{$olddir}=~/(.*)\//;
$this->do("install", "-d", "$dir/$dirbase");
$this->do("mv", "$dir/$olddir", "$dir/$dirtrans{$olddir}");
if (-d "$dir/$olddir") {
$this->do("rmdir", "-p", "$dir/$olddir");
}
}
else {
delete $dirtrans{$olddir};
}
}
$this->dirtrans(\%dirtrans); # store for cleantree
}
=item build
Build a deb.
=cut
sub build {
my $this=shift;
# Detect architecture mismatch and abort with a comprehensible
# error message.
my $arch=$this->arch;
if ($arch ne 'all') {
my $ret=system("dpkg-architecture", "-i".$arch);
if ($ret != 0) {
die $this->filename." is for architecture ".$this->arch." ; the package cannot be built on this system"."\n";
}
}
chdir $this->unpacked_tree;
my $log=$this->runpipe(1, "debian/rules binary 2>&1");
chdir "..";
my $err=$?;
if ($err) {
if (! defined $log) {
die "Package build failed; could not run generated debian/rules file.\n";
}
die "Package build failed. Here's the log:\n", $log;
}
return $this->name."_".$this->version."-".$this->release."_".$this->arch.".deb";
}
=item cleantree
Delete the entire debian/ directory.
=cut
sub cleantree {
my $this=shift;
my $dir=$this->unpacked_tree || die "The package must be unpacked first!";
my %dirtrans=%{$this->dirtrans};
foreach my $olddir (keys %dirtrans) {
if (! -e "$dir/$olddir" && -d "$dir/$dirtrans{$olddir}") {
# Ignore failure.. (should I?)
my ($dirbase)=$dir=~/(.*)\//;
$this->do("install", "-d", "$dir/$dirbase");
$this->do("mv", "$dir/$dirtrans{$olddir}", "$dir/$olddir");
if (-d "$dir/$dirtrans{$olddir}") {
$this->do("rmdir", "-p", "$dir/$dirtrans{$olddir}");
}
}
}
$this->do("rm", "-rf", "$dir/debian");
}
=item package
Set/get package name.
Always returns the packge name in lowercase with all invalid characters
rmoved. The name is however, stored unchanged.
=cut
sub name {
my $this=shift;
# set
$this->{name} = shift if @_;
return unless defined wantarray; # optimization
# get
$_=lc($this->{name});
tr/_/-/;
s/[^a-z0-9-\.\+]//g;
return $_;
}
=item version
Set/get package version.
When the version is set, it will be stripped of any epoch. If there is a
release, the release will be stripped away and used to set the release
field as a side effect. Otherwise, the release will be set to 1.
More sanitization of the version is done when the field is retrieved, to
make sure it is a valid debian version field.
=cut
sub version {
my $this=shift;
# set
if (@_) {
my $version=shift;
if ($version =~ /(.+)-(.+)/) {
$version=$1;
$this->release($2);
}
else {
$this->release(1);
}
# Kill epochs.
$version=~s/^\d+://;
$this->{version}=$version;
}
# get
return unless defined wantarray; # optimization
$_=$this->{version};
# Make sure the version contains a digit at the start, as required
# by dpkg-deb.
unless (/^[0-9]/) {
$_="0".$_;
}
# filter out some characters not allowed in debian versions
s/[^-.+~:A-Za-z0-9]//g; # see lib/dpkg/parsehelp.c parseversion
return $_;
}
=item release
Set/get package release.
Always returns a sanitized release version. The release is however, stored
unchanged.
=cut
sub release {
my $this=shift;
# set
$this->{release} = shift if @_;
# get
return unless defined wantarray; # optimization
$_=$this->{release};
# Make sure the release contains digets.
return $_."-1" unless /[0-9]/;
return $_;
}
=item description
Set/get description
Although the description is stored internally unchanged, this will always
return a sanitized form of it that is compliant with Debian standards.
=cut
sub description {
my $this=shift;
# set
$this->{description} = shift if @_;
# get
return unless defined wantarray; # optimization
my $ret='';
foreach (split /\n/,$this->{description}) {
s/\t/ /g; # change tabs to spaces
s/\s+$//g; # remove trailing whitespace
$_="." if $_ eq ''; # empty lines become dots
$ret.=" $_\n";
}
$ret=~s/^\n+//g; # kill leading blank lines
$ret.=" .\n" if length $ret;
$ret.=" (Converted from a ".$this->origformat." package by alien version $Alien::Version.)";
return $ret;
}
=item date
Returns the date, in rfc822 format.
=cut
sub date {
my $this=shift;
my $date=$this->runpipe(1, "date -R");
chomp $date;
if (!$date) {
die "date -R did not return a valid result.";
}
return $date;
}
=item email
Returns an email address for the current user.
=cut
sub email {
my $this=shift;
return $ENV{EMAIL} if exists $ENV{EMAIL};
my $login = getlogin || (getpwuid($<))[0] || $ENV{USER};
my $mailname='';
if (open (MAILNAME,"</etc/mailname")) {
$mailname=<MAILNAME>;
if (defined $mailname) {
chomp $mailname;
}
close MAILNAME;
}
if (!$mailname) {
$mailname=$this->runpipe(1, "hostname");
chomp $mailname;
}
return "$login\@$mailname";
}
=item username
Returns the user name of the real uid.
=cut
sub username {
my $this=shift;
my $username;
my $login = getlogin || (getpwuid($<))[0] || $ENV{USER};
(undef, undef, undef, undef, undef, undef, $username) = getpwnam($login);
# Remove GECOS fields from username.
$username=~s/,.*//g;
# The ultimate fallback.
if ($username eq '') {
$username=$login;
}
return $username;
}
=item savescript
Saves script to debian directory.
=cut
sub savescript {
my $this=shift;
my $script=shift;
my $data=shift;
if ($script eq 'postinst') {
$data=$this->gen_postinst($data);
}
my $dir=$this->unpacked_tree;
return unless defined $data;
next if $data =~ m/^\s*$/;
open (OUT,">$dir/debian/$script") ||
die "$dir/debian/$script: $!";
print OUT $data;
close OUT;
}
=item gen_postinst
Modifies or creates a postinst. This may include generated shell code to set
owners and groups from the owninfo field, and update modes from the modeinfo
field.
=cut
sub gen_postinst {
my $this=shift;
my $postinst=shift;
my $owninfo = $this->owninfo;
my $modeinfo = $this->modeinfo;
return $postinst unless ref $owninfo && %$owninfo;
# If there is no postinst, let's make one up..
$postinst="#!/bin/sh\n" unless defined $postinst && length $postinst;
my ($firstline, $rest)=split(/\n/, $postinst, 2);
if ($firstline !~ m/^#!\s*\/bin\/(ba)?sh/) {
print STDERR "warning: unable to add ownership fixup code to postinst as the postinst is not a shell script!\n";
return $postinst;
}
my $permscript="# alien added permissions fixup code\n";
foreach my $file (sort keys %$owninfo) {
my $quotedfile=$file;
$quotedfile=~s/'/'"'"'/g; # no single quotes in single quotes..
$permscript.="chown '".$owninfo->{$file}."' '$quotedfile'\n";
$permscript.="chmod '".$modeinfo->{$file}."' '$quotedfile'\n"
if (defined $modeinfo->{$file});
}
return "$firstline\n$permscript\n$rest";
}
=back
=head1 AUTHOR
Joey Hess <joey@kitenet.net>
=cut
1

132
Alien/Package/Lsb.pm Normal file
View File

@@ -0,0 +1,132 @@
#!/usr/bin/perl -w
=head1 NAME
Alien::Package::Lsb - an object that represents a lsb package
=cut
package Alien::Package::Lsb;
use strict;
use base qw(Alien::Package::Rpm);
=head1 DESCRIPTION
This is an object class that represents a lsb package. It is derived from
Alien::Package::Rpm.
=head1 METHODS
=over 4
=item checkfile
Lsb files are rpm's with a lsb- prefix, that depend on a package called 'lsb'
and nothing else.
=cut
sub checkfile {
my $this=shift;
my $file=shift;
return unless $file =~ m/^lsb-.*\.rpm$/;
my @deps=$this->runpipe(1, "LANG=C rpm -qp -R '$file'");
return 1 if grep { s/\s+//g; $_ eq 'lsb' } @deps;
return;
}
=item scan
Uses the parent scan method to read the file. lsb is added to the depends.
=cut
sub scan {
my $this=shift;
$this->SUPER::scan(@_);
$this->distribution("Linux Standard Base");
$this->origformat("lsb");
$this->depends("lsb");
# Converting from lsb, so the scripts should be portable and safe.
# Haha.
$this->usescripts(1);
return 1;
}
=item prep
The parent's prep method is used to generate the spec file. First though,
the package's name is munged to make it lsb compliant (sorta) and lsb is added
to its dependencies.
=cut
sub prep {
my $this=shift;
$this->_orig_name($this->name);
if ($this->name !~ /^lsb-/) {
$this->name("lsb-".$this->name);
}
$this->_orig_depends($this->depends);
$this->depends("lsb");
# Always include scripts when generating lsb package.
$this->_orig_usescripts($this->usescripts);
$this->usescripts(1);
$this->SUPER::prep(@_);
}
=item revert
Undo the changes made by prep.
=cut
sub revert {
my $this=shift;
$this->name($this->_orig_name);
$this->depends($this->_orig_depends);
$this->usescripts($this->_orig_usescripts);
$this->SUPER::revert(@_);
}
=item build
Uses the parent's build method. If a lsb-rpmbuild is available, uses it to
build the package.
=cut
sub build {
my $this=shift;
my $buildcmd=shift || 'rpmbuild';
foreach (split(/:/,$ENV{PATH})) {
if (-x "$_/lsb-rpmbuild") {
$buildcmd='lsb-rpmbuild';
last;
}
}
$this->SUPER::build($buildcmd);
}
=item incrementrelease
LSB package versions are not changed.
=cut
sub incrementrelease {}
=back
=head1 AUTHOR
Joey Hess <joey@kitenet.net>
=cut
1

338
Alien/Package/Pkg.pm Normal file
View File

@@ -0,0 +1,338 @@
#!/usr/bin/perl -w
=head1 NAME
Alien::Package::Pkg - an object that represents a Solaris pkg package
=cut
package Alien::Package::Pkg;
use strict;
use base qw(Alien::Package);
=head1 DESCRIPTION
This is an object class that represents a pkg package, as used in Solaris.
It is derived from Alien::Package.
=head1 CLASS DATA
=over 4
=item scripttrans
Translation table between canoical script names and the names used in
pkg's.
=cut
use constant scripttrans => {
postinst => 'postinstall',
preinst => 'preinstall',
};
=back
=head1 METHODS
=over 4
=item init
This class needs the Solaris pkginfo and kgtrans tools to work.
=cut
sub init {
foreach (qw(/usr/bin/pkginfo /usr/bin/pkgtrans)) {
-x || die "$_ is needed to use ".__PACKAGE__."\n";
}
}
=item converted_name
Convert name from something debian-like to something that the
Solaris constraints will handle (i.e. 9 chars max).
=cut
sub converted_name {
my $this = shift;
my $prefix = "ALN";
my $name = $this->name;
for ($name) { # A Short list to start us off.
# Still, this is risky since we need
# unique names.
s/^lib/l/;
s/-perl$/p/;
s/^perl-/pl/;
}
$name = substr($name, 0, 9);
return $prefix.$name;
}
=item checkfile
Detect pkg files by their contents.
=cut
sub checkfile {
my $this=shift;
my $file=shift;
open(F, $file) || die "Couldn't open $file: $!\n";
my $line = <F>;
close F;
return unless defined $line;
if($line =~ "# PaCkAgE DaTaStReAm") {
return 1;
}
}
=item install
Install a pkg with pkgadd. Pass in the filename of the pkg to install.
=cut
sub install {
my $this=shift;
my $pkg=shift;
if (-x "/usr/sbin/pkgadd") {
my $v=$Alien::Package::verbose;
$Alien::Package::verbose=2;
$this->do("/usr/sbin/pkgadd", "-d .", "$pkg")
or die "Unable to install";
$Alien::Package::verbose=$v;
}
else {
die "Sorry, I cannot install the generated .pkg file because /usr/sbin/pkgadd is not present.\n";
}
}
=item scan
Scan a pkg file for fields.
=cut
sub scan {
my $this=shift;
$this->SUPER::scan(@_);
my $file=$this->filename;
my $tdir="pkg-scan-tmp.$$";
$this->do("mkdir", $tdir) || die "Error making $tdir: $!\n";
my $pkgname;
if (-x "/usr/bin/pkginfo" && -x "/usr/bin/pkgtrans") {
my $pkginfo;
open(INFO, "/usr/bin/pkginfo -d $file|")
|| die "Couldn't open pkginfo: $!\n";
$_ = <INFO>;
($pkgname) = /\S+\s+(\S+)/;
close INFO;
# Extract the files
$this->do("/usr/bin/pkgtrans -i $file $tdir $pkgname")
|| die "Error running pkgtrans: $!\n";
open(INFO, "$tdir/$pkgname/pkginfo")
|| die "Couldn't open pkgparam: $!\n";
my ($key, $value);
while (<INFO>) {
if (/^([^=]+)=(.*)$/) {
$key = $1;
$value = $2;
}
else {
$value = $_;
}
push @{$pkginfo->{$key}}, $value
}
close INFO;
$file =~ m,([^/]+)-[^-]+(?:.pkg)$,;
$this->name($1);
$this->arch($pkginfo->{ARCH}->[0]);
$this->summary("Converted Solaris pkg package");
$this->description(join("", @{[$pkginfo->{DESC} || "."]}));
$this->version($pkginfo->{VERSION}->[0]);
$this->distribution("Solaris");
$this->group("unknown"); # *** FIXME
$this->origformat('pkg');
$this->changelogtext('');
$this->binary_info('unknown'); # *** FIXME
if (-f "$tdir/$pkgname/copyright") {
open (COPYRIGHT, "$file/install/copyright")
|| die "Couldn't open copyright: $!\n";
$this->copyright(join("\n",<COPYRIGHT>));
close(COPYRIGHT);
}
else {
$this->copyright("unknown");
}
}
# Now figure out the conffiles. Assume anything in etc/ is a
# conffile.
my @conffiles;
my @filelist;
my @scripts;
open (FILELIST,"$tdir/$pkgname/pkgmap") ||
die "getting filelist ($file/pkgmap): $!";
while (<FILELIST>) {
if (m,^1 f \S+ etc/([^\s=]+),) {
push @conffiles, "/etc/$1";
}
if (m,^1 [fd] \S+ ([^\s=]+),) {
push @filelist, $1;
}
if (m,^1 i (\S+),) {
push @scripts, $1;
}
}
$this->filelist(\@filelist);
$this->conffiles(\@conffiles);
# Now get the scripts.
foreach my $script (keys %{scripttrans()}) {
$this->$script(scripttrans()->{$script})
if -e "$file/".scripttrans()->{$script};
}
$this->do("rm -rf $tdir");
return 1;
}
=item unpack
Unpack pkg.
=cut
sub unpack {
my $this=shift;
$this->SUPER::unpack(@_);
my $file=$this->filename;
my $pkgname;
open(INFO, "/usr/bin/pkginfo -d $file|")
|| die "Couldn't open pkginfo: $!\n";
$_ = <INFO>;
($pkgname) = /\S+\s+(\S+)/;
close INFO;
if (-x "/usr/bin/pkgtrans") {
my $workdir = $this->name."-".$this->version;;
$this->do("mkdir", $workdir) || die "unable to mkdir $workdir: $!\n";
$this->do("/usr/bin/pkgtrans $file $workdir $pkgname")
|| die "unable to extract $file: $!\n";
rename("$workdir/$pkgname", "$ {workdir}_1")
|| die "unable rename $workdir/$pkgname: $!\n";
rmdir $workdir;
rename("$ {workdir}_1", $workdir)
|| die "unable to rename $ {workdir}_1: $!\n";
$this->unpacked_tree($workdir);
}
}
=item prep
Adds a populated install directory to the build tree.
=cut
sub prep {
my $this=shift;
my $dir=$this->unpacked_tree || die "The package must be unpacked first!";
# opendir(DIR, $this->unpacked_tree);
# my @sub = map {$this->unpacked_tree . "$_"}
# grep {/^\./} readdir DIR;
# closedir DIR;
$this->do("cd $dir; find . -print | sed -e '/.\\/prototype\$/d' | pkgproto > ./prototype")
|| die "error during pkgproto: $!\n";
open(PKGPROTO, ">>$dir/prototype")
|| die "error appending to prototype: $!\n";
open(PKGINFO, ">$dir/pkginfo")
|| die "error creating pkginfo: $!\n";
print PKGINFO qq{PKG="}.$this->converted_name.qq{"\n};
print PKGINFO qq{NAME="}.$this->name.qq{"\n};
print PKGINFO qq{ARCH="}.$this->arch.qq{"\n};
print PKGINFO qq{VERSION="}.$this->version.qq{"\n};
print PKGINFO qq{CATEGORY="application"\n};
print PKGINFO qq{VENDOR="Alien-converted package"\n};
print PKGINFO qq{EMAIL=\n};
print PKGINFO qq{PSTAMP=alien\n};
print PKGINFO qq{MAXINST=1000\n};
print PKGINFO qq{BASEDIR="/"\n};
print PKGINFO qq{CLASSES="none"\n};
print PKGINFO qq{DESC="}.$this->description.qq{"\n};
close PKGINFO;
print PKGPROTO "i pkginfo=./pkginfo\n";
$this->do("mkdir", "$dir/install") || die "unable to mkdir $dir/install: $!";
open(COPYRIGHT, ">$dir/install/copyright")
|| die "error creating copyright: $!\n";
print COPYRIGHT $this->copyright;
close COPYRIGHT;
print PKGPROTO "i copyright=./install/copyright\n";
foreach my $script (keys %{scripttrans()}) {
my $data=$this->$script();
my $out=$this->unpacked_tree."/install/".${scripttrans()}{$script};
next if ! defined $data || $data =~ m/^\s*$/;
open (OUT, ">$out") || die "$out: $!";
print OUT $data;
close OUT;
$this->do("chmod", 755, $out);
print PKGPROTO "i $script=$out\n";
}
close PKGPROTO;
}
=item build
Build a pkg.
=cut
sub build {
my $this = shift;
my $dir = $this->unpacked_tree;
$this->do("cd $dir; pkgmk -r / -d .")
|| die "Error during pkgmk: $!\n";
my $pkgname = $this->converted_name;
my $name = $this->name."-".$this->version.".pkg";
$this->do("pkgtrans $dir $name $pkgname")
|| die "Error during pkgtrans: $!\n";
$this->do("mv", "$dir/$name", $name);
return $name;
}
=back
=head1 AUTHOR
Mark Hershberger <mah@everybody.org>
=cut
1

644
Alien/Package/Rpm.pm Normal file
View File

@@ -0,0 +1,644 @@
#!/usr/bin/perl -w
=head1 NAME
Alien::Package::Rpm - an object that represents a rpm package
=cut
package Alien::Package::Rpm;
use strict;
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.
=back
=head1 METHODS
=over 4
=item checkfile
Detect rpm files by their extention.
=cut
sub checkfile {
my $this=shift;
my $file=shift;
return $file =~ m/.*\.rpm$/;
}
=item install
Install a rpm. If RPMINSTALLOPT is set in the environement, the options in
it are passed to rpm on its command line.
=cut
sub install {
my $this=shift;
my $rpm=shift;
my $v=$Alien::Package::verbose;
$Alien::Package::verbose=2;
$this->do("rpm -ivh ".(exists $ENV{RPMINSTALLOPT} ? $ENV{RPMINSTALLOPT} : '').$rpm)
or die "Unable to install";
$Alien::Package::verbose=$v;
}
=item scan
Implement the scan method to read a rpm file.
=cut
sub scan {
my $this=shift;
$this->SUPER::scan(@_);
my $file=$this->filename;
my %fieldtrans=(
PREIN => 'preinst',
POSTIN => 'postinst',
PREUN => 'prerm',
POSTUN => 'postrm',
LICENSE => 'copyright',
);
# Use --queryformat to pull out all the fields we need.
foreach my $field (qw{NAME VERSION RELEASE ARCH CHANGELOGTEXT
SUMMARY DESCRIPTION PREFIXES},
keys(%fieldtrans)) {
my $value=$this->runpipe(0, "LANG=C rpm -qp --queryformat \%{$field} '$file'");
next if $? || $value eq '(none)';
my $key;
if (exists $fieldtrans{$field}) {
$key=$fieldtrans{$field};
}
else {
$key=lc($field);
}
$this->$key($value);
}
# Get the conffiles list.
$this->conffiles([map { chomp; $_ } $this->runpipe(0, "LANG=C rpm -qcp '$file'")]);
if (defined $this->conffiles->[0] &&
$this->conffiles->[0] eq '(contains no files)') {
$this->conffiles([]);
}
$this->binary_info(scalar $this->runpipe(0, "rpm -qpi '$file'"));
# Get the filelist.
$this->filelist([map { chomp; $_ } $this->runpipe(0, "LANG=C rpm -qpl '$file'")]);
if (defined $this->filelist->[0] &&
$this->filelist->[0] eq '(contains no files)') {
$this->filelist([]);
}
# 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->description) {
$this->description($this->summary);
}
unless (defined $this->copyright) {
# Older rpms have no licence tag, but have a copyright.
$this->copyright($this->runpipe(0, "LANG=C rpm -qp --queryformat \%{COPYRIGHT} '$file'"));
# Fallback.
if (! $this->copyright) {
$this->copyright('unknown');
}
}
if (! defined $this->release || ! defined $this->version ||
! defined $this->name) {
die "Error querying rpm file";
}
$this->distribution("Red Hat");
$this->origformat("rpm");
return 1;
}
=item unpack
Implement the unpack method to unpack a rpm file. This is a little nasty
because it has to handle relocatable rpms and has to do a bit of
permissions fixing as well.
=cut
sub unpack {
my $this=shift;
$this->SUPER::unpack(@_);
my $workdir=$this->unpacked_tree;
# Check if we need to use lzma to uncompress the cpio archive
my $decomp='';
if ($this->do("rpm2cpio ".$this->filename." | lzma -t -q > /dev/null 2>&1")) {
$decomp = 'lzma -d -q |';
}
$this->do("rpm2cpio ".$this->filename." | (cd $workdir; $decomp cpio --extract --make-directories --no-absolute-filenames --preserve-modification-time) 2>&1")
or die "Unpacking of '".$this->filename."' failed";
# cpio does not necessarily store all parent directories in an
# archive, and so some directories, if it has to make them and has
# no permission info, will come out with some random permissions.
# Find those directories and make them mode 755, which is more
# reasonable.
my %seenfiles;
open (RPMLIST, "rpm2cpio ".$this->filename." | $decomp cpio -it --quiet |")
or die "File list of '".$this->filename."' failed";
while (<RPMLIST>) {
chomp;
$seenfiles{$_}=1;
}
close RPMLIST;
foreach my $file (`cd $workdir; find ./`) {
chomp $file;
if (! $seenfiles{$file} && -d "$workdir/$file" && ! -l "$workdir/$file") {
$this->do("chmod 755 $workdir/$file");
}
}
# If the package is relocatable. We'd like to move it to be under
# the $this->prefixes directory. However, it's possible that that
# directory is in the package - it seems some rpm's are marked as
# relocatable and unpack already in the directory they can relocate
# to, while some are marked relocatable and the directory they can
# relocate to is removed from all filenames in the package. I
# suppose this is due to some change between versions of rpm, but
# none of this is adequatly documented, so we'll just muddle
# through.
#
# Test to see if the package contains the prefix directory already.
if (defined $this->prefixes && ! -e "$workdir/".$this->prefixes) {
my $relocate=1;
# Get the files to move.
my @filelist=glob("$workdir/*");
# Now, make the destination directory.
my $collect=$workdir;
foreach (split m:/:, $this->prefixes) {
if ($_ ne '') { # this keeps us from using anything but relative paths.
$collect.="/$_";
if (-d $collect) {
# The package contains a parent
# directory of the relocation
# directory. Since it's impossible
# to move a parent directory into
# its child, bail out and do
# nothing.
$relocate=0;
last;
}
$this->do("mkdir", $collect) || die "unable to mkdir $collect: $!";
}
}
if ($relocate) {
# Now move all files in the package to the directory we made.
if (@filelist) {
$this->do("mv", @filelist, "$workdir/".$this->prefixes)
or die "error moving unpacked files into the default prefix directory: $!";
}
# Deal with relocating conffiles.
my @cf;
foreach my $cf (@{$this->conffiles}) {
$cf=$this->prefixes.$cf;
push @cf, $cf;
}
$this->conffiles([@cf]);
}
}
# rpm files have two sets of permissions; the set in the cpio
# archive, and the set in the control data; which override them.
# The set in the control data are more correct, so let's use those.
# Some permissions setting may have to be postponed until the
# postinst.
my %owninfo = ();
my %modeinfo = ();
open (GETPERMS, 'rpm --queryformat \'[%{FILEMODES} %{FILEUSERNAME} %{FILEGROUPNAME} %{FILENAMES}\n]\' -qp '.$this->filename.' |');
while (<GETPERMS>) {
chomp;
my ($mode, $owner, $group, $file) = split(/ /, $_, 4);
next if -l "$workdir/$file";
$mode = $mode & 07777; # remove filetype
my $uid = getpwnam($owner);
if (! defined $uid || $uid != 0) {
$owninfo{$file}=$owner;
$uid=0;
}
my $gid = getgrnam($group);
if (! defined $gid || $gid != 0) {
if (exists $owninfo{$file}) {
$owninfo{$file}.=":$group";
}
else {
$owninfo{$file}=":$group";
}
$gid=0;
}
if (defined($owninfo{$file}) && (($mode & 07000) > 0)) {
$modeinfo{$file} = sprintf "%lo", $mode;
}
# Note that ghost files exist in the metadata but not
# in the cpio archive, so check that the file exists
# before trying to access it
if (-e "$workdir/$file") {
if ($> == 0) {
$this->do("chown", "$uid:$gid", "$workdir/$file")
|| die "failed chowning $file to $uid\:$gid\: $!";
}
$this->do("chmod", sprintf("%lo", $mode), "$workdir/$file")
|| die "failed changing mode of $file to $mode\: $!";
}
}
$this->owninfo(\%owninfo);
$this->modeinfo(\%modeinfo);
return 1;
}
=item prep
Prepare for package building by generating the spec file.
=cut
sub prep {
my $this=shift;
my $dir=$this->unpacked_tree || die "The package must be unpacked first!";
# Place %config in front of files that are conffiles.
my @conffiles = @{$this->conffiles};
my $filelist;
foreach my $fn (@{$this->filelist}) {
# Unquote any escaped characters in filenames - needed for
# non ascii characters. (eg. iso_8859-1 latin set)
if ($fn =~ /\\/) {
$fn=eval qq{"$fn"};
}
# Note all filenames are quoted in case they contain
# spaces.
if ($fn =~ m:/$:) {
$filelist.=qq{%dir "$fn"\n};
}
elsif (grep(m:^\Q$fn\E$:,@conffiles)) { # it's a conffile
$filelist.=qq{%config "$fn"\n};
}
else { # normal file
$filelist.=qq{"$fn"\n};
}
}
# Write out the spec file.
my $spec="$dir/".$this->name."-".$this->version."-".$this->release.".spec";
open (OUT, ">$spec") || die "$spec: $!";
my $pwd=`pwd`;
chomp $pwd;
print OUT "Buildroot: $pwd/$dir\n"; # must be absolute dirname
print OUT "Name: ".$this->name."\n";
print OUT "Version: ".$this->version."\n";
print OUT "Release: ".$this->release."\n";
print OUT "Requires: ".$this->depends."\n"
if defined $this->depends && length $this->depends;
print OUT "Summary: ".$this->summary."\n";
print OUT "License: ".$this->copyright."\n";
print OUT "Distribution: ".$this->distribution."\n";
print OUT "Group: Converted/".$this->group."\n";
print OUT "\n";
print OUT "\%define _rpmdir ../\n"; # write rpm to current directory
print OUT "\%define _rpmfilename %%{NAME}-%%{VERSION}-%%{RELEASE}.%%{ARCH}.rpm\n";
print OUT "\%define _unpackaged_files_terminate_build 0\n"; # work on SuSE
print OUT "\n";
if ($this->usescripts) {
if ($this->preinst) {
print OUT "\%pre\n";
print OUT $this->preinst."\n";
print OUT "\n";
}
if ($this->postinst) {
print OUT "\%post\n";
print OUT $this->postinst."\n";
print OUT "\n";
}
if ($this->prerm) {
print OUT "\%preun\n";
print OUT $this->prerm."\n";
print OUT "\n";
}
if ($this->postrm) {
print OUT "\%postun\n";
print OUT $this->postrm."\n";
print OUT "\n";
}
}
print OUT "\%description\n";
print OUT $this->description."\n";
print OUT "\n";
print OUT "(Converted from a ".$this->origformat." package by alien version $Alien::Version.)\n";
print OUT "\n";
print OUT "%files\n";
print OUT $filelist if defined $filelist;
close OUT;
}
=item cleantree
Delete the spec file.
=cut
sub cleantree {
my $this=shift;
my $dir=$this->unpacked_tree || die "The package must be unpacked first!";
unlink "$dir/".$this->name."-".$this->version."-".$this->release.".spec";
}
=item build
Build a rpm. If RPMBUILDOPT is set in the environement, the options in
it are passed to rpm on its command line.
An optional parameter, if passed, can be used to specify the program to use
to build the rpm. It defaults to rpmbuild.
=cut
sub build {
my $this=shift;
my $buildcmd=shift || 'rpmbuild';
my $dir=$this->unpacked_tree || die "The package must be unpacked first!";
# Ask rpm how it's set up. We want to know where it will place rpms.
my $rpmdir;
foreach ($this->runpipe(1, "rpm --showrc")) {
chomp;
if (/^rpmdir\s+:\s(.*)$/) {
$rpmdir=$1;
}
}
my $rpm=$this->name."-".$this->version."-".$this->release.".".$this->arch.".rpm";
my $opts='';
if ($rpmdir) {
# Old versions of rpm toss it off in the middle of nowhere.
$rpm="$rpmdir/".$this->arch."/$rpm";
# This is the old command line argument to set the arch.
$opts="--buildarch ".$this->arch;
}
else {
# Presumably we're dealing with rpm 3.0 or above, which
# doesn't output rpmdir in any format I'd care to try to
# parse. Instead, rpm is now of a late enough version to
# notice the %define's in the spec file, that will make the
# file end up in the directory we started in.
# Anyway, let's assume this is version 3 or above.
# This is the new command line arcgument to set the arch
# rpms. It appeared in rpm version 3.
$opts="--target ".$this->arch;
}
$opts.=" $ENV{RPMBUILDOPT}" if exists $ENV{RPMBUILDOPT};
my $pwd=`pwd`;
chomp $pwd;
my $command="cd $dir; $buildcmd --buildroot='$pwd/$dir' -bb $opts '".$this->name."-".$this->version."-".$this->release.".spec'";
my $log=$this->runpipe(1, "$command 2>&1");
if ($?) {
die "Package build failed. Here's the log of the command ($command):\n", $log;
}
return $rpm;
}
=item version
Set/get version.
When retreiving the version, remove any dashes in it.
=cut
sub version {
my $this=shift;
# set
$this->{version} = shift if @_;
# get
return unless defined wantarray; # optimization
$_=$this->{version};
tr/-/_/;
return $_;
}
=item postinst
=item postrm
=item preinst
=item prerm
Set/get script fields.
When retrieving a value, we have to do some truely sick mangling. Since
debian/slackware scripts can be anything -- perl programs or binary files
-- and rpm is limited to only shell scripts, we need to encode the files
and add a scrap of shell script to make it unextract and run on the fly.
When setting a value, we do some mangling too. Rpm maintainer scripts
are typically shell scripts, but often lack the leading shebang line.
This can confuse dpkg, so add the shebang if it looks like there
is no shebang magic already in place.
Additionally, it's not uncommon for rpm maintainer scripts to contain
bashisms, which can be triggered when they are ran on systems where /bin/sh
is not bash. To work around this, the shebang line of the scripts is
changed to use bash.
Also, if the rpm is relocatable, the script could refer to
RPM_INSTALL_PREFIX, which is set by rpm at run time. Deal with this by
adding code to the script to set RPM_INSTALL_PREFIX.
=cut
# This helper function deals with all the scripts.
sub _script_helper {
my $this=shift;
my $script=shift;
# set
if (@_) {
my $prefixcode="";
if (defined $this->prefixes) {
$prefixcode="RPM_INSTALL_PREFIX=".$this->prefixes."\n";
$prefixcode.="export RPM_INSTALL_PREFIX\n";
}
my $value=shift;
if (length $value and $value !~ m/^#!\s*\//) {
$value="#!/bin/bash\n$prefixcode$value";
}
else {
$value=~s@^#!\s*/bin/sh(\s)@#!/bin/bash$1@;
$value=~s/\n/\n$prefixcode/s;
}
$this->{$script} = $value;
}
$this->{$script} = shift if @_;
# get
return unless defined wantarray; # optimization
$_=$this->{$script};
return '' unless defined $_;
return $_ if m/^\s*$/;
return $_ if m/^#!\s*\/bin\/sh/; # looks like a shell script already
my $f = pack("u",$_);
$f =~ s/%/%%/g; # Rpm expands %S, so escape such things.
return "#!/bin/sh\n".
"set -e\n".
"mkdir /tmp/alien.\$\$\n".
qq{perl -pe '\$_=unpack("u",\$_)' << '__EOF__' > /tmp/alien.\$\$/script\n}.
$f."__EOF__\n".
"chmod 755 /tmp/alien.\$\$/script\n".
"/tmp/alien.\$\$/script \"\$@\"\n".
"rm -f /tmp/alien.\$\$/script\n".
"rmdir /tmp/alien.\$\$";
}
sub postinst {
my $this=shift;
$this->_script_helper('postinst', @_);
}
sub postrm {
my $this=shift;
$this->_script_helper('postrm', @_);
}
sub preinst {
my $this=shift;
$this->_script_helper('preinst', @_);
}
sub prerm {
my $this=shift;
$this->_script_helper('prerm', @_);
}
=item arch
Set/get arch field. When the arch field is set, some sanitizing is done
first to convert it to the debian format used internally. When it's
retreived it's converted back to rpm form from the internal form.
=cut
sub arch {
my $this=shift;
my $arch;
if (@_) {
$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';
}
elsif ($arch eq 'x86_64') {
$arch='amd64';
}
elsif ($arch eq 'em64t') {
$arch='amd64';
}
elsif ($arch =~ m/i\d86/i || $arch =~ m/pentium/i) {
# Treat 486, 586, etc, as 386.
$arch='i386';
}
elsif ($arch eq 'armv4l') {
# Treat armv4l as arm.
$arch='arm';
}
elsif ($arch eq 'parisc') {
$arch='hppa';
}
$this->{arch}=$arch;
}
$arch=$this->{arch};
if ($arch eq 'amd64') {
$arch='x86_64';
}
elsif ($arch eq 'powerpc') {
# XXX is this the canonical name for powerpc on rpm
# systems?
$arch='ppc';
}
elsif ($arch eq 'hppa') {
$arch='parisc';
}
elsif ($arch eq 'all') {
$arch='noarch';
}
return $arch
}
=back
=head1 AUTHOR
Joey Hess <joey@kitenet.net>
=cut
1

369
Alien/Package/Slp.pm Normal file
View File

@@ -0,0 +1,369 @@
#!/usr/bin/perl -w
=head1 NAME
Alien::Package::Slp - an object that represents a slp package
=cut
package Alien::Package::Slp;
use strict;
use base qw(Alien::Package);
=head1 DESCRIPTION
This is an object class that represents a slp package. It is derived from
Alien::Package.
=head1 CLASS DATA
The following data is global to the class, and is used to describe the slp
package format, which this class processes directly.
=over 4
=item footer_size
Complete sizeof(slpformat) from slp.h in the stampede package manager
source.
=item footer_packstring
This is the pack format string for the footer. (A=space terminated
character, I=unsigned integer.)
=item footer_version
What package format are we up to now? (Lowest one this is still
compatable with.)
=item archtrans
This is a translation table between architectures and the number
that represents them in a slp package.
=item fieldlist
This is a list of all the fields in the order they appear in the footer.
=cut
use constant footer_size => 3784;
use constant footer_packstring => "A756IIIIA128A128A80A1536A512A512A30A30IA20A20III";
use constant footer_version => 5;
use constant archtrans => {
0 => 'all',
1 => 'i386',
2 => 'sparc',
3 => 'alpha',
4 => 'powerpc',
5 => 'm68k',
};
use constant copyrighttrans => {
0 => 'GPL',
1 => 'BSD',
2 => 'LGPL',
3 => 'unknown',
254 => 'unknown',
};
use constant fieldlist => [qw{conffiles priority compresstype release copyright
conflicts setupscript summary description depends
provides maintainer date compiler version name
arch group slpkgversion}];
=back
=head1 FIELDS
=over 4
=item compresstype
Holds the compression type used in the slp file.
=item slpkgversion
Holds the slp package format version of the slp file.
=back
=head1 METHODS
=over 4
=item checkfile
Detect slp files by their extention.
=cut
sub checkfile {
my $this=shift;
my $file=shift;
return $file =~ m/.*\.slp$/;
}
=item install
Install a slp. Pass in the filename of the slp to install.
=cut
sub install {
my $this=shift;
my $slp=shift;
my $v=$Alien::Package::verbose;
$Alien::Package::verbose=2;
$this->do("slpi", $slp)
or die "Unable to install";
$Alien::Package::verbose=$v;
}
=item getfooter
Pulls the footer out of the slp file and returns it.
=cut
sub getfooter {
my $this=shift;
my $file=$this->filename;
open (SLP,"<$file") || die "$file: $!";
# position at beginning of footer (2 = seek from EOF)
seek SLP,(- footer_size),2;
read SLP,$_,footer_size;
close SLP;
return $_;
}
=item scan
Implement the scan method to read a slp file.
=cut
sub scan {
my $this=shift;
$this->SUPER::scan(@_);
my $file=$this->filename;
# Decode the footer.
my @values=unpack(footer_packstring(),$this->getfooter);
# Populate fields.
foreach my $field (@{fieldlist()}) {
$_=shift @values;
$this->$field($_);
}
# A simple sanity check.
if (! defined $this->slpkgversion || $this->slpkgversion < footer_version()) {
die "unsupported stampede package version";
}
# Read in the file list.
my @filelist;
# FIXME: support gzip files too!
foreach ($this->runpipe(0, "bzip2 -d < '$file' | tar -tf -")) {
chomp;
s:^\./:/:;
$_="/$_" unless m:^/:;
push @filelist, $_;
}
$this->filelist(\@filelist);
# TODO: read in postinst script.
$this->distribution('Stampede');
$this->origformat('slp');
$this->changelogtext('');
$this->binary_info($this->runpipe(0, "ls -l '$file'"));
return 1;
}
=item unpack
Unpack a slp file. They can be compressed in various ways, depending on
what is in the compresstype field.
=cut
sub unpack {
my $this=shift;
$this->SUPER::unpack(@_);
my $file=$this->filename;
my $compresstype=$this->compresstype;
if ($compresstype == 0) {
$this->do("bzip2 -d < $file | (cd ".$this->unpacked_tree."; tar xpf -)")
}
elsif ($compresstype == 1) {
$this->do("gzip -dc $file | (cd ".$this->unpacked_tree."; tar xpf -)")
}
else {
die "package uses an unknown compression type, $compresstype (please file a bug report)";
}
return 1;
}
=item build
Build a slp.
=cut
sub build {
my $this=shift;
my $slp=$this->name."-".$this->version.".slp";
# Now generate the footer.
# We cannot use the actual $slp::footer_packstring, becuase it uses
# space terminated strings (A) instead of null terminated strings
# (a). That is good for decoding, but not for encoding.
my $fmt=footer_packstring();
$fmt=~tr/A/a/;
my $footer=pack($fmt,
$this->conffiles,
2, # Use priority optional for alien packages.
0, # Always use bzip2 as the compression type.
$this->release,
254, # Don't try to guess copyright, just use unknown.
'', # Conflicts.
'', # Set up script. TODO
$this->summary,
$this->description,
'', # $this->depends would go here, but slp uses some weird format
'', # Provides.
$this->maintainer,
scalar localtime, # Use current date.
252, # Unknown compiler.
$this->version,
$this->name,
$this->arch,
252, # Unknown group.
footer_version(),
);
# Generate .tar.bz2 file.
# Note that it's important I use "./*" instead of just "." or
# something like that, becuase it results in a tar file where all
# the files in it start with "./", which is consitent with how
# normal stampede files look.
$this->do("(cd ".$this->unpacked_tree."; tar cf - ./*) | bzip2 - > $slp")
or die "package build failed: $!";
# Now append the footer.
open (OUT,">>$slp") || die "$slp: $!";
print OUT $footer;
close OUT;
return $slp;
}
=item conffiles
Set/get conffiles.
When the conffiles are set, the format used by slp (a colon-delimited list)
is turned into the real list that is used internally. The list is changed
back into slp's internal format when it is retreived.
=cut
sub conffiles {
my $this=shift;
# set
$this->{conffiles}=[split /:/, shift] if @_;
# get
return unless defined wantarray; # optimization
return join(':',@{$this->{conffiles}});
}
=item copyright
Set/get copyright.
When the copyright is set, the number used by slp is changed into a textual
description. This is changed back into a number when the value is
retreived.
=cut
sub copyright {
my $this=shift;
# set
$this->{copyright}=(${copyrighttrans()}{shift} || 'unknown') if @_;
# get
return unless defined wantarray; # optimization
my %transcopyright=reverse %{copyrighttrans()};
return $transcopyright{$this->{copyright}}
if (exists $transcopyright{$this->{copyright}});
return 254; # unknown
}
=item arch
Set/get arch.
When the arch is set, the number used by slp is changed into a textual
description. This is changed back into a number when the value is
retreived.
=cut
sub arch {
my $this=shift;
# set
if (@_) {
my $arch=shift;
$this->{arch}=${archtrans()}{$arch};
die "unknown architecture $arch" unless defined $this->{arch};
}
# get
return unless defined wantarray; # optimization
my %transarch=reverse %{archtrans()};
return $transarch{$this->{arch}}
if (exists $transarch{$this->{arch}});
die "Stampede does not support architecture ".$this->{arch}." packages";
}
=item release
Set/get release version.
When the release version is retreived, it is converted to an unsigned
integer, as is required by the slp package format.
=cut
sub release {
my $this=shift;
# set
$this->{release}=shift if @_;
# get
return unless defined wantarray; # optimization
return int($this->{release});
}
=back
=head1 AUTHOR
Joey Hess <joey@kitenet.net>
=cut
1

233
Alien/Package/Tgz.pm Normal file
View File

@@ -0,0 +1,233 @@
#!/usr/bin/perl -w
=head1 NAME
Alien::Package::Tgz - an object that represents a tgz package
=cut
package Alien::Package::Tgz;
use strict;
use base qw(Alien::Package);
use Cwd qw(abs_path);
my $tarext=qr/\.(?:tgz|tar(?:\.(?:gz|Z|z|bz|bz2))?|taz)$/;
=head1 DESCRIPTION
This is an object class that represents a tgz package, as used in Slackware.
It also allows conversion of raw tar files.
It is derived from Alien::Package.
=head1 CLASS DATA
=over 4
=item scripttrans
Translation table between canoical script names and the names used in
tgz's.
=cut
use constant scripttrans => {
postinst => 'doinst.sh',
postrm => 'delete.sh',
prerm => 'predelete.sh',
preinst => 'predoinst.sh',
};
=back
=head1 METHODS
=over 4
=item checkfile
Detect tgz files by their extention.
=cut
sub checkfile {
my $this=shift;
my $file=shift;
return $file =~ m/$tarext$/;
}
=item install
Install a tgz with installpkg. Pass in the filename of the tgz to install.
installpkg (a slackware program) is used because I'm not sanguine about
just untarring a tgz file. It might trash a system.
=cut
sub install {
my $this=shift;
my $tgz=shift;
if (-x "/sbin/installpkg") {
my $v=$Alien::Package::verbose;
$Alien::Package::verbose=2;
$this->do("/sbin/installpkg", "$tgz")
or die "Unable to install";
$Alien::Package::verbose=$v;
}
else {
die "Sorry, I cannot install the generated .tgz file because /sbin/installpkg is not present. You can use tar to install it yourself.\n"
}
}
=item scan
Scan a tgz file for fields. Has to scan the filename for most of the
information, since there is little useful metadata in the file itself.
=cut
sub scan {
my $this=shift;
$this->SUPER::scan(@_);
my $file=$this->filename;
# Get basename of the filename.
my ($basename)=('/'.$file)=~m#^/?.*/(.*?)$#;
# Strip out any tar extentions.
$basename=~s/$tarext//;
if ($basename=~m/([\w-]+)-([0-9\.?]+).*/) {
$this->name($1);
$this->version($2);
}
else {
$this->name($basename);
$this->version(1);
}
$this->arch('all');
$this->summary("Converted tgz package");
$this->description($this->summary);
$this->copyright('unknown');
$this->release(1);
$this->distribution("Slackware/tarball");
$this->group("unknown");
$this->origformat('tgz');
$this->changelogtext('');
$this->binary_info($this->runpipe(0, "ls -l '$file'"));
# Now figure out the conffiles. Assume anything in etc/ is a
# conffile.
my @conffiles;
open (FILELIST,"tar vtf $file | grep etc/ |") ||
die "getting filelist: $!";
while (<FILELIST>) {
# Make sure it's a normal file. This is looking at the
# permissions, and making sure the first character is '-'.
# Ie: -rw-r--r--
if (m:^-:) {
# Strip it down to the filename.
m/^(.*) (.*)$/;
push @conffiles, "/$2";
}
}
$this->conffiles(\@conffiles);
# Now get the whole filelist. We have to add leading /'s to the
# filenames. We have to ignore all files under /install/
my @filelist;
open (FILELIST, "tar tf $file |") ||
die "getting filelist: $!";
while (<FILELIST>) {
chomp;
unless (m:^install/:) {
push @filelist, "/$_";
}
}
$this->filelist(\@filelist);
# Now get the scripts.
foreach my $script (keys %{scripttrans()}) {
$this->$script(scalar $this->runpipe(1, "tar Oxf '$file' install/${scripttrans()}{$script} 2>/dev/null"));
}
return 1;
}
=item unpack
Unpack tgz.
=cut
sub unpack {
my $this=shift;
$this->SUPER::unpack(@_);
my $file=abs_path($this->filename);
$this->do("cd ".$this->unpacked_tree."; tar xpf $file")
or die "Unpacking of '$file' failed: $!";
# Delete the install directory that has slackware info in it.
$this->do("cd ".$this->unpacked_tree."; rm -rf ./install");
return 1;
}
=item prep
Adds a populated install directory to the build tree.
=cut
sub prep {
my $this=shift;
my $dir=$this->unpacked_tree || die "The package must be unpacked first!";
my $install_made=0;
if ($this->usescripts) {
foreach my $script (keys %{scripttrans()}) {
my $data=$this->$script();
my $out=$this->unpacked_tree."/install/".${scripttrans()}{$script};
next if ! defined $data || $data =~ m/^\s*$/;
if (!$install_made) {
mkdir($this->unpacked_tree."/install", 0755)
|| die "unable to mkdir ".$this->unpacked_tree."/install: $!";
$install_made=1;
}
open (OUT, ">$out") || die "$out: $!";
print OUT $data;
close OUT;
$this->do("chmod", 755, $out);
}
}
}
=item build
Build a tgz.
=cut
sub build {
my $this=shift;
my $tgz=$this->name."-".$this->version.".tgz";
$this->do("cd ".$this->unpacked_tree."; tar czf ../$tgz .")
or die "Package build failed";
return $tgz;
}
=back
=head1 AUTHOR
Joey Hess <joey@kitenet.net>
=cut
1