Expunge revision histories in files.

[sw-tools] / perl / SWList.pm

# -*-perl-*-
#
# $Id: SWList.pm,v 1.3 2004/04/08 01:52:19 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.

#----- 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>&lt;<a href=\"mailto:$addr\">$addr</a>&gt;\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") {
      printf("  <td><a href=\"$ref?act=doc&pkg=%s\">Yes</a>\n",
	     SWCGI::sanitize($pkg));
    } 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;