mirror of
https://github.com/Project-OSS-Revival/alien.git
synced 2026-04-24 14:00:17 +00:00
Moving right along.. I've moved the fixfields code in now.
This commit is contained in:
@@ -32,6 +32,20 @@ The text of the changelog
|
||||
|
||||
=over 4
|
||||
|
||||
=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;
|
||||
|
||||
system("rpm -ivh $ENV{RPMINSTALLOPT} ".$this->filename) &&
|
||||
die "Unable to install: $!";
|
||||
}
|
||||
|
||||
=item read_file
|
||||
|
||||
Implement the read_file method to read a rpm file.
|
||||
@@ -63,11 +77,6 @@ sub read_file {
|
||||
$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`]);
|
||||
|
||||
@@ -104,10 +113,164 @@ sub read_file {
|
||||
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;
|
||||
|
||||
system ("rpm2cpio ".$this->filename." | (cd $workdir; cpio --extract --make-directories --no-absolute-filenames --preserve-modification-time) 2>/dev/null") &&
|
||||
die "Unpacking of `".$this->filename."' failed: $!";
|
||||
|
||||
# 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) {
|
||||
# Get the files to move.
|
||||
my $filelist=join ' ',glob("$workdir/*");
|
||||
|
||||
# Now, make the destination directory.
|
||||
my $collect=$workdir;
|
||||
foreach (split m:/:, $this->prefixes) {
|
||||
if ($_ ne undef) { # this keeps us from using anything but relative paths.
|
||||
$collect.="$_/";
|
||||
mkdir $collect,0755 || die "unable to mkdir $collect: $!";
|
||||
}
|
||||
}
|
||||
# Now move all files in the package to the directory we made.
|
||||
system "mv $filelist $workdir/".$this->prefixes &&
|
||||
die "error moving unpacked files into the default prefix directory: $!";
|
||||
}
|
||||
|
||||
# When cpio extracts the file, any child directories that are
|
||||
# present, but whose parent directories are not, end up mode 700.
|
||||
# This next block correctsthat to 755, which is more reasonable.
|
||||
#
|
||||
# Of course, this whole thing assumes we get the filelist in sorted
|
||||
# order.
|
||||
my $lastdir='';
|
||||
foreach my $file (@{$this->filelist}) {
|
||||
$file=~s/^\///;
|
||||
if (($lastdir && $file=~m:^\Q$lastdir\E/[^/]*$: eq undef) || !$lastdir) {
|
||||
# We've found one of the nasty directories. Fix it
|
||||
# up.
|
||||
#
|
||||
# Note that I strip the trailing filename off $file
|
||||
# here, for two reasons. First, it makes the loop
|
||||
# easier, we don't need to fix the perms on the
|
||||
# last file, after all! Second, it makes the -d
|
||||
# test below fire, which saves us from trying to
|
||||
# fix a parent directory twice.
|
||||
($file)=$file=~m:(.*)/.*?:;
|
||||
my $dircollect='';
|
||||
foreach my $dir (split(/\//,$file)) {
|
||||
$dircollect.="$dir/";
|
||||
chmod 0755,$dircollect; # TADA!
|
||||
}
|
||||
}
|
||||
$lastdir=$file if -d "./$file";
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
=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 retreiving 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.
|
||||
|
||||
=cut
|
||||
|
||||
# This helper function deals with all the scripts.
|
||||
sub _script_helper {
|
||||
my $this=shift;
|
||||
my $script=shift;
|
||||
|
||||
# set
|
||||
$this->{$script} = shift if @_;
|
||||
|
||||
# get
|
||||
return unless defined wantarray; # optimization
|
||||
$_=$this->{$script};
|
||||
return $_ if ! defined $_ || m/^\s*$/;
|
||||
my $f = pack("u",$_);
|
||||
$f =~ s/%/%%/g; # Rpm expands %S, so escape such things.
|
||||
return "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($this, 'postinst', @_);
|
||||
}
|
||||
sub postrm {
|
||||
my $this=shift;
|
||||
$this->_script_helper($this, 'postrm', @_);
|
||||
}
|
||||
sub preinst {
|
||||
my $this=shift;
|
||||
$this->_script_helper($this, 'preinst', @_);
|
||||
}
|
||||
sub prerm {
|
||||
my $this=shift;
|
||||
$this->_script_helper($this, 'prerm', @_);
|
||||
}
|
||||
|
||||
=item arch
|
||||
|
||||
Set/get arch field. When the arch field is set, some sanitizing is done
|
||||
first.
|
||||
first to convert it to the debian format used internally.
|
||||
|
||||
=cut
|
||||
|
||||
@@ -136,7 +299,7 @@ sub arch {
|
||||
}
|
||||
|
||||
# Treat 486, 586, etc, as 386.
|
||||
if ($arch =~ m/i\d86/) {
|
||||
if ($arch =~ m/i\d86/i || $arch =~ m/pentium/i) {
|
||||
$arch='i386';
|
||||
}
|
||||
|
||||
|
||||
Reference in New Issue
Block a user