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

Annotation of /FigKernelPackages/HTML.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3