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

Added checkfile class method.

Browse Source
This commit is contained in:
joey
2000-04-21 22:18:49 +00:00
parent b78f13c060
commit 25d4bcbe7a
6 changed files with 80 additions and 154 deletions
Download Patch File Download Diff File Expand all files Collapse all files

14
Alien/Package.pm
View File

@@ -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.

13
Alien/Package/Deb.pm
View File

@@ -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.

13
Alien/Package/Rpm.pm
View File

@@ -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

13
Alien/Package/Slp.pm
View File

@@ -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.

19
Alien/Package/Tgz.pm
View File

@@ -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";

162
lib/Alien.pm
View File

@@ -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,"</etc/mailname");
my $mailname=<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,"</etc/passwd");
while (<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(/:/,<YPMATCH>);
$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 (<IN>) {
s/#(.*?)#/$fields{$1}/g;
print OUT $_;
}
close OUT;
close IN;
}
1