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

Annotation of /FigKernelPackages/HTML.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3