diff --git a/Alien/Package.pm b/Alien/Package.pm index 2637662..3dc6e12 100644 --- a/Alien/Package.pm +++ b/Alien/Package.pm @@ -155,6 +155,20 @@ having to write your own new() method. sub init {} +=item checkfile + +This is a class method. 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 install Simply installs a package file. The filename is passed on standard input. diff --git a/Alien/Package/Deb.pm b/Alien/Package/Deb.pm index a2e249c..ebea496 100644 --- a/Alien/Package/Deb.pm +++ b/Alien/Package/Deb.pm @@ -50,6 +50,19 @@ sub init { } } +=item checkfile + +Detect deb files by their extention. + +=cut + +sub checkfile { + my $this=shift; + my $file=shift; + + return $file =~ m/.*\.deb$/; +} + =item install Install a deb with dpkg. Pass in the filename of the deb to install. diff --git a/Alien/Package/Rpm.pm b/Alien/Package/Rpm.pm index 701ae12..8e73b78 100644 --- a/Alien/Package/Rpm.pm +++ b/Alien/Package/Rpm.pm @@ -28,6 +28,19 @@ Relocatable rpm packages have a prefixes field. =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 diff --git a/Alien/Package/Slp.pm b/Alien/Package/Slp.pm index 300dbb7..7f511cc 100644 --- a/Alien/Package/Slp.pm +++ b/Alien/Package/Slp.pm @@ -92,6 +92,19 @@ Holds the slp package format version of the slp file. =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. diff --git a/Alien/Package/Tgz.pm b/Alien/Package/Tgz.pm index f338bde..41d7b88 100644 --- a/Alien/Package/Tgz.pm +++ b/Alien/Package/Tgz.pm @@ -45,6 +45,19 @@ use constant =over 4 +=item checkfile + +Detect tgz files by their extention. + +=cut + +sub checkfile { + my $this=shift; + my $file=shift; + + return $file =~ m/.*\.(?:tgz|tar\.(?:gz|Z|z)|taz)$/; +} + =item install Install a tgz with installpkg. Pass in the filename of the tgz to install. @@ -171,14 +184,14 @@ sub prep { my $install_made=0; foreach my $script (keys %{scriptrans()}) { - my $data=$this->$script; + my $data=$this->$script(); next if ! defined $data || $data =~ m/^\s*$/; if (!$install_made) { mkdir $this->unpacked_tree."/install", 0755; $install_made=1; } - open OUT (">".$this->unpacked_tree."/install/$script") || - die $this->unpacked_tree."/install/$script: $!" + open (OUT, ">".$this->unpacked_tree."/install/$script") || + die $this->unpacked_tree."/install/$script: $!"; print OUT $data; close OUT; chmod 0755, $this->unpacked_tree."/install/$script"; diff --git a/lib/Alien.pm b/lib/Alien.pm index 9c29cc9..615f7ab 100644 --- a/lib/Alien.pm +++ b/lib/Alien.pm @@ -6,68 +6,25 @@ package Alien; use strict; -# Print out a status line. -sub Status { my $message=shift; - print "-- $message\n"; -} - -# Print out an error message and exit the program. -sub Error { my $message=shift; - print STDERR "alien: $message\n"; - exit 1; -} - -# Run a system command, and print an error message if it fails. -# The errormessage parameter is optional. -sub SafeSystem { my ($command,$errormessage)=@_; - my $ret=system $command; - if (int($ret/256) > 0) { - $errormessage="Error running: $command" if !$errormessage; - Error($errormessage); - } -} - -# Make the passed directory. Exits with error if the directory already -# exists. -sub SafeMkdir { my ($dir)=@_; - if (-e $dir) { - Error("Directory $dir already exists.\nRemove it and re-run alien."); - } - mkdir $dir,0755 || Error("Unable to make directory, \"$dir\": $!"); -} - -# Pass the filename of a package. -# Returns "rpm" or "tgz" or "deb", depending on what it thinks the file type -# is, based on the filename. -# Perhaps this should call file(1), instead? -# -# Note that the file type this returns corresponds to directories in -# $libdir. -sub FileType { my $file=shift; - if ($file=~m/.*\.rpm/ ne undef) { - return 'rpm'; - } - elsif ($file=~m/.*\.(tgz|tar\.gz)/ ne undef) { - return 'tgz'; - } - elsif ($file=~m/.*\.deb/ ne undef) { - return 'deb'; - } - else { - Error("Format of filename bad: $file"); - } -} # Pass this the name and version and revision of a package, it will return the # filename of a patch file for the package or undef if there is none. sub GetPatch { my ($name,$version,$revision)=@_; - my @patches=glob("$main::patchdir/$name\_$version-$revision*.diff.gz"); + my @patches=(); + my $dir; + foreach $dir (@main::patchdirs) { + push @patches,glob("$dir/$name\_$version-$revision*.diff.gz"); + } if ($#patches < 0) { # try not matching the revision, see if that helps. - @patches=glob("$main::patchdir/$name\_$version*.diff.gz"); + foreach $dir (@main::patchdirs) { + push @patches,glob("$dir/$name\_$version*.diff.gz"); + } if ($#patches < 0) { # fallback to anything that matches the name. - @patches=glob("$main::patchdir/$name\_*.diff.gz"); + foreach $dir (@main::patchdirs) { + push @patches,glob("$dir/$name\_*.diff.gz"); + } } } @@ -75,101 +32,4 @@ sub GetPatch { my ($name,$version,$revision)=@_; return $patches[0]; } -# Apply the given patch file to the given subdirectory. -sub Patch { my ($patchfile,$subdir)=@_; - Status("Patching in $patchfile"); - chdir $subdir; - # cd .. here in case the patchfile's name was a relative path. - # The -f passed to zcat makes it pass uncompressed files through - # without error. - SafeSystem("(cd ..;zcat -f $patchfile) | patch -p1","Patch error.\n"); - # look for .rej files - if (`find . -name "*.rej"`) { - Error("Patch failed: giving up."); - } - SafeSystem('find . -name \'*.orig\' -exec rm {} \\;',"Error removing .orig files"); - chdir ".."; -} - -# Returns the 822-date. -sub GetDate { - my $date=`822-date`; - chomp $date; - if (!$date) { - Error("822-date did not return a valid result.\n"); - } - - return $date; -} - -# Returns a email address for the current user. -sub GetEmail { - if (!$ENV{EMAIL}) { - my $login = getlogin || (getpwuid($<))[0] || $ENV{USER}; - open (MAILNAME,"; - chomp $mailname; - close MAILNAME; - if (!$mailname) { - $mailname=`hostname -f`; - chomp $mailname; - } - return "$login\@$mailname"; - } - else { - return $ENV{EMAIL}; - } -} - -# Returns the user name of the user who is running this. -sub GetUserName { - my $username; - my $username_in_passwd=undef; - - my $login = getlogin || (getpwuid($<))[0] || $ENV{USER}; - - open (PASSWD,") { - my (@fields)=split(/:/,$_); - if ($fields[0] eq $login) { - $username=$fields[4]; - $username_in_passwd=1; # don't try NIS, no matter what. - close PASSWD; - } - } - close PASSWD; - - if (!$username_in_passwd && !$username && -x "/usr/bin/ypmatch") { - # Give NIS a try. - open (YPMATCH,"ypmatch $login passwd.byname |"); - my (@fields)=split(/:/,); - $username=$fields[4]; - close YPMATCH; - } - - # Remove GECOS(?) fields from username. - $username=~s/,.*//g; - - # The ultimate fallback. - if (!$username) { - $username=$login; - } - - return $username; -} - -# Fill out a template, and save it to the passed location. -# The hash that is passed to this function lists the tags that can be onthe -# template, and the values to fill in for those tags. -sub FillOutTemplate { my ($fn,$destfn,%fields)=@_; - open (IN,"<$fn") || Error("$fn: $!"); - open (OUT,">$destfn") || Error("$destfn: $!"); - while () { - s/#(.*?)#/$fields{$1}/g; - print OUT $_; - } - close OUT; - close IN; -} - 1