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