--- /dev/null
+# -*-perl-*-
+#
+# $Id: SWList.pm,v 1.1 1999/07/30 18:46:37 mdw Exp $
+#
+# Create the main list of installed packages
+#
+# (c) 1999 EBI
+#
+
+#----- Licensing notice -----------------------------------------------------
+#
+# This file is part of sw-tools.
+#
+# sw-tools is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# sw-tools is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with sw-tools; if not, write to the Free Software Foundation,
+# Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+#----- Revision history -----------------------------------------------------
+#
+# $Log: SWList.pm,v $
+# Revision 1.1 1999/07/30 18:46:37 mdw
+# New CGI script for browsing installed software and documentation.
+#
+
+#----- Package header -------------------------------------------------------
+
+package SWList;
+
+use IO;
+use POSIX;
+
+use SWConfig;
+use SW;
+use SWCGI qw(:DEFAULT :layout);
+
+#----- Main code ------------------------------------------------------------
+
+# --- @list@ ---
+#
+# Action to output the installed software list.
+
+%archmap = ( "linux" => 'l',
+ "solaris" => 's',
+ "sunos" => 's',
+ "irix" => 'i',
+ "alpha" => 'a',
+ "hpux" => 'h' );
+
+
+sub list {
+
+ my @arch = ();
+ my $narch = 0;
+
+ # --- Read the architecture table and assign mnemonic-ish letters ---
+
+ {
+ my $a = IO::File->new("$C{datadir}/archtab") or
+ barf("couldn't open archtab: $!");
+ my %mn = ();
+ LINE: while (my $line = $a->getline()) {
+
+ # --- Skip comments and boring things ---
+
+ chomp($line);
+ next LINE if $line =~ /^\s*$/ || $line =~ /^\s*\#/;
+
+ # --- Break into components ---
+
+ my ($arch, $host) = split(" ", $line, 3);
+
+ # --- Assign a mnemonic character ---
+ #
+ # In dire cases, this will choose multiple characters. Oh, well. If
+ # you have more than 26 architectures to maintain, this is the least of
+ # your worries.
+
+ my $mn = "";
+ my $hi;
+ foreach my $k (keys(%archmap)) {
+ if (index($arch, $k) >= 0 && !$mn->{$archmap{$k}}) {
+ $mn = $archmap{$k};
+ last;
+ }
+ }
+ unless ($mn) {
+ for (my $i = 0; $i < length($arch); $i++) {
+ my $ch = lc(substr($arch, $i, 1));
+ next unless $ch =~ /[a-z]/;
+ $mn = $ch, last unless $mn{$ch};
+ }
+ }
+ if ($mn) {
+ ($hi = $arch) =~ s:$mn:<u>$mn</u>:;
+ } else {
+ for ($mn = "a"; $mn{$mn}; $mn++) { }
+ $hi = "$arch (<u>$mn</u>)";
+ }
+ push(@arch, { arch => $arch, host => $host, mn => $mn, hi => $hi });
+ }
+ }
+ @arch = sort { length($a->{mn}) <=> length($b->{mn}) ||
+ $a->{mn} cmp $b->{mn} } @arch;
+ $narch = @arch;
+
+ # --- Emit a header ---
+
+ header("Installed software");
+
+ print <<EOF;
+<h3>Documentation</h3>
+<ul>
+<li><a href="$ref?act=man">Manual pages</a>
+<li><a href="$ref?act=info">GNU Info</a>
+</ul>
+<hr>
+<h3>Installed software</h3>
+<table>
+<tr align=left>
+ <th rowspan=2>Package
+ <th rowspan=2>Version
+ <th rowspan=2 colspan=2>Maintainer
+ <th colspan=$narch>Architectures
+ <th rowspan=2>Date installed
+ <th rowspan=2>Doc
+EOF
+
+ # --- Spit out the archtecture mnemonics ---
+
+ print "<tr align=left>\n ";
+ foreach my $a (@arch) { print "<th>" . $a->{mn}; }
+ print "\n";
+
+ # --- Iterate through the installed packages ---
+
+ my $sw = SW->new();
+ foreach my $pkg ($sw->list()) {
+ my $m = $sw->get($pkg);
+ print("<tr>\n");
+
+ # --- The package and version number are easy ---
+
+ print(" <td>$m->{package}\n");
+ print(" <td>$m->{version}\n");
+
+ # --- Resolve the maintainer into a sensible real name ---
+
+ {
+ my $maint = $m->{"maintainer"};
+ my @pw = getpwnam($maint);
+ my ($gecos) = split(/,/, $pw[6], 2);
+ my $addr = $maint . ($C{domain} && "\@" . $C{domain});
+ print(" <td>$gecos<td><<a href=\"mailto:$addr\">$addr</a>>\n");
+ }
+
+ # --- Dump out the architectures ---
+ #
+ # Assume that the names aren't ambiguous.
+
+ {
+ my %a = ();
+ foreach my $ar (split(/[\s,]+/, $m->{"arch"})) {
+ next unless $ar;
+ foreach my $a (@arch) {
+ if ($a->{arch} =~ /^$ar/) {
+ $a{$a->{arch}} = 1;
+ last;
+ }
+ }
+ }
+
+ print(" ");
+ foreach my $a (@arch) {
+ if ($a{$a->{arch}}) {
+ print("<td>", $a->{mn});
+ } else {
+ print("<td>");
+ }
+ }
+ print("\n");
+ }
+
+ # --- Print the date ---
+
+ print(" <td>$m->{date}\n");
+
+ # --- If the documentation file exists, put a link in ---
+
+ if (-r "$C{doc}/$pkg") {
+ print(" <td><a href=\"$ref?act=doc&pkg=$pkg\">Yes</a>\n");
+ } else {
+ print(" <td>No\n");
+ }
+ }
+
+ # --- Finish up ---
+
+ print "</table>\n";
+
+ # --- Emit a legend for the architecture lists ---
+
+ print "<p><b>Architectures:</b>\n";
+ foreach my $a (@arch) {
+ print $a->{hi}, "\n";
+ }
+ footer();
+}
+
+#----- Register actions -----------------------------------------------------
+
+$main::ACT{"list"} = \&list;
+
+#----- That's all, folks ----------------------------------------------------
+
+1;
~mdw / sw-tools / blobdiff