software/debian-lib.pl

   1 # debian-lib.pl
   2 # Functions for debian DPKG package management
   3
   4 sub list_package_system_commands
   5 {
   6 return ("dpkg");
   7 }
   8
   9 # list_packages([package]*)
  10 # Fills the array %packages with a list of all packages
  11 sub list_packages
  12 {
  13 local $i = 0;
  14 local $arg = @_ ? join(" ", map { quotemeta($_) } @_) : "";
  15 %packages = ( );
  16 &open_execute_command(PKGINFO, "COLUMNS=1024 dpkg --list $arg", 1, 1);
  17 while(<PKGINFO>) {
  18         next if (/^\|/ || /^\+/);
  19         if (/^[uirph]i..(\S+)\s+(\S+)\s+(.*)/) {
  20                 $packages{$i,'name'} = $1;
  21                 $packages{$i,'class'} = &alphabet_name($1);
  22                 $packages{$i,'version'} = $2;
  23                 $packages{$i,'desc'} = $3;
  24                 if ($packages{$i,'version'} =~ /^(\d+):(.*)$/) {
  25                         $packages{$i,'epoch'} = $1;
  26                         $packages{$i,'version'} = $2;
  27                         }
  28                 $i++;
  29                 }
  30         }
  31 close(PKGINFO);
  32 return $i;
  33 }
  34
  35 sub alphabet_name
  36 {
  37 return lc($_[0]) =~ /^[a-e]/ ? "A-E" :
  38        lc($_[0]) =~ /^[f-j]/ ? "F-J" :
  39        lc($_[0]) =~ /^[k-o]/ ? "K-O" :
  40        lc($_[0]) =~ /^[p-t]/ ? "P-T" :
  41        lc($_[0]) =~ /^[u-z]/ ? "U-Z" : "Other";
  42 }
  43
  44 # package_info(package)
  45 # Returns an array of package information in the order
  46 #  name, class, description, arch, version, vendor, installtime
  47 sub package_info
  48 {
  49 local $qm = quotemeta($_[0]);
  50
  51 # First check if it is really installed, and not just known to the package
  52 # system in some way
  53 local $out = &backquote_command("dpkg --list $qm 2>&1", 1);
  54 local @lines = split(/\r?\n/, $out);
  55 if ($lines[$#lines] !~ /^.[ih]/) {
  56         return ( );
  57         }
  58
  59 # Get full status
  60 local $out = &backquote_command("dpkg --print-avail $qm 2>&1", 1);
  61 return () if ($? || $out =~ /Package .* is not available/i);
  62 local @rv = ( $_[0], &alphabet_name($_[0]) );
  63 push(@rv, $out =~ /Description:\s+([\0-\177]*\S)/i ? $1
  64                                                    : $text{'debian_unknown'});
  65 push(@rv, $out =~ /Architecture:\s+(\S+)/i ? $1 : $text{'debian_unknown'});
  66 push(@rv, $out =~ /Version:\s+(\S+)/i ? $1 : $text{'debian_unknown'});
  67 push(@rv, $out =~ /Maintainer:\s+(.*)/i ? &html_escape($1)
  68                                          : $text{'debian_unknown'});
  69 push(@rv, $text{'debian_unknown'});
  70 return @rv;
  71 }
  72
  73 # check_files(package)
  74 # Fills in the %files array with information about the files belonging
  75 # to some package. Values in %files are  path type user group mode size error
  76 sub check_files
  77 {
  78 local $i = 0;
  79 local $file;
  80 local $qm = quotemeta($_[0]);
  81 &open_execute_command(PKGINFO, "dpkg --listfiles $qm", 1, 1);
  82 while($file = <PKGINFO>) {
  83         $file =~ s/\r|\n//g;
  84         next if ($file !~ /^\/[^\.]/);
  85         local @st = stat($file);
  86         $files{$i,'path'} = $file;
  87         $files{$i,'type'} = -l $file ? 3 :
  88                             -d $file ? 1 : 0;
  89         $files{$i,'user'} = getpwuid($st[4]);
  90         $files{$i,'group'} = getgrgid($st[5]);
  91         $files{$i,'mode'} = sprintf "%o", $st[2] & 07777;
  92         $files{$i,'size'} = $st[7];
  93         $files{$i,'link'} = readlink($file);
  94         $i++;
  95         }
  96 return $i;
  97 }
  98
  99 # package_files(package)
 100 # Returns a list of all files in some package
 101 sub package_files
 102 {
 103 local ($pkg) = @_;
 104 local $qn = quotemeta($pkg);
 105 local @rv;
 106 &open_execute_command(RPM, "dpkg --listfiles $qn", 1, 1);
 107 while(<RPM>) {
 108         s/\r|\n//g;
 109         push(@rv, $_);
 110         }
 111 close(RPM);
 112 return @rv;
 113 }
 114
 115 # installed_file(file)
 116 # Given a filename, fills %file with details of the given file and returns 1.
 117 # If the file is not known to the package system, returns 0
 118 # Usable values in %file are  path type user group mode size packages
 119 sub installed_file
 120 {
 121 local $qm = quotemeta($_[0]);
 122 local $out = &backquote_command("dpkg --search $qm 2>&1", 1);
 123 return 0 if ($out =~ /not found/i);
 124 $out =~ s/:\s+\S+\n$//;
 125 local @pkgin = split(/[\s,]+/, $out);
 126 local $real = &translate_filename($_[0]);
 127 local @st = stat($real);
 128 $file{'path'} = $_[0];
 129 $file{'type'} = -l $real ? 3 :
 130                 -d $real ? 1 : 0;
 131 $file{'user'} = getpwuid($st[4]);
 132 $file{'group'} = getgrgid($st[5]);
 133 $file{'mode'} = sprintf "%o", $st[2] & 07777;
 134 $file{'size'} = $st[7];
 135 $file{'link'} = readlink($real);
 136 $file{'packages'} = join(" ", @pkgin);
 137 return 1;
 138 }
 139
 140 # is_package(file)
 141 sub is_package
 142 {
 143 local $qm = quotemeta($_[0]);
 144 local $out = &backquote_command("dpkg --info $qm 2>&1", 1);
 145 return $? || $out !~ /Package:/ ? 0 : 1;
 146 }
 147
 148 # file_packages(file)
 149 # Returns a list of all packages in the given file, in the form
 150 #  package description
 151 sub file_packages
 152 {
 153 local $qm = quotemeta($_[0]);
 154 local $out = &backquote_command("dpkg --info $qm 2>&1", 1);
 155 local $name;
 156 if ($out =~ /Package:\s+(\S+)/i && ($name=$1) &&
 157     $out =~ /Description:\s+(.*)/i) {
 158         return ( "$name $1" );
 159         }
 160 return ();
 161 }
 162
 163 # install_options(file, package)
 164 # Outputs HTML for choosing install options
 165 sub install_options
 166 {
 167 print &ui_table_row($text{'debian_depends'},
 168         &ui_yesno_radio("depends", 0));
 169
 170 print &ui_table_row($text{'debian_conflicts'},
 171         &ui_yesno_radio("conflicts", 0));
 172
 173 print &ui_table_row($text{'debian_overwrite'},
 174         &ui_yesno_radio("overwrite", 0));
 175
 176 print &ui_table_row($text{'debian_downgrade'},
 177         &ui_yesno_radio("downgrade", 0));
 178 }
 179
 180 # install_package(file, package)
 181 # Installs the package in the given file, with options from %in
 182 sub install_package
 183 {
 184 local $in = $_[2] ? $_[2] : \%in;
 185 local $args = ($in->{'depends'} ? " --force-depends" : "").
 186               ($in->{'conflicts'} ? " --force-conflicts" : "").
 187               ($in->{'overwrite'} ? " --force-overwrite" : "").
 188               ($in->{'downgrade'} ? " --force-downgrade" : "");
 189 local $qm = quotemeta($_[0]);
 190 $ENV{'DEBIAN_FRONTEND'} = 'noninteractive';
 191 local $out = &backquote_logged("dpkg --install $args $qm 2>&1 </dev/null");
 192 if ($?) {
 193         return "<pre>$out</pre>";
 194         }
 195 return undef;
 196 }
 197
 198 # delete_package(package)
 199 # Totally remove some package
 200 sub delete_package
 201 {
 202 local $qm = quotemeta($_[0]);
 203 $ENV{'DEBIAN_FRONTEND'} = 'noninteractive';
 204 local $out = &backquote_logged("dpkg --remove $qm 2>&1 </dev/null");
 205 if ($? || $out =~ /which isn.t installed/i) {
 206         return "<pre>$out</pre>";
 207         }
 208 return undef;
 209 }
 210
 211 sub package_system
 212 {
 213 return $text{'debian_manager'};
 214 }
 215
 216 sub package_help
 217 {
 218 return "dpkg";
 219 }
 220
 221 1;
 222