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