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

Annotation of /FigKernelPackages/HTML.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (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 : golsen 1.6 # The SEED header file goes immediately after <BODY>. Figure out
35 :     # what parts of the HTML document skeleton are there, and fill in
36 :     # missing ones.
37 : golsen 1.5 #
38 : golsen 1.6 # This list should be as comprehensive as feasible:
39 : golsen 1.5 #
40 :    
41 : golsen 1.6 my %head_tag = ( base => 1,
42 :     basefont => 1,
43 :     html => 1,
44 :     isindex => 1,
45 :     link => 1,
46 :     meta => 1,
47 :     nextid => 1,
48 :     style => 1,
49 :     title => 1
50 :     );
51 :    
52 :     #
53 :     # This list need not be comprehensive; it is just stopping conditions:
54 :     #
55 :    
56 :     my %body_tag = ( a => 1,
57 :     br => 1,
58 :     center => 1,
59 :     form => 1,
60 :     h1 => 1,
61 :     h2 => 1,
62 :     h3 => 1,
63 :     hr => 1,
64 :     img => 1,
65 :     p => 1,
66 :     pre => 1,
67 :     table => 1
68 :     );
69 :    
70 :     my $html_line = -1;
71 :     my $head_line = -1;
72 :     my $base_line = -1;
73 :     my $head_end_line = -1;
74 :     my $body_line = -1;
75 :     my $last_head_line = -1; # If no head tags are found, text goes at top.
76 :     my $done = 0;
77 :    
78 :     for ( $i = 0; $i < @$html; $i++ )
79 :     {
80 :     # Some special cases:
81 :    
82 :     if ( $html->[$i] =~ /\<html[^0-9a-z]/i ) { $html_line = $i }
83 :     if ( $html->[$i] =~ /\<head[^0-9a-z]/i ) { $head_line = $i }
84 :     if ( $html->[$i] =~ /\<base[^0-9a-z]/i ) { $base_line = $i }
85 :     if ( $html->[$i] =~ /\<\/head\>/i ) { $head_end_line = $i }
86 :    
87 :     # The content goes after this line:
88 :    
89 :     if ( $html->[$i] =~ /\<body[^0-9a-z]/i )
90 :     {
91 :     $body_line = $i;
92 :     $last;
93 :     }
94 :    
95 :     # Now the general case.
96 :     # Analyze all the html tags on the line:
97 :    
98 :     foreach ( $html->[$i] =~ /\<\/?([0-9a-z]+)/ig )
99 :     {
100 :     # At first body tag, we stop the search and put the text
101 :     # after the last line with a head tag:
102 :    
103 :     if ( $body_tag{ lc $_ } )
104 :     {
105 :     $done = 1;
106 :     last;
107 :     }
108 :    
109 :     # If this is a head tag, then move the marker forward
110 :    
111 :     elsif ( $head_tag{ lc $_ } )
112 :     {
113 :     $last_head_line = $i;
114 :     }
115 :     }
116 :     last if $done; # When done, break loop to avoid increment
117 : efrank 1.1 }
118 : golsen 1.6
119 :     # Some sanity checks on structure:
120 :    
121 :     if ( 1 )
122 : efrank 1.1 {
123 : golsen 1.6 if ( $html_line >= 0 )
124 : efrank 1.1 {
125 : golsen 1.6 if ( ( $head_line >= 0 ) && ( $html_line > $head_line ) )
126 :     {
127 :     print STDERR "<HTML> tag follows <HEAD> tag\n";
128 :     }
129 :     if ( ( $head_end_line >= 0 ) && ( $html_line > $head_end_line ) )
130 :     {
131 :     print STDERR "<HTML> tag follows </HEAD> tag\n";
132 :     }
133 : efrank 1.1 }
134 : golsen 1.6 if ( $head_line >= 0 )
135 : efrank 1.1 {
136 : golsen 1.6 if ( ( $head_end_line >= 0 ) && ( $head_line > $head_end_line ) )
137 :     {
138 :     print STDERR "<HEAD> tag follows </HEAD> tag\n";
139 :     }
140 : efrank 1.1 }
141 :     }
142 :    
143 : golsen 1.6 #
144 :     # Okay. Let's put in the html header file, and missing tags:
145 :     #
146 :     # <BODY> goes after last head line
147 :     #
148 :    
149 :     if ( $body_line < 0 )
150 :     {
151 :     $body_line = $last_head_line + 1;
152 :     splice( @$html, $body_line, 0, "<BODY>\n" );
153 :     }
154 :    
155 :     #
156 :     # Seed page header (if it exists) goes after <BODY>
157 :     #
158 :    
159 :     if ( -f $html_hdr_file )
160 :     {
161 :     splice( @$html, $body_line + 1, 0, `cat $html_hdr_file` );
162 :     }
163 :    
164 :     #
165 :     # </HEAD> goes before <BODY>
166 :     #
167 :    
168 :     if ( $head_end_line < 0 )
169 :     {
170 :     $head_end_line = $body_line;
171 :     splice( @$html, $body_line, 0, "</HEAD>\n" );
172 :     }
173 :    
174 :     #
175 :     # <BASE ...> goes before </HEAD>
176 :     #
177 :    
178 :     if ( $base_line < 0 )
179 :     {
180 :     #
181 :     # Use a relative base address for pages. Also, because I am
182 :     # worried about when FIG_config.pm gets updated (clean installs
183 :     # only, or every update?), I provide an alternative derivation
184 :     # from $cgi_url. -- GJO
185 :     #
186 : olson 1.7 # BASE href needs to be absolute. RDO.
187 :     #
188 :     #
189 :     $base_url = &FIG::cgi_url;
190 :     # my $base_url = $FIG_Config::cgi_base;
191 :     # if ( ! $base_url ) # if cgi_base was not defined
192 :     # {
193 :     # $base_url = $FIG_Config::cgi_url; # get the full cgi url
194 :     # $base_url =~ s~^http://[^/]*~~; # remove protocol and host
195 :     # $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash
196 :     # }
197 : golsen 1.6
198 :     $base_line = $head_end_line;
199 : olson 1.8 splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );
200 : golsen 1.6 }
201 :    
202 :     #
203 :     # <HTML> goes at the top of the output
204 :     #
205 :    
206 :     if ( $html_line < 0 )
207 :     {
208 :     $html_line = 0;
209 :     splice( @$html, $html_line, 0, "<HTML>\n" );
210 :     }
211 :    
212 :     #
213 :     # <HEAD> goes after <HTML>
214 :     #
215 :    
216 :     if ( $head_line < 0 )
217 :     {
218 :     $head_line = $html_line + 1;
219 :     splice( @$html, $head_line, 0, "<HEAD>\n" );
220 :     }
221 :    
222 :     #
223 :     # Place FIG search link at bottom of page
224 :     #
225 :    
226 :     my @tail = -f $html_tail_file ? `cat $html_tail_file` : ();
227 : efrank 1.1 if (! $no_home)
228 :     {
229 : golsen 1.6 my $user = $cgi->param('user') || "";
230 :     push( @tail, "<hr><a href=\"index.cgi?user=$user\">FIG search</a>\n" );
231 : efrank 1.1 }
232 :    
233 : golsen 1.6 #
234 :     # Figure out where to insert The SEED tail. Before </body>,
235 :     # or before </html>, or at end of page.
236 :     #
237 :    
238 :     my @tags = ();
239 :    
240 :     for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}
241 :     if ($i >= @$html) # </body> not found; look for </html>
242 : efrank 1.1 {
243 : golsen 1.6 push @tags, "\n</BODY>\n";
244 :     # Even if tag is not found, index points to correct place for splice
245 :     for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/html\>/i); $i++) {}
246 :     if ($i >= @$html) # </html> not found; add it
247 : efrank 1.1 {
248 : golsen 1.6 push @tags, "</HTML>\n";
249 : efrank 1.1 }
250 :     }
251 : golsen 1.6
252 :     if ( @tail )
253 :     {
254 :     splice( @$html, $i, 0, @tail, @tags );
255 :     }
256 :     elsif ( @tags )
257 :     {
258 :     splice( @$html, $i, 0, @tags );
259 :     }
260 :    
261 : efrank 1.1 print @$html;
262 :     }
263 :    
264 :     sub make_table {
265 : overbeek 1.9 my($col_hdrs,$tab,$title) = @_;
266 : efrank 1.1 my(@tab);
267 :    
268 : golsen 1.6 push( @tab, "\n<table border>\n",
269 :     "\t<caption><b>$title</b></caption>\n",
270 :     "\t<tr>\n\t\t<th>"
271 :     . join( "</th>\n\t\t<th>", @$col_hdrs )
272 :     . "</th>\n\t</tr>\n"
273 :     );
274 : overbeek 1.9 my($i);
275 : efrank 1.1
276 : overbeek 1.3 my $row;
277 :     foreach $row (@$tab)
278 : efrank 1.1 {
279 : golsen 1.6 push( @tab, "\t<tr>\n"
280 : overbeek 1.9 . join( "\n", map { &expand($_) } @$row )
281 : golsen 1.6 . "\n\t</tr>\n"
282 :     );
283 : efrank 1.1 }
284 :     push(@tab,"</table>\n");
285 :     return join("",@tab);
286 :     }
287 :    
288 : overbeek 1.3 sub expand {
289 : overbeek 1.9 my($x) = @_;
290 : overbeek 1.3
291 : overbeek 1.9 if ($x =~ /^\@([^:]+)\:(.*)$/)
292 : overbeek 1.3 {
293 : overbeek 1.9 return "\t\t<td $1>$2</td>";
294 : overbeek 1.3 }
295 :     else
296 :     {
297 : overbeek 1.9 return "\t\t<td>$x</td>";
298 : overbeek 1.3 }
299 :     }
300 :    
301 : overbeek 1.11 sub set_ec_links {
302 :     my($cgi,$x) = @_;
303 :     my($before,$match,$after);
304 :    
305 :     if ($x =~ /^(.*)(EC \d+\.\d+\.\d+\.\d+)(.*)/s)
306 :     {
307 :     $before = $1;
308 :     $match = $2;
309 :     $after = $3;
310 :     return &set_ec_links($cgi,$before) . &HTML::ec_link($match) . &set_ec_links($cgi,$after);
311 :     }
312 :     return $x;
313 :     }
314 :    
315 : efrank 1.1 sub ec_link {
316 :     my($role) = @_;
317 :    
318 :     if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)
319 :     {
320 :     return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?ec:$1\">$role</a>";
321 :     }
322 :     else
323 :     {
324 :     return $role;
325 :     }
326 :     }
327 :    
328 :     sub role_link {
329 :     my($cgi,$role) = @_;
330 :    
331 :     my $roleR = ($role =~ /^(\d+\.\d+\.\d+\.\d+)\s+-\s+/) ? $1 : $role;
332 :     my $user = $cgi->param('user');
333 :     if (! $user) { $user = "" }
334 :     my $link = $cgi->url() . "?role=$roleR&user=$user";
335 :     $link =~ s/[a-z]+\.cgi\?/pom.cgi?/;
336 :     return "<a href=$link>$role</a>";
337 :     }
338 :    
339 : olson 1.13 #
340 :     # Local means to eliminate the fig|org.peg from the
341 :     # text of the link.
342 :     #
343 : efrank 1.1 sub fid_link {
344 :     my($cgi,$fid,$local,$just_url) = @_;
345 :     my($n);
346 :    
347 :     if ($fid =~ /^fig\|\d+\.\d+\.([a-z]+)\.(\d+)/)
348 :     {
349 :     if ($local)
350 :     {
351 :     if ($1 eq "peg")
352 :     {
353 :     $n = $2;
354 :     }
355 :     else
356 :     {
357 :     $n = "$1.$2";
358 :     }
359 :     }
360 :     else
361 :     {
362 :     $n = $fid;
363 :     }
364 :     if ($1 ne "peg") { return $n }
365 :     my $user = $cgi->param('user');
366 :     if (! $user) { $user = "" }
367 :     my $trans = $cgi->param('translate') ? "&translate=1" : "";
368 :     my $link = $cgi->url() . "?prot=$fid&user=$user$trans";
369 : overbeek 1.10 $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
370 : efrank 1.1 if ($just_url)
371 :     {
372 :     return $link;
373 :     }
374 :     else
375 :     {
376 :     return "<a href=$link>$n</a>";
377 :     }
378 :     }
379 :     return $fid;
380 :     }
381 :    
382 :     sub family_link {
383 :     my($family,$user) = @_;
384 :    
385 :     return $family;
386 :     }
387 :    
388 :     use URI::Escape;
389 :    
390 :     sub get_html {
391 :     my( $url, $type, $kv_pairs) = @_;
392 :     my( $encoded, $ua, $args, @args, $out, @output, $x );
393 :    
394 :     $ua = new LWP::UserAgent;
395 :     $ua->timeout( 900 );
396 :    
397 :     if ($type =~/post/i)
398 :     {
399 :     $args = [];
400 :     foreach $x (@$kv_pairs)
401 :     {
402 :     push(@$args, ( $x->[0], $x->[1]) );
403 :     }
404 :     my $request = POST $url, $args;
405 :     my $response = $ua->request($request);
406 :     $out = $response->content;
407 :     }
408 :     else
409 :     {
410 :     @args = ();
411 :     foreach $x (@$kv_pairs)
412 :     {
413 :     push( @args, "$x->[0]=" . uri_escape($x->[1]) );
414 :     }
415 :    
416 :     if (@args > 0)
417 :     {
418 :     $url .= "?" . join("&",@args);
419 :     }
420 :     $request = new HTTP::Request('GET', $url);
421 :     my $response = $ua->request($request);
422 :    
423 :     if ($response->is_success)
424 :     {
425 :     $out = $response->content;
426 :     }
427 :     else
428 :     {
429 :     $out = "<H1>Error: " . $response->code . "</H1>" . $response->message;
430 :     }
431 :     }
432 :     # set up a document with proper eol characters
433 :     @output = split(/[\012\015]+/,$out);
434 :     foreach $out (@output) { $out .= "\n"; }
435 :    
436 :     # Now splice in a line of the form <base href=URL> to cause all relative links to work
437 :     # properly. Remove the header.
438 :    
439 :     for ($i=0; ($i < @output) && ($output[$i] !~ /^\s*\</); $i++) {}
440 :     if ($i < @output)
441 :     {
442 :    
443 :     splice(@output,0,$i);
444 :     }
445 :    
446 :     for ($i=0; ($i < @output) && ($output[$i] !~ /\<body\>/i); $i++) {}
447 :     if ($i == @output)
448 :     {
449 :     $i = -1;
450 :     }
451 :     splice(@output,$i+1,0,"<base href=\"$url\">\n");
452 :     return @output;
453 :     }
454 :    
455 :     sub trim_output {
456 :     my($out) = @_;
457 :     my $i;
458 :    
459 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /^\</); $i++) {}
460 :     splice(@$out,0,$i);
461 :    
462 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<body\>/i); $i++) {}
463 :     if ($i == @$out)
464 :     {
465 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<html\>/i); $i++) {}
466 :     if ($i == @$out)
467 :     {
468 :     $i = -1;
469 :     }
470 :     }
471 :     for ($j=$i+1; ($j < @$out) && ($out->[$j] !~ /^\<hr\>$/); $j++) {}
472 :     if ($j < @$out)
473 :     {
474 :     splice(@$out,$i+1,($j-$i));
475 :     }
476 :    
477 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<\/body\>/i); $i++) {}
478 :     if ($i == @$out)
479 :     {
480 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<\/html\>/i); $i++) {}
481 :     }
482 :    
483 :     for ($j=$i-1; ($j > 0) && ($out->[$j] !~ /FIG search/); $j--) {}
484 :     if ($j > 0)
485 :     {
486 : olson 1.2 my @tmp = `cat $html_tail_file`;
487 : efrank 1.1 my $n = @tmp;
488 :     splice(@$out,$j-$n,$n+1);
489 :     }
490 :     }
491 :    
492 :     sub set_prot_links {
493 :     my($cgi,$x) = @_;
494 :     my($before,$match,$after);
495 :    
496 : overbeek 1.11 if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)/s)
497 : efrank 1.1 {
498 :     $before = $1;
499 :     $match = $2;
500 :     $after = $3;
501 : overbeek 1.11 return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after);
502 : efrank 1.1 }
503 : overbeek 1.11 elsif ($x =~ /^(.*)(gi\|\d+)(.*)/s)
504 : efrank 1.1 {
505 :     $before = $1;
506 :     $match = $2;
507 :     $after = $3;
508 : overbeek 1.11 return &set_prot_links($cgi,$before) . &HTML::gi_link($cgi,$match) . &set_prot_links($cgi,$after);
509 : efrank 1.1 }
510 : overbeek 1.14 elsif ($x =~ /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
511 :     {
512 :     $before = $1;
513 :     $match = $2;
514 :     $after = $3;
515 :     return &set_prot_links($cgi,$before) . &HTML::uni_link($cgi,$match) . &set_prot_links($cgi,$after);
516 :     }
517 : overbeek 1.11 elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)/s)
518 : efrank 1.1 {
519 :     $before = $1;
520 :     $match = $2;
521 :     $after = $3;
522 : overbeek 1.11 return &set_prot_links($cgi,$before) . &HTML::sp_link($cgi,$match) . &set_prot_links($cgi,$after);
523 : efrank 1.1 }
524 : overbeek 1.11 elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)/s)
525 : efrank 1.1 {
526 :     $before = $1;
527 :     $match = $2;
528 :     $after = $3;
529 : overbeek 1.11 return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after);
530 : efrank 1.1 }
531 : overbeek 1.12 elsif ($x =~ /^(.*)(kegg\|[a-z]{2,4}:[a-zA-Z_0-9]+)(.*)/s)
532 :     {
533 :     $before = $1;
534 :     $match = $2;
535 :     $after = $3;
536 :     return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after);
537 :     }
538 : efrank 1.1 return $x;
539 :     }
540 :    
541 :     sub gi_link {
542 :     my($cgi,$gi) = @_;
543 :    
544 :     if ($gi =~ /^gi\|(\d+)$/)
545 :     {
546 :     return "<a href=http://www.ncbi.nlm.nih.gov:80/entrez/query.fcgi?cmd=Retrieve&db=Protein&list_uids=$1&dopt=GenPept>$gi</a>";
547 :     }
548 :     return $gi;
549 :     }
550 :    
551 : overbeek 1.14 sub uni_link {
552 :     my($cgi,$uni) = @_;
553 :    
554 :     if ($uni =~ /^uni\|(\S+)$/)
555 :     {
556 :     return "<a href=http://www.pir.uniprot.org/cgi-bin/upEntry?id=$1>$uni</a>";
557 :     }
558 :     return $uni;
559 :     }
560 :    
561 : efrank 1.1 sub sp_link {
562 :     my($cgi,$sp) = @_;
563 :    
564 :     if ($sp =~ /^sp\|(\S+)$/)
565 :     {
566 :     return "<a href=http://us.expasy.org/cgi-bin/get-sprot-entry?$1>$sp</a>";
567 :     }
568 :     return $sp;
569 :     }
570 :    
571 :     sub pir_link {
572 :     my($cgi,$pir) = @_;
573 :    
574 :     if ($pir =~ /^pirnr\|(NF\d+)$/)
575 :     {
576 :     return "<a href=http://pir.georgetown.edu/cgi-bin/nfEntry.pl?id=$1>$pir</a>";
577 :     }
578 :     return $pir;
579 :     }
580 :    
581 : overbeek 1.12 sub kegg_link {
582 :     my($cgi,$kegg) = @_;
583 :    
584 :     if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)
585 :     {
586 :     return "<a href=http://www.genome.ad.jp/dbget-bin/www_bget?$1+$2>$kegg</a>";
587 :     }
588 :     return $kegg;
589 :     }
590 :    
591 : overbeek 1.11 sub set_map_links {
592 :     my($cgi,$x) = @_;
593 :     my($before,$match,$after);
594 : efrank 1.1
595 : overbeek 1.11 my $org = ($cgi->param('org') || $cgi->param('genome') || "");
596 :    
597 :     if ($x =~ /^(.*)(MAP\d+)(.*)/s)
598 :     {
599 :     $before = $1;
600 :     $match = $2;
601 :     $after = $3;
602 :     return &set_map_links($cgi,$before) . &map_link($cgi,$match,$org) . &set_map_links($cgi,$after);
603 :     }
604 :     return $x;
605 :     }
606 :    
607 :     sub map_link {
608 :     my($cgi,$map,$org) = @_;
609 :    
610 :     $user = $cgi->param('user');
611 :     $user = $user ? $user : "";
612 :     $org = $org ? $org : "";
613 :     my $url = "$FIG_Config::cgi_url/show_kegg_map.cgi?user=$user&map=$map&org=$org";
614 :     my $link = "<a href=\"$url\">$map</a>";
615 :     return $link;
616 :     }
617 :    
618 : efrank 1.1 1

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3