[Bio] / FigKernelPackages / HTML.pm Repository:
ViewVC logotype

Annotation of /FigKernelPackages/HTML.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (view) (download) (as text)

1 : efrank 1.1 package HTML;
2 :    
3 :     use Carp;
4 :     use Data::Dumper;
5 :     use LWP::UserAgent;
6 :     use LWP::Simple;
7 :     use URI::URL;
8 :     use HTTP::Request::Common;
9 :    
10 :     sub show_page {
11 :     my($cgi,$html,$no_home) = @_;
12 :     my $i;
13 :    
14 : olson 1.2 #
15 :     # Find the HTML header
16 :     #
17 :    
18 :     my $html_hdr_file = "./Html/html.hdr";
19 :     if (! -f $html_hdr_file)
20 :     {
21 :     $html_hdr_file = "$FIG_Config::fig/CGI/Html/html.hdr";
22 :     }
23 :    
24 :     my $html_tail_file = "./Html/html.tail";
25 :     if (! -f $html_tail_file)
26 :     {
27 :     $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";
28 :     }
29 :    
30 :    
31 : efrank 1.1 print $cgi->header;
32 : golsen 1.5
33 :     #
34 :     # Use a relative base address for pages. Also, because I am worried
35 :     # about when FIG_config.pm gets updated (clean installs only, or every
36 :     # update?), I provide an alternative derivation from $cgi_url. -- GJO
37 :     #
38 :     # print "<base href=\"" . &FIG::cgi_url . "/\">\n";
39 :     #
40 :     my $base_url = $FIG_Config::cgi_base;
41 :     if ( ! $base_url ) # if cgi_base was not defined
42 :     {
43 :     $base_url = $FIG_Config::cgi_url; # get the full cgi url
44 :     $base_url =~ s~^http://[^/]*~~; # remove protocol and host
45 :     $base_url =~ m~/$~ || $base_url =~ s~$~/~; # and add trailing slash?
46 :     }
47 :     print "<base href=\"$base_url\">\n";
48 :    
49 : efrank 1.1 for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<body\>/i); $i++) {}
50 :     if ($i < @$html)
51 :     {
52 : olson 1.2 splice(@$html,$i+1,0,`cat $html_hdr_file`);
53 : efrank 1.1 }
54 :     else
55 :     {
56 :     for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<html\>/i); $i++) {}
57 :     if ($i < @$html)
58 :     {
59 : olson 1.2 splice(@$html,$i+1,0,`cat $html_hdr_file`);
60 : efrank 1.1 }
61 :     else
62 :     {
63 : olson 1.2 splice(@$html,0,0,`cat $html_hdr_file`);
64 : efrank 1.1 }
65 :     }
66 :    
67 : olson 1.2 @tail = `cat $html_tail_file`;
68 : efrank 1.1 if (! $no_home)
69 :     {
70 :     my $user = $cgi->param('user');
71 :     $user = $user ? $user : "";
72 :     my $link = $cgi->url();
73 :     $link =~ s/[a-zA-Z_]+\.cgi$/index.cgi/;
74 :     push(@tail,"<hr><a href=\"$link?user=$user\">FIG search</a>\n");
75 :     }
76 :    
77 :     if (@tail > 0)
78 :     {
79 :     for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}
80 :     if ($i < @$html)
81 :     {
82 :     splice(@$html,$i,0,@tail);
83 :     }
84 :     else
85 :     {
86 :     for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/html\>/i); $i++) {}
87 :     if ($i < @$html)
88 :     {
89 :     splice(@$html,$i,0,@tail);
90 :     }
91 :     else
92 :     {
93 :     push(@$html,@tail);
94 :     }
95 :     }
96 :     }
97 :     print @$html;
98 :     }
99 :    
100 :     sub make_table {
101 :     my($col_hdrs,$tab,$title,$instr) = @_;
102 :     my(@tab);
103 :    
104 :     push(@tab,"<table border><caption><b>$title</b></caption>\n");
105 :     push(@tab,"<tr><th>" . join("</th><th>",@$col_hdrs) . "</th></tr>\n");
106 :     my($i,$nowrap);
107 :    
108 :     for ($i=0; ($i < @$instr) && ($instr->[$i] !~ /nowrap/); $i++) {}
109 :     $nowrap = ($i == @$instr) ? "" : " nowrap";
110 :    
111 : overbeek 1.3 my $row;
112 :     foreach $row (@$tab)
113 : efrank 1.1 {
114 : overbeek 1.4 push(@tab,"<tr>" . join("</td>",map { &expand($_,$nowrap) } @$row) . "</td></tr>\n");
115 : efrank 1.1 }
116 :     push(@tab,"</table>\n");
117 :     return join("",@tab);
118 :     }
119 :    
120 : overbeek 1.3 sub expand {
121 : overbeek 1.4 my($x,$nowrap) = @_;
122 : overbeek 1.3
123 :     if ($x =~ /^\@([^:]+)\:([^:]+)\:(.*)$/)
124 :     {
125 :     return "<td$nowrap $1=\"$2\">$3";
126 :     }
127 :     else
128 :     {
129 :     return "<td$nowrap>$x";
130 :     }
131 :     }
132 :    
133 : efrank 1.1 sub ec_link {
134 :     my($role) = @_;
135 :    
136 :     if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)
137 :     {
138 :     return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?ec:$1\">$role</a>";
139 :     }
140 :     else
141 :     {
142 :     return $role;
143 :     }
144 :     }
145 :    
146 :     sub role_link {
147 :     my($cgi,$role) = @_;
148 :    
149 :     my $roleR = ($role =~ /^(\d+\.\d+\.\d+\.\d+)\s+-\s+/) ? $1 : $role;
150 :     my $user = $cgi->param('user');
151 :     if (! $user) { $user = "" }
152 :     my $link = $cgi->url() . "?role=$roleR&user=$user";
153 :     $link =~ s/[a-z]+\.cgi\?/pom.cgi?/;
154 :     return "<a href=$link>$role</a>";
155 :     }
156 :    
157 :     sub fid_link {
158 :     my($cgi,$fid,$local,$just_url) = @_;
159 :     my($n);
160 :    
161 :     if ($fid =~ /^fig\|\d+\.\d+\.([a-z]+)\.(\d+)/)
162 :     {
163 :     if ($local)
164 :     {
165 :     if ($1 eq "peg")
166 :     {
167 :     $n = $2;
168 :     }
169 :     else
170 :     {
171 :     $n = "$1.$2";
172 :     }
173 :     }
174 :     else
175 :     {
176 :     $n = $fid;
177 :     }
178 :     if ($1 ne "peg") { return $n }
179 :     my $user = $cgi->param('user');
180 :     if (! $user) { $user = "" }
181 :     my $trans = $cgi->param('translate') ? "&translate=1" : "";
182 :     my $link = $cgi->url() . "?prot=$fid&user=$user$trans";
183 :     $link =~ s/[a-z_A-Z]+\.cgi\?/protein.cgi?/;
184 :     if ($just_url)
185 :     {
186 :     return $link;
187 :     }
188 :     else
189 :     {
190 :     return "<a href=$link>$n</a>";
191 :     }
192 :     }
193 :     return $fid;
194 :     }
195 :    
196 :     sub family_link {
197 :     my($family,$user) = @_;
198 :    
199 :     return $family;
200 :     }
201 :    
202 :     use URI::Escape;
203 :    
204 :     sub get_html {
205 :     my( $url, $type, $kv_pairs) = @_;
206 :     my( $encoded, $ua, $args, @args, $out, @output, $x );
207 :    
208 :     $ua = new LWP::UserAgent;
209 :     $ua->timeout( 900 );
210 :    
211 :     if ($type =~/post/i)
212 :     {
213 :     $args = [];
214 :     foreach $x (@$kv_pairs)
215 :     {
216 :     push(@$args, ( $x->[0], $x->[1]) );
217 :     }
218 :     my $request = POST $url, $args;
219 :     my $response = $ua->request($request);
220 :     $out = $response->content;
221 :     }
222 :     else
223 :     {
224 :     @args = ();
225 :     foreach $x (@$kv_pairs)
226 :     {
227 :     push( @args, "$x->[0]=" . uri_escape($x->[1]) );
228 :     }
229 :    
230 :     if (@args > 0)
231 :     {
232 :     $url .= "?" . join("&",@args);
233 :     }
234 :     $request = new HTTP::Request('GET', $url);
235 :     my $response = $ua->request($request);
236 :    
237 :     if ($response->is_success)
238 :     {
239 :     $out = $response->content;
240 :     }
241 :     else
242 :     {
243 :     $out = "<H1>Error: " . $response->code . "</H1>" . $response->message;
244 :     }
245 :     }
246 :     # set up a document with proper eol characters
247 :     @output = split(/[\012\015]+/,$out);
248 :     foreach $out (@output) { $out .= "\n"; }
249 :    
250 :     # Now splice in a line of the form <base href=URL> to cause all relative links to work
251 :     # properly. Remove the header.
252 :    
253 :     for ($i=0; ($i < @output) && ($output[$i] !~ /^\s*\</); $i++) {}
254 :     if ($i < @output)
255 :     {
256 :    
257 :     splice(@output,0,$i);
258 :     }
259 :    
260 :     for ($i=0; ($i < @output) && ($output[$i] !~ /\<body\>/i); $i++) {}
261 :     if ($i == @output)
262 :     {
263 :     $i = -1;
264 :     }
265 :     splice(@output,$i+1,0,"<base href=\"$url\">\n");
266 :     return @output;
267 :     }
268 :    
269 :     sub trim_output {
270 :     my($out) = @_;
271 :     my $i;
272 :    
273 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /^\</); $i++) {}
274 :     splice(@$out,0,$i);
275 :    
276 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<body\>/i); $i++) {}
277 :     if ($i == @$out)
278 :     {
279 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<html\>/i); $i++) {}
280 :     if ($i == @$out)
281 :     {
282 :     $i = -1;
283 :     }
284 :     }
285 :     for ($j=$i+1; ($j < @$out) && ($out->[$j] !~ /^\<hr\>$/); $j++) {}
286 :     if ($j < @$out)
287 :     {
288 :     splice(@$out,$i+1,($j-$i));
289 :     }
290 :    
291 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<\/body\>/i); $i++) {}
292 :     if ($i == @$out)
293 :     {
294 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<\/html\>/i); $i++) {}
295 :     }
296 :    
297 :     for ($j=$i-1; ($j > 0) && ($out->[$j] !~ /FIG search/); $j--) {}
298 :     if ($j > 0)
299 :     {
300 : olson 1.2 my @tmp = `cat $html_tail_file`;
301 : efrank 1.1 my $n = @tmp;
302 :     splice(@$out,$j-$n,$n+1);
303 :     }
304 :     }
305 :    
306 :     sub set_prot_links {
307 :     my($cgi,$x) = @_;
308 :     my($before,$match,$after);
309 :    
310 :     if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)$/)
311 :     {
312 :     $before = $1;
313 :     $match = $2;
314 :     $after = $3;
315 :     return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";
316 :     }
317 :     elsif ($x =~ /^(.*)(gi\|\d+)(.*)$/)
318 :     {
319 :     $before = $1;
320 :     $match = $2;
321 :     $after = $3;
322 :     return &set_prot_links($cgi,$before) . &HTML::gi_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";
323 :     }
324 :     elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)$/)
325 :     {
326 :     $before = $1;
327 :     $match = $2;
328 :     $after = $3;
329 :     return &set_prot_links($cgi,$before) . &HTML::sp_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";
330 :     }
331 :     elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)$/)
332 :     {
333 :     $before = $1;
334 :     $match = $2;
335 :     $after = $3;
336 :     return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";
337 :     }
338 :     return $x;
339 :     }
340 :    
341 :     sub gi_link {
342 :     my($cgi,$gi) = @_;
343 :    
344 :     if ($gi =~ /^gi\|(\d+)$/)
345 :     {
346 :     return "<a href=http://www.ncbi.nlm.nih.gov:80/entrez/query.fcgi?cmd=Retrieve&db=Protein&list_uids=$1&dopt=GenPept>$gi</a>";
347 :     }
348 :     return $gi;
349 :     }
350 :    
351 :     sub sp_link {
352 :     my($cgi,$sp) = @_;
353 :    
354 :     if ($sp =~ /^sp\|(\S+)$/)
355 :     {
356 :     return "<a href=http://us.expasy.org/cgi-bin/get-sprot-entry?$1>$sp</a>";
357 :     }
358 :     return $sp;
359 :     }
360 :    
361 :     sub pir_link {
362 :     my($cgi,$pir) = @_;
363 :    
364 :     if ($pir =~ /^pirnr\|(NF\d+)$/)
365 :     {
366 :     return "<a href=http://pir.georgetown.edu/cgi-bin/nfEntry.pl?id=$1>$pir</a>";
367 :     }
368 :     return $pir;
369 :     }
370 :    
371 :    
372 :     1

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3