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

Annotation of /FigKernelPackages/HTML.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : olson 1.72 #
2 :     # Copyright (c) 2003-2006 University of Chicago and Fellowship
3 :     # for Interpretations of Genomes. All Rights Reserved.
4 :     #
5 :     # This file is part of the SEED Toolkit.
6 : parrello 1.119 #
7 : olson 1.72 # The SEED Toolkit is free software. You can redistribute
8 :     # it and/or modify it under the terms of the SEED Toolkit
9 : parrello 1.119 # Public License.
10 : olson 1.72 #
11 :     # You should have received a copy of the SEED Toolkit Public License
12 :     # along with this program; if not write to the University of Chicago
13 :     # at info@ci.uchicago.edu or the Fellowship for Interpretation of
14 :     # Genomes at veronika@thefig.info or download a copy from
15 :     # http://www.theseed.org/LICENSE.TXT.
16 :     #
17 :    
18 : efrank 1.1 package HTML;
19 :    
20 : parrello 1.100 use strict;
21 : parrello 1.49 use Tracer;
22 : parrello 1.119 use FIG;
23 : parrello 1.123 use FIGRules;
24 : efrank 1.1 use Carp;
25 :     use Data::Dumper;
26 :     use LWP::UserAgent;
27 :     use LWP::Simple;
28 : golsen 1.41 use URI::Escape; # uri_escape()
29 : efrank 1.1 use URI::URL;
30 :     use HTTP::Request::Common;
31 : olson 1.16 use POSIX;
32 : parrello 1.111 use CGI;
33 : efrank 1.1
34 : parrello 1.100 #use raelib; # now used for the excel function, that should eventually end up in here. Way too experimental!
35 :     my $raelib;
36 : overbeek 1.90
37 : redwards 1.61
38 : overbeek 1.68 my $top_link_cache;
39 :    
40 :    
41 : olson 1.31 sub new
42 :     {
43 :     my($class) = @_;
44 :    
45 :     my $self = {};
46 :    
47 :     return bless $self, $class;
48 :     }
49 :    
50 : overbeek 1.68 sub top_link
51 :     {
52 : parrello 1.119
53 : overbeek 1.68 #
54 :     # Determine if this is a toplevel cgi or one in one of the subdirs (currently
55 :     # just /p2p).
56 :     #
57 :    
58 :     return $top_link_cache if ($top_link_cache);
59 :    
60 :     my @parts = split(/\//, $ENV{SCRIPT_NAME});
61 :     my $top;
62 : parrello 1.103 if (defined $parts[-2] && $parts[-2] eq 'FIG')
63 : overbeek 1.68 {
64 : parrello 1.123 $top = '.';
65 :     # warn "toplevel @parts\n";
66 : overbeek 1.68 }
67 : parrello 1.103 elsif (defined $parts[-3] && $parts[-3] eq 'FIG')
68 : overbeek 1.68 {
69 : parrello 1.123 $top = '..';
70 :     # warn "subdir @parts\n";
71 : overbeek 1.68 }
72 :     else
73 :     {
74 : parrello 1.123 $top = $FIG_Config::cgi_base;
75 :     # warn "other @parts\n";
76 : overbeek 1.68 }
77 :    
78 :     $top_link_cache = $top;
79 :     return $top;
80 :     }
81 :    
82 : olson 1.25 sub compute_html_header
83 :     {
84 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
85 : olson 1.42 my($additional_insert, $user, %options ) = @_;
86 :    
87 : overbeek 1.88 local $/ = "\n";
88 :    
89 : olson 1.42 my $header_name = $options{header_name} ? $options{header_name} : "html.hdr";
90 :     my $tail_name = $options{tail_name} ? $options{tail_name} : "html.tail";
91 :    
92 :     my $html_hdr_file = "./Html/$header_name";
93 : olson 1.2 if (! -f $html_hdr_file)
94 :     {
95 : parrello 1.49 $html_hdr_file = "$FIG_Config::fig/CGI/Html/$header_name";
96 : olson 1.2 }
97 : olson 1.15 my @html_hdr = &FIG::file_read($html_hdr_file);
98 : olson 1.42
99 : olson 1.67 # for my $k (sort keys %ENV) { warn "$k = $ENV{$k}\n"; }
100 :    
101 :     #
102 :     # Determine if this is a toplevel cgi or one in one of the subdirs (currently
103 :     # just /p2p).
104 :     #
105 :    
106 :     my @parts = split(/\//, $ENV{SCRIPT_NAME});
107 :     my $top;
108 :     if ($parts[-2] eq 'FIG')
109 :     {
110 : parrello 1.123 $top = '.';
111 :     # warn "toplevel @parts\n";
112 : olson 1.67 }
113 :     elsif ($parts[-3] eq 'FIG')
114 :     {
115 : parrello 1.123 $top = '..';
116 :     # warn "subdir @parts\n";
117 : olson 1.67 }
118 :     else
119 :     {
120 : parrello 1.123 $top = $FIG_Config::cgi_base;
121 :     # warn "other @parts\n";
122 : olson 1.67 }
123 :    
124 :     $options{no_fig_search} or push( @html_hdr, "<br><a href=\"$top/index.cgi?user=$user\">FIG search</a>\n" );
125 : overbeek 1.18
126 : olson 1.15 if (@html_hdr)
127 :     {
128 : parrello 1.49 my $insert_stuff;
129 : olson 1.42
130 : parrello 1.49 if (not $options{no_release_info})
131 :     {
132 :     my @ver = &FIG::file_head("$FIG_Config::fig_disk/CURRENT_RELEASE", 1);
133 :     my $ver = $ver[0];
134 :     chomp $ver;
135 :     if ($ver =~ /^cvs\.(\d+)$/)
136 :     {
137 :     my $d = asctime(localtime($1));
138 :     chomp($d);
139 :     $ver .= " ($d)";
140 :     }
141 :     my $host = &FIG::get_local_hostname();
142 :     $insert_stuff = "SEED version <b>$ver</b> on $host";
143 :     }
144 : parrello 1.119
145 : parrello 1.49 if ($additional_insert)
146 :     {
147 :     $insert_stuff .= "<br>" . $additional_insert;
148 :     }
149 : parrello 1.119
150 : parrello 1.49 for $_ (@html_hdr)
151 :     {
152 : parrello 1.71 s,(href|img\s+src)="/FIG/,$1="$top/,g;
153 :     s,(\?user\=)\",$1$user",;
154 : parrello 1.49 if ($_ eq "<!-- HEADER_INSERT -->\n")
155 :     {
156 :     $_ = $insert_stuff;
157 :     }
158 :     }
159 : olson 1.15 }
160 :    
161 : olson 1.25 return @html_hdr;
162 :     }
163 :    
164 :     sub show_page {
165 : efrank 1.32 #warn "SHOWPAGE: cgi=", Dumper(@_);
166 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
167 : overbeek 1.87 my($cgi,$html,$no_home, $alt_header, $css, $javasrc, $cookie, $options) = @_;
168 : olson 1.25 my $i;
169 : parrello 1.111 Trace("Setting top link.") if T(3);
170 : overbeek 1.70 my $top = top_link();
171 :    
172 : parrello 1.119 # ARGUMENTS:
173 : redwards 1.34 # $cgi is the CGI method
174 :     # $html is an array with all the html in it. It is just joined by "\n" (and not <br> or <p>
175 : redwards 1.35 # $no_home eliminates ONLY the bottom FIG search link in a page
176 : parrello 1.49 # $alt_header is a reference to an array for an alternate header banner that you can replace the standard one with
177 : 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
178 :     # 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
179 :     # 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
180 : overbeek 1.79 # $javasrc is a reference to an array of URLs to javascripts to be included (e.g. "FIG/Html/css/styleswitcher.js")
181 : redwards 1.61 # $cookie is the name and value of the cookie to set. Note that you should probably use raelib->cookie to get/set your cookies
182 : overbeek 1.87 # $options is a reference to a hash of options that you can pass around the pages
183 : olson 1.25 #
184 :     # Find the HTML header
185 :     #
186 : parrello 1.111 Trace("Reading tail.") if T(3);
187 : olson 1.101 my $tail_name = $options->{tail_name} ? $options->{tail_name} : "html.tail";
188 :     my $html_tail_file = "./Html/$tail_name";
189 :     if (! -f $html_tail_file)
190 :     {
191 :     $html_tail_file = "$FIG_Config::fig/CGI/Html/$tail_name";
192 :     }
193 : parrello 1.111 Trace("Extracting user name and header data.") if T(3);
194 : overbeek 1.33 my $user = $cgi->param('user') || "";
195 : redwards 1.35 my @html_hdr;
196 : redwards 1.39 if ($alt_header && ref($alt_header) eq "ARRAY")
197 : redwards 1.35 {
198 :     @html_hdr = @$alt_header;
199 :     }
200 : parrello 1.119 else
201 : redwards 1.35 {
202 : overbeek 1.87 @html_hdr = compute_html_header(undef,$user,%$options);
203 : redwards 1.35 }
204 : olson 1.25
205 : redwards 1.61 # RAE: I am offloading the handling of cookies to CGI.pm since I don't know how they are set up.
206 :     # This modification adds the cookies if necessary
207 : parrello 1.119
208 : redwards 1.63 # Note: 3/10/05 commented this line out pending the discussion of adding cookies into the seed that we are waiting to see about
209 :     # to add cookies back in replace these two header lines with each other
210 : parrello 1.111 #my $hdr_thing = $cgi->header(-cookie=>$cookie);
211 :     my $hdr_thing = $cgi->header();
212 :     Trace("Printing HTML header: $hdr_thing.") if T(3);
213 :     print $hdr_thing;
214 :     Trace("Header printed.") if T(3);
215 : golsen 1.5 #
216 : golsen 1.6 # The SEED header file goes immediately after <BODY>. Figure out
217 :     # what parts of the HTML document skeleton are there, and fill in
218 :     # missing ones.
219 : golsen 1.5 #
220 : golsen 1.6 # This list should be as comprehensive as feasible:
221 : golsen 1.5 #
222 :    
223 : golsen 1.6 my %head_tag = ( base => 1,
224 :     basefont => 1,
225 :     html => 1,
226 :     isindex => 1,
227 :     link => 1,
228 :     meta => 1,
229 :     nextid => 1,
230 :     style => 1,
231 : redwards 1.61 title => 1,
232 : golsen 1.6 );
233 :    
234 :     #
235 :     # This list need not be comprehensive; it is just stopping conditions:
236 :     #
237 :    
238 :     my %body_tag = ( a => 1,
239 :     br => 1,
240 :     center => 1,
241 :     form => 1,
242 :     h1 => 1,
243 :     h2 => 1,
244 :     h3 => 1,
245 :     hr => 1,
246 :     img => 1,
247 :     p => 1,
248 :     pre => 1,
249 :     table => 1
250 :     );
251 :    
252 :     my $html_line = -1;
253 :     my $head_line = -1;
254 :     my $base_line = -1;
255 :     my $head_end_line = -1;
256 :     my $body_line = -1;
257 :     my $last_head_line = -1; # If no head tags are found, text goes at top.
258 :     my $done = 0;
259 : parrello 1.111 Trace("Processing special cases.") if T(3);
260 : golsen 1.6 for ( $i = 0; $i < @$html; $i++ )
261 :     {
262 : parrello 1.49 # Some special cases:
263 : golsen 1.6
264 : parrello 1.49 if ( $html->[$i] =~ /\<html[^0-9a-z]/i ) { $html_line = $i }
265 :     if ( $html->[$i] =~ /\<head[^0-9a-z]/i ) { $head_line = $i }
266 :     if ( $html->[$i] =~ /\<base[^0-9a-z]/i ) { $base_line = $i }
267 :     if ( $html->[$i] =~ /\<\/head\>/i ) { $head_end_line = $i }
268 :    
269 :     # The content goes after this line:
270 :    
271 :     if ( $html->[$i] =~ /\<body[^0-9a-z]/i )
272 :     {
273 :     $body_line = $i;
274 : parrello 1.71 last;
275 : parrello 1.49 }
276 :    
277 :     # Now the general case.
278 :     # Analyze all the html tags on the line:
279 :    
280 :     foreach ( $html->[$i] =~ /\<\/?([0-9a-z]+)/ig )
281 :     {
282 :     # At first body tag, we stop the search and put the text
283 :     # after the last line with a head tag:
284 :    
285 :     if ( $body_tag{ lc $_ } )
286 :     {
287 :     $done = 1;
288 :     last;
289 :     }
290 :    
291 :     # If this is a head tag, then move the marker forward
292 :    
293 :     elsif ( $head_tag{ lc $_ } )
294 :     {
295 :     $last_head_line = $i;
296 :     }
297 :     }
298 :     last if $done; # When done, break loop to avoid increment
299 : efrank 1.1 }
300 : golsen 1.6
301 :     # Some sanity checks on structure:
302 :    
303 :     if ( 1 )
304 : efrank 1.1 {
305 : parrello 1.123 Trace("Sanity checks in progress.") if T(3);
306 : parrello 1.49 if ( $html_line >= 0 )
307 :     {
308 :     if ( ( $head_line >= 0 ) && ( $html_line > $head_line ) )
309 :     {
310 : parrello 1.111 Trace("<HTML> tag follows <HEAD> tag.") if T(1);
311 : parrello 1.49 }
312 :     if ( ( $head_end_line >= 0 ) && ( $html_line > $head_end_line ) )
313 :     {
314 : parrello 1.111 Trace("<HTML> tag follows </HEAD> tag.") if T(1);
315 : parrello 1.49 }
316 :     }
317 :     if ( $head_line >= 0 )
318 :     {
319 :     if ( ( $head_end_line >= 0 ) && ( $head_line > $head_end_line ) )
320 :     {
321 : parrello 1.111 Trace("<HEAD> tag follows </HEAD> tag.") if T(1);
322 : parrello 1.49 }
323 :     }
324 : efrank 1.1 }
325 : parrello 1.111 Trace("Sanity checks complete.") if T(3);
326 : golsen 1.6 #
327 :     # Okay. Let's put in the html header file, and missing tags:
328 :     #
329 :     # <BODY> goes after last head line
330 :     #
331 : parrello 1.119 # RAE:
332 : redwards 1.34 # Added the javascript for the buttons immediately after body.
333 : redwards 1.20 # Note if no buttons are added we still (at the moment) add the script,
334 :     # but it only adds a little text (495 characters) to the html and noone will notice!
335 : redwards 1.46 # RAE: This is now deprecated because everything is in an external file, FIG.js, included later
336 : golsen 1.6 if ( $body_line < 0 )
337 :     {
338 : parrello 1.49 $body_line = $last_head_line + 1;
339 : parrello 1.123 Trace("Splicing body line at $body_line.") if T(3);
340 : parrello 1.49 splice( @$html, $body_line, 0, "<BODY>\n" );
341 : golsen 1.6 }
342 :    
343 :     #
344 :     # Seed page header (if it exists) goes after <BODY>
345 :     #
346 :    
347 : olson 1.15 if (@html_hdr)
348 : golsen 1.6 {
349 : parrello 1.123 Trace("Splicing SEED page header after $body_line.") if T(3);
350 : parrello 1.49 splice( @$html, $body_line + 1, 0, @html_hdr );
351 : golsen 1.6 }
352 :    
353 :     #
354 :     # </HEAD> goes before <BODY>
355 :     #
356 :    
357 :     if ( $head_end_line < 0 )
358 :     {
359 : parrello 1.49 $head_end_line = $body_line;
360 : parrello 1.123 Trace("Splicing header terminater at $body_line.") if T(3);
361 : parrello 1.49 splice( @$html, $body_line, 0, "</HEAD>\n" );
362 : golsen 1.6 }
363 :    
364 : redwards 1.34 # RAE:
365 :     # Add css here
366 : golsen 1.40 # Note that at the moment I define these two sheets here. I think this should
367 :     # be moved out, but I want to try it and see what happens. css has the format:
368 :     #
369 : redwards 1.34 # <link rel='stylesheet' title='default' href='/css/default.css' type='text/css'>
370 : parrello 1.111 Trace("Formatting CSS.") if T(3);
371 : redwards 1.35 # convert the default key to the right case. and eliminate dups
372 :     foreach my $k (keys %$css) {if (lc($k) eq "default") {$css->{'Default'}=$css->{$k}}}
373 : golsen 1.40
374 : redwards 1.34 if (!$css || !$css->{'Default'})
375 :     {
376 : overbeek 1.79 $css->{'Default'} = "Html/css/default.css";
377 : redwards 1.34 }
378 :     if (!$css->{"Sans Serif"})
379 :     {
380 : overbeek 1.79 $css->{'Sans Serif'} = "Html/css/sanserif.css";
381 : redwards 1.34 }
382 : redwards 1.55
383 : redwards 1.34 my $csstext = "<link rel='stylesheet' title='default' href='".$css->{'Default'}."' type='text/css'>\n";
384 :     $csstext .= "<link rel='alternate stylesheet' title='Sans Serif' href='".$css->{'Sans Serif'}."' type='text/css'>\n";
385 : parrello 1.119
386 : redwards 1.34 foreach my $k (keys %$css)
387 :     {
388 :     next if (lc($k) eq "default" || lc($k) eq "sans serif");
389 : redwards 1.38 $csstext .= "<link rel='alternate stylesheet' title='$k' href='".$css->{$k}."' type='text/css'>\n";
390 :     }
391 :    
392 : overbeek 1.79 $csstext .= "<link rel='alternate' title='SEED RSS feeds' href='Html/rss/SEED.rss' type='application/rss+xml'>\n";
393 : parrello 1.119
394 : redwards 1.38 # RAE: also added support for external javascripts here.
395 :     # we are cluttering the HTML code with all the javascripts when they could easily be in external files
396 :     # this solution allows us to source other files
397 :    
398 : parrello 1.119 # the file FIG.js contains most of the java script we use routinely. Every browser will just cache this and so
399 : redwards 1.46 # it will reduce our overhead.
400 : parrello 1.111 Trace("Formatting javascript.") if T(3);
401 : redwards 1.38 # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts
402 : overbeek 1.79 push @$javasrc, "Html/css/FIG.js";
403 : redwards 1.46 foreach my $script (@$javasrc) {
404 : parrello 1.49 $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";
405 : redwards 1.34 }
406 : parrello 1.119
407 : parrello 1.111 Trace("Re-splicing the header terminator at $head_end_line.") if T(3);
408 : 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.
409 :    
410 : golsen 1.6 #
411 :     # <BASE ...> goes before </HEAD>
412 :     #
413 :    
414 :     if ( $base_line < 0 )
415 :     {
416 : parrello 1.49 #
417 :     # Use a relative base address for pages. Also, because I am
418 :     # worried about when FIG_config.pm gets updated (clean installs
419 :     # only, or every update?), I provide an alternative derivation
420 :     # from $cgi_url. -- GJO
421 :     #
422 :     # BASE href needs to be absolute. RDO.
423 :     #
424 : parrello 1.119 #
425 : parrello 1.100 # $base_url = &FIG::cgi_url;
426 : parrello 1.49 # my $base_url = $FIG_Config::cgi_base;
427 :     # if ( ! $base_url ) # if cgi_base was not defined
428 :     # {
429 :     # $base_url = $FIG_Config::cgi_url; # get the full cgi url
430 :     # $base_url =~ s~^http://[^/]*~~; # remove protocol and host
431 :     # $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash
432 : parrello 1.119 # }
433 : golsen 1.6
434 : parrello 1.49 $base_line = $head_end_line;
435 : parrello 1.123 #
436 :     # RDO 2005-1006. Remove this so proxying works better.
437 :     #
438 : overbeek 1.64 # splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );
439 : golsen 1.6 }
440 :    
441 :     #
442 :     # <HTML> goes at the top of the output
443 :     #
444 :    
445 :     if ( $html_line < 0 )
446 :     {
447 : parrello 1.49 $html_line = 0;
448 : parrello 1.123 Trace("Splicing the HTML tag at $html_line.") if T(3);
449 : parrello 1.49 splice( @$html, $html_line, 0, "<HTML>\n" );
450 : golsen 1.6 }
451 :    
452 :     #
453 :     # <HEAD> goes after <HTML>
454 :     #
455 :    
456 :     if ( $head_line < 0 )
457 :     {
458 : parrello 1.49 $head_line = $html_line + 1;
459 : parrello 1.123 Trace("Splicing the HEAD tag at $head_line.") if T(3);
460 : parrello 1.49 splice( @$html, $head_line, 0, "<HEAD>\n" );
461 : golsen 1.6 }
462 :    
463 :     #
464 :     # Place FIG search link at bottom of page
465 :     #
466 : parrello 1.111 Trace("Placing FIG search link.") if T(3);
467 : golsen 1.6 my @tail = -f $html_tail_file ? `cat $html_tail_file` : ();
468 : efrank 1.1 if (! $no_home)
469 :     {
470 : parrello 1.49 my $user = $cgi->param('user') || "";
471 :     push( @tail, "<hr><a href=\"index.cgi?user=$user\">FIG search</a>\n" );
472 : efrank 1.1 }
473 :    
474 : golsen 1.6 #
475 : olson 1.21 # See if we have a site-specific tail (for disclaimers, etc).
476 :     #
477 : parrello 1.111 Trace("Placing site tail.") if T(3);
478 : olson 1.21 my $site_tail = "$FIG_Config::fig_disk/config/site_tail.html";
479 :     my $site_fh;
480 :     if (open($site_fh, "<$site_tail"))
481 :     {
482 : parrello 1.49 push(@tail, <$site_fh>);
483 :     close($site_fh);
484 : olson 1.21 }
485 :    
486 :     #
487 : golsen 1.6 # Figure out where to insert The SEED tail. Before </body>,
488 :     # or before </html>, or at end of page.
489 :     #
490 :     my @tags = ();
491 : parrello 1.111 Trace("Processing closing tags.") if T(3);
492 : golsen 1.6 for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}
493 :     if ($i >= @$html) # </body> not found; look for </html>
494 : efrank 1.1 {
495 : parrello 1.49 push @tags, "\n</BODY>\n";
496 :     # Even if tag is not found, index points to correct place for splice
497 :     for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/html\>/i); $i++) {}
498 :     if ($i >= @$html) # </html> not found; add it
499 :     {
500 :     push @tags, "</HTML>\n";
501 :     }
502 : efrank 1.1 }
503 : golsen 1.6
504 :     if ( @tail )
505 :     {
506 : parrello 1.123 Trace("Splicing tail.") if T(3);
507 : parrello 1.49 splice( @$html, $i, 0, @tail, @tags );
508 : golsen 1.6 }
509 :     elsif ( @tags )
510 :     {
511 : parrello 1.123 Trace("Splicing tags.") if T(3);
512 : parrello 1.49 splice( @$html, $i, 0, @tags );
513 : golsen 1.6 }
514 :    
515 : parrello 1.111 Trace("Printing the HTML array.") if T(3);
516 : golsen 1.40 # RAE the chomp will return any new lines at the ends of elements in the array,
517 :     # and then we can join with a "\n". This is because somethings put newlines in,
518 :     # and others don't. This should make nicer looking html
519 :     #
520 :     # chomp(@$html);
521 :     # print join "\n", @$html;
522 :     #
523 :     # Apparently the above still breaks things. This is the correct code:
524 : overbeek 1.43 foreach $_ (@$html)
525 :     {
526 : parrello 1.123 my $line = $_;
527 :     if (T(4)) {
528 :     my $escapedLine = CGI::escapeHTML($line);
529 :     Trace("Printing:\n$escapedLine") if T(4);
530 :     }
531 : parrello 1.111 print $line;
532 : overbeek 1.43 }
533 : parrello 1.119
534 : efrank 1.1 }
535 :    
536 : overbeek 1.90
537 :     =head1 make_table
538 :    
539 : parrello 1.119 The main method to convert an array into a table.
540 : overbeek 1.90
541 :     The col_hdrs are set to the <th> headers, the $tab is an array of arrays. The first is the rows, and the second is the columns. The title is the title of the table.
542 :    
543 :     The options define the settings for the table such as border, width, and class for css formatting. If the option "excelfile" is set to a filename that will be created in FIG_Config::temp, and the link included that allows the user to download the file as an excel file.
544 :    
545 :     =cut
546 :    
547 : efrank 1.1 sub make_table {
548 : olson 1.17 my($col_hdrs,$tab,$title, %options ) = @_;
549 : efrank 1.1 my(@tab);
550 :    
551 : olson 1.17 my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";
552 : parrello 1.103 my $width = defined $options{width} ? "width=\"$options{width}\"" : "";
553 :     my $class = defined $options{class} ? "class=\"$options{class}\"" : "";
554 : overbeek 1.73 push( @tab, "\n<table $border $width $class>\n",
555 : golsen 1.6 "\t<caption><b>$title</b></caption>\n",
556 : olson 1.27 "\t<tr>\n\t\t"
557 : parrello 1.119 . join( "\n", map { &expand($_, "th") } @$col_hdrs )
558 : olson 1.27 . "\n\t</tr>\n"
559 : golsen 1.6 );
560 : overbeek 1.9 my($i);
561 : efrank 1.1
562 : overbeek 1.3 my $row;
563 :     foreach $row (@$tab)
564 : efrank 1.1 {
565 : parrello 1.49 push( @tab, "\t<tr>\n"
566 :     . join( "\n", map { &expand($_) } @$row )
567 :     . "\n\t</tr>\n"
568 :     );
569 : efrank 1.1 }
570 :     push(@tab,"</table>\n");
571 : overbeek 1.90
572 :     # excelfile should be appropriate for a filename (no spaces/special characters)
573 : parrello 1.100 if (defined $options{"excelfile"}) {
574 :     if (! defined($raelib)) {
575 :     require raelib;
576 :     $raelib = new raelib;
577 :     }
578 :     push @tab, $raelib->tab2excel($col_hdrs,$tab,$title,\%options,$options{"excelfile"})}
579 : parrello 1.119
580 : efrank 1.1 return join("",@tab);
581 :     }
582 :    
583 : overbeek 1.74 sub abstract_coupling_table {
584 : overbeek 1.75 my($cgi,$prot,$coupling) = @_;
585 : overbeek 1.77 my %fc;
586 : overbeek 1.74
587 :     my $col_hdrs = ["coupled to","Score","Type of Coupling", "Type-specific Data"];
588 :     my $tab = [];
589 : overbeek 1.76 my %by_peg;
590 : overbeek 1.74 foreach my $x (@$coupling)
591 :     {
592 : parrello 1.123 my($peg2,$psc,$type,$extra) = @$x;
593 :     if (($type !~ /^[ID]FC$/) || (! $fc{$peg2}))
594 :     {
595 :     if ($type =~ /^[ID]FC$/)
596 :     {
597 :     $fc{$peg2} = 1;
598 :     }
599 : overbeek 1.78
600 : parrello 1.123 $by_peg{$peg2} += $psc;
601 :     }
602 : overbeek 1.76 }
603 :    
604 :     foreach my $x (sort { ($by_peg{$b->[0]} <=> $by_peg{$a->[0]})
605 : parrello 1.123 or ($a->[0] cmp $b->[0])
606 :     or ($b->[1] <=> $a->[1])
607 :     or ($a->[2] cmp $b->[2]) } @$coupling)
608 : overbeek 1.76 {
609 : parrello 1.123 my($peg2,$psc,$type,$extra) = @$x;
610 :     push(@$tab,[&fid_link($cgi,$peg2,1),$psc,$type,&set_prot_links($cgi,join(", ",@$extra))]);
611 : overbeek 1.74 }
612 : overbeek 1.75
613 : overbeek 1.76
614 : overbeek 1.77 my $help = "<a href=\"Html/abstract_coupling.html\" target=\"SEED_or_SPROUT_help\">for help</a>";
615 : overbeek 1.75 # my @html = &make_table($col_hdrs,$tab,"Abstract Coupling Data for $prot");
616 :     # push(@html,"<hr>\n",$cgi->h3($help),"<br>");
617 :     # return @html;
618 :    
619 :     return &make_table($col_hdrs,$tab,"Abstract Coupling Data for $prot [$help]");
620 : overbeek 1.74 }
621 :    
622 : overbeek 1.3 sub expand {
623 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
624 : golsen 1.40 my( $x, $tag ) = @_;
625 :    
626 : olson 1.27 $tag = "td" unless $tag;
627 : golsen 1.40 my $endtag = $tag;
628 :    
629 :     # RAE modified this so that you can pass in a reference to an array where
630 :     # the first element is the data to display and the second element is optional
631 :     # things like colspan and align. Note that in this case you need to include the td
632 : redwards 1.30 # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]
633 : overbeek 1.3
634 : redwards 1.47 # per GJO's request modified this line so it can take any tag.
635 :     if ( ref($x) eq "ARRAY" ) { ($x, $tag) = @$x; $tag =~ /^(\S+)/; $endtag = $1 }
636 : golsen 1.40
637 :     if ( $x =~ /^\@([^:]+)\:(.*)$/ )
638 : overbeek 1.3 {
639 : parrello 1.49 return "\t\t<$tag $1>$2</$endtag>";
640 : overbeek 1.3 }
641 :     else
642 :     {
643 : parrello 1.49 return "\t\t<$tag>$x</$endtag>";
644 : overbeek 1.3 }
645 :     }
646 :    
647 : redwards 1.47
648 : redwards 1.62 =head2 merge_table_rows()
649 :    
650 :     Merge table rows together. This will merge a table so that adjacent cells with the same content will only be shown once.
651 :    
652 :     Something like this:
653 :    
654 :     -----------------------
655 :     | 1 | a |
656 :     -----------------------
657 :     | 1 | b |
658 :     -----------------------
659 :     | 2 | c |
660 :     -----------------------
661 :     | 3 | d |
662 :     -----------------------
663 :     | 4 | d |
664 :     -----------------------
665 :     | 5 | d |
666 :     -----------------------
667 :    
668 : parrello 1.119 Will become:
669 : redwards 1.62
670 :     -----------------------
671 :     | | a |
672 :     | 1 |-----------
673 :     | | b |
674 :     -----------------------
675 :     | 2 | c |
676 :     -----------------------
677 :     | 3 | |
678 :     ------------ |
679 :     | 4 | 5 |
680 :     ------------ |
681 :     | 5 | |
682 :     -----------------------
683 : parrello 1.119
684 : redwards 1.62
685 :     The method takes two arguments. The reference to the array that is the table ($tab). This is the standard table that is created for HTML.pm to draw, and a reference to a hash of columns that you don't want to merge together. The reference to the hash is optional, and if not included, everything will be merged.
686 :    
687 : parrello 1.119 $tab=&HTML::merge_table_rows($tab);
688 : redwards 1.62
689 :     or
690 :    
691 : parrello 1.119 $skip=(1=>1, 3=>1, 5=>1);
692 : redwards 1.62 $tab=&HTML::merge_table_rows($tab, $skip); # will merge all columns except 1, 3 and 5. Note the first column in the table is #0
693 : parrello 1.119
694 : redwards 1.62
695 :     =cut
696 :    
697 :    
698 :    
699 :    
700 : redwards 1.47 sub merge_table_rows {
701 :     # RAE:
702 :     # Experimental piece of code. We often want to have rows or columns were cells are merged. It just looks so much nicer
703 :     # this block should merge adjacent rows that have the same text in them.
704 : parrello 1.119 # use like this:
705 :     # $tab=&HTML::merge_table_rows($tab);
706 : redwards 1.47 # before you do a make_table call
707 :    
708 :     my $self=shift if UNIVERSAL::isa($_[0],__PACKAGE__);
709 : redwards 1.62 my ($tab, $skip)=@_;
710 : parrello 1.119
711 : redwards 1.47 my $newtable;
712 :     my $lastrow;
713 :     my $rowspan;
714 :     my $refs;
715 : parrello 1.119
716 : redwards 1.47 for (my $y=0; $y <= $#$tab; $y++) {
717 :     #$y is the row in the table;
718 :     for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
719 : redwards 1.62 # this is the user definable columns not to merge
720 :     if ($skip->{$x})
721 :     {
722 :     $newtable->[$y]->[$x] = $tab->[$y]->[$x];
723 :     next;
724 :     }
725 : parrello 1.119
726 : redwards 1.47 #$x is the column in the table
727 : parrello 1.119 # if the column in the row we are looking at is the same as the column in the previous row, we don't add
728 : redwards 1.47 # this cell to $newtable. Instead we increment the rowspan of the previous row by one
729 : parrello 1.119
730 : redwards 1.47 # handle cells that are references to arrays
731 :     if (ref($tab->[$y]->[$x]) eq "ARRAY") {$refs->[$y]->[$x]=$tab->[$y]->[$x]->[1]; $tab->[$y]->[$x]=$tab->[$y]->[$x]->[0]}
732 : parrello 1.119
733 : redwards 1.47 # now we go back through the table looking where to draw the merge line:
734 :     my $lasty=$y;
735 : redwards 1.52 while ($lasty >= 0 && $tab->[$y]->[$x] eq $tab->[$lasty]->[$x]) {$lasty--}
736 : 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
737 :     if ($lasty == $y) {
738 :     # we always want to have something in rows that may otherwise be empty but should be there (see below)
739 :     unless ($tab->[$y]->[$x]) {$tab->[$y]->[$x]=" &nbsp; "}
740 :     $newtable->[$y]->[$x] = $tab->[$y]->[$x];
741 :     }
742 :     else {$rowspan->[$lasty]->[$x]++}
743 :     }
744 :     }
745 :    
746 :     # now just join everything back together
747 :     for (my $y=0; $y <= $#$tab; $y++) {
748 :     for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
749 :     if ($rowspan->[$y]->[$x]) {
750 :     if ($refs->[$y]->[$x]) {$refs->[$y]->[$x] .= " rowspan=". ($rowspan->[$y]->[$x]+1)}
751 :     else {$refs->[$y]->[$x] = "td rowspan=". ($rowspan->[$y]->[$x]+1)}
752 :     $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
753 :     }
754 :     elsif ($newtable->[$y]->[$x] && $refs->[$y]->[$x]) {
755 :     $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
756 :     }
757 :     }
758 :     }
759 : parrello 1.119
760 :    
761 : redwards 1.47 # finally we have to remove any completely empty cells that have been added by the array mechanism
762 :     # (e.g. if you define $a->[2] then $a->[0] and $a->[1] are now undef).
763 :     # that is why in the loop above I replace empty cells with nbsp. They are now not undef!
764 :     # I am sure that Gary can do this in one line, but I am hacking.
765 :     my @trimmed;
766 :     foreach my $a (@$newtable) {
767 :     my @row;
768 :     foreach my $b (@$a) {
769 :     push @row, $b if ($b);
770 :     }
771 :     push @trimmed, \@row;
772 :     }
773 : parrello 1.119
774 : redwards 1.47 return \@trimmed;
775 :     }
776 :    
777 :    
778 : parrello 1.119
779 : redwards 1.47
780 : overbeek 1.11 sub set_ec_links {
781 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
782 : overbeek 1.11 my($cgi,$x) = @_;
783 :     my($before,$match,$after);
784 :    
785 :     if ($x =~ /^(.*)(EC \d+\.\d+\.\d+\.\d+)(.*)/s)
786 :     {
787 : parrello 1.49 $before = $1;
788 :     $match = $2;
789 :     $after = $3;
790 :     return &set_ec_links($cgi,$before) . &HTML::ec_link($match) . &set_ec_links($cgi,$after);
791 : overbeek 1.11 }
792 :     return $x;
793 :     }
794 :    
795 : efrank 1.1 sub ec_link {
796 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
797 : efrank 1.1 my($role) = @_;
798 :    
799 :     if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)
800 :     {
801 : parrello 1.49 return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?ec:$1\">$role</a>";
802 : efrank 1.1 }
803 :     else
804 :     {
805 : parrello 1.49 return $role;
806 : efrank 1.1 }
807 :     }
808 :    
809 :     sub role_link {
810 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
811 : efrank 1.1 my($cgi,$role) = @_;
812 :    
813 :     my $roleR = ($role =~ /^(\d+\.\d+\.\d+\.\d+)\s+-\s+/) ? $1 : $role;
814 :     my $user = $cgi->param('user');
815 :     if (! $user) { $user = "" }
816 :     my $link = $cgi->url() . "?role=$roleR&user=$user";
817 :     $link =~ s/[a-z]+\.cgi\?/pom.cgi?/;
818 :     return "<a href=$link>$role</a>";
819 :     }
820 :    
821 : redwards 1.102 =head2 fid_link
822 :    
823 :     Get a link to a fid.
824 :    
825 :     use: my $html=&HTML::fid_link($cgi, $fid, Local, Just_URL, Full_Path);
826 :    
827 :     Local is a boolean means to eliminate the fig|org.peg from the text of the link.
828 :    
829 :     Just_URL will only return the URL and not the HTML code. The default is to return the full code.
830 :    
831 :     Full_Path is a boolean that will get the full path to the URL not just a relative path. This is required in pages where the base href changes (e.g. if an image is imported like on the metabolic pages).
832 :    
833 :     =cut
834 :    
835 :    
836 : efrank 1.1 sub fid_link {
837 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
838 : redwards 1.102 my($cgi,$fid,$local,$just_url,$fullpath) = @_;
839 : parrello 1.105 Trace("Creating link for feature $fid.") if T(4);
840 : redwards 1.102 my $err=join(" ", $cgi,$fid,$local,$just_url,$fullpath);
841 : parrello 1.123 if (FIGRules::nmpdr_mode($cgi)) {
842 :     # We're NMPDR. Compute the link to the seed viewer feature page.
843 :     my $link = "seedviewer.cgi?page=Annotation;feature=$fid";
844 :     if ($fullpath) {
845 :     # Full-path mode: add the base URL.
846 :     $link = "$FIG_Config::cgi_url/$link";
847 :     }
848 :     if ($just_url) {
849 :     # URL-only mode: return the link.
850 :     return $link;
851 :     } else {
852 :     # HTML mode. We need to compute the link text.
853 :     my $text = $fid;
854 :     # If we're in local mode, we remove everything but the final number from the fig ID.
855 :     if ($local) {
856 :     $fid =~ s/^.+\.//;
857 :     }
858 :     # Return the full HTML for the link.
859 :     return "<a href=\"$link\">$text</a>";
860 :     }
861 :     }
862 : efrank 1.1 my($n);
863 :    
864 : overbeek 1.68 my $top = top_link();
865 : redwards 1.102 if ($fullpath) {$top=$FIG_Config::cgi_url}
866 :    
867 : mkubal 1.113 if ($fid =~ /^fig\|\d+\.\d+\.([a-zA-Z]+)\.(\d+)/)
868 : efrank 1.1 {
869 : parrello 1.49 if ($local)
870 :     {
871 :     if ($1 eq "peg")
872 :     {
873 :     $n = $2;
874 :     }
875 :     else
876 :     {
877 :     $n = "$1.$2";
878 :     }
879 :     }
880 :     else
881 :     {
882 :     $n = $fid;
883 :     }
884 : overbeek 1.60
885 : parrello 1.123 my $link;
886 :     my $new_framework = $cgi->param('new_framework') ? 1 : 0;
887 : mkubal 1.57 #added to format prophage and path island links to feature.cgi
888 : parrello 1.98 my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
889 : parrello 1.123 my $virt = "&48hr_job=" . $cgi->param("48hr_job");
890 : parrello 1.105 Trace("Sprout mode is \"$sprout\".") if T(4);
891 : parrello 1.123 if ($1 ne "peg" && ! $sprout)
892 :     {
893 : parrello 1.105 Trace("Creating feature link for $fid.") if T(4);
894 : mkubal 1.57 my $user = $cgi->param('user');
895 : parrello 1.123 if (! $user) { $user = "" }
896 :     $link = "$top/feature.cgi?feature=$fid&user=$user$sprout$virt";
897 :     $link =~ s/[a-z_A-Z0-9]+\.cgi\?/feature.cgi?/;
898 : mkubal 1.57 }
899 : parrello 1.123 else
900 : mkubal 1.57 {
901 : parrello 1.105 Trace("Creating protein link for $fid.") if T(4);
902 : parrello 1.123 my $user = $cgi->param('user');
903 :     if (! $user) { $user = "" }
904 :     my $trans = $cgi->param('translate') ? "&translate=1" : "";
905 :     my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
906 : overbeek 1.56 ###a
907 :    
908 :     ### This used to be
909 :     ### my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
910 :     ###
911 :     ### The cost became prohibitive in the subsystem spreadsheets. Hence, we cache the value
912 :     ###
913 :     ### RAO
914 :    
915 : parrello 1.123 #if (! $cgi_url) { $cgi_url = &FIG::cgi_url }
916 :     #$link = $cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
917 :     $link = "$top/protein.cgi?prot=$fid&user=$user$trans$sprout$virt\&new_framework=$new_framework";
918 :     $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
919 :     }
920 :     if ($just_url)
921 :     {
922 :     return $link;
923 :     }
924 :     else
925 :     {
926 :     return "<a href='$link'>$n</a>";
927 :     }
928 : efrank 1.1 }
929 :     return $fid;
930 :     }
931 :    
932 :     sub family_link {
933 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
934 : efrank 1.1 my($family,$user) = @_;
935 :    
936 :     return $family;
937 :     }
938 :    
939 : paczian 1.108 =head2 evidence_codes_explain
940 :    
941 :     Given an evidence code, returns a string that explains this eveidence code.
942 :    
943 :     =cut
944 :    
945 :     sub evidence_codes_explain {
946 :     my($ec)=@_;
947 :     return unless ($ec);
948 :    
949 :     $ec=uc($ec);
950 :     return "IDA: Inferred from Direct Assay" if ($ec =~ /IDA/);
951 :     return "IGI: Inferred from Genetic Interaction" if ($ec =~ /IGI/);
952 :     return "TAS: Traceable Author Statement" if ($ec =~ /TAS/);
953 :     return "ISU: in subsystem unique" if ($ec =~ /ISU/);
954 :     return "$ec: in subsystem duplicates" if ($ec =~ /IDU/);
955 :     return "$ec: in cluster with" if ($ec =~ /ICW/);
956 :     return "FF: in FIGfam" if ($ec =~ /FF/);
957 :     return "CWN: clustered with nonhypothetical" if ($ec =~ /CWN/);
958 :     return "CWH: clustered, but only with hypotheticals" if ($ec =~ /CWH/);
959 :     return "DLIT: literature references to this gene exist" if ($ec =~ /DLIT/);
960 :     return "ILIT: no references to this gene exist, but they do to other genes with the same functional role" if ($ec =~ /ILIT/);
961 : paczian 1.110 return "$ec: unknown!";
962 : paczian 1.108 }
963 : efrank 1.1
964 :     sub get_html {
965 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
966 : efrank 1.1 my( $url, $type, $kv_pairs) = @_;
967 :     my( $encoded, $ua, $args, @args, $out, @output, $x );
968 : parrello 1.119
969 : efrank 1.1 $ua = new LWP::UserAgent;
970 :     $ua->timeout( 900 );
971 :     if ($type =~/post/i)
972 :     {
973 : parrello 1.49 $args = [];
974 :     foreach $x (@$kv_pairs)
975 :     {
976 :     push(@$args, ( $x->[0], $x->[1]) );
977 :     }
978 :     my $request = POST $url, $args;
979 :     my $response = $ua->request($request);
980 :     $out = $response->content;
981 : efrank 1.1 }
982 : parrello 1.119
983 :     if ($type =~/get/i)
984 : efrank 1.1 {
985 : parrello 1.49 @args = ();
986 :     foreach $x (@$kv_pairs)
987 :     {
988 :     push( @args, "$x->[0]=" . uri_escape($x->[1]) );
989 :     }
990 : parrello 1.119
991 : parrello 1.49 if (@args > 0)
992 :     {
993 :     $url .= "?" . join("&",@args);
994 :     }
995 : parrello 1.100 my $request = new HTTP::Request('GET', $url);
996 : parrello 1.49 my $response = $ua->request($request);
997 :    
998 : parrello 1.119 if ($response->is_success)
999 : parrello 1.49 {
1000 :     $out = $response->content;
1001 : parrello 1.119 }
1002 :     else
1003 : parrello 1.49 {
1004 :     $out = "<H1>Error: " . $response->code . "</H1>" . $response->message;
1005 :     }
1006 : efrank 1.1 }
1007 :     # set up a document with proper eol characters
1008 :     @output = split(/[\012\015]+/,$out);
1009 :     foreach $out (@output) { $out .= "\n"; }
1010 :    
1011 : parrello 1.119 # Now splice in a line of the form <base href=URL> to cause all relative links to work
1012 : efrank 1.1 # properly. Remove the header.
1013 : parrello 1.100 my $i;
1014 : efrank 1.1 for ($i=0; ($i < @output) && ($output[$i] !~ /^\s*\</); $i++) {}
1015 : parrello 1.100 if ($i < @output) {
1016 : parrello 1.49 splice(@output,0,$i);
1017 : efrank 1.1 }
1018 :    
1019 :     for ($i=0; ($i < @output) && ($output[$i] !~ /\<body\>/i); $i++) {}
1020 :     if ($i == @output)
1021 :     {
1022 : parrello 1.49 $i = -1;
1023 : efrank 1.1 }
1024 :     splice(@output,$i+1,0,"<base href=\"$url\">\n");
1025 :     return @output;
1026 :     }
1027 :    
1028 :     sub trim_output {
1029 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1030 : efrank 1.1 my($out) = @_;
1031 : parrello 1.100 my ($i, $j);
1032 : efrank 1.1
1033 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /^\</); $i++) {}
1034 :     splice(@$out,0,$i);
1035 :    
1036 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<body\>/i); $i++) {}
1037 :     if ($i == @$out)
1038 :     {
1039 : parrello 1.49 for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<html\>/i); $i++) {}
1040 :     if ($i == @$out)
1041 :     {
1042 :     $i = -1;
1043 :     }
1044 : efrank 1.1 }
1045 :     for ($j=$i+1; ($j < @$out) && ($out->[$j] !~ /^\<hr\>$/); $j++) {}
1046 :     if ($j < @$out)
1047 :     {
1048 : parrello 1.49 splice(@$out,$i+1,($j-$i));
1049 : efrank 1.1 }
1050 :    
1051 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<\/body\>/i); $i++) {}
1052 :     if ($i == @$out)
1053 :     {
1054 : parrello 1.49 for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<\/html\>/i); $i++) {}
1055 : efrank 1.1 }
1056 :    
1057 :     for ($j=$i-1; ($j > 0) && ($out->[$j] !~ /FIG search/); $j--) {}
1058 :     if ($j > 0)
1059 :     {
1060 : parrello 1.123 #
1061 :     # Hm. We would have tried using the options here:
1062 :     # my $tail_name = $options{tail_name} ? $options{tail_name} : "html.tail";
1063 :     # but they're not passed in. So use the default html.tail.
1064 :     #
1065 :     my $html_tail_file = "./Html/html.tail";
1066 : olson 1.101 my @tmp = `cat $html_tail_file`;
1067 :     my $n = @tmp;
1068 :     splice(@$out,$j-$n,$n+1);
1069 : efrank 1.1 }
1070 :     }
1071 :    
1072 : paczian 1.120 =head2 alias_url
1073 :    
1074 :     Returns the url that links to an external page showing information about the given alias.
1075 :     The type of the alias will be determined by the prefix (i.e. 'tr|' for Trembl) If the type
1076 :     cannot be determined, the function will return undef.
1077 :    
1078 :     use: my $html=&HTML::alias_url($alias, $type);
1079 :    
1080 :     =cut
1081 :    
1082 :     sub alias_url {
1083 :     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1084 :    
1085 :     my ($id, $type) = @_;
1086 :    
1087 :     if ($type eq "SEED") { # 1
1088 :     return "http://seed-viewer.theseed.org/linkin.cgi?id=$id";
1089 :     }
1090 : paczian 1.121 elsif ($type eq "UniProt") {
1091 :     return "http://www.uniprot.org/entry/$id";
1092 :     }
1093 : paczian 1.120 elsif ($type eq "UniProt_ac") { # 2
1094 :     return "http://www.uniprot.org/entry/$id";
1095 :     }
1096 :     elsif ($type eq "UniProt_id") { # 3
1097 :     return "http://www.uniprot.org/entry/$id";
1098 :     }
1099 :     elsif ($type eq "EntrezGene") { # 4
1100 :     return "http://www.ncbi.nlm.nih.gov/entrez/viewer.fcgi?db=protein&id=$id";
1101 :     }
1102 :     elsif ($type eq "RefSeq") { # 5
1103 :     return "http://www.ncbi.nlm.nih.gov/entrez/viewer.fcgi?db=protein&id=$id";
1104 :     }
1105 :     elsif ($type eq "GIID") { # 6
1106 :     return "http://www.ncbi.nlm.nih.gov/entrez/viewer.fcgi?db=protein&id=$id";
1107 :     }
1108 : paczian 1.121 elsif ($type eq "NCBI") {
1109 :     return "http://www.ncbi.nlm.nih.gov/entrez/viewer.fcgi?db=protein&id=$id";
1110 :     }
1111 : paczian 1.120 elsif ($type eq "PDB") { # 7
1112 :     $id =~ s/\:\w//;
1113 :     return "http://www.rcsb.org/pdb/explore/explore.do?structureId=$id";
1114 :     }
1115 :     elsif ($type eq "PFAM") { # 8
1116 :     return "http://pfam.janelia.org/family?acc=$id";
1117 :     }
1118 :     elsif ($type eq "GO") { # 9
1119 :     return "http://amigo.geneontology.org/cgi-bin/amigo/go.cgi?view=details&search_constraint=terms&depth=0&query=$id";
1120 :     }
1121 :     elsif ($type eq "PIRSF") { # 10
1122 :     return "http://pir.georgetown.edu/cgi-bin/ipcSF?id=$id";
1123 :     }
1124 :     elsif ($type eq "IPI") { # 11
1125 :     return "http://srs.ebi.ac.uk/srsbin/cgi-bin/wgetz?-newId+[IPI-AllText:".$id."*]+-lv+30+-view+SeqSimpleView+-page+qResult";
1126 :     }
1127 :     elsif ($type eq "UniRef_100") { # 12
1128 :     return "http://www.uniprot.org/entry/$id";
1129 :     }
1130 :     elsif ($type eq "UniRef_90") { # 13
1131 :     return "http://www.uniprot.org/entry/$id";
1132 :     }
1133 :     elsif ($type eq "UniRef_50") { # 14
1134 :     return "http://www.uniprot.org/entry/$id";
1135 :     }
1136 :     elsif ($type eq "UniParc") { # 15
1137 :     return "http://www.uniprot.org/entry/$id";
1138 :     }
1139 :     elsif ($type eq "PIR-PSD") { # 16
1140 :     return "http://pir.georgetown.edu/cgi-bin/pir_psd_get.pl?id=$id";
1141 :     }
1142 :     elsif ($type eq "Taxon_ID") { # 17
1143 :     return "http://www.ncbi.nlm.nih.gov/Taxonomy/Browser/wwwtax.cgi?id=$id";
1144 :     }
1145 :     elsif ($type eq "OMIM") { # 18
1146 :     return "http://www.ncbi.nlm.nih.gov/entrez/dispomim.cgi?id=$id";
1147 :     }
1148 :     elsif ($type eq "UniGene") { # 19
1149 :     return "http://www.ncbi.nlm.nih.gov/sites/entrez?db=unigene&cmd=search&term=$id";
1150 :     }
1151 :     elsif ($type eq "Ensemble_ID") { # 20
1152 :     #return "$id";
1153 :     }
1154 :     elsif ($type eq "PMID") { # 21
1155 :     return "http://www.ncbi.nlm.nih.gov/pubmed/$id";
1156 :     }
1157 :     elsif ($type eq "EMBL_DNA_AC") { # 22
1158 :     return "http://srs.ebi.ac.uk/srsbin/cgi-bin/wgetz?-e+[EMBL:".$id."]+-newId";
1159 :     }
1160 :     elsif ($type eq "EMBL_Protein_AC") { # 23
1161 :     $id =~ s/\.\d//;
1162 :     return "http://srs.ebi.ac.uk/srsbin/cgi-bin/wgetz?-e+[{EMBL}-ProteinID:".$id."]";
1163 :     }
1164 : paczian 1.121 elsif ($type eq "CMR") { # 24
1165 : paczian 1.122 if ($id =~ /^\d+$/) {
1166 : paczian 1.121 return "http://cmr.jcvi.org/cgi-bin/CMR/shared/GenePage.cgi?type=PID&acc=".$id;
1167 :     } else {
1168 :     return "http://cmr.jcvi.org/tigr-scripts/CMR/shared/GenePage.cgi?locus=".$id;
1169 :     }
1170 :     }
1171 : paczian 1.120
1172 :     return undef;
1173 :     }
1174 :    
1175 : efrank 1.1 sub set_prot_links {
1176 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1177 : efrank 1.1 my($cgi,$x) = @_;
1178 :     my($before,$match,$after);
1179 :    
1180 : overbeek 1.11 if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)/s)
1181 : efrank 1.1 {
1182 : parrello 1.49 $before = $1;
1183 :     $match = $2;
1184 :     $after = $3;
1185 :     return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after);
1186 : efrank 1.1 }
1187 : efrank 1.69 elsif ($x =~ /^(.*)\b([NXYZA][PM]_[0-9\.]+)\b(.*)/s)
1188 : overbeek 1.19 {
1189 : parrello 1.49 $before = $1;
1190 :     $match = $2;
1191 :     $after = $3;
1192 :     return &set_prot_links($cgi,$before) . &HTML::refseq_link($cgi,$match) . &set_prot_links($cgi,$after);
1193 : overbeek 1.19 }
1194 : overbeek 1.11 elsif ($x =~ /^(.*)(gi\|\d+)(.*)/s)
1195 : efrank 1.1 {
1196 : parrello 1.49 $before = $1;
1197 :     $match = $2;
1198 :     $after = $3;
1199 :     return &set_prot_links($cgi,$before) . &HTML::gi_link($cgi,$match) . &set_prot_links($cgi,$after);
1200 : efrank 1.1 }
1201 : olson 1.112 elsif ($x =~ /^(.*)(img\|\d+)(.*)/s)
1202 :     {
1203 :     $before = $1;
1204 :     $match = $2;
1205 :     $after = $3;
1206 :     return &set_prot_links($cgi,$before) . &HTML::img_link($cgi,$match) . &set_prot_links($cgi,$after);
1207 :     }
1208 : overbeek 1.87 elsif ($x =~ /^(.*)(tigr\|\w+)(.*)/s)
1209 : overbeek 1.44 {
1210 : parrello 1.49 $before = $1;
1211 :     $match = $2;
1212 :     $after = $3;
1213 :     return &set_prot_links($cgi,$before) . &HTML::tigr_link($cgi,$match) . &set_prot_links($cgi,$after);
1214 : overbeek 1.44 }
1215 : olson 1.116 elsif ($x =~ /^(.*)(tigrcmr\|\w+)(.*)/s)
1216 :     {
1217 :     $before = $1;
1218 :     $match = $2;
1219 :     $after = $3;
1220 :     return &set_prot_links($cgi,$before) . &HTML::tigr_link($cgi,$match) . &set_prot_links($cgi,$after);
1221 :     }
1222 : overbeek 1.84 elsif ($x =~ /^(.*)\b(eric\|\S+)\b(.*)/s)
1223 : overbeek 1.80 {
1224 :     $before = $1;
1225 :     $match = $2;
1226 :     $after = $3;
1227 :     return &set_prot_links($cgi,$before) . &HTML::eric_link($cgi,$match) . &set_prot_links($cgi,$after);
1228 :     }
1229 :    
1230 : overbeek 1.93 elsif ($x =~ /^(.*)\b(bhb\|.*?)\b(.*)/s)
1231 : overbeek 1.80 {
1232 :     $before = $1;
1233 :     $match = $2;
1234 :     $after = $3;
1235 :     return &set_prot_links($cgi,$before) . &HTML::bhb_link($cgi,$match) . &set_prot_links($cgi,$after);
1236 :     }
1237 :    
1238 : overbeek 1.93 elsif ($x =~ /^(.*)\b(apidb\|[0-9\.a-z_]+)\b(.*)/s)
1239 : overbeek 1.80 {
1240 :     $before = $1;
1241 :     $match = $2;
1242 :     $after = $3;
1243 :     return &set_prot_links($cgi,$before) . &HTML::apidb_link($cgi,$match) . &set_prot_links($cgi,$after);
1244 :     }
1245 :    
1246 : overbeek 1.93 elsif ($x =~ /^(.*)\b(patric\|.*?)\b(.*)/s)
1247 : overbeek 1.80 {
1248 :     $before = $1;
1249 :     $match = $2;
1250 :     $after = $3;
1251 :     return &set_prot_links($cgi,$before) . &HTML::patric_link($cgi,$match) . &set_prot_links($cgi,$after);
1252 :     }
1253 :    
1254 : overbeek 1.93 elsif ($x =~ /^(.*)\b(vbrc\|.*?)\b(.*)/s)
1255 : overbeek 1.80 {
1256 :     $before = $1;
1257 :     $match = $2;
1258 :     $after = $3;
1259 :     return &set_prot_links($cgi,$before) . &HTML::vbrc_link($cgi,$match) . &set_prot_links($cgi,$after);
1260 :     }
1261 :    
1262 : overbeek 1.93 elsif ($x =~ /^(.*)\b(vectorbase\|.*?)\b(.*)/s)
1263 : overbeek 1.80 {
1264 :     $before = $1;
1265 :     $match = $2;
1266 :     $after = $3;
1267 :     return &set_prot_links($cgi,$before) . &HTML::vectorbase_link($cgi,$match) . &set_prot_links($cgi,$after);
1268 : parrello 1.119 }
1269 : overbeek 1.14 elsif ($x =~ /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
1270 :     {
1271 : parrello 1.49 $before = $1;
1272 :     $match = $2;
1273 :     $after = $3;
1274 :     return &set_prot_links($cgi,$before) . &HTML::uni_link($cgi,$match) . &set_prot_links($cgi,$after);
1275 : overbeek 1.14 }
1276 : overbeek 1.11 elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)/s)
1277 : efrank 1.1 {
1278 : parrello 1.49 $before = $1;
1279 :     $match = $2;
1280 :     $after = $3;
1281 :     return &set_prot_links($cgi,$before) . &HTML::sp_link($cgi,$match) . &set_prot_links($cgi,$after);
1282 : efrank 1.1 }
1283 : overbeek 1.11 elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)/s)
1284 : efrank 1.1 {
1285 : parrello 1.49 $before = $1;
1286 :     $match = $2;
1287 :     $after = $3;
1288 :     return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after);
1289 : efrank 1.1 }
1290 : overbeek 1.12 elsif ($x =~ /^(.*)(kegg\|[a-z]{2,4}:[a-zA-Z_0-9]+)(.*)/s)
1291 :     {
1292 : parrello 1.49 $before = $1;
1293 :     $match = $2;
1294 :     $after = $3;
1295 :     return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after);
1296 : overbeek 1.12 }
1297 : efrank 1.69 elsif ($x =~ /^(.*)(Ensembl[a-zA-Z]+:[a-zA-Z_0-9\.]+)(.*)/s)
1298 :     {
1299 :     $before = $1;
1300 :     $match = $2;
1301 :     $after = $3;
1302 :     return &set_prot_links($cgi,$before) . &HTML::ensembl_link($cgi,$match) . &set_prot_links($cgi,$after);
1303 :     }
1304 :     elsif ($x =~ /^(.*)(EntrezGene:[a-zA-Z_0-9\.]+)(.*)/s)
1305 :     {
1306 :     $before = $1;
1307 :     $match = $2;
1308 :     $after = $3;
1309 :     return &set_prot_links($cgi,$before) . &HTML::entrezgene_link($cgi,$match) . &set_prot_links($cgi,$after);
1310 :     }
1311 :     elsif ($x =~ /^(.*)(MIM:[a-zA-Z_0-9\.]+)(.*)/s)
1312 :     {
1313 :     $before = $1;
1314 :     $match = $2;
1315 :     $after = $3;
1316 :     return &set_prot_links($cgi,$before) . &HTML::mim_link($cgi,$match) . &set_prot_links($cgi,$after);
1317 :     }
1318 : efrank 1.89 elsif ($x =~ /^(.*)(HGNC:[a-zA-Z_0-9\.]+)(.*)/s)
1319 : efrank 1.69 {
1320 :     $before = $1;
1321 :     $match = $2;
1322 :     $after = $3;
1323 : efrank 1.89 return &set_prot_links($cgi,$before) . &HTML::hgnc_link($cgi,$match) . &set_prot_links($cgi,$after);
1324 : efrank 1.69 }
1325 : efrank 1.89 elsif ($x =~ /^(.*)(UniGene:[a-zA-Z_0-9\.]+)(.*)/s)
1326 : efrank 1.69 {
1327 :     $before = $1;
1328 :     $match = $2;
1329 :     $after = $3;
1330 : efrank 1.89 return &set_prot_links($cgi,$before) . &HTML::unigene_link($cgi,$match) . &set_prot_links($cgi,$after);
1331 : efrank 1.69 }
1332 : efrank 1.89 # IPI stopped working. turn off for now.
1333 :     # elsif ($x =~ /^(.*)(IPI:[a-zA-Z_0-9\.]+)(.*)/s)
1334 :     # {
1335 :     # $before = $1;
1336 :     # $match = $2;
1337 :     # $after = $3;
1338 :     # return &set_prot_links($cgi,$before) . &HTML::ipi_link($cgi,$match) . &set_prot_links($cgi,$after);
1339 :     # }
1340 : efrank 1.69 elsif ($x =~ /^(.*)(WP:[a-zA-Z_0-9\.]+)(.*)/s)
1341 :     {
1342 : parrello 1.123 #wormbase
1343 : efrank 1.69
1344 :     $before = $1;
1345 :     $match = $2;
1346 :     $after = $3;
1347 :     return &set_prot_links($cgi,$before) . &HTML::wp_link($cgi,$match) . &set_prot_links($cgi,$after);
1348 :     }
1349 :     elsif ($x =~ /^(.*)(FB:[a-zA-Z_0-9\.]+)(.*)/s)
1350 :     {
1351 : parrello 1.123 #flybase
1352 : efrank 1.69
1353 :     $before = $1;
1354 :     $match = $2;
1355 :     $after = $3;
1356 :     return &set_prot_links($cgi,$before) . &HTML::fb_link($cgi,$match) . &set_prot_links($cgi,$after);
1357 :     }
1358 :     elsif ($x =~ /^(.*)(FlyBaseORFNames:[a-zA-Z_0-9\.]+)(.*)/s)
1359 :     {
1360 : parrello 1.123 #flybase
1361 : efrank 1.69
1362 :     $before = $1;
1363 :     $match = $2;
1364 :     $after = $3;
1365 :     return &set_prot_links($cgi,$before) . &HTML::fborf_link($cgi,$match) . &set_prot_links($cgi,$after);
1366 :     }
1367 :     elsif ($x =~ /^(.*)(SGD_LOCUS:[a-zA-Z_0-9\.]+)(.*)/s)
1368 :     {
1369 : parrello 1.123 #flybase
1370 : efrank 1.69
1371 :     $before = $1;
1372 :     $match = $2;
1373 :     $after = $3;
1374 :     return &set_prot_links($cgi,$before) . &HTML::sgd_link($cgi,$match) . &set_prot_links($cgi,$after);
1375 :     }
1376 : paczian 1.96 elsif ($x =~ /^(.*)(tr\|[a-zA-Z0-9]+)(.*)/s)
1377 :     {
1378 :    
1379 :     $before = $1;
1380 :     $match = $2;
1381 :     $after = $3;
1382 : parrello 1.119
1383 : paczian 1.96 return &set_prot_links($cgi,$before) . &HTML::trembl_link($cgi,$match) . &set_prot_links($cgi,$after);
1384 :     }
1385 : efrank 1.1 return $x;
1386 :     }
1387 :    
1388 : paczian 1.96 sub trembl_link {
1389 :     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1390 :     my($cgi,$id) = @_;
1391 :    
1392 :     if ($id =~ /^tr\|(.*)/) {
1393 : paczian 1.97 return "<a href='http://ca.expasy.org/uniprot/$1' target=_blank>$id</a>";
1394 : paczian 1.96 } else {
1395 :     return "invalid call to trembl link";
1396 :     }
1397 :     }
1398 :    
1399 : overbeek 1.19 sub refseq_link {
1400 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1401 : overbeek 1.19 my($cgi,$id) = @_;
1402 :    
1403 :     if ($id =~ /^[NXYZA]P_/)
1404 :     {
1405 : paczian 1.97 return "<a href='http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id' target=_blank>$id</a>";
1406 : parrello 1.119 }
1407 : efrank 1.69 elsif ($id =~ /^[NXYZA]M_/)
1408 :     {
1409 : paczian 1.97 return "<a href='http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=nuccore&cmd=search&term=$id' target=_blank>$id</a>";
1410 : overbeek 1.19 }
1411 :     }
1412 :    
1413 : efrank 1.1 sub gi_link {
1414 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1415 : efrank 1.1 my($cgi,$gi) = @_;
1416 :    
1417 :     if ($gi =~ /^gi\|(\d+)$/)
1418 :     {
1419 : paczian 1.97 return "<a href='http://www.ncbi.nlm.nih.gov:80/entrez/query.fcgi?cmd=Retrieve&db=Protein&list_uids=$1&dopt=GenPept' target=_blank>$gi</a>";
1420 : efrank 1.1 }
1421 :     return $gi;
1422 :     }
1423 :    
1424 : overbeek 1.44 sub tigr_link {
1425 :     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1426 :     my($cgi,$tigr) = @_;
1427 :    
1428 : overbeek 1.82 if ($tigr =~ /^tigr\|(NT|ntbp|ntbpA|BA|BMAA|BXB|GBA)(\w+)$/)
1429 : overbeek 1.44 {
1430 : overbeek 1.81 my $id=$1.$2;
1431 : paczian 1.97 return "<a href=\"http://pathema.tigr.org/tigr-scripts/pathema/shared/GenePage.cgi?locus=$id\" target=_blank>$tigr</a> (Pathema)";
1432 : overbeek 1.81 }
1433 : parrello 1.119 elsif ($tigr =~ /^tigr(cmr)?\|(\S+)$/)
1434 : overbeek 1.81 {
1435 : olson 1.116 return "<a href=\"http://www.tigr.org/tigr-scripts/CMR2/GenePage.spl?locus=$2\" target=_blank>$tigr</a>";
1436 : overbeek 1.44 }
1437 :     return $tigr;
1438 :     }
1439 :    
1440 : overbeek 1.80 sub eric_link {
1441 :     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1442 :     my($cgi,$eric) = @_;
1443 :    
1444 : overbeek 1.83 if ($eric =~ /^eric\|(\S+)/)
1445 : overbeek 1.80 {
1446 : paczian 1.97 return "<a href=\"https://asap.ahabs.wisc.edu/asap/feature_info.php?FeatureID=$1\" target=_blank>$eric</a>";
1447 : overbeek 1.80 }
1448 :     return $eric;
1449 :     }
1450 :    
1451 :     sub bhb_link {
1452 :     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1453 :     my($cgi,$bhb) = @_;
1454 :    
1455 : paczian 1.97 return "<a href=\"http://www.biohealthbase.org\" target=_blank>$bhb</a>";
1456 : overbeek 1.80 }
1457 :    
1458 :     sub apidb_link {
1459 :     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1460 :     my($cgi,$api) = @_;
1461 :    
1462 :     if ($api =~ /apidb\|(.*?)\.(.*)$/)
1463 :     {
1464 : paczian 1.97 return "<a href=\"http://www.apidb.org/cgi-bin/redirect.cgi?taxon_id=$1&source_id=$2\" target=_blank>$api</a>";
1465 : overbeek 1.80 }
1466 :     return $api;
1467 :     }
1468 :    
1469 :     sub patric_link {
1470 :     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1471 :     my($cgi,$patric) = @_;
1472 : parrello 1.119
1473 : overbeek 1.80 if ($patric =~ /patric\|(.*)/)
1474 :     {
1475 : paczian 1.97 return "<a href=\"https://patric.vbi.vt.edu/software/curationTool/gep/pgiCuration.php?locus_name=$1\" target=_blank>$patric</a>";
1476 : overbeek 1.80 }
1477 :     return $patric;
1478 :     }
1479 : parrello 1.119
1480 : overbeek 1.80 sub vbrc_link {
1481 :     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1482 :     my($cgi,$vbrc) = @_;
1483 :    
1484 :     if ($vbrc =~ /vbrc\|(.*)/)
1485 :     {
1486 : paczian 1.97 return "<a href=\"http://www.biovirus.org/gene_detail.asp?name=$1\" target=_blank>$vbrc</a>";
1487 : overbeek 1.80 }
1488 :     return $vbrc;
1489 :     }
1490 :    
1491 :     sub vectorbase_link {
1492 :     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1493 :     my($cgi,$vec) = @_;
1494 : paczian 1.97 return "<a href=\"http://www.vectorbase.org\" target=_blank>$vec</a>";
1495 : overbeek 1.80 }
1496 :    
1497 :    
1498 : overbeek 1.14 sub uni_link {
1499 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1500 : overbeek 1.14 my($cgi,$uni) = @_;
1501 :    
1502 :     if ($uni =~ /^uni\|(\S+)$/)
1503 :     {
1504 : overbeek 1.91 #return "<a href=http://www.pir.uniprot.org/cgi-bin/upEntry?id=$1>$uni</a>";
1505 : paczian 1.97 return "<a href='http://www.ebi.uniprot.org/uniprot-srv/uniProtView.do?proteinAc=$1' target=_blank>$uni</a>";
1506 : overbeek 1.14 }
1507 :     return $uni;
1508 :     }
1509 :    
1510 : efrank 1.1 sub sp_link {
1511 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1512 : efrank 1.1 my($cgi,$sp) = @_;
1513 :    
1514 :     if ($sp =~ /^sp\|(\S+)$/)
1515 :     {
1516 : paczian 1.97 return "<a href='http://us.expasy.org/cgi-bin/get-sprot-entry?$1' target=_blank>$sp</a>";
1517 : efrank 1.1 }
1518 :     return $sp;
1519 :     }
1520 :    
1521 :     sub pir_link {
1522 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1523 : efrank 1.1 my($cgi,$pir) = @_;
1524 :    
1525 :     if ($pir =~ /^pirnr\|(NF\d+)$/)
1526 :     {
1527 : paczian 1.97 return "<a href='http://pir.georgetown.edu/cgi-bin/nfEntry.pl?id=$1' target=_blank>$pir</a>";
1528 : efrank 1.1 }
1529 :     return $pir;
1530 :     }
1531 :    
1532 : overbeek 1.12 sub kegg_link {
1533 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1534 : overbeek 1.12 my($cgi,$kegg) = @_;
1535 :    
1536 :     if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)
1537 :     {
1538 : paczian 1.97 return "<a href='http://www.genome.ad.jp/dbget-bin/www_bget?$1+$2' target=_blank>$kegg</a>";
1539 : overbeek 1.12 }
1540 :     return $kegg;
1541 :     }
1542 :    
1543 : olson 1.112 sub img_link {
1544 :     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1545 :     my($cgi,$img) = @_;
1546 :    
1547 :     if ($img =~ /^img\|(\S+)$/)
1548 :     {
1549 :     return "<a href='http://img.jgi.doe.gov/cgi-bin/pub/main.cgi?page=geneDetail&gene_oid=$1' target=_blank>$img</a>";
1550 :     }
1551 :     return $img;
1552 :     }
1553 :    
1554 : efrank 1.69 sub ensembl_link {
1555 :     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1556 :     my($cgi,$ensembl) = @_;
1557 :    
1558 :     if ($ensembl =~ /^(\S+):(\S+)$/)
1559 :     {
1560 : parrello 1.123 my $what=$1;
1561 :     my $key=$2;
1562 :     my $idx="All";
1563 :     if ($what eq "EnsemblGene") { $idx = "Gene" }
1564 :     if ($what eq "EnsemblTranscript") { $idx = "All" }
1565 :     if ($what eq "EnsemblProtein") { $idx = "All" }
1566 :    
1567 :     #I really want to get right to the transcript and peptide pages, but
1568 :     #can't see how to do that without knowing the org name too, which
1569 :     #I don't know at this point. (ensembl org name, not real org name)
1570 : efrank 1.69
1571 : paczian 1.97 return "<a href='http://www.ensembl.org/Homo_sapiens/searchview?species=all&idx=$idx&q=$key' target=_blank>$ensembl</a>";
1572 : efrank 1.69 }
1573 :     return $ensembl;
1574 :     }
1575 :    
1576 :     sub entrezgene_link {
1577 :     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1578 :     my($cgi,$entrezgene) = @_;
1579 :    
1580 :     if ($entrezgene =~ /^EntrezGene:(\S+)$/)
1581 :     {
1582 : paczian 1.97 return "<a href='http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=gene&cmd=Retrieve&dopt=full_report&list_uids=$1' target=_blank>$entrezgene</a>";
1583 : efrank 1.69 }
1584 :     return $entrezgene;
1585 :     }
1586 :    
1587 :     sub mim_link {
1588 :     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1589 :     my($cgi,$mim) = @_;
1590 :    
1591 :     if ($mim =~ /^MIM:(\S+)$/)
1592 :     {
1593 : paczian 1.97 return "<a href='http://www3.ncbi.nlm.nih.gov/entrez/dispomim.cgi?id=$1' target=_blank>$mim</a>";
1594 : efrank 1.69 }
1595 :     return $mim;
1596 :     }
1597 :    
1598 : efrank 1.89 sub hgnc_link {
1599 :     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1600 :     my($cgi,$hgnc) = @_;
1601 :    
1602 :     if ($hgnc =~ /^HGNC:(\S+)$/)
1603 :     {
1604 : paczian 1.97 return "<a href='http://www.gene.ucl.ac.uk/cgi-bin/nomenclature/searchgenes.pl?field=symbol&anchor=equals&match=$1&symbol_search=Search&number=50&format=html&sortby=symbol' target=_blank>$hgnc</a>";
1605 : efrank 1.89 }
1606 : olson 1.101
1607 : parrello 1.100 return $hgnc;
1608 : efrank 1.89 }
1609 :    
1610 : efrank 1.69 sub unigene_link {
1611 :     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1612 :     my($cgi,$unigene) = @_;
1613 :    
1614 :     if ($unigene =~ /^UniGene:(\S+)$/)
1615 :     {
1616 : paczian 1.97 return "<a href='http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=unigene&cmd=search&term=$1' target=_blank>$unigene</a>";
1617 : efrank 1.69 }
1618 :     return $unigene;
1619 :     }
1620 :    
1621 :     sub ipi_link {
1622 :     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1623 :     my($cgi,$ipi) = @_;
1624 :    
1625 :     if ($ipi =~ /^IPI:(\S+)$/)
1626 :     {
1627 : paczian 1.97 return "<a href='http://srs.ebi.ac.uk/srsbin/cgi-bin/wgetz?-id+AEoS1R8Jnn+-e+[IPI:\'$1\']+-qnum+1+-enum+1' target=_blank>$ipi</a>";
1628 : efrank 1.69 }
1629 :     return $ipi;
1630 :     }
1631 :    
1632 :     sub wp_link {
1633 :     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1634 :     my($cgi,$wp) = @_;
1635 :    
1636 :     #wormbase
1637 :    
1638 :     if ($wp =~ /^WP:(\S+)$/)
1639 :     {
1640 : paczian 1.97 return "<a href='http://www.wormbase.org/db/searches/basic?class=Any&query=$1&Search=Search' target=_blank>$wp</a>";
1641 : efrank 1.69 }
1642 :     return $wp;
1643 :     }
1644 :    
1645 :     sub fb_link {
1646 :     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1647 :     my($cgi,$fb) = @_;
1648 :    
1649 :     #flybase
1650 :    
1651 :     if ($fb =~ /^FB:(\S+)$/)
1652 :     {
1653 : paczian 1.97 return "<a href='http://flybase.bio.indiana.edu/.bin/fbidq.html?$1' target=_blank>$fb</a>";
1654 : efrank 1.69 }
1655 :     return $fb;
1656 :     }
1657 :    
1658 :     sub fborf_link {
1659 :     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1660 :     my($cgi,$fb) = @_;
1661 :    
1662 :     #flybase
1663 :    
1664 :     if ($fb =~ /^FlyBaseORFNames:(\S+)$/)
1665 :     {
1666 : paczian 1.97 return "<a href='http://flybase.bio.indiana.edu/.bin/fbidq.html?$1' target=_blank>$fb</a>";
1667 : efrank 1.69 }
1668 :     return $fb;
1669 :     }
1670 :    
1671 :     sub sgd_link {
1672 :     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1673 :     my($cgi,$sgd) = @_;
1674 :    
1675 :     #yeast
1676 :    
1677 :     if ($sgd =~ /^SGD_LOCUS:(\S+)$/)
1678 :     {
1679 : paczian 1.97 return "<a href='http://db.yeastgenome.org/cgi-bin/locus.pl?locus=$1' target=_blank>$sgd</a>";
1680 : efrank 1.69 }
1681 :     return $sgd;
1682 :     }
1683 :    
1684 : parrello 1.119
1685 : efrank 1.69
1686 :    
1687 : overbeek 1.11 sub set_map_links {
1688 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1689 : overbeek 1.11 my($cgi,$x) = @_;
1690 :     my($before,$match,$after);
1691 : efrank 1.1
1692 : overbeek 1.11 my $org = ($cgi->param('org') || $cgi->param('genome') || "");
1693 :    
1694 :     if ($x =~ /^(.*)(MAP\d+)(.*)/s)
1695 :     {
1696 : parrello 1.49 $before = $1;
1697 :     $match = $2;
1698 :     $after = $3;
1699 :     return &set_map_links($cgi,$before) . &map_link($cgi,$match,$org) . &set_map_links($cgi,$after);
1700 : overbeek 1.11 }
1701 :     return $x;
1702 :     }
1703 :    
1704 : efrank 1.69
1705 :    
1706 : overbeek 1.11 sub map_link {
1707 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1708 : overbeek 1.11 my($cgi,$map,$org) = @_;
1709 :    
1710 : parrello 1.100 my $user = $cgi->param('user');
1711 : overbeek 1.11 $user = $user ? $user : "";
1712 :     $org = $org ? $org : "";
1713 : parrello 1.119
1714 : overbeek 1.64 my $url = "show_kegg_map.cgi?user=$user&map=$map&org=$org";
1715 :     #rel my $url = &FIG::cgi_url() . "/show_kegg_map.cgi?user=$user&map=$map&org=$org";
1716 : overbeek 1.11 my $link = "<a href=\"$url\">$map</a>";
1717 :     return $link;
1718 :     }
1719 : redwards 1.20
1720 :     sub java_buttons {
1721 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1722 : redwards 1.20 ## ADDED BY RAE
1723 :     # Provides code to include check all/first half/second half/none for javascrspt
1724 :     # this takes two variables - the form name provided in start_form with the
1725 :     # -name => field and the checkbox name
1726 :     my ($form, $button)=@_;
1727 :    
1728 : parrello 1.100 my $java_script="<input type=\"button\" name=\"CheckAll\" value=\"Check All\"\nonClick=\"checkAll(document.$form.$button)\">\n";
1729 : redwards 1.20 $java_script.="<input type=\"button\" name=\"CheckFirst\" value=\"Check First Half\"\nonClick=\"checkFirst(document.$form.$button)\">\n";
1730 :     $java_script.="<input type=\"button\" name=\"CheckSecond\" value=\"Check Second Half\"\nonClick=\"checkSecond(document.$form.$button)\">\n";
1731 :     $java_script.="<input type=\"button\" name=\"UnCheckAll\" value=\"Uncheck All\"\nonClick=\"uncheckAll(document.$form.$button)\">\n";
1732 : parrello 1.119
1733 : redwards 1.20 return $java_script;
1734 :     }
1735 :    
1736 : parrello 1.106 =head3 sub_link
1737 :    
1738 : parrello 1.119 my $htmlText = HTML::sub_link($cgi, $sub, gid);
1739 : parrello 1.106
1740 :     Create a subsystem link. The link will be to the display page if there is no
1741 :     user or we are in SPROUT mode; otherwise it will be to the edit page.
1742 :    
1743 :     =over 4
1744 :    
1745 :     =item cgi
1746 :    
1747 :     CGI query object for the current web session. The parameters of special interest
1748 :     are C<SPROUT> and C<user>. If the user is non-blank and SPROUT mode is 0, then
1749 :     the subsystem's edit page will be shown rather than its display page.
1750 :    
1751 :     =item sub
1752 :    
1753 :     Name of the desired subsystem. It will be cleaned of underscores before the
1754 :     hyperlink is applied.
1755 :    
1756 : parrello 1.115 =item gid
1757 :    
1758 :     Genome ID to be specified as the focus.
1759 :    
1760 : parrello 1.106 =back
1761 :    
1762 :     =cut
1763 :    
1764 : overbeek 1.22 sub sub_link {
1765 : parrello 1.106 # Allow call as an instance in addition to the authorized method.
1766 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1767 : parrello 1.106 # Get the parameters.
1768 : parrello 1.115 my ($cgi, $sub, $gid) = @_;
1769 : parrello 1.106 # Declare the return variable.
1770 :     my $retVal;
1771 :     # Clean the subsystem name for display purposes. This is a very
1772 :     # different thing from URL-escaping.
1773 : parrello 1.107 my $cleaned = CGI::escapeHTML($sub);
1774 : parrello 1.106 $cleaned =~ s/_/ /g;
1775 :     # URL-escape the subsystem name for use in the link.
1776 :     my $linkable = uri_escape($sub);
1777 :     # Determine the mode. Note we use the little OR trick to insure that
1778 :     # we have the correct value for plugging into the output link.
1779 :     my $user = $cgi->param('user') || "";
1780 :     my $sproutMode = $cgi->param('SPROUT') || 0;
1781 :     if ($user && ! $sproutMode) {
1782 :     # A SEED user is calling, so we go to the edit page.
1783 :     $retVal = "<a href=\"subsys.cgi?ssa_name=$linkable&request=show_ssa&user=$user\">$cleaned</a>";
1784 :     } else {
1785 :     # A visitor or SPROUT user is calling, so we go to the display page.
1786 : parrello 1.115 $retVal = "<a href=\"display_subsys.cgi?ssa_name=$linkable;request=show_ssa;sort=by_phylo;focus=$gid;SPROUT=$sproutMode\">$cleaned</a>";
1787 : overbeek 1.22 }
1788 : parrello 1.106 # Return the result.
1789 :     return $retVal;
1790 : overbeek 1.22 }
1791 :    
1792 : olson 1.114 sub reaction_map_link {
1793 :     my($mapID, @reaction_list) = @_;
1794 :     if($mapID =~ /\d+/)
1795 :     {
1796 : parrello 1.123 my $reactions = join "+", @reaction_list;
1797 :     if ($reactions ne "")
1798 :     {
1799 :     $reactions = "+".$reactions;
1800 :     }
1801 : olson 1.114
1802 : parrello 1.123 return "<a href=http://www.genome.jp/dbget-bin/show_pathway?rn$mapID$reactions>$mapID</a>";
1803 : olson 1.114 }
1804 :     else
1805 :     {
1806 : parrello 1.123 return $mapID;
1807 : olson 1.114 }
1808 :     }
1809 :    
1810 :     sub compound_link {
1811 :     my($compound) = @_;
1812 :     if($compound =~ /^C\d+/)
1813 :     {
1814 : parrello 1.123 return "<a href=\"javascript:void(0)\"onclick=\"window.open('http://www.genome.jp/dbget-bin/www_bget?compound+$compound','$&','height=640,width=800,scrollbars=yes,toolbar=yes,status=yes,resizable=yes')\">$compound</a>";
1815 : olson 1.114 }
1816 :     else
1817 :     {
1818 : parrello 1.123 return $compound;
1819 : olson 1.114 }
1820 :     }
1821 :    
1822 : parrello 1.106
1823 : overbeek 1.50 sub reaction_link {
1824 :     my($reaction) = @_;
1825 : mkubal 1.99 if ($reaction =~ /^(\*)?(R\d+)/)
1826 : overbeek 1.50 {
1827 : olson 1.114 # return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?rn+$2\" target=reaction$$>$reaction</a>";
1828 : parrello 1.123 return "<a href=\"javascript:void(0)\"onclick=\"window.open('http://www.genome.ad.jp/dbget-bin/www_bget?rn+$reaction','$&','height=640,width=800,scrollbars=yes,toolbar=yes,status=yes,resizable=yes')\">$reaction</a>";
1829 : overbeek 1.50 }
1830 :     return $reaction;
1831 :     }
1832 :    
1833 : mkubal 1.99
1834 : overbeek 1.53 sub html_for_assignments {
1835 :     my($fig,$user,$peg_sets) = @_;
1836 :     my $i;
1837 :    
1838 :     my @vals = ();
1839 :     my $set = 1;
1840 : parrello 1.100 foreach my $peg_set (@$peg_sets)
1841 : overbeek 1.53 {
1842 : parrello 1.123 for ($i=0; ($i < @$peg_set); $i++)
1843 :     {
1844 :     my $peg = $peg_set->[$i];
1845 :     push(@vals,'show=' . join("@",($set,$i+1,$peg,&FIG::abbrev($fig->org_of($peg)),"")));
1846 :     }
1847 :     $set++;
1848 : overbeek 1.53 }
1849 :    
1850 :     $ENV{'REQUEST_METHOD'} = 'GET';
1851 :     $ENV{'QUERY_STRING'} = join('&',('request=show_commentary',"uni=1","user=$user",@vals));
1852 :     my $out = join("",`$FIG_Config::fig/CGI/chromosomal_clusters.cgi`);
1853 :     $out =~ s/^.*?<form/<form/si;
1854 :     $out =~ s/^(.*)<table.*/$1/si;
1855 :     return $out;
1856 :     }
1857 :    
1858 : redwards 1.55 =head1 rss_feed
1859 :    
1860 :     Add something to the RSS feed. The rss feeds are stored in the Html directory, and there are several RSS feeds:
1861 : parrello 1.123 SEED.rss - everything gets written here
1862 :     SEEDgenomes.rss - whenever a genome is added to the SEED
1863 :     SEEDsubsystems.rss - whenever a subsystem is edited (or should this be added?)
1864 : redwards 1.55
1865 :    
1866 :     RSS feeds must contain a title, description, and link. The title is what is seen e.g. from the firefox or safari pull down menu. The description is seen from within an rss aggregator, and may be displayed on web pages and so on.
1867 :    
1868 :     The method takes a reference to an array containing the file names for the RSS feeds to add your item to, and a hash of items for the xml. Only title, description, and link are required tags in the XML.
1869 :    
1870 :     The file names are the full name of the file, eg SEEDsubsystems.rss, SEEDgenomes.rss. Be aware that this is a file name, though, so don't uses special characters. The path will be added.
1871 :    
1872 :     The has can have these keys:
1873 :    
1874 :     REQUIRED:
1875 :     title : the title. This is usually what is seen by the user in the pull down menu
1876 :     description : a more complete description that is often seen is rss viewers but not always
1877 :     link : link to the item that was added/edited
1878 : parrello 1.119 All other keys are treated as optional RSS arguments and written to the file.
1879 : redwards 1.65
1880 :     At most, $max_entries recent entries are stored in the rss file, and this is currently 50.
1881 : redwards 1.55
1882 :     RSS files are quite simple, and contain some standard header information, and then individual items surrounded by an <item> </item> tag. Note that there is also an initial title/description/link set that describes the file.
1883 :    
1884 :    
1885 :     =cut
1886 :    
1887 :     sub rss_feed {
1888 :     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1889 :     my ($files, $args)=@_;
1890 : redwards 1.65
1891 :     # how many entries to store in the file
1892 :     my $max_entries=50;
1893 : parrello 1.119
1894 : redwards 1.55 foreach my $a (keys %$args) {if ($a =~ /^-(.*)/) {my $b=$1; $args->{$b}=$args->{$a}; delete $args->{$a}}}
1895 :    
1896 :     my $filepath=$FIG_Config::fig."/CGI/Html/rss";
1897 :     # check for the directory and if not, make it
1898 :     mkdir $filepath unless (-d $filepath);
1899 :    
1900 :     # note that $info is a hash of references to hashes that are written out as headers in the file
1901 :     my $info=
1902 :     {
1903 :     "SEED.rss" =>
1904 :     {
1905 : parrello 1.123 title => "The SEED",
1906 :     description => "Latest news from the SEED",
1907 :     link => "Html/rss/SEED.rss",
1908 : redwards 1.55 },
1909 : parrello 1.119
1910 : redwards 1.55 "SEEDsubsystems.rss" =>
1911 :     {
1912 : parrello 1.123 title => "SEED Subsystems",
1913 :     description => "Recently updated SEED subsystems",
1914 :     link => "Html/rss/SEEDsubsystems.rss",
1915 : redwards 1.55 },
1916 : parrello 1.119
1917 : redwards 1.55 "SEEDsubsystems.rss" =>
1918 :     {
1919 : parrello 1.123 title => "SEED Genomes",
1920 :     description => "Genomes recently added to the SEED",
1921 :     link => &FIG::cgi_url()."/Html/rss/SEEDsubsystems.rss",
1922 : redwards 1.55 },
1923 :    
1924 :     };
1925 :    
1926 :    
1927 :     # build the new xml
1928 :     my $xml = "\t<item>\n";
1929 :     foreach my $qw ("title", "description", "link") {
1930 :     unless ($args->{$qw}) {
1931 :     print STDERR "You need to include a $qw tag in your RSS description\n";
1932 :     return(0);
1933 :     }
1934 :     # we need to do something a bit funky with the link. We can't have ampersands in the <link> </link> in valid html
1935 :     # so we are going to pull out the links and uri_escape just the part after the .cgi
1936 : parrello 1.119 if ($qw eq "link")
1937 : redwards 1.55 {
1938 :     $args->{$qw} =~ /^(.*?\.cgi.)(.*)$/;
1939 :     $args->{$qw} = $1.uri_escape($2) if ($1 && $2);
1940 :     }
1941 : parrello 1.119
1942 : redwards 1.55 $xml .= "\t\t<$qw>".$args->{$qw}."</$qw>\n";
1943 :     delete $args->{$qw};
1944 :     }
1945 :    
1946 : parrello 1.119 foreach my $tag (grep {!/type/i} keys %$args)
1947 : redwards 1.55 {
1948 :     $xml .= "\t\t<$tag>".$args->{$tag}."</$tag>\n";
1949 :     }
1950 : parrello 1.119
1951 : redwards 1.55 $xml .= "\t</item>\n";
1952 :    
1953 : parrello 1.119
1954 : redwards 1.55 my @files=("SEED.rss");
1955 : parrello 1.100 if ($args->{"type"}) {
1956 :     my $type = $args->{type};
1957 :     push @files, "SEED.$type.rss"
1958 :     }
1959 : parrello 1.119
1960 : redwards 1.55 foreach my $file ("SEED.rss", @$files)
1961 :     {
1962 : parrello 1.119 if (-e "$filepath/$file")
1963 : redwards 1.55 {
1964 :     my @out; # the new content of the file
1965 :     my $itemcount=0; # how many <item> </item>'s are we keeping
1966 :     my $initem; # are we in an item?
1967 :     open(IN, "$filepath/$file") || die "Can't open $filepath/$file";
1968 : parrello 1.119 while (<IN>)
1969 : redwards 1.55 {
1970 :     if (/\<item\>/) {
1971 :     push @out, $xml, unless ($itemcount);
1972 : parrello 1.119 $itemcount++;
1973 : redwards 1.55 $initem=1;
1974 :     }
1975 : redwards 1.65 if (/\<\/item\>/) {$initem=0; next if ($itemcount > $max_entries)}
1976 :     next if ($initem && $itemcount > $max_entries);
1977 : redwards 1.55 push @out, $_;
1978 :     }
1979 :     close IN;
1980 :     open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1981 :     print OUT @out;
1982 :     }
1983 :     else
1984 :     {
1985 :     open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1986 :     print OUT "<?xml version=\"1.0\"?>\n<rss version=\"2.0\">\n<channel>\n";
1987 :     if ($info->{$file})
1988 :     {
1989 :     # we're going to sanity check each of the three options we output, just to be sure
1990 :     foreach my $qw ("title", "description", "link")
1991 :     {
1992 :     if ($info->{$file}->{$qw})
1993 :     {
1994 :     print OUT "<$qw>", $info->{$file}->{$qw}, "</$qw>\n";
1995 :     } else {
1996 :     print STDERR "Please add a $qw for $file\n"; print OUT "<$qw>$file</$qw>\n";
1997 :     }
1998 :     }
1999 :     }
2000 :     else {
2001 :     print STDERR "Please define title, link, and description information for $file\n";
2002 :     print OUT "<title>$file</title>\n<description>An RSS feed</description>\n<link>", &FIG::cgi_url, "</link>\n";
2003 :     }
2004 :     print OUT "\n", $xml;
2005 :     print OUT "\n", "</channel>\n</rss>\n"
2006 :     }
2007 :     }
2008 :     }
2009 : redwards 1.61
2010 :    
2011 :    
2012 : redwards 1.55 1;
2013 :    

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3