| 1 | # -*-perl-*- |
| 2 | # |
| 3 | # $Id: SWList.pm,v 1.3 2004/04/08 01:52:19 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 | #----- Package header ------------------------------------------------------- |
| 29 | |
| 30 | package SWList; |
| 31 | |
| 32 | use IO; |
| 33 | use POSIX; |
| 34 | |
| 35 | use SWConfig; |
| 36 | use SW; |
| 37 | use SWCGI qw(:DEFAULT :layout); |
| 38 | |
| 39 | #----- Main code ------------------------------------------------------------ |
| 40 | |
| 41 | # --- @list@ --- |
| 42 | # |
| 43 | # Action to output the installed software list. |
| 44 | |
| 45 | %archmap = ( "linux" => 'l', |
| 46 | "solaris" => 's', |
| 47 | "sunos" => 's', |
| 48 | "irix" => 'i', |
| 49 | "alpha" => 'a', |
| 50 | "hpux" => 'h' ); |
| 51 | |
| 52 | |
| 53 | sub list { |
| 54 | |
| 55 | my @arch = (); |
| 56 | my $narch = 0; |
| 57 | |
| 58 | # --- Read the architecture table and assign mnemonic-ish letters --- |
| 59 | |
| 60 | { |
| 61 | my $a = IO::File->new("$C{datadir}/archtab") or |
| 62 | barf("couldn't open archtab: $!"); |
| 63 | my %mn = (); |
| 64 | LINE: while (my $line = $a->getline()) { |
| 65 | |
| 66 | # --- Skip comments and boring things --- |
| 67 | |
| 68 | chomp($line); |
| 69 | next LINE if $line =~ /^\s*$/ || $line =~ /^\s*\#/; |
| 70 | |
| 71 | # --- Break into components --- |
| 72 | |
| 73 | my ($arch, $host) = split(" ", $line, 3); |
| 74 | |
| 75 | # --- Assign a mnemonic character --- |
| 76 | # |
| 77 | # In dire cases, this will choose multiple characters. Oh, well. If |
| 78 | # you have more than 26 architectures to maintain, this is the least of |
| 79 | # your worries. |
| 80 | |
| 81 | my $mn = ""; |
| 82 | my $hi; |
| 83 | foreach my $k (keys(%archmap)) { |
| 84 | if (index($arch, $k) >= 0 && !$mn->{$archmap{$k}}) { |
| 85 | $mn = $archmap{$k}; |
| 86 | last; |
| 87 | } |
| 88 | } |
| 89 | unless ($mn) { |
| 90 | for (my $i = 0; $i < length($arch); $i++) { |
| 91 | my $ch = lc(substr($arch, $i, 1)); |
| 92 | next unless $ch =~ /[a-z]/; |
| 93 | $mn = $ch, last unless $mn{$ch}; |
| 94 | } |
| 95 | } |
| 96 | if ($mn) { |
| 97 | ($hi = $arch) =~ s:$mn:<u>$mn</u>:; |
| 98 | } else { |
| 99 | for ($mn = "a"; $mn{$mn}; $mn++) { } |
| 100 | $hi = "$arch (<u>$mn</u>)"; |
| 101 | } |
| 102 | push(@arch, { arch => $arch, host => $host, mn => $mn, hi => $hi }); |
| 103 | } |
| 104 | } |
| 105 | @arch = sort { length($a->{mn}) <=> length($b->{mn}) || |
| 106 | $a->{mn} cmp $b->{mn} } @arch; |
| 107 | $narch = @arch; |
| 108 | |
| 109 | # --- Emit a header --- |
| 110 | |
| 111 | header("Installed software"); |
| 112 | |
| 113 | print <<EOF; |
| 114 | <h3>Documentation</h3> |
| 115 | <ul> |
| 116 | <li><a href="$ref?act=man">Manual pages</a> |
| 117 | <li><a href="$ref?act=info">GNU Info</a> |
| 118 | </ul> |
| 119 | <hr> |
| 120 | <h3>Installed software</h3> |
| 121 | <table> |
| 122 | <tr align=left> |
| 123 | <th rowspan=2>Package |
| 124 | <th rowspan=2>Version |
| 125 | <th rowspan=2 colspan=2>Maintainer |
| 126 | <th colspan=$narch>Architectures |
| 127 | <th rowspan=2>Date installed |
| 128 | <th rowspan=2>Doc |
| 129 | EOF |
| 130 | |
| 131 | # --- Spit out the archtecture mnemonics --- |
| 132 | |
| 133 | print "<tr align=left>\n "; |
| 134 | foreach my $a (@arch) { print "<th>" . $a->{mn}; } |
| 135 | print "\n"; |
| 136 | |
| 137 | # --- Iterate through the installed packages --- |
| 138 | |
| 139 | my $sw = SW->new(); |
| 140 | foreach my $pkg ($sw->list()) { |
| 141 | my $m = $sw->get($pkg); |
| 142 | print("<tr>\n"); |
| 143 | |
| 144 | # --- The package and version number are easy --- |
| 145 | |
| 146 | print(" <td>$m->{package}\n"); |
| 147 | print(" <td>$m->{version}\n"); |
| 148 | |
| 149 | # --- Resolve the maintainer into a sensible real name --- |
| 150 | |
| 151 | { |
| 152 | my $maint = $m->{"maintainer"}; |
| 153 | my @pw = getpwnam($maint); |
| 154 | my ($gecos) = split(/,/, $pw[6], 2); |
| 155 | my $addr = $maint . ($C{domain} && "\@" . $C{domain}); |
| 156 | print(" <td>$gecos<td><<a href=\"mailto:$addr\">$addr</a>>\n"); |
| 157 | } |
| 158 | |
| 159 | # --- Dump out the architectures --- |
| 160 | # |
| 161 | # Assume that the names aren't ambiguous. |
| 162 | |
| 163 | { |
| 164 | my %a = (); |
| 165 | foreach my $ar (split(/[\s,]+/, $m->{"arch"})) { |
| 166 | next unless $ar; |
| 167 | foreach my $a (@arch) { |
| 168 | if ($a->{arch} =~ /^$ar/) { |
| 169 | $a{$a->{arch}} = 1; |
| 170 | last; |
| 171 | } |
| 172 | } |
| 173 | } |
| 174 | |
| 175 | print(" "); |
| 176 | foreach my $a (@arch) { |
| 177 | if ($a{$a->{arch}}) { |
| 178 | print("<td>", $a->{mn}); |
| 179 | } else { |
| 180 | print("<td>"); |
| 181 | } |
| 182 | } |
| 183 | print("\n"); |
| 184 | } |
| 185 | |
| 186 | # --- Print the date --- |
| 187 | |
| 188 | print(" <td>$m->{date}\n"); |
| 189 | |
| 190 | # --- If the documentation file exists, put a link in --- |
| 191 | |
| 192 | if (-r "$C{doc}/$pkg") { |
| 193 | printf(" <td><a href=\"$ref?act=doc&pkg=%s\">Yes</a>\n", |
| 194 | SWCGI::sanitize($pkg)); |
| 195 | } else { |
| 196 | print(" <td>No\n"); |
| 197 | } |
| 198 | } |
| 199 | |
| 200 | # --- Finish up --- |
| 201 | |
| 202 | print "</table>\n"; |
| 203 | |
| 204 | # --- Emit a legend for the architecture lists --- |
| 205 | |
| 206 | print "<p><b>Architectures:</b>\n"; |
| 207 | foreach my $a (@arch) { |
| 208 | print $a->{hi}, "\n"; |
| 209 | } |
| 210 | footer(); |
| 211 | } |
| 212 | |
| 213 | #----- Register actions ----------------------------------------------------- |
| 214 | |
| 215 | $main::ACT{"list"} = \&list; |
| 216 | |
| 217 | #----- That's all, folks ---------------------------------------------------- |
| 218 | |
| 219 | 1; |