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

Annotation of /FigKernelPackages/HTML.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : efrank 1.1 package HTML;
2 :    
3 : olson 1.25 use FIG;
4 : efrank 1.1 use Carp;
5 :     use Data::Dumper;
6 :     use LWP::UserAgent;
7 :     use LWP::Simple;
8 :     use URI::URL;
9 :     use HTTP::Request::Common;
10 : olson 1.16 use POSIX;
11 : efrank 1.1
12 : olson 1.25 sub compute_html_header
13 :     {
14 : olson 1.26 my($additional_insert) = @_;
15 : olson 1.2 my $html_hdr_file = "./Html/html.hdr";
16 :     if (! -f $html_hdr_file)
17 :     {
18 :     $html_hdr_file = "$FIG_Config::fig/CGI/Html/html.hdr";
19 :     }
20 : olson 1.15 my @html_hdr = &FIG::file_read($html_hdr_file);
21 : overbeek 1.18 push( @html_hdr, "<br><a href=\"index.cgi?user=$user\">FIG search</a>\n" );
22 :    
23 : olson 1.15 if (@html_hdr)
24 :     {
25 :     my $insert_stuff;
26 :     my @ver = &FIG::file_head("$FIG_Config::fig_disk/CURRENT_RELEASE", 1);
27 :     my $ver = $ver[0];
28 :     chomp $ver;
29 :     if ($ver =~ /^cvs\.(\d+)$/)
30 :     {
31 :     my $d = asctime(localtime($1));
32 :     chomp($d);
33 :     $ver .= " ($d)";
34 :     }
35 :     my $host = &FIG::get_local_hostname();
36 :     $insert_stuff = "SEED version <b>$ver</b> on $host";
37 : olson 1.26 if ($additional_insert)
38 :     {
39 :     $insert_stuff .= "<br>" . $additional_insert;
40 :     }
41 : olson 1.15
42 :     for $_ (@html_hdr)
43 :     {
44 :     s,(href|img\s+src)="/FIG/,\1="$FIG_Config::cgi_base,g;
45 :     if ($_ eq "<!-- HEADER_INSERT -->\n")
46 :     {
47 :     $_ = $insert_stuff;
48 :     }
49 :     }
50 :     }
51 :    
52 : olson 1.25 return @html_hdr;
53 :     }
54 :    
55 :     sub show_page {
56 :     my($cgi,$html,$no_home) = @_;
57 :     my $i;
58 :    
59 :     #
60 :     # Find the HTML header
61 :     #
62 :    
63 :     my $html_tail_file = "./Html/html.tail";
64 :     if (! -f $html_tail_file)
65 :     {
66 :     $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";
67 :     }
68 :    
69 :     my @html_hdr = compute_html_header();
70 :    
71 :     my $user = $cgi->param('user') || "";
72 : olson 1.2
73 : efrank 1.1 print $cgi->header;
74 : golsen 1.5
75 :     #
76 : golsen 1.6 # The SEED header file goes immediately after <BODY>. Figure out
77 :     # what parts of the HTML document skeleton are there, and fill in
78 :     # missing ones.
79 : golsen 1.5 #
80 : golsen 1.6 # This list should be as comprehensive as feasible:
81 : golsen 1.5 #
82 :    
83 : golsen 1.6 my %head_tag = ( base => 1,
84 :     basefont => 1,
85 :     html => 1,
86 :     isindex => 1,
87 :     link => 1,
88 :     meta => 1,
89 :     nextid => 1,
90 :     style => 1,
91 :     title => 1
92 :     );
93 :    
94 :     #
95 :     # This list need not be comprehensive; it is just stopping conditions:
96 :     #
97 :    
98 :     my %body_tag = ( a => 1,
99 :     br => 1,
100 :     center => 1,
101 :     form => 1,
102 :     h1 => 1,
103 :     h2 => 1,
104 :     h3 => 1,
105 :     hr => 1,
106 :     img => 1,
107 :     p => 1,
108 :     pre => 1,
109 :     table => 1
110 :     );
111 :    
112 :     my $html_line = -1;
113 :     my $head_line = -1;
114 :     my $base_line = -1;
115 :     my $head_end_line = -1;
116 :     my $body_line = -1;
117 :     my $last_head_line = -1; # If no head tags are found, text goes at top.
118 :     my $done = 0;
119 :    
120 :     for ( $i = 0; $i < @$html; $i++ )
121 :     {
122 :     # Some special cases:
123 :    
124 :     if ( $html->[$i] =~ /\<html[^0-9a-z]/i ) { $html_line = $i }
125 :     if ( $html->[$i] =~ /\<head[^0-9a-z]/i ) { $head_line = $i }
126 :     if ( $html->[$i] =~ /\<base[^0-9a-z]/i ) { $base_line = $i }
127 :     if ( $html->[$i] =~ /\<\/head\>/i ) { $head_end_line = $i }
128 :    
129 :     # The content goes after this line:
130 :    
131 :     if ( $html->[$i] =~ /\<body[^0-9a-z]/i )
132 :     {
133 :     $body_line = $i;
134 :     $last;
135 :     }
136 :    
137 :     # Now the general case.
138 :     # Analyze all the html tags on the line:
139 :    
140 :     foreach ( $html->[$i] =~ /\<\/?([0-9a-z]+)/ig )
141 :     {
142 :     # At first body tag, we stop the search and put the text
143 :     # after the last line with a head tag:
144 :    
145 :     if ( $body_tag{ lc $_ } )
146 :     {
147 :     $done = 1;
148 :     last;
149 :     }
150 :    
151 :     # If this is a head tag, then move the marker forward
152 :    
153 :     elsif ( $head_tag{ lc $_ } )
154 :     {
155 :     $last_head_line = $i;
156 :     }
157 :     }
158 :     last if $done; # When done, break loop to avoid increment
159 : efrank 1.1 }
160 : golsen 1.6
161 :     # Some sanity checks on structure:
162 :    
163 :     if ( 1 )
164 : efrank 1.1 {
165 : golsen 1.6 if ( $html_line >= 0 )
166 : efrank 1.1 {
167 : golsen 1.6 if ( ( $head_line >= 0 ) && ( $html_line > $head_line ) )
168 :     {
169 :     print STDERR "<HTML> tag follows <HEAD> tag\n";
170 :     }
171 :     if ( ( $head_end_line >= 0 ) && ( $html_line > $head_end_line ) )
172 :     {
173 :     print STDERR "<HTML> tag follows </HEAD> tag\n";
174 :     }
175 : efrank 1.1 }
176 : golsen 1.6 if ( $head_line >= 0 )
177 : efrank 1.1 {
178 : golsen 1.6 if ( ( $head_end_line >= 0 ) && ( $head_line > $head_end_line ) )
179 :     {
180 :     print STDERR "<HEAD> tag follows </HEAD> tag\n";
181 :     }
182 : efrank 1.1 }
183 :     }
184 :    
185 : golsen 1.6 #
186 :     # Okay. Let's put in the html header file, and missing tags:
187 :     #
188 :     # <BODY> goes after last head line
189 :     #
190 : redwards 1.20 # RAE: Added the javascript for the buttons immediately after body.
191 :     # Note if no buttons are added we still (at the moment) add the script,
192 :     # but it only adds a little text (495 characters) to the html and noone will notice!
193 : golsen 1.6
194 :     if ( $body_line < 0 )
195 :     {
196 : redwards 1.20 my $js=&javascript;
197 : golsen 1.6 $body_line = $last_head_line + 1;
198 : redwards 1.20 splice( @$html, $body_line, 0, "<BODY>\n$js\n" );
199 : golsen 1.6 }
200 :    
201 :     #
202 :     # Seed page header (if it exists) goes after <BODY>
203 :     #
204 :    
205 : olson 1.15 if (@html_hdr)
206 : golsen 1.6 {
207 : olson 1.15 splice( @$html, $body_line + 1, 0, @html_hdr );
208 : golsen 1.6 }
209 :    
210 :     #
211 :     # </HEAD> goes before <BODY>
212 :     #
213 :    
214 :     if ( $head_end_line < 0 )
215 :     {
216 :     $head_end_line = $body_line;
217 :     splice( @$html, $body_line, 0, "</HEAD>\n" );
218 :     }
219 :    
220 :     #
221 :     # <BASE ...> goes before </HEAD>
222 :     #
223 :    
224 :     if ( $base_line < 0 )
225 :     {
226 :     #
227 :     # Use a relative base address for pages. Also, because I am
228 :     # worried about when FIG_config.pm gets updated (clean installs
229 :     # only, or every update?), I provide an alternative derivation
230 :     # from $cgi_url. -- GJO
231 :     #
232 : olson 1.7 # BASE href needs to be absolute. RDO.
233 :     #
234 :     #
235 :     $base_url = &FIG::cgi_url;
236 :     # my $base_url = $FIG_Config::cgi_base;
237 :     # if ( ! $base_url ) # if cgi_base was not defined
238 :     # {
239 :     # $base_url = $FIG_Config::cgi_url; # get the full cgi url
240 :     # $base_url =~ s~^http://[^/]*~~; # remove protocol and host
241 :     # $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash
242 :     # }
243 : golsen 1.6
244 :     $base_line = $head_end_line;
245 : olson 1.8 splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );
246 : golsen 1.6 }
247 :    
248 :     #
249 :     # <HTML> goes at the top of the output
250 :     #
251 :    
252 :     if ( $html_line < 0 )
253 :     {
254 :     $html_line = 0;
255 :     splice( @$html, $html_line, 0, "<HTML>\n" );
256 :     }
257 :    
258 :     #
259 :     # <HEAD> goes after <HTML>
260 :     #
261 :    
262 :     if ( $head_line < 0 )
263 :     {
264 :     $head_line = $html_line + 1;
265 :     splice( @$html, $head_line, 0, "<HEAD>\n" );
266 :     }
267 :    
268 :     #
269 :     # Place FIG search link at bottom of page
270 :     #
271 :    
272 :     my @tail = -f $html_tail_file ? `cat $html_tail_file` : ();
273 : efrank 1.1 if (! $no_home)
274 :     {
275 : golsen 1.6 my $user = $cgi->param('user') || "";
276 :     push( @tail, "<hr><a href=\"index.cgi?user=$user\">FIG search</a>\n" );
277 : efrank 1.1 }
278 :    
279 : golsen 1.6 #
280 : olson 1.21 # See if we have a site-specific tail (for disclaimers, etc).
281 :     #
282 :    
283 :     my $site_tail = "$FIG_Config::fig_disk/config/site_tail.html";
284 :     my $site_fh;
285 :     if (open($site_fh, "<$site_tail"))
286 :     {
287 :     push(@tail, <$site_fh>);
288 :     close($site_fh);
289 :     }
290 :    
291 :     #
292 : golsen 1.6 # Figure out where to insert The SEED tail. Before </body>,
293 :     # or before </html>, or at end of page.
294 :     #
295 :    
296 :     my @tags = ();
297 :    
298 :     for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}
299 :     if ($i >= @$html) # </body> not found; look for </html>
300 : efrank 1.1 {
301 : golsen 1.6 push @tags, "\n</BODY>\n";
302 :     # Even if tag is not found, index points to correct place for splice
303 :     for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/html\>/i); $i++) {}
304 :     if ($i >= @$html) # </html> not found; add it
305 : efrank 1.1 {
306 : golsen 1.6 push @tags, "</HTML>\n";
307 : efrank 1.1 }
308 :     }
309 : golsen 1.6
310 :     if ( @tail )
311 :     {
312 :     splice( @$html, $i, 0, @tail, @tags );
313 :     }
314 :     elsif ( @tags )
315 :     {
316 :     splice( @$html, $i, 0, @tags );
317 :     }
318 :    
319 : efrank 1.1 print @$html;
320 :     }
321 :    
322 :     sub make_table {
323 : olson 1.17 my($col_hdrs,$tab,$title, %options ) = @_;
324 : efrank 1.1 my(@tab);
325 :    
326 : olson 1.17 my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";
327 :     push( @tab, "\n<table $border>\n",
328 : golsen 1.6 "\t<caption><b>$title</b></caption>\n",
329 : olson 1.27 "\t<tr>\n\t\t"
330 :     . join( "\n", map { &expand($_, "th") } @$col_hdrs )
331 :     . "\n\t</tr>\n"
332 : golsen 1.6 );
333 : overbeek 1.9 my($i);
334 : efrank 1.1
335 : overbeek 1.3 my $row;
336 :     foreach $row (@$tab)
337 : efrank 1.1 {
338 : golsen 1.6 push( @tab, "\t<tr>\n"
339 : overbeek 1.9 . join( "\n", map { &expand($_) } @$row )
340 : golsen 1.6 . "\n\t</tr>\n"
341 :     );
342 : efrank 1.1 }
343 :     push(@tab,"</table>\n");
344 :     return join("",@tab);
345 :     }
346 :    
347 : overbeek 1.3 sub expand {
348 : olson 1.27 my($x, $tag) = @_;
349 : redwards 1.29
350 : olson 1.27 $tag = "td" unless $tag;
351 : redwards 1.29 # RAE modified this so that you can pass in a reference to an array where the first element is the data to
352 :     # display and the second element is optional things like colspan and align. Note that in this case you need to include the td
353 :     if (ref($x) eq "ARRAY") {($x, $tag)=@$x}
354 : overbeek 1.3
355 : overbeek 1.9 if ($x =~ /^\@([^:]+)\:(.*)$/)
356 : overbeek 1.3 {
357 : olson 1.27 return "\t\t<$tag $1>$2</$tag>";
358 : overbeek 1.3 }
359 :     else
360 :     {
361 : olson 1.27 return "\t\t<$tag>$x</$tag>";
362 : overbeek 1.3 }
363 :     }
364 :    
365 : overbeek 1.11 sub set_ec_links {
366 :     my($cgi,$x) = @_;
367 :     my($before,$match,$after);
368 :    
369 :     if ($x =~ /^(.*)(EC \d+\.\d+\.\d+\.\d+)(.*)/s)
370 :     {
371 :     $before = $1;
372 :     $match = $2;
373 :     $after = $3;
374 :     return &set_ec_links($cgi,$before) . &HTML::ec_link($match) . &set_ec_links($cgi,$after);
375 :     }
376 :     return $x;
377 :     }
378 :    
379 : efrank 1.1 sub ec_link {
380 :     my($role) = @_;
381 :    
382 :     if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)
383 :     {
384 :     return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?ec:$1\">$role</a>";
385 :     }
386 :     else
387 :     {
388 :     return $role;
389 :     }
390 :     }
391 :    
392 :     sub role_link {
393 :     my($cgi,$role) = @_;
394 :    
395 :     my $roleR = ($role =~ /^(\d+\.\d+\.\d+\.\d+)\s+-\s+/) ? $1 : $role;
396 :     my $user = $cgi->param('user');
397 :     if (! $user) { $user = "" }
398 :     my $link = $cgi->url() . "?role=$roleR&user=$user";
399 :     $link =~ s/[a-z]+\.cgi\?/pom.cgi?/;
400 :     return "<a href=$link>$role</a>";
401 :     }
402 :    
403 : olson 1.13 #
404 :     # Local means to eliminate the fig|org.peg from the
405 :     # text of the link.
406 :     #
407 : efrank 1.1 sub fid_link {
408 :     my($cgi,$fid,$local,$just_url) = @_;
409 :     my($n);
410 :    
411 :     if ($fid =~ /^fig\|\d+\.\d+\.([a-z]+)\.(\d+)/)
412 :     {
413 :     if ($local)
414 :     {
415 :     if ($1 eq "peg")
416 :     {
417 :     $n = $2;
418 :     }
419 :     else
420 :     {
421 :     $n = "$1.$2";
422 :     }
423 :     }
424 :     else
425 :     {
426 :     $n = $fid;
427 :     }
428 :     if ($1 ne "peg") { return $n }
429 :     my $user = $cgi->param('user');
430 :     if (! $user) { $user = "" }
431 :     my $trans = $cgi->param('translate') ? "&translate=1" : "";
432 : olson 1.28 my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
433 :     my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
434 : overbeek 1.10 $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
435 : olson 1.15 #
436 :     # Elimin the p2p part if we're in that subdir. Ugh.
437 :     #
438 :     $link =~ s,p2p/protein.cgi,protein.cgi,;
439 :    
440 : efrank 1.1 if ($just_url)
441 :     {
442 :     return $link;
443 :     }
444 :     else
445 :     {
446 :     return "<a href=$link>$n</a>";
447 :     }
448 :     }
449 :     return $fid;
450 :     }
451 :    
452 :     sub family_link {
453 :     my($family,$user) = @_;
454 :    
455 :     return $family;
456 :     }
457 :    
458 :     use URI::Escape;
459 :    
460 :     sub get_html {
461 :     my( $url, $type, $kv_pairs) = @_;
462 :     my( $encoded, $ua, $args, @args, $out, @output, $x );
463 :    
464 :     $ua = new LWP::UserAgent;
465 :     $ua->timeout( 900 );
466 :     if ($type =~/post/i)
467 :     {
468 :     $args = [];
469 :     foreach $x (@$kv_pairs)
470 :     {
471 :     push(@$args, ( $x->[0], $x->[1]) );
472 :     }
473 :     my $request = POST $url, $args;
474 :     my $response = $ua->request($request);
475 :     $out = $response->content;
476 :     }
477 :     else
478 :     {
479 :     @args = ();
480 :     foreach $x (@$kv_pairs)
481 :     {
482 :     push( @args, "$x->[0]=" . uri_escape($x->[1]) );
483 :     }
484 :    
485 :     if (@args > 0)
486 :     {
487 :     $url .= "?" . join("&",@args);
488 :     }
489 :     $request = new HTTP::Request('GET', $url);
490 :     my $response = $ua->request($request);
491 :    
492 :     if ($response->is_success)
493 :     {
494 :     $out = $response->content;
495 :     }
496 :     else
497 :     {
498 :     $out = "<H1>Error: " . $response->code . "</H1>" . $response->message;
499 :     }
500 :     }
501 :     # set up a document with proper eol characters
502 :     @output = split(/[\012\015]+/,$out);
503 :     foreach $out (@output) { $out .= "\n"; }
504 :    
505 :     # Now splice in a line of the form <base href=URL> to cause all relative links to work
506 :     # properly. Remove the header.
507 :    
508 :     for ($i=0; ($i < @output) && ($output[$i] !~ /^\s*\</); $i++) {}
509 :     if ($i < @output)
510 :     {
511 :    
512 :     splice(@output,0,$i);
513 :     }
514 :    
515 :     for ($i=0; ($i < @output) && ($output[$i] !~ /\<body\>/i); $i++) {}
516 :     if ($i == @output)
517 :     {
518 :     $i = -1;
519 :     }
520 :     splice(@output,$i+1,0,"<base href=\"$url\">\n");
521 :     return @output;
522 :     }
523 :    
524 :     sub trim_output {
525 :     my($out) = @_;
526 :     my $i;
527 :    
528 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /^\</); $i++) {}
529 :     splice(@$out,0,$i);
530 :    
531 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<body\>/i); $i++) {}
532 :     if ($i == @$out)
533 :     {
534 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<html\>/i); $i++) {}
535 :     if ($i == @$out)
536 :     {
537 :     $i = -1;
538 :     }
539 :     }
540 :     for ($j=$i+1; ($j < @$out) && ($out->[$j] !~ /^\<hr\>$/); $j++) {}
541 :     if ($j < @$out)
542 :     {
543 :     splice(@$out,$i+1,($j-$i));
544 :     }
545 :    
546 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<\/body\>/i); $i++) {}
547 :     if ($i == @$out)
548 :     {
549 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<\/html\>/i); $i++) {}
550 :     }
551 :    
552 :     for ($j=$i-1; ($j > 0) && ($out->[$j] !~ /FIG search/); $j--) {}
553 :     if ($j > 0)
554 :     {
555 : olson 1.2 my @tmp = `cat $html_tail_file`;
556 : efrank 1.1 my $n = @tmp;
557 :     splice(@$out,$j-$n,$n+1);
558 :     }
559 :     }
560 :    
561 :     sub set_prot_links {
562 :     my($cgi,$x) = @_;
563 :     my($before,$match,$after);
564 :    
565 : overbeek 1.11 if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)/s)
566 : efrank 1.1 {
567 :     $before = $1;
568 :     $match = $2;
569 :     $after = $3;
570 : overbeek 1.11 return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after);
571 : efrank 1.1 }
572 : overbeek 1.19 elsif ($x =~ /^(.*)\b([NXYZA]P_[0-9\.]+)\b(.*)/s)
573 :     {
574 :     $before = $1;
575 :     $match = $2;
576 :     $after = $3;
577 :     return &set_prot_links($cgi,$before) . &HTML::refseq_link($cgi,$match) . &set_prot_links($cgi,$after);
578 :     }
579 : overbeek 1.11 elsif ($x =~ /^(.*)(gi\|\d+)(.*)/s)
580 : efrank 1.1 {
581 :     $before = $1;
582 :     $match = $2;
583 :     $after = $3;
584 : overbeek 1.11 return &set_prot_links($cgi,$before) . &HTML::gi_link($cgi,$match) . &set_prot_links($cgi,$after);
585 : efrank 1.1 }
586 : overbeek 1.14 elsif ($x =~ /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
587 :     {
588 :     $before = $1;
589 :     $match = $2;
590 :     $after = $3;
591 :     return &set_prot_links($cgi,$before) . &HTML::uni_link($cgi,$match) . &set_prot_links($cgi,$after);
592 :     }
593 : overbeek 1.11 elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)/s)
594 : efrank 1.1 {
595 :     $before = $1;
596 :     $match = $2;
597 :     $after = $3;
598 : overbeek 1.11 return &set_prot_links($cgi,$before) . &HTML::sp_link($cgi,$match) . &set_prot_links($cgi,$after);
599 : efrank 1.1 }
600 : overbeek 1.11 elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)/s)
601 : efrank 1.1 {
602 :     $before = $1;
603 :     $match = $2;
604 :     $after = $3;
605 : overbeek 1.11 return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after);
606 : efrank 1.1 }
607 : overbeek 1.12 elsif ($x =~ /^(.*)(kegg\|[a-z]{2,4}:[a-zA-Z_0-9]+)(.*)/s)
608 :     {
609 :     $before = $1;
610 :     $match = $2;
611 :     $after = $3;
612 :     return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after);
613 :     }
614 : efrank 1.1 return $x;
615 :     }
616 :    
617 : overbeek 1.19 sub refseq_link {
618 :     my($cgi,$id) = @_;
619 :    
620 :     if ($id =~ /^[NXYZA]P_/)
621 :     {
622 :     return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id>$id</a>";
623 :     }
624 :     }
625 :    
626 : efrank 1.1 sub gi_link {
627 :     my($cgi,$gi) = @_;
628 :    
629 :     if ($gi =~ /^gi\|(\d+)$/)
630 :     {
631 :     return "<a href=http://www.ncbi.nlm.nih.gov:80/entrez/query.fcgi?cmd=Retrieve&db=Protein&list_uids=$1&dopt=GenPept>$gi</a>";
632 :     }
633 :     return $gi;
634 :     }
635 :    
636 : overbeek 1.14 sub uni_link {
637 :     my($cgi,$uni) = @_;
638 :    
639 :     if ($uni =~ /^uni\|(\S+)$/)
640 :     {
641 :     return "<a href=http://www.pir.uniprot.org/cgi-bin/upEntry?id=$1>$uni</a>";
642 :     }
643 :     return $uni;
644 :     }
645 :    
646 : efrank 1.1 sub sp_link {
647 :     my($cgi,$sp) = @_;
648 :    
649 :     if ($sp =~ /^sp\|(\S+)$/)
650 :     {
651 :     return "<a href=http://us.expasy.org/cgi-bin/get-sprot-entry?$1>$sp</a>";
652 :     }
653 :     return $sp;
654 :     }
655 :    
656 :     sub pir_link {
657 :     my($cgi,$pir) = @_;
658 :    
659 :     if ($pir =~ /^pirnr\|(NF\d+)$/)
660 :     {
661 :     return "<a href=http://pir.georgetown.edu/cgi-bin/nfEntry.pl?id=$1>$pir</a>";
662 :     }
663 :     return $pir;
664 :     }
665 :    
666 : overbeek 1.12 sub kegg_link {
667 :     my($cgi,$kegg) = @_;
668 :    
669 :     if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)
670 :     {
671 :     return "<a href=http://www.genome.ad.jp/dbget-bin/www_bget?$1+$2>$kegg</a>";
672 :     }
673 :     return $kegg;
674 :     }
675 :    
676 : overbeek 1.11 sub set_map_links {
677 :     my($cgi,$x) = @_;
678 :     my($before,$match,$after);
679 : efrank 1.1
680 : overbeek 1.11 my $org = ($cgi->param('org') || $cgi->param('genome') || "");
681 :    
682 :     if ($x =~ /^(.*)(MAP\d+)(.*)/s)
683 :     {
684 :     $before = $1;
685 :     $match = $2;
686 :     $after = $3;
687 :     return &set_map_links($cgi,$before) . &map_link($cgi,$match,$org) . &set_map_links($cgi,$after);
688 :     }
689 :     return $x;
690 :     }
691 :    
692 :     sub map_link {
693 :     my($cgi,$map,$org) = @_;
694 :    
695 :     $user = $cgi->param('user');
696 :     $user = $user ? $user : "";
697 :     $org = $org ? $org : "";
698 :     my $url = "$FIG_Config::cgi_url/show_kegg_map.cgi?user=$user&map=$map&org=$org";
699 :     my $link = "<a href=\"$url\">$map</a>";
700 :     return $link;
701 :     }
702 : redwards 1.20
703 :     sub javascript {
704 :     #### MODIFIED BY RAE TO ADD JAVA SUPPORT FOR CHECK ALL/UNCHECK ALL
705 :     # This routine takes three arguments, $html, $form, and $button
706 :     # $html is the ref to the array with the html in it
707 :     # $form is the name of the form. This must be added whenever start_form is called
708 :     # by including a -name entry. This is only used for the javascript
709 :     # $button is the name of the button that should be checked/unchecked.
710 :     #
711 :     # At the moment this add's four buttons:
712 :     # Check all, check's all
713 :     # Check first half will check the first 50% of the entries
714 :     # Check second half will check the second 50% of the entries
715 :     # Uncheck all will remove the checks.
716 :    
717 :     # Note that the other change is I added a -name=>'fig_checked' to the start_form
718 :     # field. The name is needed for the java script.
719 :     #
720 :    
721 :     $java_script=<<EOF;
722 :     <SCRIPT LANGUAGE="JavaScript">
723 :     <!-- Begin
724 :     function checkAll(field)
725 :     {
726 :     for (i = 0; i < field.length; i++)
727 :     field[i].checked = true ;
728 :     }
729 :    
730 :     function checkFirst(field)
731 :     {
732 :     for (i = 0; i < field.length/2; i++)
733 :     field[i].checked = true;
734 :     }
735 :    
736 :     function checkSecond(field)
737 :     {
738 :     for (i=Math.round(field.length/2); i < field.length; i++)
739 :     field[i].checked = true ;
740 :     }
741 :    
742 :     function uncheckAll(field)
743 :     {
744 :     for (i = 0; i < field.length; i++)
745 :     field[i].checked = false ;
746 :     }
747 :     // End -->
748 :     </script>
749 :     EOF
750 :     return $java_script;
751 :     }
752 :    
753 :     sub java_buttons {
754 :     ## ADDED BY RAE
755 :     # Provides code to include check all/first half/second half/none for javascrspt
756 :     # this takes two variables - the form name provided in start_form with the
757 :     # -name => field and the checkbox name
758 :     my ($form, $button)=@_;
759 :    
760 :     $java_script="<input type=\"button\" name=\"CheckAll\" value=\"Check All\"\nonClick=\"checkAll(document.$form.$button)\">\n";
761 :     $java_script.="<input type=\"button\" name=\"CheckFirst\" value=\"Check First Half\"\nonClick=\"checkFirst(document.$form.$button)\">\n";
762 :     $java_script.="<input type=\"button\" name=\"CheckSecond\" value=\"Check Second Half\"\nonClick=\"checkSecond(document.$form.$button)\">\n";
763 :     $java_script.="<input type=\"button\" name=\"UnCheckAll\" value=\"Uncheck All\"\nonClick=\"uncheckAll(document.$form.$button)\">\n";
764 :    
765 :     return $java_script;
766 :     }
767 :    
768 : overbeek 1.22 sub sub_link {
769 :     my($cgi,$sub) = @_;
770 :     my($sub_link);
771 :    
772 :     my $user = $cgi->param('user');
773 :     if ($user)
774 :     {
775 :     $sub_link = "<a href=./subsys.cgi?ssa_name=$sub&request=show_ssa&user=$user>$sub</a>";
776 :     }
777 :     else
778 :     {
779 :     $sub_link = $sub;
780 :     }
781 :     return $sub_link;
782 :     }
783 :    
784 : efrank 1.1 1

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3