3 # $Id: SWList.pm,v 1.2 1999/08/24 12:15:34 mdw Exp $
5 # Create the main list of installed packages
10 #----- Licensing notice -----------------------------------------------------
12 # This file is part of sw-tools.
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.
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.
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.
28 #----- Revision history -----------------------------------------------------
31 # Revision 1.2 1999/08/24 12:15:34 mdw
32 # Properly sanitize CGI arguments (like `gtk+').
34 # Revision 1.1 1999/07/30 18:46:37 mdw
35 # New CGI script for browsing installed software and documentation.
38 #----- Package header -------------------------------------------------------
47 use SWCGI
qw(:DEFAULT
:layout
);
49 #----- Main code ------------------------------------------------------------
53 # Action to output the installed software list.
55 %archmap = ( "linux" => 'l',
68 # --- Read the architecture table and assign mnemonic-ish letters ---
71 my $a = IO
::File
->new("$C{datadir}/archtab") or
72 barf
("couldn't open archtab: $!");
74 LINE
: while (my $line = $a->getline()) {
76 # --- Skip comments and boring things ---
79 next LINE
if $line =~ /^\s*$/ || $line =~ /^\s*\#/;
81 # --- Break into components ---
83 my ($arch, $host) = split(" ", $line, 3);
85 # --- Assign a mnemonic character ---
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
93 foreach my $k (keys(%archmap)) {
94 if (index($arch, $k) >= 0 && !$mn->{$archmap{$k}}) {
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};
107 ($hi = $arch) =~ s
:$mn:<u
>$mn</u
>:;
109 for ($mn = "a"; $mn{$mn}; $mn++) { }
110 $hi = "$arch (<u>$mn</u>)";
112 push(@arch, { arch
=> $arch, host
=> $host, mn
=> $mn, hi
=> $hi });
115 @arch = sort { length($a->{mn
}) <=> length($b->{mn
}) ||
116 $a->{mn
} cmp $b->{mn
} } @arch;
119 # --- Emit a header ---
121 header
("Installed software");
124 <h3>Documentation</h3>
126 <li><a href="$ref?act=man">Manual pages</a>
127 <li><a href="$ref?act=info">GNU Info</a>
130 <h3>Installed software</h3>
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
141 # --- Spit out the archtecture mnemonics ---
143 print "<tr align=left>\n ";
144 foreach my $a (@arch) { print "<th>" . $a->{mn
}; }
147 # --- Iterate through the installed packages ---
150 foreach my $pkg ($sw->list()) {
151 my $m = $sw->get($pkg);
154 # --- The package and version number are easy ---
156 print(" <td>$m->{package}\n");
157 print(" <td>$m->{version}\n");
159 # --- Resolve the maintainer into a sensible real name ---
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><<a href=\"mailto:$addr\">$addr</a>>\n");
169 # --- Dump out the architectures ---
171 # Assume that the names aren't ambiguous.
175 foreach my $ar (split(/[\s,]+/, $m->{"arch"})) {
177 foreach my $a (@arch) {
178 if ($a->{arch
} =~ /^$ar/) {
186 foreach my $a (@arch) {
187 if ($a{$a->{arch
}}) {
188 print("<td>", $a->{mn
});
196 # --- Print the date ---
198 print(" <td>$m->{date}\n");
200 # --- If the documentation file exists, put a link in ---
202 if (-r
"$C{doc}/$pkg") {
203 printf(" <td><a href=\"$ref?act=doc&pkg=%s\">Yes</a>\n",
204 SWCGI
::sanitize
($pkg));
214 # --- Emit a legend for the architecture lists ---
216 print "<p><b>Architectures:</b>\n";
217 foreach my $a (@arch) {
218 print $a->{hi
}, "\n";
223 #----- Register actions -----------------------------------------------------
225 $main::ACT
{"list"} = \
&list
;
227 #----- That's all, folks ----------------------------------------------------