software/slackware-lib.pl

   1 # slackware-lib.pl
   2 # Functions for slackware package management
   3
   4 $package_dir = "/var/log/packages";
   5 %class_map = (  'a', 'Base Slackware system',
   6                 'ap', 'Linux applications',
   7                 'd', 'Program development',
   8                 'e', 'GNU Emacs',
   9                 'extra', 'Extra Slackware packages',
  10                 'f', 'FAQs, howtos, and documentation',
  11                 'gnome', 'GNOME desktop and programs',
  12                 'k', 'Linux kernel source',
  13                 'kde', 'KDE desktop and programs',
  14                 'kdei', 'Language support of KDE',
  15                 'l', 'Libraries',
  16                 'n', 'Networking',
  17                 'pasture', 'Software put to pasture',
  18                 't', 'TeX',
  19                 'testing', 'Software in testing',
  20                 'tcl', 'TcL/Tk',
  21                 'x', 'X Windows',
  22                 'xap', 'X applications',
  23                 'y', 'Classic BSD console games' );
  24 use POSIX;
  25 chop($system_arch = `uname -m`);
  26
  27 sub validate_package_system
  28 {
  29 return -d &translate_filename($package_dir) ? undef :
  30         &text('slack_edir', "<tt>$package_dir</tt>");
  31 }
  32
  33 # list_packages([package]*)
  34 # Fills the array %packages with a list of all packages
  35 sub list_packages
  36 {
  37 local ($i, $f, @list);
  38 %packages = ( );
  39 opendir(DIR, &translate_filename($package_dir));
  40 local @list = @_ ? @_ : grep { !/^\./ } readdir(DIR);
  41 $i = 0;
  42 foreach $f (@list) {
  43         $packages{$i,'name'} = $f;
  44         $packages{$i,'class'} = $text{'slack_unclass'};
  45         &open_tempfile(PKG, "$package_dir/$f");
  46         while(<PKG>) {
  47                 if (/^PACKAGE LOCATION:\s+disk([a-z]+)\d+/i ||
  48                     /^PACKAGE LOCATION:\s+\S+\/([a-z]+)\/[^\/]+$/i) {
  49                         $packages{$i,'class'} = $class_map{$1} ||
  50                                                 $text{'slack_unclass'};
  51                         }
  52                 elsif (/^PACKAGE DESCRIPTION:/i) {
  53                         local $desc = <PKG>;
  54                         $desc =~ s/^\S+:\s+//;
  55                         $desc =~ s/\n//;
  56                         $packages{$i,'desc'} = $desc;
  57                         }
  58                 }
  59         close(PKG);
  60         $i++;
  61         }
  62 closedir(DIR);
  63 return $i;
  64 }
  65
  66 # package_info(package)
  67 # Returns an array of package information in the order
  68 #  name, class, description, arch, version, vendor, installtime
  69 sub package_info
  70 {
  71 local @rv = ( $_[0], $text{'slack_unclass'}, $text{'slack_unknown'},
  72               $system_arch, $text{'slack_unknown'}, "Slackware" );
  73 local @st = stat(&translate_filename("$package_dir/$_[0]"));
  74 $rv[6] = ctime($st[9]);
  75 &open_readfile(PKG, "$package_dir/$_[0]");
  76 while(<PKG>) {
  77         if (/^PACKAGE LOCATION:\s+disk([a-z]+)\d+/i) {
  78                 $rv[1] = $class_map{$1};
  79                 }
  80         elsif (/^PACKAGE DESCRIPTION:/i) {
  81                 $rv[2] = "";
  82                 while(<PKG>) {
  83                         last if (/^FILE LIST/i);
  84                         s/^\S+: *//;
  85                         if (!$rv[2] && /([0-9][0-9\.]*)/) {
  86                                 $rv[4] = $1;
  87                                 }
  88                         $rv[2] .= $_;
  89                         }
  90                 $rv[2] =~ s/\s+$//;
  91                 }
  92         }
  93 close(PKG);
  94 return @rv;
  95 }
  96
  97 # check_files(package)
  98 # Fills in the %files array with information about the files belonging
  99 # to some package. Values in %files are  path type user group mode size error
 100 sub check_files
 101 {
 102 local $i = 0;
 103 local $file;
 104 &open_readfile(PKG, "$package_dir/$_[0]");
 105 while(<PKG>) {
 106         last if (/^FILE LIST:/i);
 107         }
 108 while($file = <PKG>) {
 109         $file =~ s/\r|\n//g;
 110         next if ($file eq "./");
 111         $file = '/'.$file;
 112         local $real = &translate_filename($file);
 113         $files{$i,'path'} = $file;
 114         local @st = stat($real);
 115         if (@st) {
 116                 $files{$i,'type'} = -l $real ? 3 :
 117                                     -d $real ? 1 : 0;
 118                 $files{$i,'user'} = getpwuid($st[4]);
 119                 $files{$i,'group'} = getgrgid($st[5]);
 120                 $files{$i,'mode'} = sprintf "%o", $st[2] & 07777;
 121                 $files{$i,'size'} = $st[7];
 122                 $files{$i,'link'} = readlink($file);
 123                 }
 124         else {
 125                 $files{$i,'type'} = $file =~ /\// ? 1 : 0;
 126                 $files{$i,'user'} = $files{$i,'group'} =
 127                  $files{$i,'mode'} = $files{$i,'size'} = $text{'slack_unknown'};
 128                 $files{$i,'error'} = $text{'slack_missing'};
 129                 }
 130         $i++;
 131         }
 132 return $i;
 133 }
 134
 135 # package_files(package)
 136 # Returns a list of all files in some package
 137 sub package_files
 138 {
 139 local ($pkg) = @_;
 140 local @rv;
 141 &open_readfile(PKG, "$package_dir/$_[0]");
 142 while(<PKG>) {
 143         last if (/^FILE LIST:/i);
 144         }
 145 while(my $file = <PKG>) {
 146         $file =~ s/\r|\n//g;
 147         next if ($file eq "./");
 148         $file = '/'.$file;
 149         push(@rv, $file);
 150         }
 151 close(PKG);
 152 return @rv;
 153 }
 154
 155 # installed_file(file)
 156 # Given a filename, fills %file with details of the given file and returns 1.
 157 # If the file is not known to the package system, returns 0
 158 # Usable values in %file are  path type user group mode size packages
 159 sub installed_file
 160 {
 161 local ($f, $file, @pkgin);
 162 opendir(DIR, &translate_filename($package_dir));
 163 while($f = readdir(DIR)) {
 164         next if ($f =~ /^\./);
 165         &open_readfile(PKG, "$package_dir/$f");
 166         while(<PKG>) {
 167                 last if (/^FILE LIST:/);
 168                 }
 169         while($file = <PKG>) {
 170                 next if ($file eq "./");
 171                 $file =~ s/[\/\r\n]+$//;
 172                 $file = '/'.$file;
 173                 if ($_[0] eq $file) {
 174                         # found it!
 175                         push(@pkgin, $f);
 176                         last;
 177                         }
 178                 }
 179         close(PKG);
 180         }
 181 closedir(DIR);
 182 if (@pkgin) {
 183         local $real = &translate_filename($_[0]);
 184         local @st = stat($real);
 185         $file{'path'} = $_[0];
 186         $file{'type'} = -l $real ? 3 :
 187                         -d $real ? 1 : 0;
 188         $file{'user'} = getpwuid($st[4]);
 189         $file{'group'} = getgrgid($st[5]);
 190         $file{'mode'} = sprintf "%o", $st[2] & 07777;
 191         $file{'size'} = $st[7];
 192         $file{'link'} = readlink($real);
 193         $file{'packages'} = join(" ", @pkgin);
 194         return 1;
 195         }
 196 else {
 197         return 0;
 198         }
 199 }
 200
 201 # is_package(file)
 202 sub is_package
 203 {
 204 local $count;
 205 local $qm = quotemeta($_[0]);
 206 &open_execute_command(TAR, "gunzip -c $qm | tar tf - 2>&1", 1, 1);
 207 while(<TAR>) {
 208         $count++ if (/^[^\/\s]\S+/);
 209         }
 210 close(TAR);
 211 return $count < 2 ? 0 : 1;
 212 }
 213
 214 # file_packages(file)
 215 # Returns a list of all packages in the given file, in the form
 216 #  package description
 217 sub file_packages
 218 {
 219 if ($_[0] !~ /^(.*)\/(([^\/]+)(\.tgz|\.tar\.gz))$/) {
 220         return "$_[0] $text{'slack_unknown'}";
 221         }
 222 local ($dir, $file, $base) = ($1, $2, $3);
 223 local $diskfile;
 224 opendir(DIR, &translate_filename($dir));
 225 while($f = readdir(DIR)) {
 226         if ($f =~ /^disk\S+\d+$/ || $f eq 'package_descriptions') {
 227                 # found the slackware disk file
 228                 $diskfile = "$dir/$f";
 229                 last;
 230                 }
 231         }
 232 closedir(DIR);
 233 return "$base $text{'slack_unknown'}" if (!$diskfile);
 234
 235 # read the disk file
 236 local $desc;
 237 &open_readfile(DISK, $diskfile);
 238 while(<DISK>) {
 239         if (/^$base:\s*(.*)/) {
 240                 $desc = $1;
 241                 last;
 242                 }
 243         }
 244 close(DISK);
 245 return $desc ? "$base $desc" : "$base $text{'slack_unknown'}";
 246 }
 247
 248 # install_options(file, package)
 249 # Outputs HTML for choosing install options
 250 sub install_options
 251 {
 252 print &ui_table_row($text{'slack_root'},
 253         &ui_textbox("root", "/", 50)." ".
 254         &file_chooser_button("root", 1), 3);
 255 }
 256
 257 # install_package(file, package)
 258 # Installs the package in the given file, with options from %in
 259 sub install_package
 260 {
 261 local $in = $_[2] ? $_[2] : \%in;
 262 return $text{'slack_eroot'} if (!-d $in->{'root'});
 263 $ENV{'ROOT'} = $in->{'root'};
 264 local $out;
 265 local $qm = quotemeta($_[0]);
 266 if (&has_command("upgradepkg") &&
 267     -r &translate_filename("$package_dir/$_[1]")) {
 268         # Try to upgrade properly
 269         $out = &backquote_logged("upgradepkg $qm 2>&1");
 270         }
 271 else {
 272         # Just install
 273         $out = &backquote_logged("installpkg $qm 2>&1");
 274         }
 275 if ($?) {
 276         return "<pre>$out</pre>";
 277         }
 278 return undef;
 279 }
 280
 281 # delete_package(package)
 282 # Totally remove some package
 283 sub delete_package
 284 {
 285 local $qm = quotemeta($_[0]);
 286 local $out = &backquote_logged("removepkg $qm 2>&1");
 287 if ($?) { return "<pre>$out</pre>"; }
 288 return undef;
 289 }
 290
 291 sub package_system
 292 {
 293 return $text{'slack_manager'};
 294 }
 295
 296 sub package_help
 297 {
 298 return "installpkg removepkg";
 299 }
 300
 301 1;
 302