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

Annotation of /FigKernelPackages/HTML.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.57 - (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 : redwards 1.55
282 : redwards 1.34 my $csstext = "<link rel='stylesheet' title='default' href='".$css->{'Default'}."' type='text/css'>\n";
283 :     $csstext .= "<link rel='alternate stylesheet' title='Sans Serif' href='".$css->{'Sans Serif'}."' type='text/css'>\n";
284 :    
285 :     foreach my $k (keys %$css)
286 :     {
287 :     next if (lc($k) eq "default" || lc($k) eq "sans serif");
288 : redwards 1.38 $csstext .= "<link rel='alternate stylesheet' title='$k' href='".$css->{$k}."' type='text/css'>\n";
289 :     }
290 :    
291 : redwards 1.55 $csstext .= "<link rel='alternate' title='SEED RSS feeds' href='".&FIG::cgi_url()."/Html/rss/SEED.rss' type='application/rss+xml'>\n";
292 : redwards 1.38
293 :     # RAE: also added support for external javascripts here.
294 :     # we are cluttering the HTML code with all the javascripts when they could easily be in external files
295 :     # this solution allows us to source other files
296 :    
297 : redwards 1.46 # the file FIG.js contains most of the java script we use routinely. Every browser will just cache this and so
298 :     # it will reduce our overhead.
299 :    
300 : redwards 1.38 # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts
301 : olson 1.51 push @$javasrc, &FIG::cgi_url() . "/Html/css/FIG.js";
302 : redwards 1.46 foreach my $script (@$javasrc) {
303 : parrello 1.49 $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";
304 : redwards 1.34 }
305 : redwards 1.38
306 :    
307 :    
308 : 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.
309 :    
310 : golsen 1.6 #
311 :     # <BASE ...> goes before </HEAD>
312 :     #
313 :    
314 :     if ( $base_line < 0 )
315 :     {
316 : parrello 1.49 #
317 :     # Use a relative base address for pages. Also, because I am
318 :     # worried about when FIG_config.pm gets updated (clean installs
319 :     # only, or every update?), I provide an alternative derivation
320 :     # from $cgi_url. -- GJO
321 :     #
322 :     # BASE href needs to be absolute. RDO.
323 :     #
324 :     #
325 :     $base_url = &FIG::cgi_url;
326 :     # my $base_url = $FIG_Config::cgi_base;
327 :     # if ( ! $base_url ) # if cgi_base was not defined
328 :     # {
329 :     # $base_url = $FIG_Config::cgi_url; # get the full cgi url
330 :     # $base_url =~ s~^http://[^/]*~~; # remove protocol and host
331 :     # $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash
332 :     # }
333 : golsen 1.6
334 : parrello 1.49 $base_line = $head_end_line;
335 :     splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );
336 : golsen 1.6 }
337 :    
338 :     #
339 :     # <HTML> goes at the top of the output
340 :     #
341 :    
342 :     if ( $html_line < 0 )
343 :     {
344 : parrello 1.49 $html_line = 0;
345 :     splice( @$html, $html_line, 0, "<HTML>\n" );
346 : golsen 1.6 }
347 :    
348 :     #
349 :     # <HEAD> goes after <HTML>
350 :     #
351 :    
352 :     if ( $head_line < 0 )
353 :     {
354 : parrello 1.49 $head_line = $html_line + 1;
355 :     splice( @$html, $head_line, 0, "<HEAD>\n" );
356 : golsen 1.6 }
357 :    
358 :     #
359 :     # Place FIG search link at bottom of page
360 :     #
361 :    
362 :     my @tail = -f $html_tail_file ? `cat $html_tail_file` : ();
363 : efrank 1.1 if (! $no_home)
364 :     {
365 : parrello 1.49 my $user = $cgi->param('user') || "";
366 :     push( @tail, "<hr><a href=\"index.cgi?user=$user\">FIG search</a>\n" );
367 : efrank 1.1 }
368 :    
369 : golsen 1.6 #
370 : olson 1.21 # See if we have a site-specific tail (for disclaimers, etc).
371 :     #
372 :    
373 :     my $site_tail = "$FIG_Config::fig_disk/config/site_tail.html";
374 :     my $site_fh;
375 :     if (open($site_fh, "<$site_tail"))
376 :     {
377 : parrello 1.49 push(@tail, <$site_fh>);
378 :     close($site_fh);
379 : olson 1.21 }
380 :    
381 :     #
382 : golsen 1.6 # Figure out where to insert The SEED tail. Before </body>,
383 :     # or before </html>, or at end of page.
384 :     #
385 :     my @tags = ();
386 : parrello 1.49 # Check for a tracing queue.
387 :     my $traceString = QTrace("HTML");
388 :     if ($traceString) {
389 :     push @tags, $traceString;
390 :     }
391 : golsen 1.6 for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}
392 :     if ($i >= @$html) # </body> not found; look for </html>
393 : efrank 1.1 {
394 : parrello 1.49 push @tags, "\n</BODY>\n";
395 :     # Even if tag is not found, index points to correct place for splice
396 :     for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/html\>/i); $i++) {}
397 :     if ($i >= @$html) # </html> not found; add it
398 :     {
399 :     push @tags, "</HTML>\n";
400 :     }
401 : efrank 1.1 }
402 : golsen 1.6
403 :     if ( @tail )
404 :     {
405 : parrello 1.49 splice( @$html, $i, 0, @tail, @tags );
406 : golsen 1.6 }
407 :     elsif ( @tags )
408 :     {
409 : parrello 1.49 splice( @$html, $i, 0, @tags );
410 : golsen 1.6 }
411 :    
412 : golsen 1.40 # RAE the chomp will return any new lines at the ends of elements in the array,
413 :     # and then we can join with a "\n". This is because somethings put newlines in,
414 :     # and others don't. This should make nicer looking html
415 :     #
416 :     # chomp(@$html);
417 :     # print join "\n", @$html;
418 :     #
419 :     # Apparently the above still breaks things. This is the correct code:
420 : redwards 1.37
421 : overbeek 1.43 foreach $_ (@$html)
422 :     {
423 : parrello 1.49 print $_;
424 : overbeek 1.43 }
425 : parrello 1.49
426 : efrank 1.1 }
427 :    
428 :     sub make_table {
429 : olson 1.17 my($col_hdrs,$tab,$title, %options ) = @_;
430 : efrank 1.1 my(@tab);
431 :    
432 : olson 1.17 my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";
433 :     push( @tab, "\n<table $border>\n",
434 : golsen 1.6 "\t<caption><b>$title</b></caption>\n",
435 : olson 1.27 "\t<tr>\n\t\t"
436 :     . join( "\n", map { &expand($_, "th") } @$col_hdrs )
437 :     . "\n\t</tr>\n"
438 : golsen 1.6 );
439 : overbeek 1.9 my($i);
440 : efrank 1.1
441 : overbeek 1.3 my $row;
442 :     foreach $row (@$tab)
443 : efrank 1.1 {
444 : parrello 1.49 push( @tab, "\t<tr>\n"
445 :     . join( "\n", map { &expand($_) } @$row )
446 :     . "\n\t</tr>\n"
447 :     );
448 : efrank 1.1 }
449 :     push(@tab,"</table>\n");
450 :     return join("",@tab);
451 :     }
452 :    
453 : overbeek 1.3 sub expand {
454 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
455 : golsen 1.40 my( $x, $tag ) = @_;
456 :    
457 : olson 1.27 $tag = "td" unless $tag;
458 : golsen 1.40 my $endtag = $tag;
459 :    
460 :     # RAE modified this so that you can pass in a reference to an array where
461 :     # the first element is the data to display and the second element is optional
462 :     # things like colspan and align. Note that in this case you need to include the td
463 : redwards 1.30 # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]
464 : overbeek 1.3
465 : redwards 1.47 # per GJO's request modified this line so it can take any tag.
466 :     if ( ref($x) eq "ARRAY" ) { ($x, $tag) = @$x; $tag =~ /^(\S+)/; $endtag = $1 }
467 : golsen 1.40
468 :     if ( $x =~ /^\@([^:]+)\:(.*)$/ )
469 : overbeek 1.3 {
470 : parrello 1.49 return "\t\t<$tag $1>$2</$endtag>";
471 : overbeek 1.3 }
472 :     else
473 :     {
474 : parrello 1.49 return "\t\t<$tag>$x</$endtag>";
475 : overbeek 1.3 }
476 :     }
477 :    
478 : redwards 1.47
479 :     sub merge_table_rows {
480 :     # RAE:
481 :     # Experimental piece of code. We often want to have rows or columns were cells are merged. It just looks so much nicer
482 :     # this block should merge adjacent rows that have the same text in them.
483 :     # use like this:
484 :     # $tab=&HTML::merge_table_rows($tab);
485 :     # before you do a make_table call
486 :    
487 :     my $self=shift if UNIVERSAL::isa($_[0],__PACKAGE__);
488 :     my ($tab)=@_;
489 :    
490 :     my $newtable;
491 :     my $lastrow;
492 :     my $rowspan;
493 :     my $refs;
494 :    
495 :     for (my $y=0; $y <= $#$tab; $y++) {
496 :     #$y is the row in the table;
497 :     for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
498 :     #$x is the column in the table
499 :     # if the column in the row we are looking at is the same as the column in the previous row, we don't add
500 :     # this cell to $newtable. Instead we increment the rowspan of the previous row by one
501 :    
502 :     # handle cells that are references to arrays
503 :     if (ref($tab->[$y]->[$x]) eq "ARRAY") {$refs->[$y]->[$x]=$tab->[$y]->[$x]->[1]; $tab->[$y]->[$x]=$tab->[$y]->[$x]->[0]}
504 :    
505 :     # now we go back through the table looking where to draw the merge line:
506 :     my $lasty=$y;
507 : redwards 1.52 while ($lasty >= 0 && $tab->[$y]->[$x] eq $tab->[$lasty]->[$x]) {$lasty--}
508 : 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
509 :     if ($lasty == $y) {
510 :     # we always want to have something in rows that may otherwise be empty but should be there (see below)
511 :     unless ($tab->[$y]->[$x]) {$tab->[$y]->[$x]=" &nbsp; "}
512 :     $newtable->[$y]->[$x] = $tab->[$y]->[$x];
513 :     }
514 :     else {$rowspan->[$lasty]->[$x]++}
515 :     }
516 :     }
517 :    
518 :     # now just join everything back together
519 :     for (my $y=0; $y <= $#$tab; $y++) {
520 :     for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
521 :     if ($rowspan->[$y]->[$x]) {
522 :     if ($refs->[$y]->[$x]) {$refs->[$y]->[$x] .= " rowspan=". ($rowspan->[$y]->[$x]+1)}
523 :     else {$refs->[$y]->[$x] = "td rowspan=". ($rowspan->[$y]->[$x]+1)}
524 :     $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
525 :     }
526 :     elsif ($newtable->[$y]->[$x] && $refs->[$y]->[$x]) {
527 :     $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
528 :     }
529 :     }
530 :     }
531 :    
532 :    
533 :     # finally we have to remove any completely empty cells that have been added by the array mechanism
534 :     # (e.g. if you define $a->[2] then $a->[0] and $a->[1] are now undef).
535 :     # that is why in the loop above I replace empty cells with nbsp. They are now not undef!
536 :     # I am sure that Gary can do this in one line, but I am hacking.
537 :     my @trimmed;
538 :     foreach my $a (@$newtable) {
539 :     my @row;
540 :     foreach my $b (@$a) {
541 :     push @row, $b if ($b);
542 :     }
543 :     push @trimmed, \@row;
544 :     }
545 :    
546 :     return \@trimmed;
547 :     }
548 :    
549 :    
550 :    
551 :    
552 : overbeek 1.11 sub set_ec_links {
553 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
554 : overbeek 1.11 my($cgi,$x) = @_;
555 :     my($before,$match,$after);
556 :    
557 :     if ($x =~ /^(.*)(EC \d+\.\d+\.\d+\.\d+)(.*)/s)
558 :     {
559 : parrello 1.49 $before = $1;
560 :     $match = $2;
561 :     $after = $3;
562 :     return &set_ec_links($cgi,$before) . &HTML::ec_link($match) . &set_ec_links($cgi,$after);
563 : overbeek 1.11 }
564 :     return $x;
565 :     }
566 :    
567 : efrank 1.1 sub ec_link {
568 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
569 : efrank 1.1 my($role) = @_;
570 :    
571 :     if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)
572 :     {
573 : parrello 1.49 return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?ec:$1\">$role</a>";
574 : efrank 1.1 }
575 :     else
576 :     {
577 : parrello 1.49 return $role;
578 : efrank 1.1 }
579 :     }
580 :    
581 :     sub role_link {
582 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
583 : efrank 1.1 my($cgi,$role) = @_;
584 :    
585 :     my $roleR = ($role =~ /^(\d+\.\d+\.\d+\.\d+)\s+-\s+/) ? $1 : $role;
586 :     my $user = $cgi->param('user');
587 :     if (! $user) { $user = "" }
588 :     my $link = $cgi->url() . "?role=$roleR&user=$user";
589 :     $link =~ s/[a-z]+\.cgi\?/pom.cgi?/;
590 :     return "<a href=$link>$role</a>";
591 :     }
592 :    
593 : olson 1.13 #
594 :     # Local means to eliminate the fig|org.peg from the
595 :     # text of the link.
596 :     #
597 : efrank 1.1 sub fid_link {
598 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
599 : efrank 1.1 my($cgi,$fid,$local,$just_url) = @_;
600 :     my($n);
601 :    
602 :     if ($fid =~ /^fig\|\d+\.\d+\.([a-z]+)\.(\d+)/)
603 :     {
604 : parrello 1.49 if ($local)
605 :     {
606 :     if ($1 eq "peg")
607 :     {
608 :     $n = $2;
609 :     }
610 :     else
611 :     {
612 :     $n = "$1.$2";
613 :     }
614 :     }
615 :     else
616 :     {
617 :     $n = $fid;
618 :     }
619 : mkubal 1.57
620 :     #added to format prophage and path island links to feature.cgi
621 :     if ($1 ne "peg")
622 :     {
623 :     my $user = $cgi->param('user');
624 :     if (! $user) { $user = "" }
625 :     my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
626 :     my $link = &FIG::cgi_url . "/feature.cgi?feature=$fid&user=$user$trans$sprout";
627 :     $link =~ s/[a-z_A-Z0-9]+\.cgi\?/feature.cgi?/;
628 :     return "<a href=$link>$n</a>";
629 :     }
630 :    
631 :     if ($1 eq "peg")
632 :     {
633 :     my $user = $cgi->param('user');
634 :     if (! $user) { $user = "" }
635 :     my $trans = $cgi->param('translate') ? "&translate=1" : "";
636 :     my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
637 : overbeek 1.56 ###a
638 :    
639 :     ### This used to be
640 :     ### my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
641 :     ###
642 :     ### The cost became prohibitive in the subsystem spreadsheets. Hence, we cache the value
643 :     ###
644 :     ### RAO
645 :    
646 : mkubal 1.57 if (! $cgi_url) { $cgi_url = &FIG::cgi_url }
647 :     my $link = $cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
648 :     $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
649 :     #
650 :     # Elimin the p2p part if we're in that subdir. Ugh.
651 :     #
652 :     $link =~ s,p2p/protein.cgi,protein.cgi,;
653 :     return "<a href=$link>$n</a>";
654 :     }
655 :     if ($just_url)
656 :     {
657 :     return $link;
658 :     }
659 :     else
660 :     {
661 :     return "<a href=$link>$n</a>";
662 :     }
663 : efrank 1.1 }
664 :     return $fid;
665 :     }
666 :    
667 :     sub family_link {
668 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
669 : efrank 1.1 my($family,$user) = @_;
670 :    
671 :     return $family;
672 :     }
673 :    
674 :    
675 :     sub get_html {
676 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
677 : efrank 1.1 my( $url, $type, $kv_pairs) = @_;
678 :     my( $encoded, $ua, $args, @args, $out, @output, $x );
679 :    
680 :     $ua = new LWP::UserAgent;
681 :     $ua->timeout( 900 );
682 :     if ($type =~/post/i)
683 :     {
684 : parrello 1.49 $args = [];
685 :     foreach $x (@$kv_pairs)
686 :     {
687 :     push(@$args, ( $x->[0], $x->[1]) );
688 :     }
689 :     my $request = POST $url, $args;
690 :     my $response = $ua->request($request);
691 :     $out = $response->content;
692 : efrank 1.1 }
693 :     else
694 :     {
695 : parrello 1.49 @args = ();
696 :     foreach $x (@$kv_pairs)
697 :     {
698 :     push( @args, "$x->[0]=" . uri_escape($x->[1]) );
699 :     }
700 :    
701 :     if (@args > 0)
702 :     {
703 :     $url .= "?" . join("&",@args);
704 :     }
705 :     $request = new HTTP::Request('GET', $url);
706 :     my $response = $ua->request($request);
707 :    
708 :     if ($response->is_success)
709 :     {
710 :     $out = $response->content;
711 :     }
712 :     else
713 :     {
714 :     $out = "<H1>Error: " . $response->code . "</H1>" . $response->message;
715 :     }
716 : efrank 1.1 }
717 :     # set up a document with proper eol characters
718 :     @output = split(/[\012\015]+/,$out);
719 :     foreach $out (@output) { $out .= "\n"; }
720 :    
721 :     # Now splice in a line of the form <base href=URL> to cause all relative links to work
722 :     # properly. Remove the header.
723 :    
724 :     for ($i=0; ($i < @output) && ($output[$i] !~ /^\s*\</); $i++) {}
725 :     if ($i < @output)
726 :     {
727 : parrello 1.49
728 :     splice(@output,0,$i);
729 : efrank 1.1 }
730 :    
731 :     for ($i=0; ($i < @output) && ($output[$i] !~ /\<body\>/i); $i++) {}
732 :     if ($i == @output)
733 :     {
734 : parrello 1.49 $i = -1;
735 : efrank 1.1 }
736 :     splice(@output,$i+1,0,"<base href=\"$url\">\n");
737 :     return @output;
738 :     }
739 :    
740 :     sub trim_output {
741 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
742 : efrank 1.1 my($out) = @_;
743 :     my $i;
744 :    
745 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /^\</); $i++) {}
746 :     splice(@$out,0,$i);
747 :    
748 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<body\>/i); $i++) {}
749 :     if ($i == @$out)
750 :     {
751 : parrello 1.49 for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<html\>/i); $i++) {}
752 :     if ($i == @$out)
753 :     {
754 :     $i = -1;
755 :     }
756 : efrank 1.1 }
757 :     for ($j=$i+1; ($j < @$out) && ($out->[$j] !~ /^\<hr\>$/); $j++) {}
758 :     if ($j < @$out)
759 :     {
760 : parrello 1.49 splice(@$out,$i+1,($j-$i));
761 : efrank 1.1 }
762 :    
763 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<\/body\>/i); $i++) {}
764 :     if ($i == @$out)
765 :     {
766 : parrello 1.49 for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<\/html\>/i); $i++) {}
767 : efrank 1.1 }
768 :    
769 :     for ($j=$i-1; ($j > 0) && ($out->[$j] !~ /FIG search/); $j--) {}
770 :     if ($j > 0)
771 :     {
772 : parrello 1.49 my @tmp = `cat $html_tail_file`;
773 :     my $n = @tmp;
774 :     splice(@$out,$j-$n,$n+1);
775 : efrank 1.1 }
776 :     }
777 :    
778 :     sub set_prot_links {
779 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
780 : efrank 1.1 my($cgi,$x) = @_;
781 :     my($before,$match,$after);
782 :    
783 : overbeek 1.11 if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)/s)
784 : efrank 1.1 {
785 : parrello 1.49 $before = $1;
786 :     $match = $2;
787 :     $after = $3;
788 :     return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after);
789 : efrank 1.1 }
790 : overbeek 1.19 elsif ($x =~ /^(.*)\b([NXYZA]P_[0-9\.]+)\b(.*)/s)
791 :     {
792 : parrello 1.49 $before = $1;
793 :     $match = $2;
794 :     $after = $3;
795 :     return &set_prot_links($cgi,$before) . &HTML::refseq_link($cgi,$match) . &set_prot_links($cgi,$after);
796 : overbeek 1.19 }
797 : overbeek 1.11 elsif ($x =~ /^(.*)(gi\|\d+)(.*)/s)
798 : efrank 1.1 {
799 : parrello 1.49 $before = $1;
800 :     $match = $2;
801 :     $after = $3;
802 :     return &set_prot_links($cgi,$before) . &HTML::gi_link($cgi,$match) . &set_prot_links($cgi,$after);
803 : efrank 1.1 }
804 : overbeek 1.44 elsif ($x =~ /^(.*)(tigr\|[0-9a-zA-Z]+)(.*)/s)
805 :     {
806 : parrello 1.49 $before = $1;
807 :     $match = $2;
808 :     $after = $3;
809 :     return &set_prot_links($cgi,$before) . &HTML::tigr_link($cgi,$match) . &set_prot_links($cgi,$after);
810 : overbeek 1.44 }
811 : overbeek 1.14 elsif ($x =~ /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
812 :     {
813 : parrello 1.49 $before = $1;
814 :     $match = $2;
815 :     $after = $3;
816 :     return &set_prot_links($cgi,$before) . &HTML::uni_link($cgi,$match) . &set_prot_links($cgi,$after);
817 : overbeek 1.14 }
818 : overbeek 1.11 elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)/s)
819 : efrank 1.1 {
820 : parrello 1.49 $before = $1;
821 :     $match = $2;
822 :     $after = $3;
823 :     return &set_prot_links($cgi,$before) . &HTML::sp_link($cgi,$match) . &set_prot_links($cgi,$after);
824 : efrank 1.1 }
825 : overbeek 1.11 elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)/s)
826 : efrank 1.1 {
827 : parrello 1.49 $before = $1;
828 :     $match = $2;
829 :     $after = $3;
830 :     return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after);
831 : efrank 1.1 }
832 : overbeek 1.12 elsif ($x =~ /^(.*)(kegg\|[a-z]{2,4}:[a-zA-Z_0-9]+)(.*)/s)
833 :     {
834 : parrello 1.49 $before = $1;
835 :     $match = $2;
836 :     $after = $3;
837 :     return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after);
838 : overbeek 1.12 }
839 : efrank 1.1 return $x;
840 :     }
841 :    
842 : overbeek 1.19 sub refseq_link {
843 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
844 : overbeek 1.19 my($cgi,$id) = @_;
845 :    
846 :     if ($id =~ /^[NXYZA]P_/)
847 :     {
848 : parrello 1.49 return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id>$id</a>";
849 : overbeek 1.19 }
850 :     }
851 :    
852 : efrank 1.1 sub gi_link {
853 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
854 : efrank 1.1 my($cgi,$gi) = @_;
855 :    
856 :     if ($gi =~ /^gi\|(\d+)$/)
857 :     {
858 : 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>";
859 : efrank 1.1 }
860 :     return $gi;
861 :     }
862 :    
863 : overbeek 1.44 sub tigr_link {
864 :     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
865 :     my($cgi,$tigr) = @_;
866 :    
867 :     if ($tigr =~ /^tigr\|([0-9a-zA-Z]+)$/)
868 :     {
869 : parrello 1.49 return "<a href=\"http://pathema.tigr.org/tigr-scripts/CMR/GenePage.cgi?locus=$1\">$tigr</a>";
870 : overbeek 1.44 }
871 :     return $tigr;
872 :     }
873 :    
874 : overbeek 1.14 sub uni_link {
875 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
876 : overbeek 1.14 my($cgi,$uni) = @_;
877 :    
878 :     if ($uni =~ /^uni\|(\S+)$/)
879 :     {
880 : parrello 1.49 return "<a href=http://www.pir.uniprot.org/cgi-bin/upEntry?id=$1>$uni</a>";
881 : overbeek 1.14 }
882 :     return $uni;
883 :     }
884 :    
885 : efrank 1.1 sub sp_link {
886 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
887 : efrank 1.1 my($cgi,$sp) = @_;
888 :    
889 :     if ($sp =~ /^sp\|(\S+)$/)
890 :     {
891 : parrello 1.49 return "<a href=http://us.expasy.org/cgi-bin/get-sprot-entry?$1>$sp</a>";
892 : efrank 1.1 }
893 :     return $sp;
894 :     }
895 :    
896 :     sub pir_link {
897 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
898 : efrank 1.1 my($cgi,$pir) = @_;
899 :    
900 :     if ($pir =~ /^pirnr\|(NF\d+)$/)
901 :     {
902 : parrello 1.49 return "<a href=http://pir.georgetown.edu/cgi-bin/nfEntry.pl?id=$1>$pir</a>";
903 : efrank 1.1 }
904 :     return $pir;
905 :     }
906 :    
907 : overbeek 1.12 sub kegg_link {
908 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
909 : overbeek 1.12 my($cgi,$kegg) = @_;
910 :    
911 :     if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)
912 :     {
913 : parrello 1.49 return "<a href=http://www.genome.ad.jp/dbget-bin/www_bget?$1+$2>$kegg</a>";
914 : overbeek 1.12 }
915 :     return $kegg;
916 :     }
917 :    
918 : overbeek 1.11 sub set_map_links {
919 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
920 : overbeek 1.11 my($cgi,$x) = @_;
921 :     my($before,$match,$after);
922 : efrank 1.1
923 : overbeek 1.11 my $org = ($cgi->param('org') || $cgi->param('genome') || "");
924 :    
925 :     if ($x =~ /^(.*)(MAP\d+)(.*)/s)
926 :     {
927 : parrello 1.49 $before = $1;
928 :     $match = $2;
929 :     $after = $3;
930 :     return &set_map_links($cgi,$before) . &map_link($cgi,$match,$org) . &set_map_links($cgi,$after);
931 : overbeek 1.11 }
932 :     return $x;
933 :     }
934 :    
935 :     sub map_link {
936 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
937 : overbeek 1.11 my($cgi,$map,$org) = @_;
938 :    
939 :     $user = $cgi->param('user');
940 :     $user = $user ? $user : "";
941 :     $org = $org ? $org : "";
942 : olson 1.51
943 :     my $url = &FIG::cgi_url() . "/show_kegg_map.cgi?user=$user&map=$map&org=$org";
944 : overbeek 1.11 my $link = "<a href=\"$url\">$map</a>";
945 :     return $link;
946 :     }
947 : redwards 1.20
948 :     sub java_buttons {
949 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
950 : redwards 1.20 ## ADDED BY RAE
951 :     # Provides code to include check all/first half/second half/none for javascrspt
952 :     # this takes two variables - the form name provided in start_form with the
953 :     # -name => field and the checkbox name
954 :     my ($form, $button)=@_;
955 :    
956 :     $java_script="<input type=\"button\" name=\"CheckAll\" value=\"Check All\"\nonClick=\"checkAll(document.$form.$button)\">\n";
957 :     $java_script.="<input type=\"button\" name=\"CheckFirst\" value=\"Check First Half\"\nonClick=\"checkFirst(document.$form.$button)\">\n";
958 :     $java_script.="<input type=\"button\" name=\"CheckSecond\" value=\"Check Second Half\"\nonClick=\"checkSecond(document.$form.$button)\">\n";
959 :     $java_script.="<input type=\"button\" name=\"UnCheckAll\" value=\"Uncheck All\"\nonClick=\"uncheckAll(document.$form.$button)\">\n";
960 : parrello 1.49
961 : redwards 1.20 return $java_script;
962 :     }
963 :    
964 : overbeek 1.22 sub sub_link {
965 : olson 1.31 shift if UNIVERSAL::isa($_[0],__PACKAGE__);
966 : overbeek 1.22 my($cgi,$sub) = @_;
967 :     my($sub_link);
968 :    
969 :     my $user = $cgi->param('user');
970 :     if ($user)
971 :     {
972 : parrello 1.49 my $esc_sub = uri_escape( $sub );
973 :     $sub_link = "<a href=./subsys.cgi?ssa_name=$esc_sub&request=show_ssa&user=$user>$sub</a>";
974 : overbeek 1.22 }
975 :     else
976 :     {
977 : parrello 1.49 $sub_link = $sub;
978 : overbeek 1.22 }
979 :     return $sub_link;
980 :     }
981 :    
982 : overbeek 1.50 sub reaction_link {
983 :     my($reaction) = @_;
984 :    
985 :     if ($reaction =~ /^R\d+/)
986 :     {
987 :     return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?rn+$reaction\" target=reaction$$>$reaction</a>";
988 :     }
989 :     return $reaction;
990 :     }
991 :    
992 : overbeek 1.53 sub html_for_assignments {
993 :     my($fig,$user,$peg_sets) = @_;
994 :     my $i;
995 :    
996 :     my @vals = ();
997 :     my $set = 1;
998 :     foreach $peg_set (@$peg_sets)
999 :     {
1000 :     for ($i=0; ($i < @$peg_set); $i++)
1001 :     {
1002 :     $peg = $peg_set->[$i];
1003 :     push(@vals,'show=' . join("@",($set,$i+1,$peg,&FIG::abbrev($fig->org_of($peg)),"")));
1004 :     }
1005 :     $set++;
1006 :     }
1007 :    
1008 :     $ENV{'REQUEST_METHOD'} = 'GET';
1009 :     $ENV{'QUERY_STRING'} = join('&',('request=show_commentary',"uni=1","user=$user",@vals));
1010 :     my $out = join("",`$FIG_Config::fig/CGI/chromosomal_clusters.cgi`);
1011 :     $out =~ s/^.*?<form/<form/si;
1012 :     $out =~ s/^(.*)<table.*/$1/si;
1013 :     return $out;
1014 :     }
1015 :    
1016 : redwards 1.55 =head1 rss_feed
1017 :    
1018 :     Add something to the RSS feed. The rss feeds are stored in the Html directory, and there are several RSS feeds:
1019 :     SEED.rss - everything gets written here
1020 :     SEEDgenomes.rss - whenever a genome is added to the SEED
1021 :     SEEDsubsystems.rss - whenever a subsystem is edited (or should this be added?)
1022 :    
1023 :    
1024 :     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.
1025 :    
1026 :     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.
1027 :    
1028 :     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.
1029 :    
1030 :     The has can have these keys:
1031 :    
1032 :     REQUIRED:
1033 :     title : the title. This is usually what is seen by the user in the pull down menu
1034 :     description : a more complete description that is often seen is rss viewers but not always
1035 :     link : link to the item that was added/edited
1036 :     All other keys are treated as optional RSS arguments and written to the file. At most, 10 recent entries are stored in the rss file.
1037 :    
1038 :     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.
1039 :    
1040 :    
1041 :     =cut
1042 :    
1043 :     sub rss_feed {
1044 :     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1045 :     my ($files, $args)=@_;
1046 :     foreach my $a (keys %$args) {if ($a =~ /^-(.*)/) {my $b=$1; $args->{$b}=$args->{$a}; delete $args->{$a}}}
1047 :    
1048 :     my $filepath=$FIG_Config::fig."/CGI/Html/rss";
1049 :     # check for the directory and if not, make it
1050 :     mkdir $filepath unless (-d $filepath);
1051 :    
1052 :     # note that $info is a hash of references to hashes that are written out as headers in the file
1053 :     my $info=
1054 :     {
1055 :     "SEED.rss" =>
1056 :     {
1057 :     title => "The SEED",
1058 :     description => "Latest news from the SEED",
1059 :     link => &FIG::cgi_url()."/Html/rss/SEED.rss",
1060 :     },
1061 :    
1062 :     "SEEDsubsystems.rss" =>
1063 :     {
1064 :     title => "SEED Subsystems",
1065 :     description => "Recently updated SEED subsystems",
1066 :     link => &FIG::cgi_url()."/Html/rss/SEEDsubsystems.rss",
1067 :     },
1068 :    
1069 :     "SEEDsubsystems.rss" =>
1070 :     {
1071 :     title => "SEED Genomes",
1072 :     description => "Genomes recently added to the SEED",
1073 :     link => &FIG::cgi_url()."/Html/rss/SEEDsubsystems.rss",
1074 :     },
1075 :    
1076 :     };
1077 :    
1078 :    
1079 :     # build the new xml
1080 :     my $xml = "\t<item>\n";
1081 :     foreach my $qw ("title", "description", "link") {
1082 :     unless ($args->{$qw}) {
1083 :     print STDERR "You need to include a $qw tag in your RSS description\n";
1084 :     return(0);
1085 :     }
1086 :     # we need to do something a bit funky with the link. We can't have ampersands in the <link> </link> in valid html
1087 :     # so we are going to pull out the links and uri_escape just the part after the .cgi
1088 :     if ($qw eq "link")
1089 :     {
1090 :     $args->{$qw} =~ /^(.*?\.cgi.)(.*)$/;
1091 :     print STDERR "Got ->>$1<<- and ->>$2<<-\n";
1092 :     $args->{$qw} = $1.uri_escape($2) if ($1 && $2);
1093 :     }
1094 :    
1095 :     $xml .= "\t\t<$qw>".$args->{$qw}."</$qw>\n";
1096 :     delete $args->{$qw};
1097 :     }
1098 :    
1099 :     foreach my $tag (grep {!/type/i} keys %$args)
1100 :     {
1101 :     $xml .= "\t\t<$tag>".$args->{$tag}."</$tag>\n";
1102 :     }
1103 :    
1104 :     $xml .= "\t</item>\n";
1105 :    
1106 :    
1107 :     my @files=("SEED.rss");
1108 :     if ($args->{"type"}) {push @files, "SEED.$type.rss"}
1109 :    
1110 :     foreach my $file ("SEED.rss", @$files)
1111 :     {
1112 :     if (-e "$filepath/$file")
1113 :     {
1114 :     my @out; # the new content of the file
1115 :     my $itemcount=0; # how many <item> </item>'s are we keeping
1116 :     my $initem; # are we in an item?
1117 :     open(IN, "$filepath/$file") || die "Can't open $filepath/$file";
1118 :     while (<IN>)
1119 :     {
1120 :     if (/\<item\>/) {
1121 :     push @out, $xml, unless ($itemcount);
1122 :     $itemcount++;
1123 :     $initem=1;
1124 :     }
1125 :     if (/\<\/item\>/) {$initem=0; next if ($itemcount > 9)}
1126 :     next if ($initem && $itemcount > 9);
1127 :     push @out, $_;
1128 :     }
1129 :     close IN;
1130 :     open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1131 :     print OUT @out;
1132 :     }
1133 :     else
1134 :     {
1135 :     open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1136 :     print OUT "<?xml version=\"1.0\"?>\n<rss version=\"2.0\">\n<channel>\n";
1137 :     if ($info->{$file})
1138 :     {
1139 :     # we're going to sanity check each of the three options we output, just to be sure
1140 :     foreach my $qw ("title", "description", "link")
1141 :     {
1142 :     if ($info->{$file}->{$qw})
1143 :     {
1144 :     print OUT "<$qw>", $info->{$file}->{$qw}, "</$qw>\n";
1145 :     } else {
1146 :     print STDERR "Please add a $qw for $file\n"; print OUT "<$qw>$file</$qw>\n";
1147 :     }
1148 :     }
1149 :     }
1150 :     else {
1151 :     print STDERR "Please define title, link, and description information for $file\n";
1152 :     print OUT "<title>$file</title>\n<description>An RSS feed</description>\n<link>", &FIG::cgi_url, "</link>\n";
1153 :     }
1154 :     print OUT "\n", $xml;
1155 :     print OUT "\n", "</channel>\n</rss>\n"
1156 :     }
1157 :     }
1158 :     }
1159 :    
1160 :     1;
1161 :    

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3