webmin/software/slackware-lib.pl

# slackware-lib.pl
# Functions for slackware package management

$package_dir = "/var/log/packages";
%class_map = (	'a',	'Base Linux system',
		'ap',	'Applications',
		'd',	'Program development',
		'des',	'Crypt library',
		'e',	'GNU Emacs',
		'f',	'FAQs and documentation',
		'gtk',	'GTK+ and GNOME programs',
		'k',	'Linux kernel source',
		'kde',	'KDE desktop and programs',
		'n',	'Networking',
		't',	'TeX',
		'tcl',	'TcL/Tk',
		'xap',	'X applications',
		'xd',	'X server development',
		'xv',	'XView programs',
		'y',	'Games' );
use POSIX;
chop($system_arch = `uname -m`);

# list_packages([package]*)
# Fills the array %packages with a list of all packages
sub list_packages
{
local ($i, $f, @list);
opendir(DIR, &translate_filename($package_dir));
local @list = @_ ? @_ : grep { !/^\./ } readdir(DIR);
$i = 0;
foreach $f (@list) {
	$packages{$i,'name'} = $f;
	$packages{$i,'class'} = $text{'slack_unclass'};
	&open_tempfile(PKG, "$package_dir/$f");
	while(<PKG>) {
		if (/^PACKAGE LOCATION:\s+disk([a-z]+)\d+/i) {
			$packages{$i,'class'} = $class_map{$1};
			}
		elsif (/^PACKAGE DESCRIPTION:/i) {
			local $desc = <PKG>;
			$desc =~ s/^\S+:\s+//;
			$desc =~ s/\n//;
			$packages{$i,'desc'} = $desc;
			}
		}
	close(PKG);
	$i++;
	}
closedir(DIR);
return $i;
}

# package_info(package)
# Returns an array of package information in the order
#  name, class, description, arch, version, vendor, installtime
sub package_info
{
local @rv = ( $_[0], $text{'slack_unclass'}, $text{'slack_unknown'},
	      $system_arch, $text{'slack_unknown'}, "Slackware" );
local @st = stat(&translate_filename("$package_dir/$_[0]"));
$rv[6] = ctime($st[9]);
&open_readfile(PKG, "$package_dir/$_[0]");
while(<PKG>) {
	if (/^PACKAGE LOCATION:\s+disk([a-z]+)\d+/i) {
		$rv[1] = $class_map{$1};
		}
	elsif (/^PACKAGE DESCRIPTION:/i) {
		$rv[2] = "";
		while(<PKG>) {
			last if (/^FILE LIST/i);
			s/^\S+: *//;
			if (!$rv[2] && /([0-9][0-9\.]*)/) {
				$rv[4] = $1;
				}
			$rv[2] .= $_;
			}
		$rv[2] =~ s/\s+$//;
		}
	}
close(PKG);
return @rv;
}

# check_files(package)
# Fills in the %files array with information about the files belonging
# to some package. Values in %files are  path type user group mode size error
sub check_files
{
local $i = 0;
local $file;
&open_readfile(PKG, "$package_dir/$_[0]");
while(<PKG>) {
	last if (/^FILE LIST:/i);
	}
while($file = <PKG>) {
	$file =~ s/\r|\n//g;
	next if ($file eq "./");
	$file = '/'.$file;
	local $real = &translate_filename($file);
	$files{$i,'path'} = $file;
	local @st = stat($real);
	if (@st) {
		$files{$i,'type'} = -l $real ? 3 :
				    -d $real ? 1 : 0;
		$files{$i,'user'} = getpwuid($st[4]);
		$files{$i,'group'} = getgrgid($st[5]);
		$files{$i,'mode'} = sprintf "%o", $st[2] & 07777;
		$files{$i,'size'} = $st[7];
		$files{$i,'link'} = readlink($file);
		}
	else {
		$files{$i,'type'} = $file =~ /\// ? 1 : 0;
		$files{$i,'user'} = $files{$i,'group'} =
		 $files{$i,'mode'} = $files{$i,'size'} = $text{'slack_unknown'};
		$files{$i,'error'} = $text{'slack_missing'};
		}
	$i++;
	}
return $i;
}

