diff --git a/Alien/Package.pm b/Alien/Package.pm index 84c94c8..4b69238 100644 --- a/Alien/Package.pm +++ b/Alien/Package.pm @@ -28,6 +28,15 @@ 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 @@ -136,6 +145,16 @@ having to write your own new() method. sub init {} +=item install + +Simply installs the package. This has to be overridden in child classes. + +=cut + +sub install { + my $this=shift; +} + =item read_file This method looks at the actual package file the package represents, and diff --git a/Alien/Package/Deb.pm b/Alien/Package/Deb.pm index cdab7a9..e99147b 100644 --- a/Alien/Package/Deb.pm +++ b/Alien/Package/Deb.pm @@ -22,7 +22,7 @@ Alien::Package. =item have_dpkg_deb -Set to a true value if dpkg-deb is available. +Set to a true value if dpkg-deb is available. =back @@ -32,7 +32,8 @@ Set to a true value if dpkg-deb is available. =item init -Sets have_dpkg_deb if dpkg-deb is in the path. +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 @@ -49,13 +50,23 @@ sub init { } } +=item install + +Install a deb with dpkg. + +=cut + +sub install { + my $this=shift; + + system("dpkg --no-force-overwrite -i ".$this->filename) && + die "Unable to install: $!"; +} + =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 { @@ -74,7 +85,11 @@ sub read_file { @control = `ar p $file control.tar.gz | tar Oxzf - control [./]control`; } - # Parse control file and extract fields. + # 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', @@ -96,27 +111,17 @@ sub read_file { } } elsif (/^ / && $field eq 'summary') { - # Handle xtended description. + # Handle extended description. s/^ //g; $_="" if $_ eq "."; - $this->description($this->description . $_. "\n"); + $description.="$_\n"; } } + $this->description($description); $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; @@ -179,7 +184,123 @@ sub unpack { return 1; } -=back +=item package + +Set/get package name. + +Always returns the packge name in lowercase with all invalid characters +returned. 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 digets. + unless (/[0-9]/) { + # Drat. Well, add some. dpkg-deb won't work + # # on a version w/o numbers! + return $_."0"; + } + 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"; + } + chomp $ret; + return $ret; +} =head1 AUTHOR diff --git a/Alien/Package/Rpm.pm b/Alien/Package/Rpm.pm index dbd228b..aa34692 100644 --- a/Alien/Package/Rpm.pm +++ b/Alien/Package/Rpm.pm @@ -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'; }