--- /dev/null
+# -*-perl-*-
+#
+# $Id: Info.pm,v 1.1 1999/07/30 18:46:36 mdw Exp $
+#
+# Manipulation and reading of Info files
+#
+# (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: Info.pm,v $
+# Revision 1.1 1999/07/30 18:46:36 mdw
+# New CGI script for browsing installed software and documentation.
+#
+
+#----- Package preamble -----------------------------------------------------
+
+package Info;
+use IO;
+use POSIX;
+use Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(setpath);
+
+#----- Low-level twiddling --------------------------------------------------
+
+@infopath = ("/usr/info");
+
+# --- @setpath(PATH...)@ ---
+#
+# Sets the Info search path.
+
+sub setpath(@) {
+ @infopath = @_;
+}
+
+# --- @getname(INFO)@ ---
+#
+# Given the name of an Info manual, find the actual file.
+
+
+sub getname($) {
+ my ($file) = @_;
+
+ foreach my $p (@infopath) {
+ my $f = "$p/$file";
+
+ foreach my $suff ("", "-info", ".info") {
+ return $f . $suff if -r $f . $suff;
+ return $f . $suff . ".gz" if -r $f . $suff . ".gz";
+ }
+ }
+ return undef;
+}
+
+# --- @snarf(FILE)@ ---
+#
+# Snarf a file into a string, given its name. Handles compressed files.
+
+sub snarf($) {
+ my ($f) = @_;
+ local $/ = undef;
+ my $snarf;
+
+ if ($f =~ /\.gz$/) {
+ my $p = IO::Pipe->new();
+ my $kid = fork();
+ defined($kid) or return undef;
+ if ($kid == 0) {
+ $p->writer();
+ dup2($p->fileno(), 1);
+ exec("gzip", "-dc", $f);
+ exit(127);
+ }
+ $p->reader();
+ $snarf = $p->getline();
+ $p->close();
+ waitpid($kid, 0);
+ } else {
+ my $fh = IO::File->new($f, O_RDONLY) or return undef;
+ $snarf = $fh->getline();
+ $fh->close();
+ }
+ return $snarf;
+}
+
+#----- An Info-file object --------------------------------------------------
+
+# --- @node(NAME)@ ---
+#
+# Picks an individual node out of an Info file.
+
+sub node {
+ my ($me, $node) = @_;
+ my $offset = 0;
+ my $file;
+ my $chunk;
+
+ # --- If there's an index, it will help me find the node ---
+
+ if ($me->{index}) {
+ $offset = $me->{index}{lc($node)};
+
+ # --- Maybe the offset is into a different file ---
+
+ if ($me->{indir}) {
+ my $loff = 0;
+ PAIR: foreach my $pair (@{$me->{indir}}) {
+ if ($pair->[0] <= $offset) {
+ ($loff, $file) = @$pair;
+ } else {
+ last PAIR;
+ }
+ }
+ return undef unless $file;
+ $offset -= $loff;
+ }
+ }
+
+ # --- Fetch the file ---
+
+ if ($file) {
+ my $fn;
+
+ $fn = "$me->{dir}/$file", -r $fn or
+ $fn = "$me->{dir}/$file.gz", -r $fn or
+ return undef;
+
+ if ($me->{cache}{$fn}) {
+ $file = $me->{cache}{$fn};
+ } else {
+ $file = $me->{cache}{$fn} = snarf($fn) or return undef;
+ }
+ } else {
+ $file = $me->{base};
+ }
+
+ # --- Dig through the file to find the right node ---
+
+ GASP: for (;;) {
+ pos $file = $offset;
+ if ($file =~ / \G .*\1f\n
+ ([^\1f\n]* Node:\ *
+ \Q$node\E
+ [.,\n\t] [^\1f]*)
+ (?:\1f|\Z) /igsx) {
+ $chunk = $1;
+ last GASP;
+ }
+ $offset = 0, next GASP if $offset;
+ last GASP;
+ }
+
+ return $chunk;
+}
+
+# --- @load(NAME)@ ---
+#
+# Loads a file into an Info object.
+
+sub load {
+ my ($me, $file) = @_;
+ my $f = getname($file) or return undef;
+ my $c = snarf($f) or return undef;
+
+ # --- Read the index, and maybe snarf in the indirection file ---
+
+ if (my ($index) = ($c =~ /\1f\nTag Table:\n([^\1f]*)\1f\nEnd Tag Table\n/s)) {
+ my %index = ();
+ while ($index =~ /Node: *([^\n\7f]*)\7f(\d+)\n/sg) { $index{lc($1)} = $2; }
+ $me->{index} = \%index;
+ if ($index =~ /^\(Indirect\)/ and
+ my ($indir) = ($c =~ /\1f\nIndirect:\n([^\1f]*)\1f\n/s)) {
+ my @indir = ();
+ while ($indir =~ /([^\n:]*): *(\d+)\n/sg) { push(@indir, [$2, $1]); }
+ $me->{indir} = \@indir;
+ }
+ }
+
+ ($me->{dir} = $f) =~ s:/[^/]*$::;
+ $me->{base} = $c;
+ return $me;
+}
+
+# --- @new([NAME])@ ---
+#
+# Makes a new Info file and returns it to the caller.
+
+sub new {
+ my ($class, $file) = @_;
+ my $me = bless {}, $class;
+ return $me->load($file) if $file;
+ return $me;
+}
+
+#----- That's all, folks ----------------------------------------------------
+
+1;
--- /dev/null
+## -*-makefile-*-
+##
+## $Id: Makefile.am,v 1.1 1999/07/30 18:46:36 mdw Exp $
+##
+## Build and install Perl bits of `sw'.
+##
+## (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: Makefile.am,v $
+## Revision 1.1 1999/07/30 18:46:36 mdw
+## New CGI script for browsing installed software and documentation.
+##
+
+AUTOMAKE_OPTIONS = foreign
+
+cgidir = ${exec_prefix}/cgi-bin
+
+bin_SCRIPTS = sw-tidy
+cgi_SCRIPTS = sw
+man_MANS = sw-tidy.1 sw-cgi.1
+pkgdata_DATA = \
+ SW.pm SWConfig.pm SWCGI.pm Info.pm \
+ SWList.pm SWDoc.pm SWMan.pm SWInfo.pm
+noinst_DATA = sw.conf
+EXTRA_DIST = \
+ sw.conf \
+ SW.pm SWCGI.pm Info.pm \
+ SWList.pm SWDoc.pm SWMan.pm SWInfo.pm \
+ $(man_MANS)
+
+install-data-hook:
+ [ -r $(datadir)/sw.conf ] || \
+ @INSTALL_DATA@ $(srcdir)/sw.conf $(datadir)/sw.conf
+
+##----- That's all, folks ---------------------------------------------------
--- /dev/null
+# -*-perl-*-
+#
+# $Id: SWCGI.pm,v 1.1 1999/07/30 18:46:37 mdw Exp $
+#
+# Miscellaneous CGI support functions
+#
+# (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: SWCGI.pm,v $
+# Revision 1.1 1999/07/30 18:46:37 mdw
+# New CGI script for browsing installed software and documentation.
+#
+
+#----- Package header -------------------------------------------------------
+
+package SWCGI;
+
+use Exporter;
+use SWConfig;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(barf %Q $ref);
+@EXPORT_OK = qw(read);
+%EXPORT_TAGS = (layout => [qw(header footer)],
+ debug => [qw(dumphash)]);
+
+Exporter::export_ok_tags(qw(layout debug));
+
+#----- Layout control -------------------------------------------------------
+
+$header = 0;
+
+# --- @header(TITLE)@ --
+#
+# Emit an HTML header. This can be customized as required. Something
+# sensible happens if a header has already been emitted.
+
+sub header($) {
+ my ($title) = @_;
+ if ($header) {
+ print <<EOF;
+<hr><h1>
+$title
+</h1>
+EOF
+ } else {
+ print <<EOF;
+Content-Type: text/html
+
+<!doctype html public "-//W3C//DTD HTML 3.2 Final//EN">
+<html><head><title>
+$title
+</title></head><body bgcolor=white>
+EOF
+ $header = 1;
+ }
+}
+
+# --- @footer@ ---
+#
+# Emit an HTML footer to a page.
+
+sub footer() {
+ print <<EOF;
+<hr><div align=right><font size="-1"><i>
+sw.cgi ($C{pkg} $C{version})
+</i></font></div></body></html>
+EOF
+}
+
+#----- Useful functions -----------------------------------------------------
+
+# --- @barf(ERROR)@ ---
+#
+# Reports an error and exits. The error is lovingly trapped in an HTML
+# wrapper so that it can appropriately terrify a user.
+
+sub barf($) {
+ my ($error) = @_;
+ header("Internal error in sw.cgi");
+ print <<EOF;
+<h3>
+Internal error in sw.cgi
+</h3>
+
+<p>$error
+
+<p>This may be a result of a broken link or a server misconfiguration,
+or it might be a bug in sw.cgi itself. Please report this problem to
+your <a href="mailto:$ENV{SERVER_ADMIN}">server administrator</a> to
+sort out.
+EOF
+ footer();
+ exit;
+}
+
+#----- Debugging ------------------------------------------------------------
+
+# --- @dumphash(HASH)@ ---
+#
+# Dumps a hash out in a tabular format.
+
+sub dumphash(\%) {
+ my ($h) = @_;
+ print "<table border=1 bgcolor=lightgrey>\n";
+ foreach my $k (sort(keys(%$h))) {
+ print " <tr><th align=left>$k<td>$h->{$k}\n";
+ }
+ print "</table>\n";
+}
+
+#----- Argument reading -----------------------------------------------------
+
+%Q = ();
+$ref = "/cgi-bin/sw.cgi";
+
+# --- @read([QUERY])@ ---
+#
+# Reads arguments from a web server.
+
+sub read(;$) {
+ my ($q) = @_;
+
+ # --- Read in the query string ---
+ #
+ # If a query is supplied as an argument then use that. Otherwise use the
+ # `REQUEST_METHOD' variable. Accept `GET' or `POST', and use the
+ # appropriate method for getting the data. If the variable wasn't set,
+ # read the command line arguments. If it's something I don't understand,
+ # raise an error.
+
+ unless (defined($q)) {
+ my $meth = $ENV{"REQUEST_METHOD"};
+ if ($meth eq "GET") {
+ $q = $ENV{"QUERY_STRING"};
+ } elsif ($meth eq "PUT") {
+ local $/ = undef;
+ $q = <STDIN>;
+ } elsif (!defined($meth)) {
+ $q = join("&", @ARGV);
+ } else {
+ barf("unsupported requst method `$meth'");
+ }
+ }
+
+ # --- Parse it up into little bits ---
+
+ foreach my $pair (split(/\&/, $q)) {
+ my ($k, $v) = split(/\=/, $pair);
+ $k =~ tr/+/ /; $k =~ s/\%([0-9A-Fa-f][0-9A-Fa-f])/chr(hex($1))/eg;
+ $v =~ tr/+/ /; $v =~ s/\%([0-9A-Fa-f][0-9A-Fa-f])/chr(hex($1))/eg;
+ $Q{$k} = $v;
+ }
+
+ # --- Set other bits of data from this ---
+
+ $ENV{"SCRIPT_NAME"} and $ref = $ENV{"SCRIPT_NAME"};
+}
+
+#----- That's all, folks ----------------------------------------------------
+
+1;
--- /dev/null
+# -*-perl-*-
+#
+# $Id: SWDoc.pm,v 1.1 1999/07/30 18:46:37 mdw Exp $
+#
+# Display documentation files
+#
+# (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: SWDoc.pm,v $
+# Revision 1.1 1999/07/30 18:46:37 mdw
+# New CGI script for browsing installed software and documentation.
+#
+
+#----- Package preamble -----------------------------------------------------
+
+package SWDoc;
+
+use IO;
+use POSIX;
+use SWConfig;
+use SWCGI qw(:DEFAULT :layout);
+use SWMan;
+
+#----- Actions provided -----------------------------------------------------
+
+sub doc {
+ my $file = "$C{doc}/$Q{pkg}";
+ barf("illegal filename `$file'") if $file =~ m:\./:;
+ my $fh = IO::File->new($file, O_RDONLY) or
+ barf("couldn't open `$file': $!");
+ header("Local documentation for package $Q{pkg}");
+ print("<h3>Local documentation for package $Q{pkg}</h3>\n");
+ print("<pre>\n");
+
+ while (my $line = $fh->getline()) {
+ last if $line =~ /\f/;
+ $line =~ s/\&/&/g;
+ $line =~ s/\</</g;
+ $line =~ s/\>/>/g;
+ $line =~ s!(http|ftp)://[^]&)\s]*[^]&).,\s\']!<a href="$&">$&</a>!g;
+ $line =~ s!info:([^]&)\s]*[^]&).,\s\'\"])!<a href="$ref?act=info&file=$1&node=Top">$&</a>!g;
+ $line =~ s![^\s()&;{}.,\`\"][^\s()&;{}\`\"]*\@[^\s()&;{}\'\"]*[^\s()&;{}.,\'\"]!<a href="mailto:$&">$&</a>!g;
+ $line =~ s!([-_.\w]+)\((\d+\w*)\)!SWMan::subst("$1($2)", $1, $2)!eg;
+ print $line;
+ }
+ print "</pre>\n";
+ footer();
+}
+
+#----- Register actions -----------------------------------------------------
+
+$main::ACT{"doc"} = \&doc;
+
+#----- That's all, folks ----------------------------------------------------
+
+1;
--- /dev/null
+# -*-perl-*-
+#
+# $Id: SWInfo.pm,v 1.1 1999/07/30 18:46:37 mdw Exp $
+#
+# Read and output GNU Info files
+#
+# (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: SWInfo.pm,v $
+# Revision 1.1 1999/07/30 18:46:37 mdw
+# New CGI script for browsing installed software and documentation.
+#
+
+#----- Package preamble -----------------------------------------------------
+
+package SWInfo;
+
+use IO;
+
+use SWConfig;
+use SWCGI qw(:DEFAULT :layout);
+use SWMan;
+use Info;
+
+#----- Useful functions -----------------------------------------------------
+
+# --- @subst(IREF, FILE, INFO)@ ---
+#
+# Given an Info reference and the name of the current Info file, returns an
+# HTML anchor which represents the link.
+
+sub subst($$$) {
+ my ($iref, $file, $i) = @_;
+ my $node;
+ my $dir;
+ my $tail = "";
+
+ # --- Dig out the node and file being referred to ---
+
+ if ($iref =~ /:$/) {
+ $tail = ":";
+ $iref = $`;
+ }
+ my $oref = $iref;
+ $iref =~ s/\s+/ /g;
+ if ($iref =~ /^.+: *(.+)$/) { $iref = $1; }
+ if ($iref =~ /(?:\(([^\)]*)\))?(.*)$/) {
+ $file = $1 || $file;
+ $node = $2 || "Top";
+ } else {
+ $node = $iref;
+ }
+
+ # --- Transform it into something that won't get mangled ---
+
+ $node =~ s/[+&=%]|[^ -~]/sprintf("%%%02x", ord($&))/eg;
+ $node =~ tr/ /+/;
+
+ ($dir = $i->{dir}) =~ s:$C{prefix}/info/?::;
+ $dir = "&dir=$dir" if $dir;
+
+ return "<a href=\"$ref?act=info&file=$file&node=$node$dir\">$oref</a>$tail";
+}
+
+#----- Actions --------------------------------------------------------------
+
+sub info {
+ my $file = $Q{file} || "dir";
+ my $node = $Q{node} || "Top";
+ my $dir = $Q{dir} || "";
+ my $out;
+
+ # --- Read the node in ---
+
+ Info::setpath("$C{prefix}/info");
+
+ "$dir/$file" =~ m:\./: and
+ barf("bad filename `$dir/$file'");
+ my $i = (($dir && Info->new("$dir/$file")) ||
+ Info->new($file))
+ or barf("couldn't find info file `$file'");
+ my $n = $i->node($node) or
+ barf("info file `$file' doesn't contain node `$node'");
+
+ # --- Now translate the node into HTML, first line first ---
+
+ $n =~ s/\&/&/;
+ $n =~ s/\</</;
+ $n =~ s/\>/>/;
+ $n =~ s/\A( [^\n]* Next:\ *) ([^,\n]*) / $1 . subst($2, $file, $i) /eix;
+ $n =~ s/\A( [^\n]* Prev:\ *) ([^,\n]*) / $1 . subst($2, $file, $i) /eix;
+ $n =~ s/\A( [^\n]* Up:\ *) ([^,\n]*) / $1 . subst($2, $file, $i) /eix;
+
+ # --- Grind through picking up any notes ---
+
+ $out = "";
+
+ for (;;) {
+ if ($n =~ /(\*Note\s*)([^:]*: *(?:\([^\)]*\))?[^.,;:]*)([.,;:])/i) {
+ $out .= $` . $1 . subst($2, $file, $i) . $3;
+ $n = $';
+ } else {
+ last;
+ }
+ }
+
+ # --- If there's a menu then process that ---
+
+ if ($n =~ /\n\* *Menu:/s) {
+ $out .= $` . $&;
+ $n = $';
+ for (;;) {
+ if ($n =~ /(\n\* *)([^:]*: *(?:\([^\)]*\))?[^.,;:]*)([.,;:])/) {
+ $out .= $` . $1 . subst($2, $file, $i) . $3;
+ $n = $';
+ } else {
+ last;
+ }
+ }
+ }
+ $out .= $n;
+
+ $out =~ s!(http|ftp)://[^]&)\s]*[^]&).,\s\'\"]!<a href="$&">$&</a>!g;
+ $out =~ s![^\s()&;{}.,\`\"][^\s()&;{}\`\"]*\@[^\s()&;{}\'\"]*[^\s()&;{}.,\'\"]!<a href="mailto:$&">$&</a>!g;
+ $out =~ s!([-_.\w]+)\((\d+\w*)\)!SWMan::subst("$1($2)", $1, $2)!eg;
+
+ header("Info: ($file)$node");
+ print("<pre>\n$out</pre>\n");
+ footer();
+}
+
+#----- Actions provided -----------------------------------------------------
+
+$main::ACT{"info"} = \&info;
+
+#----- That's all, folks ----------------------------------------------------
--- /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;
--- /dev/null
+# -*-perl-*-
+#
+# $Id: SWMan.pm,v 1.1 1999/07/30 18:46:37 mdw Exp $
+#
+# Display and other fiddling of manual pages
+#
+# (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: SWMan.pm,v $
+# Revision 1.1 1999/07/30 18:46:37 mdw
+# New CGI script for browsing installed software and documentation.
+#
+
+#----- Package preamble -----------------------------------------------------
+
+package SWMan;
+
+use IO;
+use POSIX;
+use DirHandle;
+use Exporter;
+
+use SWConfig;
+use SWCGI qw(:DEFAULT :layout);
+
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(subst check);
+
+#----- Useful functions -----------------------------------------------------
+
+%mandb = ();
+
+# --- @mans(SECTION)@ ---
+#
+# Returns a reference to a list of manual pages in the given section.
+
+sub mans($) {
+ my ($sec) = @_;
+ $mandb{$sec} and return $mandb{sec};
+
+ my $d = DirHandle->new("$C{prefix}/man/man$sec") or return undef;
+ my @f;
+ while (my $f = $d->read()) {
+ push(@f, $f);
+ }
+ $mandb{$sec} = \@f;
+ return \@f;
+}
+
+# --- @check(NAME, SECTION)@ ---
+#
+# See whether there's a manpage called NAME with section SECTION.
+
+sub check($$) {
+ my $pre = "$C{prefix}/man/man";
+ my ($man, $sec) = @_;
+ my $f;
+
+ # --- Quick check for obvious things ---
+
+ my ($base) = ($sec =~ /^(\d+)/);
+ $f = "$pre$base/$man.$sec";
+ -r $f and return $f; $f .= ".gz"; -r $f and return $f;
+
+ # --- Snarf the appropriate filename list ---
+
+ my $fs = mans($base) or return undef;
+ foreach my $f (@$fs) {
+ $f =~ /^$man\.$sec\w+(\.gz)?$/ and return "$C{prefix}/man/man$base/$f";
+ }
+ return undef;
+}
+
+# --- @subst(STRING, NAME, SECTION)@ ---
+#
+# If NAME(SECTION) is a manual page, return the STRING appropriately wrapped
+# in an anchor element; otherwise return it unmolested.
+
+sub subst($$$) {
+ my ($s, $n, $sec) = @_;
+ check($n, $sec) and
+ return "<a href=\"$ref?act=man&man=$n&sec=$sec\">$s</a>";
+ return "$s";
+}
+
+# --- @sections()@ ---
+#
+# Return a list of manual sections.
+
+@sectionlist = ();
+
+sub sections() {
+ return @sectionlist if @sectionlist;
+ my @s = ();
+ my $d = DirHandle->new("$C{prefix}/man") or
+ barf("couldn't open man directory: $!");
+ while ($f = $d->read()) {
+ next if $f !~ /^man/ || !-d "$C{prefix}/man/$f";
+ push(@s, $');
+ }
+ return (@sectionlist = sort(@s));
+}
+
+#----- Display a quick section index ----------------------------------------
+
+sub quickie {
+ print "Quick section index:\n";
+ foreach $s (sections()) {
+ print "<a href=\"$ref?act=man&sec=$s\">$s</a>\n";
+ }
+}
+
+#----- Display indices for manual sections ----------------------------------
+
+sub dosection($) {
+ my ($sec) = @_;
+ my @m = ();
+
+ barf("illegal section `$sec'") if $sec =~ m:/:;
+
+ # --- Snarf the list of manual pages in this section ---
+
+ {
+ my $d = DirHandle->new("$C{prefix}/man/man$sec") or
+ barf("couldn't read directory `$C{prefix}/man/man$sec': $!");
+ while (my $f = $d->read()) {
+ my ($man, $sec) = split(/\./, $f, 3);
+ push(@m, "$man($sec)") if $sec;
+ }
+ }
+
+ # --- Sort and emit the index ---
+
+ print("<h4>Section $sec</h4>\n<table>");
+
+ {
+ my $col = 0;
+ foreach my $m (sort(@m)) {
+ my ($man, $sec) = $m =~ /^(.*)\((.*)\)$/;
+ $col or print("<tr>\n");
+ print("<td><a href=\"$ref?act=man&man=$man&sec=$sec\">$m</a>\n");
+ $col = ($col + 1) % 5;
+ }
+ }
+
+ print("</table>\n");
+}
+
+sub section {
+ my $sec = $Q{"sec"};
+ header("Index of manual section $sec");
+ quickie(); print "<hr>\n";
+ dosection($sec);
+ print "<hr>\n"; quickie();;
+ footer();
+}
+
+sub index {
+ header("Manual page index");
+ print("<h3>Manual page index</h3>\n");
+ foreach my $s (sections()) { dosection($s); }
+ footer();
+}
+
+#----- Display a manual page ------------------------------------------------
+
+sub man {
+ my ($man, $sec) = ($Q{"man"}, $Q{"sec"});
+
+ $sec or &index(), return;
+ $man or §ion(), return;
+
+ my $file = check($man, $sec) or
+ barf("no manual page $man($sec)");
+ barf("illegal filename `$file'") if $file =~ m:\./:;
+
+ # --- Read the manual page ---
+
+ my $p = IO::Pipe->new();
+ my $kid = fork();
+ defined($kid) or barf("fork failed: $!");
+ if ($kid == 0) {
+ $p->writer();
+ dup2($p->fileno(), 1);
+ chdir("$C{prefix}/man");
+ if ($file =~ /\.gz$/) {
+ $pp = IO::Pipe->new;
+ $kkid = fork();
+ defined($kid) or exit(127);
+ if ($kkid == 0) {
+ $pp->writer();
+ dup2($pp->fileno, 1);
+ exec("gzip", "-dc", $file);
+ exit(127);
+ }
+ exec("nroff", "-man");
+ } else {
+ exec("nroff", "-man", $file);
+ }
+ exit(127);
+ }
+ $p->reader();
+
+ # --- Spit out the manual page now ---
+
+ header("Manual page $Q{man}($Q{sec})");
+ quickie(); print "<hr>\n";
+ print "<pre>\n";
+ while (my $line = $p->getline()) {
+ chomp $line;
+
+ # --- Grind through the line turning it into HTML ---
+
+ {
+ my $state = "";
+ my $l = "";
+
+ for (my $i = 0; $i < length($line); $i++) {
+ my $ch = substr($line, $i, 1);
+ my $nstate = "";
+
+ # --- Sort out overstriking ---
+
+ if (substr($line, $i + 1, 1) eq "\b") {
+ my ($italic, $bold) = (0, 0);
+ $ch eq "_" and $italic = 1;
+ $ch eq substr($line, $i + 2, 1) and $bold = 1;
+ $ch = substr($line, $i + 2, 1);
+ while (substr($line, $i + 1, 1) eq "\b") { $i += 2; }
+ if ($italic && $bold) {
+ $nstate = $state ? $state : "b";
+ } elsif ($italic) {
+ $nstate = "i";
+ } elsif ($bold) {
+ $nstate = "b";
+ }
+ }
+ $state ne $nstate and
+ $l .= ($state && "</$state>") . ($nstate && "<$nstate>");
+ $state = $nstate;
+
+ # --- Translate the character if it's magical ---
+
+ $ch eq "&" and $ch = "&";
+ $ch eq "<" and $ch = "<";
+ $ch eq ">" and $ch = ">";
+ $l .= $ch;
+ }
+ $state and $l .= "</$state>";
+
+ # --- Now find manual references in there ---
+ #
+ # I don't use /x regexps very often, but I think this is a good excuse.
+
+ $l =~ s! ((?:\<[bi]\>)*) # Leading highlighting tags
+ ([-_.\w]+) # Various plausible manual name chars
+ ((?:\</[bi]\>)* # Closing highlighting tags
+ (?:\<[bi]\>)* # And opening ones again
+ \( # An open parenthesis
+ (?:\<[bi]\>)*) # More opening highlights
+ (\d+\w*) # The section number
+ ((?:\</[bi]\>)* # Close highlights
+ \) # Close parens
+ (?:\</[bi]\>)*) # Finally more closing tags
+ ! subst($&, $2, $4) !egx;
+
+ # --- And email and hypertext references too ---
+
+ $l =~ s! ((?:\<[bi]\>)*) # Leading highlighting
+ ((?:http|ftp) # A protocol name
+ :// # The important and obvious bit
+ [^]&)\s]+ # Most characters are allowed
+ [^]&).,\s\'\"]) # Don't end on punctuation
+ ((?:\</[bi]\>)*) # Closing tags, optional
+ !<a href="$2">$&</a>!gx;
+
+ $l =~ s! ((?:\<[bi]\>)*)
+ ( [^\s()&;{}<>,.\`\"] [^\s()&;{}<>\`\"]* \@
+ [^\s()&;{}<>\'\"]* [^\s()&;{}<>.,\'\"])
+ ((?:\</[bi]\>)*)
+ !<a href="mailto:$2">$&</a>!gx;
+
+ # --- Done! ---
+
+ print $l, "\n";
+ }
+ }
+
+ # --- Done all of that ---
+
+ print "</pre>\n";
+ $p->close();
+ waitpid($kid, 0);
+ barf("nroff failed (exit status $?)") if $?;
+ print "<hr>\n"; quickie();;
+ footer();
+}
+
+#----- Register actions -----------------------------------------------------
+
+$main::ACT{"man"} = \&man;
+
+#----- That's all, folks ----------------------------------------------------
+
+1;
--- /dev/null
+.\" -*-nroff-*-
+.\"
+.\" $Id: sw-cgi.1,v 1.1 1999/07/30 18:46:38 mdw Exp $
+.\"
+.\" Man page for `sw' CGI script
+.\"
+.\" (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: sw-cgi.1,v $
+.\" Revision 1.1 1999/07/30 18:46:38 mdw
+.\" New CGI script for browsing installed software and documentation.
+.\"
+.
+.\"----- Style hacking ------------------------------------------------------
+.
+.de VS \" Start a sort-of verbatim block
+.sp 1
+.in +5n
+.nf
+.ft B
+..
+.de VE \" Stop a sort-of verbatim block
+.ft R
+.fi
+.in -5n
+.sp 1
+..
+.ie \n(.g \{\
+. fam P
+. ds mw \fR[\f(BImdw\fR]
+.\}
+.el .ds mw \fR[\fBmdw\fR]
+.ie t .ds o \(bu
+.el .ds o o
+.ds sw \fBsw\fP
+.
+.\"----- Main manual text ---------------------------------------------------
+.
+.TH sw-cgi 1 "30 July 1999" sw-tools
+.PD 1
+.
+.\"--------------------------------------------------------------------------
+.
+.SH "NAME"
+.
+sw-cgi \- CGI script for browsing installed software and documentation
+.
+.\"--------------------------------------------------------------------------
+.
+.SH "SYNOPSIS"
+.
+.IB prefix /cgi-bin/sw
+.RI [ key = value ]...
+.
+.\"--------------------------------------------------------------------------
+.
+.SH "DESCRIPTION"
+.
+The
+.B sw
+CGI script provides users with a pleasant-ish interface for browsing the
+list of locally installed software and its documentation.
+.PP
+The script picks up arguments from HTTP
+.B GET
+or
+.B POST
+requests, or from the command line (which is useful when debugging).
+Given no arguments, it emits a table of installed software read from the
+index file in
+.IB prefix /sw-index
+together with links to documentation.
+.PP
+The program assumes that any
+.I package
+has documentation stashed in
+.IB prefix /doc/ package
+in plain text format. You can require your installers to do this by
+putting this code in a
+.B sw-precommit
+script (see the
+.B "Command reference"
+in
+.BR sw (1)
+for details):
+.VS
+# --- Ensure the documentation file exists ---
+
+if [ ! -r "$SW_PREFIX/doc/$SW_PACKAGE" ]; then
+ echo >&2 "no documentation file \`$SW_PREFIX/doc/$SW_PACKAGE'"
+ exit 1
+fi
+.VE
+Links to these documentation files are put into the table
+automatically. The script picks out likely-looking references to other
+sources of information:
+.TP
+.I "manual pages"
+A reference of the form
+.IB name ( section )
+is suspected of being a manual page; the script looks in the manual
+directories to see if this is the case and if so inserts a hypertext
+link to the manual page. This is the standard form for manual page
+references.
+.TP
+.I "info manuals"
+A reference of the form
+.BI info: name
+is assumed to be a reference to the GNU Info manual called
+.I name
+and an appropriate link inserted. There isn't a standard form for Info
+references in non-Info manuals, so I've invented one.
+.TP
+.I "URLs"
+A URL which begins with one of
+.B http://
+or
+.B ftp://
+is spotted and turned into a link. Only these two work.
+.TP
+.I "email addresses"
+Something that looks like an email address is turned into a
+.B mailto
+link.
+.PP
+Similar transformations are applied to manual pages when they're
+formatted.
+.
+.SS "Script arguments"
+The behaviour of the script is determined by the value of the
+.B act
+key. Any of the following may be given:
+.TP
+.B list
+Emit the list of packages in tabular form. This is the default if no
+.B act
+is given.
+.TP
+.B doc
+Format a textual documentation file. The name of the package whose
+documentation is to be emitted is given as the value of the
+.B pkg
+key.
+.TP
+.B man
+Format a manual page, or emit a manual index. If no
+.B sec
+key is given, an index of all manual pages in the software area is
+produced. If
+.B sec
+is a manual page section (e.g.,
+.BR 1 ,
+not
+.BR man1 )
+but
+.B man
+is not given then an index of that particular section is emitted. If
+both
+.B sec
+and
+.B man
+are supplied then the manual page whose name is given by the
+.B man
+key in the section given by the
+.B sec
+key is formatted (using
+.BR nroff (1))
+and displayed. Manual page references, URLs and email addresses are
+transformed into links in the output.
+.TP
+.B info
+Format a GNU Info node. If the
+.B file
+key is given, its value names an Info manual to open; the default is
+.BR dir .
+If the
+.B node
+key is given, its value names a node within the manual; the default is
+.BR Top .
+.TP
+.B show-config
+Emits a table showing the configuration settings which the script is
+aware of. See
+.B Configuration
+below. This is useful during debugging.
+.TP
+.B show-environment
+Displays the environment variables passed to the script by the Web
+server. This is useful during debugging.
+.TP
+.B show-query
+Displays the query string passed by the Web server, decomposed into keys
+and values and decoded. This is useful during debugging.
+.
+.SS "Configuration"
+The
+.B sw
+CGI script needs some configuration before it can do its work properly.
+Indeed, it will refuse to run until the configuration file has been
+edited.
+.PP
+The configuration file is in
+.IB prefix /share/sw.conf\fR.
+The format is simple. A line may be empty, or a comment, in which case
+it is ignored. Comments have
+.RB ` # '
+as their first non-whitespace character; blank lines contain only
+whitespace. A line may also contain a configuration variable
+assignment, of the form
+.I key
+.RB [ = ]
+.IR value .
+The
+.I key
+may be anything you like; only certain keys make sense to the script.
+.PP
+Configuration keys currently used are:
+.TP
+.B pkg
+The name of the package in which the script came. This is set
+automatically and you should not change the value.
+.TP
+.B version
+The version number of the package. This is set automatically and you
+should not change the value.
+.TP
+.B edited-config-file
+Must be assigned the value
+.BR yes .
+If this is not the case the script will immediately report an error.
+The default configuration file comes with a commented-out assignment to
+this variable.
+.TP
+.B prefix
+The installation prefix where your software gets installed. You
+shouldn't need to change this, although it's handy for debugging.
+.TP
+.BR index ", " doc " and " datadir
+The name of the index file, documentation directory and shared data
+directory respectively. The default values of these variables are set
+automatically and you shouldn't need to change them.
+.TP
+.B domain
+Your email domain. Set this to the domain part for email addresses of
+people at your site, and the script will generate correct links in its
+main list page.
+.
+.\"--------------------------------------------------------------------------
+.
+.SH "SEE ALSO"
+.BR sw (1),
+.BR sw-info (5).
+.
+.SH "AUTHOR"
+.
+The \*(sw program, and this manual, are \*(mw productions, in association
+with the European Bioinformatics Institute. They were written by Mark
+Wooding <mdw@nsict.org>. Go and ask him if you have problems.
+.
+.\"----- That's all, folks --------------------------------------------------
--- /dev/null
+# Example configuration file for `sw' Perl scripts
+#
+# The syntax is straightforward: `key = value', one per line. Blank lines
+# and comments are ignored.
+
+# Uncomment this entry to make everything actually work
+# edited-config-file = yes
+
+# Put your mail domain in here. This is used for working out maintainers'
+# email addresses from their user names.
+domain = ebi.ac.uk
+
--- /dev/null
+#! @PERL@
+# -*-perl-*-
+#
+# $Id: sw.in,v 1.1 1999/07/30 18:46:38 mdw Exp $
+#
+# CGI interface for software installations
+#
+# (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: sw.in,v $
+# Revision 1.1 1999/07/30 18:46:38 mdw
+# New CGI script for browsing installed software and documentation.
+#
+
+#----- Required packages ----------------------------------------------------
+
+use lib qw(@pkgdatadir@);
+
+use POSIX;
+use IO;
+
+use SWConfig;
+use SW;
+use SWCGI qw(:DEFAULT :debug);
+
+#----- Get packages implementing various actions ----------------------------
+
+BEGIN { %ACT = (); }
+use SWList;
+use SWDoc;
+use SWMan;
+use SWInfo;
+
+#----- Some built-in debugging actions --------------------------------------
+
+sub debug($\%) {
+ my ($what, $h) = @_;
+ SWCGI::header($what);
+ SWCGI::dumphash(%$h);
+ SWCGI::footer();
+}
+
+$ACT{"show-config"} = sub { debug("configuration", %C); };
+$ACT{"show-environment"} = sub { debug("configuration", %ENV); };
+$ACT{"show-query"} = sub { debug("configuration", %Q); };
+
+#----- Snarf arguments ------------------------------------------------------
+
+$C{"edited-config-file"} eq "yes" or
+ barf("Config file $C{datadir}/sw.conf hasn't been edited.");
+
+SWCGI::read();
+$act = $Q{"act"} || "list";
+if ($ACT{$act}) {
+ &{$ACT{$act}};
+} else {
+ barf("unknown action `$act'");
+}
+
+#----- That's all, folks ----------------------------------------------------
+
+exit;
~mdw / sw-tools / commitdiff