# installed_file(file)
# Given a filename, fills %file with details of the given file and returns 1.
# If the file is not known to the package system, returns 0
# Usable values in %file are  path type user group mode size packages
sub installed_file
{
local ($f, $file, @pkgin);
opendir(DIR, &translate_filename($package_dir));
while($f = readdir(DIR)) {
	next if ($f =~ /^\./);
	&open_readfile(PKG, "$package_dir/$f");
	while(<PKG>) {
		last if (/^FILE LIST:/);
		}
	while($file = <PKG>) {
		next if ($file eq "./");
		$file =~ s/[\/\r\n]+$//;
		$file = '/'.$file;
		if ($_[0] eq $file) {
			# found it!
			push(@pkgin, $f);
			last;
			}
		}
	close(PKG);
	}
closedir(DIR);
if (@pkgin) {
	local $real = &translate_filename($_[0]);
	local @st = stat($real);
	$file{'path'} = $_[0];
	$file{'type'} = -l $real ? 3 :
			-d $real ? 1 : 0;
	$file{'user'} = getpwuid($st[4]);
	$file{'group'} = getgrgid($st[5]);
	$file{'mode'} = sprintf "%o", $st[2] & 07777;
	$file{'size'} = $st[7];
	$file{'link'} = readlink($real);
	$file{'packages'} = join(" ", @pkgin);
	return 1;
	}
else {
	return 0;
	}
}

# is_package(file)
sub is_package
{
local $count;
local $qm = quotemeta($_[0]);
&open_execute_command(TAR, "gunzip -c $qm | tar tf - 2>&1", 1, 1);
while(<TAR>) {
	$count++ if (/^[^\/\s]\S+/);
	}
close(TAR);
return $count < 2 ? 0 : 1;
}

# file_packages(file)
# Returns a list of all packages in the given file, in the form
#  package description
sub file_packages
{
if ($_[0] !~ /^(.*)\/(([^\/]+)(\.tgz|\.tar\.gz))$/) {
	return "$_[0] $text{'slack_unknown'}";
	}
local ($dir, $file, $base) = ($1, $2, $3);
local $diskfile;
opendir(DIR, &translate_filename($dir));
while($f = readdir(DIR)) {
	if ($f =~ /^disk\S+\d+$/ || $f eq 'package_descriptions') {
		# found the slackware disk file
		$diskfile = "$dir/$f";
		last;
		}
	}
closedir(DIR);
return "$base $text{'slack_unknown'}" if (!$diskfile);

# read the disk file
local $desc;
&open_readfile(DISK, $diskfile);
while(<DISK>) {
	if (/^$base:\s*(.*)/) {
		$desc = $1;
		last;
		}
	}
close(DISK);
return $desc ? "$base $desc" : "$base $text{'slack_unknown'}";
}

# install_options(file, package)
# Outputs HTML for choosing install options
sub install_options
{
print &ui_table_row($text{'slack_root'},
	&ui_textbox("root", "/", 50)." ".
	&file_chooser_button("root", 1), 3);
}

# install_package(file, package)
# Installs the package in the given file, with options from %in
sub install_package
{
local $in = $_[2] ? $_[2] : \%in;
return $text{'slack_eroot'} if (!-d $in->{'root'});
$ENV{'ROOT'} = $in->{'root'};
local $out;
local $qm = quotemeta($_[0]);
if (&has_command("upgradepkg") &&
    -r &translate_filename("$package_dir/$_[1]")) {
	# Try to upgrade properly
	$out = &backquote_logged("upgradepkg $qm 2>&1");
	}
else {
	# Just install
	$out = &backquote_logged("installpkg $qm 2>&1");
	}
if ($?) {
	return "<pre>$out</pre>";
	}
return undef;
}

# delete_package(package)
# Totally remove some package
sub delete_package
{
local $qm = quotemeta($_[0]);
local $out = &backquote_logged("removepkg $qm 2>&1");
if ($?) { return "<pre>$out</pre>"; }
return undef;
}

sub package_system
{
return $text{'slack_manager'};
}

sub package_help
{
return "installpkg removepkg";
}

1;