chiark - git - mdw - sw-tools/blob - perl/SWList.pm

   1 # -*-perl-*-
   2 #
   3 # $Id: SWList.pm,v 1.2 1999/08/24 12:15:34 mdw Exp $
   4 #
   5 # Create the main list of installed packages
   6 #
   7 # (c) 1999 EBI
   8 #
   9
  10 #----- Licensing notice -----------------------------------------------------
  11 #
  12 # This file is part of sw-tools.
  13 #
  14 # sw-tools is free software; you can redistribute it and/or modify
  15 # it under the terms of the GNU General Public License as published by
  16 # the Free Software Foundation; either version 2 of the License, or
  17 # (at your option) any later version.
  18 #
  19 # sw-tools is distributed in the hope that it will be useful,
  20 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 # GNU General Public License for more details.
  23 #
  24 # You should have received a copy of the GNU General Public License
  25 # along with sw-tools; if not, write to the Free Software Foundation,
  26 # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  27
  28 #----- Revision history -----------------------------------------------------
  29 #
  30 # $Log: SWList.pm,v $
  31 # Revision 1.2  1999/08/24 12:15:34  mdw
  32 # Properly sanitize CGI arguments (like `gtk+').
  33 #
  34 # Revision 1.1  1999/07/30 18:46:37  mdw
  35 # New CGI script for browsing installed software and documentation.
  36 #
  37
  38 #----- Package header -------------------------------------------------------
  39
  40 package SWList;
  41
  42 use IO;
  43 use POSIX;
  44
  45 use SWConfig;
  46 use SW;
  47 use SWCGI qw(:DEFAULT :layout);
  48
  49 #----- Main code ------------------------------------------------------------
  50
  51 # --- @list@ ---
  52 #
  53 # Action to output the installed software list.
  54
  55 %archmap = ( "linux" => 'l',
  56              "solaris" => 's',
  57              "sunos" => 's',
  58              "irix" => 'i',
  59              "alpha" => 'a',
  60              "hpux" => 'h' );
  61
  62
  63 sub list {
  64
  65   my @arch = ();
  66   my $narch = 0;
  67
  68   # --- Read the architecture table and assign mnemonic-ish letters ---
  69
  70   {
  71     my $a = IO::File->new("$C{datadir}/archtab") or
  72       barf("couldn't open archtab: $!");
  73     my %mn = ();
  74     LINE: while (my $line = $a->getline()) {
  75
  76       # --- Skip comments and boring things ---
  77
  78       chomp($line);
  79       next LINE if $line =~ /^\s*$/ || $line =~ /^\s*\#/;
  80
  81       # --- Break into components ---
  82
  83       my ($arch, $host) = split(" ", $line, 3);
  84
  85       # --- Assign a mnemonic character ---
  86       #
  87       # In dire cases, this will choose multiple characters.  Oh, well.  If
  88       # you have more than 26 architectures to maintain, this is the least of
  89       # your worries.
  90
  91       my $mn = "";
  92       my $hi;
  93       foreach my $k (keys(%archmap)) {
  94         if (index($arch, $k) >= 0 && !$mn->{$archmap{$k}}) {
  95           $mn = $archmap{$k};
  96           last;
  97         }
  98       }
  99       unless ($mn) {
 100         for (my $i = 0; $i < length($arch); $i++) {
 101           my $ch = lc(substr($arch, $i, 1));
 102           next unless $ch =~ /[a-z]/;
 103           $mn = $ch, last unless $mn{$ch};
 104         }
 105       }
 106       if ($mn) {
 107         ($hi = $arch) =~ s:$mn:<u>$mn</u>:;
 108       } else {
 109         for ($mn = "a"; $mn{$mn}; $mn++) { }
 110         $hi = "$arch (<u>$mn</u>)";
 111       }
 112       push(@arch, { arch => $arch, host => $host, mn => $mn, hi => $hi });
 113     }
 114   }
 115   @arch = sort { length($a->{mn}) <=> length($b->{mn}) ||
 116                    $a->{mn} cmp $b->{mn} } @arch;
 117   $narch = @arch;
 118
 119   # --- Emit a header ---
 120
 121   header("Installed software");
 122
 123   print <<EOF;
 124 <h3>Documentation</h3>
 125 <ul>
 126 <li><a href="$ref?act=man">Manual pages</a>
 127 <li><a href="$ref?act=info">GNU Info</a>
 128 </ul>
 129 <hr>
 130 <h3>Installed software</h3>
 131 <table>
 132 <tr align=left>
 133   <th rowspan=2>Package
 134   <th rowspan=2>Version
 135   <th rowspan=2 colspan=2>Maintainer
 136   <th colspan=$narch>Architectures
 137   <th rowspan=2>Date installed
 138   <th rowspan=2>Doc
 139 EOF
 140
 141   # --- Spit out the archtecture mnemonics ---
 142
 143   print "<tr align=left>\n  ";
 144   foreach my $a (@arch) { print "<th>" . $a->{mn}; }
 145   print "\n";
 146
 147   # --- Iterate through the installed packages ---
 148
 149   my $sw = SW->new();
 150   foreach my $pkg ($sw->list()) {
 151     my $m = $sw->get($pkg);
 152     print("<tr>\n");
 153
 154     # --- The package and version number are easy ---
 155
 156     print("  <td>$m->{package}\n");
 157     print("  <td>$m->{version}\n");
 158
 159     # --- Resolve the maintainer into a sensible real name ---
 160
 161     {
 162       my $maint = $m->{"maintainer"};
 163       my @pw = getpwnam($maint);
 164       my ($gecos) = split(/,/, $pw[6], 2);
 165       my $addr = $maint . ($C{domain} && "\@" . $C{domain});
 166       print("  <td>$gecos<td>&lt;<a href=\"mailto:$addr\">$addr</a>&gt;\n");
 167     }
 168
 169     # --- Dump out the architectures ---
 170     #
 171     # Assume that the names aren't ambiguous.
 172
 173     {
 174       my %a = ();
 175       foreach my $ar (split(/[\s,]+/, $m->{"arch"})) {
 176         next unless $ar;
 177         foreach my $a (@arch) {
 178           if ($a->{arch} =~ /^$ar/) {
 179             $a{$a->{arch}} = 1;
 180             last;
 181           }
 182         }
 183       }
 184
 185       print("  ");
 186       foreach my $a (@arch) {
 187         if ($a{$a->{arch}}) {
 188           print("<td>", $a->{mn});
 189         } else {
 190           print("<td>");
 191         }
 192       }
 193       print("\n");
 194     }
 195
 196     # --- Print the date ---
 197
 198     print("  <td>$m->{date}\n");
 199
 200     # --- If the documentation file exists, put a link in ---
 201
 202     if (-r "$C{doc}/$pkg") {
 203       printf("  <td><a href=\"$ref?act=doc&pkg=%s\">Yes</a>\n",
 204              SWCGI::sanitize($pkg));
 205     } else {
 206       print("  <td>No\n");
 207     }
 208   }
 209
 210   # --- Finish up ---
 211
 212   print "</table>\n";
 213
 214   # --- Emit a legend for the architecture lists ---
 215
 216   print "<p><b>Architectures:</b>\n";
 217   foreach my $a (@arch) {
 218     print $a->{hi}, "\n";
 219   }
 220   footer();
 221 }
 222
 223 #----- Register actions -----------------------------------------------------
 224
 225 $main::ACT{"list"} = \&list;
 226
 227 #----- That's all, folks ----------------------------------------------------
 228
 229 1;