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

Annotation of /FigKernelPackages/HTML.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3