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

Annotation of /FigKernelPackages/HTML.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3