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

Annotation of /FigKernelPackages/HTML.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3