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

Diff of /FigKernelPackages/HTML.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.6, Sun Mar 21 02:20:55 2004 UTC revision 1.71, Wed Nov 2 21:58:00 2005 UTC
# Line 1  Line 1 
1  package HTML;  package HTML;
2    
3    use Tracer;
4    use FIG;
5  use Carp;  use Carp;
6  use Data::Dumper;  use Data::Dumper;
7  use LWP::UserAgent;  use LWP::UserAgent;
8  use LWP::Simple;  use LWP::Simple;
9    use URI::Escape;  # uri_escape()
10  use URI::URL;  use URI::URL;
11  use HTTP::Request::Common;  use HTTP::Request::Common;
12    use POSIX;
13    
14    
15    my $top_link_cache;
16    
17    
18    sub new
19    {
20        my($class) = @_;
21    
22        my $self = {};
23    
24        return bless $self, $class;
25    }
26    
27    sub top_link
28    {
29    
30        #
31        # Determine if this is a toplevel cgi or one in one of the subdirs (currently
32        # just /p2p).
33        #
34    
35        return $top_link_cache if ($top_link_cache);
36    
37        my @parts = split(/\//, $ENV{SCRIPT_NAME});
38        my $top;
39        if ($parts[-2] eq 'FIG')
40        {
41            $top = '.';
42    #       warn "toplevel @parts\n";
43        }
44        elsif ($parts[-3] eq 'FIG')
45        {
46            $top = '..';
47    #       warn "subdir @parts\n";
48        }
49        else
50        {
51            $top = $FIG_Config::cgi_base;
52    #       warn "other @parts\n";
53        }
54    
55        $top_link_cache = $top;
56        return $top;
57    }
58    
59    sub compute_html_header
60    {
61        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
62        my($additional_insert, $user, %options ) = @_;
63    
64        my $header_name = $options{header_name} ? $options{header_name} : "html.hdr";
65        my $tail_name = $options{tail_name} ? $options{tail_name} : "html.tail";
66    
67        my $html_hdr_file = "./Html/$header_name";
68        if (! -f $html_hdr_file)
69        {
70            $html_hdr_file = "$FIG_Config::fig/CGI/Html/$header_name";
71        }
72        my @html_hdr = &FIG::file_read($html_hdr_file);
73    
74        # for my $k (sort keys %ENV) { warn "$k = $ENV{$k}\n"; }
75    
76        #
77        # Determine if this is a toplevel cgi or one in one of the subdirs (currently
78        # just /p2p).
79        #
80    
81        my @parts = split(/\//, $ENV{SCRIPT_NAME});
82        my $top;
83        if ($parts[-2] eq 'FIG')
84        {
85            $top = '.';
86    #       warn "toplevel @parts\n";
87        }
88        elsif ($parts[-3] eq 'FIG')
89        {
90            $top = '..';
91    #       warn "subdir @parts\n";
92        }
93        else
94        {
95            $top = $FIG_Config::cgi_base;
96    #       warn "other @parts\n";
97        }
98    
99        $options{no_fig_search} or push( @html_hdr, "<br><a href=\"$top/index.cgi?user=$user\">FIG search</a>\n" );
100    
101        if (@html_hdr)
102        {
103            my $insert_stuff;
104    
105            if (not $options{no_release_info})
106            {
107                my @ver = &FIG::file_head("$FIG_Config::fig_disk/CURRENT_RELEASE", 1);
108                my $ver = $ver[0];
109                chomp $ver;
110                if ($ver =~ /^cvs\.(\d+)$/)
111                {
112                    my $d = asctime(localtime($1));
113                    chomp($d);
114                    $ver .=  " ($d)";
115                }
116                my $host = &FIG::get_local_hostname();
117                $insert_stuff = "SEED version <b>$ver</b> on $host";
118            }
119    
120            if ($additional_insert)
121            {
122                $insert_stuff .= "<br>" . $additional_insert;
123            }
124    
125            for $_ (@html_hdr)
126            {
127                s,(href|img\s+src)="/FIG/,$1="$top/,g;
128                    s,(\?user\=)\",$1$user",;
129                if ($_ eq "<!-- HEADER_INSERT -->\n")
130                {
131                    $_ = $insert_stuff;
132                }
133            }
134        }
135    
136        return @html_hdr;
137    }
138    
139  sub show_page {  sub show_page {
140      my($cgi,$html,$no_home) = @_;      #warn "SHOWPAGE: cgi=", Dumper(@_);
141        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
142        my($cgi,$html,$no_home, $alt_header, $css, $javasrc, $cookie) = @_;
143      my $i;      my $i;
144    
145        my $top = top_link();
146    
147        # ARGUMENTS:
148        #     $cgi is the CGI method
149        #     $html is an array with all the html in it. It is just joined by "\n" (and not <br> or <p>
150        #     $no_home eliminates ONLY the bottom FIG search link in a page
151        #     $alt_header is a reference to an array for an alternate header banner that you can replace the standard one with
152        #     $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
153        #               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
154        #               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
155        #     $javasrc is a reference to an array of URLs to javascripts to be included (e.g. "/FIG/Html/css/styleswitcher.js")
156        #     $cookie is the name and value of the cookie to set. Note that you should probably use raelib->cookie to get/set your cookies
157      #      #
158      # Find the HTML header      # Find the HTML header
159      #      #
160    
161      my $html_hdr_file = "./Html/html.hdr";      my $html_tail_file = "./Html/$tail_name";
162      if (! -f $html_hdr_file)      if (! -f $html_tail_file)
163      {      {
164          $html_hdr_file = "$FIG_Config::fig/CGI/Html/html.hdr";          $html_tail_file = "$FIG_Config::fig/CGI/Html/$tail_name";
165      }      }
166    
167      my $html_tail_file = "./Html/html.tail";      my $user = $cgi->param('user') || "";
168      if (! -f $html_tail_file)      my @html_hdr;
169        if ($alt_header && ref($alt_header) eq "ARRAY")
170      {      {
171          $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";         @html_hdr = @$alt_header;
172        }
173        else
174        {
175            @html_hdr = compute_html_header(undef,$user);
176      }      }
177    
178        # RAE: I am offloading the handling of cookies to CGI.pm since I don't know how they are set up.
179        # This modification adds the cookies if necessary
180    
181      print $cgi->header;      # Note: 3/10/05 commented this line out pending the discussion of adding cookies into the seed that we are waiting to see about
182        # to add cookies back in replace these two header lines with each other
183    
184        #print $cgi->header(-cookie=>$cookie);
185        print $cgi->header();
186    
187      #      #
188      #  The SEED header file goes immediately after <BODY>.  Figure out      #  The SEED header file goes immediately after <BODY>.  Figure out
# Line 46  Line 200 
200                       meta     => 1,                       meta     => 1,
201                       nextid   => 1,                       nextid   => 1,
202                       style    => 1,                       style    => 1,
203                       title    => 1                       title    => 1,
204                     );                     );
205    
206      #      #
# Line 89  Line 243 
243          if ( $html->[$i] =~ /\<body[^0-9a-z]/i )          if ( $html->[$i] =~ /\<body[^0-9a-z]/i )
244          {          {
245              $body_line = $i;              $body_line = $i;
246              $last;              last;
247          }          }
248    
249          #  Now the general case.          #  Now the general case.
# Line 145  Line 299 
299      #      #
300      #  <BODY> goes after last head line      #  <BODY> goes after last head line
301      #      #
302        #  RAE:
303        #  Added the javascript for the buttons immediately after body.
304        #  Note if no buttons are added we still (at the moment) add the script,
305        #  but it only adds a little text (495 characters) to the html and noone will notice!
306        #  RAE: This is now deprecated because everything is in an external file, FIG.js, included later
307    
308      if ( $body_line < 0 )      if ( $body_line < 0 )
309      {      {
# Line 156  Line 315 
315      #  Seed page header (if it exists) goes after <BODY>      #  Seed page header (if it exists) goes after <BODY>
316      #      #
317    
318      if ( -f $html_hdr_file )      if (@html_hdr)
319      {      {
320          splice( @$html, $body_line + 1, 0, `cat $html_hdr_file` );          splice( @$html, $body_line + 1, 0, @html_hdr );
321      }      }
322    
323      #      #
# Line 171  Line 330 
330          splice( @$html, $body_line, 0, "</HEAD>\n" );          splice( @$html, $body_line, 0, "</HEAD>\n" );
331      }      }
332    
333        # RAE:
334        # Add css here
335        # Note that at the moment I define these two sheets here. I think this should
336        # be moved out, but I want to try it and see what happens.  css has the format:
337        #
338        # <link rel='stylesheet' title='default' href='/css/default.css' type='text/css'>
339    
340        # convert the default key to the right case. and eliminate dups
341        foreach my $k (keys %$css) {if (lc($k) eq "default") {$css->{'Default'}=$css->{$k}}}
342    
343        if (!$css || !$css->{'Default'})
344        {
345           $css->{'Default'} = "$top/Html/css/default.css";
346        }
347        if (!$css->{"Sans Serif"})
348        {
349           $css->{'Sans Serif'} = "$top/Html/css/sanserif.css";
350        }
351    
352        my $csstext = "<link rel='stylesheet' title='default' href='".$css->{'Default'}."' type='text/css'>\n";
353        $csstext   .= "<link rel='alternate stylesheet' title='Sans Serif' href='".$css->{'Sans Serif'}."' type='text/css'>\n";
354    
355        foreach my $k (keys %$css)
356        {
357           next if (lc($k) eq "default" || lc($k) eq "sans serif");
358           $csstext .= "<link rel='alternate stylesheet' title='$k' href='".$css->{$k}."' type='text/css'>\n";
359        }
360    
361        $csstext   .= "<link rel='alternate'  title='SEED RSS feeds' href='$top/Html/rss/SEED.rss' type='application/rss+xml'>\n";
362    
363        # RAE: also added support for external javascripts here.
364        # we are cluttering the HTML code with all the javascripts when they could easily be in external files
365        # this solution allows us to source other files
366    
367        # the file FIG.js contains most of the java script we use routinely. Every browser will just cache this and so
368        # it will reduce our overhead.
369    
370        # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts
371        push @$javasrc, "$top/Html/css/FIG.js";
372        foreach my $script (@$javasrc) {
373            $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";
374        }
375    
376    
377    
378        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.
379    
380      #      #
381      #  <BASE ...> goes before </HEAD>      #  <BASE ...> goes before </HEAD>
382      #      #
# Line 183  Line 389 
389          #  only, or every update?), I provide an alternative derivation          #  only, or every update?), I provide an alternative derivation
390          #  from $cgi_url. -- GJO          #  from $cgi_url. -- GJO
391          #          #
392            # BASE href needs to be absolute. RDO.
393          my $base_url = $FIG_Config::cgi_base;          #
394          if ( ! $base_url )                      # if cgi_base was not defined          #
395          {          $base_url = &FIG::cgi_url;
396              $base_url = $FIG_Config::cgi_url;   # get the full cgi url  #       my $base_url = $FIG_Config::cgi_base;
397              $base_url =~ s~^http://[^/]*~~;     # remove protocol and host  #       if ( ! $base_url )                      # if cgi_base was not defined
398              $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash  #       {
399          }  #           $base_url = $FIG_Config::cgi_url;   # get the full cgi url
400    #           $base_url =~ s~^http://[^/]*~~;     # remove protocol and host
401    #           $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash
402    #       }
403    
404          $base_line = $head_end_line;          $base_line = $head_end_line;
405          splice( @$html, $base_line, 0, "<BASE href=\"$base_url\">\n" );          #
406            # RDO 2005-1006. Remove this so proxying works better.
407            #
408    #        splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );
409      }      }
410    
411      #      #
# Line 228  Line 440 
440      }      }
441    
442      #      #
443        # See if we have a site-specific tail (for disclaimers, etc).
444        #
445    
446        my $site_tail = "$FIG_Config::fig_disk/config/site_tail.html";
447        my $site_fh;
448        if (open($site_fh, "<$site_tail"))
449        {
450            push(@tail, <$site_fh>);
451            close($site_fh);
452        }
453    
454        #
455      #  Figure out where to insert The SEED tail.  Before </body>,      #  Figure out where to insert The SEED tail.  Before </body>,
456      #  or before </html>, or at end of page.      #  or before </html>, or at end of page.
457      #      #
   
458      my @tags = ();      my @tags = ();
459        # Check for a tracing queue.
460        my $traceString = QTrace("HTML");
461        if ($traceString) {
462            push @tags, $traceString;
463        }
464      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}
465      if ($i >= @$html)        # </body> not found; look for </html>      if ($i >= @$html)        # </body> not found; look for </html>
466      {      {
# Line 255  Line 482 
482          splice( @$html, $i, 0, @tags );          splice( @$html, $i, 0, @tags );
483      }      }
484    
485      print @$html;      # RAE the chomp will return any new lines at the ends of elements in the array,
486        # and then we can join  with a "\n". This is because somethings put newlines in,
487        # and others don't. This should make nicer looking html
488        #
489        # chomp(@$html);
490        # print join "\n", @$html;
491        #
492        # Apparently the above still breaks things. This is the correct code:
493    
494        foreach $_ (@$html)
495        {
496            print $_;
497        }
498    
499  }  }
500    
501  sub make_table {  sub make_table {
502      my($col_hdrs,$tab,$title,$instr) = @_;      my($col_hdrs,$tab,$title, %options ) = @_;
503      my(@tab);      my(@tab);
504    
505      push( @tab, "\n<table border>\n",      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";
506        my $width = defined $options{width} ? "width=\"$options{width}\"" : undef;
507        push( @tab, "\n<table $border $width>\n",
508                  "\t<caption><b>$title</b></caption>\n",                  "\t<caption><b>$title</b></caption>\n",
509                  "\t<tr>\n\t\t<th>"                  "\t<tr>\n\t\t"
510                . join( "</th>\n\t\t<th>", @$col_hdrs )                . join( "\n", map { &expand($_, "th") } @$col_hdrs )
511                . "</th>\n\t</tr>\n"                . "\n\t</tr>\n"
512          );          );
513      my($i,$nowrap);      my($i);
   
     for ($i=0; ($i < @$instr) && ($instr->[$i] !~ /nowrap/); $i++) {}  
     $nowrap = ($i == @$instr) ? "" : " nowrap";  
514    
515      my $row;      my $row;
516      foreach $row (@$tab)      foreach $row (@$tab)
517      {      {
518          push( @tab, "\t<tr>\n"          push( @tab, "\t<tr>\n"
519                    . join( "\n", map { &expand($_,$nowrap) } @$row )                    . join( "\n", map { &expand($_) } @$row )
520                    . "\n\t</tr>\n"                    . "\n\t</tr>\n"
521              );              );
522      }      }
# Line 286  Line 525 
525  }  }
526    
527  sub expand {  sub expand {
528      my($x,$nowrap) = @_;      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
529        my( $x, $tag ) = @_;
530    
531        $tag = "td" unless $tag;
532        my $endtag = $tag;
533    
534        # RAE modified this so that you can pass in a reference to an array where
535        # the first element is the data to display and the second element is optional
536        # things like colspan and align. Note that in this case you need to include the td
537        # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]
538    
539        # per GJO's request modified this line so it can take any tag.
540        if ( ref($x) eq "ARRAY" ) { ($x, $tag) = @$x; $tag =~ /^(\S+)/; $endtag = $1 }
541    
542      if ($x =~ /^\@([^:]+)\:([^:]+)\:(.*)$/)      if ( $x =~ /^\@([^:]+)\:(.*)$/ )
543      {      {
544          return "\t\t<td$nowrap $1=\"$2\">$3</td>";          return "\t\t<$tag $1>$2</$endtag>";
545      }      }
546      else      else
547      {      {
548          return "\t\t<td$nowrap>$x</td>";          return "\t\t<$tag>$x</$endtag>";
549        }
550    }
551    
552    
553    =head2 merge_table_rows()
554    
555    Merge table rows together. This will merge a table so that adjacent cells with the same content will only be shown once.
556    
557    Something like this:
558    
559        -----------------------
560        |    1     |    a     |
561        -----------------------
562        |    1     |    b     |
563        -----------------------
564        |    2     |    c     |
565        -----------------------
566        |    3     |    d     |
567        -----------------------
568        |    4     |    d     |
569        -----------------------
570        |    5     |    d     |
571        -----------------------
572    
573    Will become:
574    
575        -----------------------
576        |          |    a     |
577        |    1     |-----------
578        |          |    b     |
579        -----------------------
580        |    2     |    c     |
581        -----------------------
582        |    3     |          |
583        ------------          |
584        |    4     |    5     |
585        ------------          |
586        |    5     |          |
587        -----------------------
588    
589    
590    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.
591    
592     $tab=&HTML::merge_table_rows($tab);
593    
594     or
595    
596     $skip=(1=>1, 3=>1, 5=>1);
597     $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
598    
599    
600    =cut
601    
602    
603    
604    
605    sub merge_table_rows {
606     # RAE:
607     # Experimental piece of code. We often want to have rows or columns were cells are merged. It just looks so much nicer
608     # this block should merge adjacent rows that have the same text in them.
609     # use like this:
610     #      $tab=&HTML::merge_table_rows($tab);
611     # before you do a make_table call
612    
613     my $self=shift if UNIVERSAL::isa($_[0],__PACKAGE__);
614     my ($tab, $skip)=@_;
615    
616     my $newtable;
617     my $lastrow;
618     my $rowspan;
619     my $refs;
620    
621     for (my $y=0; $y <= $#$tab; $y++) {
622     #$y is the row in the table;
623      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
624       # this is the user definable columns not to merge
625       if ($skip->{$x})
626       {
627        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
628        next;
629      }      }
630    
631       #$x is the column in the table
632       # if the column in the row we are looking at is the same as the column in the previous row, we don't add
633       # this cell to $newtable. Instead we increment the rowspan of the previous row by one
634    
635       # handle cells that are references to arrays
636       if (ref($tab->[$y]->[$x]) eq "ARRAY") {$refs->[$y]->[$x]=$tab->[$y]->[$x]->[1]; $tab->[$y]->[$x]=$tab->[$y]->[$x]->[0]}
637    
638       # now we go back through the table looking where to draw the merge line:
639       my $lasty=$y;
640       while ($lasty >= 0 && $tab->[$y]->[$x] eq $tab->[$lasty]->[$x]) {$lasty--}
641       $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
642       if ($lasty == $y) {
643        # we always want to have something in rows that may otherwise be empty but should be there (see below)
644        unless ($tab->[$y]->[$x]) {$tab->[$y]->[$x]=" &nbsp; "}
645        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
646       }
647       else {$rowspan->[$lasty]->[$x]++}
648      }
649     }
650    
651     # now just join everything back together
652     for (my $y=0; $y <= $#$tab; $y++) {
653      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
654       if ($rowspan->[$y]->[$x]) {
655        if ($refs->[$y]->[$x]) {$refs->[$y]->[$x] .= " rowspan=". ($rowspan->[$y]->[$x]+1)}
656        else {$refs->[$y]->[$x] = "td rowspan=". ($rowspan->[$y]->[$x]+1)}
657        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
658       }
659       elsif ($newtable->[$y]->[$x] && $refs->[$y]->[$x]) {
660        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
661       }
662      }
663     }
664    
665    
666     # finally we have to remove any completely empty cells that have been added by the array mechanism
667     # (e.g. if you define $a->[2] then $a->[0] and $a->[1] are now undef).
668     # that is why in the loop above I replace empty cells with nbsp. They are now not undef!
669     # I am sure that Gary can do this in one line, but I am hacking.
670     my @trimmed;
671     foreach my $a (@$newtable) {
672      my @row;
673      foreach my $b (@$a) {
674       push @row, $b if ($b);
675      }
676      push @trimmed, \@row;
677     }
678    
679     return \@trimmed;
680    }
681    
682    
683    
684    
685    sub set_ec_links {
686        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
687        my($cgi,$x) = @_;
688        my($before,$match,$after);
689    
690        if ($x =~ /^(.*)(EC \d+\.\d+\.\d+\.\d+)(.*)/s)
691        {
692            $before = $1;
693            $match = $2;
694            $after = $3;
695            return &set_ec_links($cgi,$before) . &HTML::ec_link($match) . &set_ec_links($cgi,$after);
696        }
697        return $x;
698  }  }
699    
700  sub ec_link {  sub ec_link {
701        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
702      my($role) = @_;      my($role) = @_;
703    
704      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)
# Line 312  Line 712 
712  }  }
713    
714  sub role_link {  sub role_link {
715        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
716      my($cgi,$role) = @_;      my($cgi,$role) = @_;
717    
718      my $roleR = ($role =~ /^(\d+\.\d+\.\d+\.\d+)\s+-\s+/) ? $1 : $role;      my $roleR = ($role =~ /^(\d+\.\d+\.\d+\.\d+)\s+-\s+/) ? $1 : $role;
# Line 322  Line 723 
723      return "<a href=$link>$role</a>";      return "<a href=$link>$role</a>";
724  }  }
725    
726    #
727    # Local means to eliminate the fig|org.peg from the
728    # text of the link.
729    #
730  sub fid_link {  sub fid_link {
731        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
732      my($cgi,$fid,$local,$just_url) = @_;      my($cgi,$fid,$local,$just_url) = @_;
733      my($n);      my($n);
734    
735        my $top = top_link();
736    
737      if ($fid =~ /^fig\|\d+\.\d+\.([a-z]+)\.(\d+)/)      if ($fid =~ /^fig\|\d+\.\d+\.([a-z]+)\.(\d+)/)
738      {      {
739          if ($local)          if ($local)
# Line 343  Line 751 
751          {          {
752              $n = $fid;              $n = $fid;
753          }          }
754          if ($1 ne "peg") { return $n }  
755            my $link;
756            #added to format prophage and path island links to feature.cgi
757            if ($1 ne "peg")
758            {
759               my $user = $cgi->param('user');
760               if (! $user) { $user = "" }
761               my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
762               $link = "$top/feature.cgi?feature=$fid&user=$user$trans$sprout";
763               $link =~ s/[a-z_A-Z0-9]+\.cgi\?/feature.cgi?/;
764            }
765            else
766            {
767          my $user = $cgi->param('user');          my $user = $cgi->param('user');
768          if (! $user) { $user = "" }          if (! $user) { $user = "" }
769          my $trans = $cgi->param('translate') ? "&translate=1" : "";          my $trans = $cgi->param('translate') ? "&translate=1" : "";
770          my $link = $cgi->url() . "?prot=$fid&user=$user$trans";              my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
771          $link =~ s/[a-z_A-Z]+\.cgi\?/protein.cgi?/;  ###a
772    
773    ### This used to be
774    ###     my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
775    ###
776    ### The cost became prohibitive in the subsystem spreadsheets.  Hence, we cache the value
777    ###
778    ### RAO
779    
780                #if (! $cgi_url) { $cgi_url = &FIG::cgi_url }
781                #$link = $cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
782                $link = "$top/protein.cgi?prot=$fid&user=$user$trans$sprout";
783                $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
784            }
785          if ($just_url)          if ($just_url)
786          {          {
787              return $link;              return $link;
# Line 362  Line 795 
795  }  }
796    
797  sub family_link {  sub family_link {
798        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
799      my($family,$user) = @_;      my($family,$user) = @_;
800    
801      return $family;      return $family;
802  }  }
803    
 use URI::Escape;  
804    
805  sub get_html {  sub get_html {
806        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
807      my( $url, $type, $kv_pairs) = @_;      my( $url, $type, $kv_pairs) = @_;
808      my( $encoded, $ua, $args, @args, $out, @output, $x );      my( $encoded, $ua, $args, @args, $out, @output, $x );
809    
810      $ua = new LWP::UserAgent;      $ua = new LWP::UserAgent;
811      $ua->timeout( 900 );      $ua->timeout( 900 );
   
812      if ($type =~/post/i)      if ($type =~/post/i)
813      {      {
814          $args = [];          $args = [];
# Line 435  Line 868 
868  }  }
869    
870  sub trim_output {  sub trim_output {
871        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
872      my($out) = @_;      my($out) = @_;
873      my $i;      my $i;
874    
# Line 472  Line 906 
906  }  }
907    
908  sub set_prot_links {  sub set_prot_links {
909        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
910      my($cgi,$x) = @_;      my($cgi,$x) = @_;
911      my($before,$match,$after);      my($before,$match,$after);
912    
913      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)$/)      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)/s)
914      {      {
915          $before = $1;          $before = $1;
916          $match = $2;          $match = $2;
917          $after = $3;          $after = $3;
918          return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";          return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after);
919      }      }
920      elsif ($x =~ /^(.*)(gi\|\d+)(.*)$/)      elsif ($x =~ /^(.*)\b([NXYZA][PM]_[0-9\.]+)\b(.*)/s)
921      {      {
922          $before = $1;          $before = $1;
923          $match = $2;          $match = $2;
924          $after = $3;          $after = $3;
925          return &set_prot_links($cgi,$before) . &HTML::gi_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";          return &set_prot_links($cgi,$before) . &HTML::refseq_link($cgi,$match) . &set_prot_links($cgi,$after);
926      }      }
927      elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)$/)      elsif ($x =~ /^(.*)(gi\|\d+)(.*)/s)
928      {      {
929          $before = $1;          $before = $1;
930          $match = $2;          $match = $2;
931          $after = $3;          $after = $3;
932          return &set_prot_links($cgi,$before) . &HTML::sp_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";          return &set_prot_links($cgi,$before) . &HTML::gi_link($cgi,$match) . &set_prot_links($cgi,$after);
933      }      }
934      elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)$/)      elsif ($x =~ /^(.*)(tigr\|[0-9a-zA-Z]+)(.*)/s)
935      {      {
936          $before = $1;          $before = $1;
937          $match = $2;          $match = $2;
938          $after = $3;          $after = $3;
939          return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";          return &set_prot_links($cgi,$before) . &HTML::tigr_link($cgi,$match) . &set_prot_links($cgi,$after);
940        }
941        elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
942        {
943            $before = $1;
944            $match = $2;
945            $after = $3;
946            return &set_prot_links($cgi,$before) . &HTML::uni_link($cgi,$match) . &set_prot_links($cgi,$after);
947        }
948        elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)/s)
949        {
950            $before = $1;
951            $match = $2;
952            $after = $3;
953            return &set_prot_links($cgi,$before) . &HTML::sp_link($cgi,$match) . &set_prot_links($cgi,$after);
954        }
955        elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)/s)
956        {
957            $before = $1;
958            $match = $2;
959            $after = $3;
960            return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after);
961        }
962        elsif ($x =~ /^(.*)(kegg\|[a-z]{2,4}:[a-zA-Z_0-9]+)(.*)/s)
963        {
964            $before = $1;
965            $match = $2;
966            $after = $3;
967            return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after);
968        }
969        elsif ($x =~ /^(.*)(Ensembl[a-zA-Z]+:[a-zA-Z_0-9\.]+)(.*)/s)
970        {
971            $before = $1;
972            $match = $2;
973            $after = $3;
974            return &set_prot_links($cgi,$before) . &HTML::ensembl_link($cgi,$match) . &set_prot_links($cgi,$after);
975        }
976        elsif ($x =~ /^(.*)(EntrezGene:[a-zA-Z_0-9\.]+)(.*)/s)
977        {
978            $before = $1;
979            $match = $2;
980            $after = $3;
981            return &set_prot_links($cgi,$before) . &HTML::entrezgene_link($cgi,$match) . &set_prot_links($cgi,$after);
982        }
983        elsif ($x =~ /^(.*)(MIM:[a-zA-Z_0-9\.]+)(.*)/s)
984        {
985            $before = $1;
986            $match = $2;
987            $after = $3;
988            return &set_prot_links($cgi,$before) . &HTML::mim_link($cgi,$match) . &set_prot_links($cgi,$after);
989        }
990        elsif ($x =~ /^(.*)(UniGene:[a-zA-Z_0-9\.]+)(.*)/s)
991        {
992            $before = $1;
993            $match = $2;
994            $after = $3;
995            return &set_prot_links($cgi,$before) . &HTML::unigene_link($cgi,$match) . &set_prot_links($cgi,$after);
996        }
997        elsif ($x =~ /^(.*)(IPI:[a-zA-Z_0-9\.]+)(.*)/s)
998        {
999            $before = $1;
1000            $match = $2;
1001            $after = $3;
1002            return &set_prot_links($cgi,$before) . &HTML::ipi_link($cgi,$match) . &set_prot_links($cgi,$after);
1003        }
1004        elsif ($x =~ /^(.*)(WP:[a-zA-Z_0-9\.]+)(.*)/s)
1005        {
1006            #wormbase
1007    
1008            $before = $1;
1009            $match = $2;
1010            $after = $3;
1011            return &set_prot_links($cgi,$before) . &HTML::wp_link($cgi,$match) . &set_prot_links($cgi,$after);
1012        }
1013        elsif ($x =~ /^(.*)(FB:[a-zA-Z_0-9\.]+)(.*)/s)
1014        {
1015            #flybase
1016    
1017            $before = $1;
1018            $match = $2;
1019            $after = $3;
1020            return &set_prot_links($cgi,$before) . &HTML::fb_link($cgi,$match) . &set_prot_links($cgi,$after);
1021        }
1022        elsif ($x =~ /^(.*)(FlyBaseORFNames:[a-zA-Z_0-9\.]+)(.*)/s)
1023        {
1024            #flybase
1025    
1026            $before = $1;
1027            $match = $2;
1028            $after = $3;
1029            return &set_prot_links($cgi,$before) . &HTML::fborf_link($cgi,$match) . &set_prot_links($cgi,$after);
1030        }
1031        elsif ($x =~ /^(.*)(SGD_LOCUS:[a-zA-Z_0-9\.]+)(.*)/s)
1032        {
1033            #flybase
1034    
1035            $before = $1;
1036            $match = $2;
1037            $after = $3;
1038            return &set_prot_links($cgi,$before) . &HTML::sgd_link($cgi,$match) . &set_prot_links($cgi,$after);
1039      }      }
1040      return $x;      return $x;
1041  }  }
1042    
1043    sub refseq_link {
1044        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1045        my($cgi,$id) = @_;
1046    
1047        if ($id =~ /^[NXYZA]P_/)
1048        {
1049            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id>$id</a>";
1050        }
1051        elsif ($id =~ /^[NXYZA]M_/)
1052        {
1053            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=nuccore&cmd=search&term=$id>$id</a>";
1054        }
1055    }
1056    
1057  sub gi_link {  sub gi_link {
1058        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1059      my($cgi,$gi) = @_;      my($cgi,$gi) = @_;
1060    
1061      if ($gi =~ /^gi\|(\d+)$/)      if ($gi =~ /^gi\|(\d+)$/)
# Line 516  Line 1065 
1065      return $gi;      return $gi;
1066  }  }
1067    
1068    sub tigr_link {
1069        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1070        my($cgi,$tigr) = @_;
1071    
1072        if ($tigr =~ /^tigr\|([0-9a-zA-Z]+)$/)
1073        {
1074            return "<a href=\"http://pathema.tigr.org/tigr-scripts/CMR/GenePage.cgi?locus=$1\">$tigr</a>";
1075        }
1076        return $tigr;
1077    }
1078    
1079    sub uni_link {
1080        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1081        my($cgi,$uni) = @_;
1082    
1083        if ($uni =~ /^uni\|(\S+)$/)
1084        {
1085            return "<a href=http://www.pir.uniprot.org/cgi-bin/upEntry?id=$1>$uni</a>";
1086        }
1087        return $uni;
1088    }
1089    
1090  sub sp_link {  sub sp_link {
1091        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1092      my($cgi,$sp) = @_;      my($cgi,$sp) = @_;
1093    
1094      if ($sp =~ /^sp\|(\S+)$/)      if ($sp =~ /^sp\|(\S+)$/)
# Line 527  Line 1099 
1099  }  }
1100    
1101  sub pir_link {  sub pir_link {
1102        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1103      my($cgi,$pir) = @_;      my($cgi,$pir) = @_;
1104    
1105      if ($pir =~ /^pirnr\|(NF\d+)$/)      if ($pir =~ /^pirnr\|(NF\d+)$/)
# Line 536  Line 1109 
1109      return $pir;      return $pir;
1110  }  }
1111    
1112    sub kegg_link {
1113        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1114        my($cgi,$kegg) = @_;
1115    
1116        if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)
1117        {
1118            return "<a href=http://www.genome.ad.jp/dbget-bin/www_bget?$1+$2>$kegg</a>";
1119        }
1120        return $kegg;
1121    }
1122    
1123    sub ensembl_link {
1124        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1125        my($cgi,$ensembl) = @_;
1126    
1127        if ($ensembl =~ /^(\S+):(\S+)$/)
1128        {
1129            my $what=$1;
1130            my $key=$2;
1131            my $idx="all";
1132            if ($what eq "EnsemblGene") { $idx = "Gene" }
1133            if ($what eq "EnsemblTranscript") { $idx = "all" }
1134            if ($what eq "EnsemblProtein") { $idx = "all" }
1135    
1136            #I really want to get right to the transcript and peptide pages, but
1137            #can't see how to do that without knowing the org name too, which
1138            #I don't know at this point. (ensembl org name, not real org name)
1139    
1140            return "<a href=http://www.ensembl.org/Homo_sapiens/textview?species=all&idx=$idx&q=$key>$ensembl</a>";
1141        }
1142        return $ensembl;
1143    }
1144    
1145    sub entrezgene_link {
1146        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1147        my($cgi,$entrezgene) = @_;
1148    
1149        if ($entrezgene =~ /^EntrezGene:(\S+)$/)
1150        {
1151            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=gene&cmd=Retrieve&dopt=full_report&list_uids=$1>$entrezgene</a>";
1152        }
1153        return $entrezgene;
1154    }
1155    
1156    sub mim_link {
1157        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1158        my($cgi,$mim) = @_;
1159    
1160        if ($mim =~ /^MIM:(\S+)$/)
1161        {
1162            return "<a href=http://www3.ncbi.nlm.nih.gov/entrez/dispomim.cgi?id=$1>$mim</a>";
1163        }
1164        return $mim;
1165    }
1166    
1167    sub unigene_link {
1168        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1169        my($cgi,$unigene) = @_;
1170    
1171        if ($unigene =~ /^UniGene:(\S+)$/)
1172        {
1173            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=unigene&cmd=search&term=$1>$unigene</a>";
1174        }
1175        return $unigene;
1176    }
1177    
1178    sub ipi_link {
1179        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1180        my($cgi,$ipi) = @_;
1181    
1182        if ($ipi =~ /^IPI:(\S+)$/)
1183        {
1184            return "<a href=http://srs.ebi.ac.uk/srsbin/cgi-bin/wgetz?-id+AEoS1R8Jnn+-e+[IPI:\'$1\']+-qnum+1+-enum+1>$ipi</a>";
1185        }
1186        return $ipi;
1187    }
1188    
1189    sub wp_link {
1190        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1191        my($cgi,$wp) = @_;
1192    
1193        #wormbase
1194    
1195        if ($wp =~ /^WP:(\S+)$/)
1196        {
1197            return "<a href=http://www.wormbase.org/db/searches/basic?class=Any&query=$1&Search=Search>$wp</a>";
1198        }
1199        return $wp;
1200    }
1201    
1202    sub fb_link {
1203        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1204        my($cgi,$fb) = @_;
1205    
1206        #flybase
1207    
1208        if ($fb =~ /^FB:(\S+)$/)
1209        {
1210            return "<a href=http://flybase.bio.indiana.edu/.bin/fbidq.html?$1>$fb</a>";
1211        }
1212        return $fb;
1213    }
1214    
1215    sub fborf_link {
1216        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1217        my($cgi,$fb) = @_;
1218    
1219        #flybase
1220    
1221        if ($fb =~ /^FlyBaseORFNames:(\S+)$/)
1222        {
1223            return "<a href=http://flybase.bio.indiana.edu/.bin/fbidq.html?$1>$fb</a>";
1224        }
1225        return $fb;
1226    }
1227    
1228    sub sgd_link {
1229        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1230        my($cgi,$sgd) = @_;
1231    
1232        #yeast
1233    
1234        if ($sgd =~ /^SGD_LOCUS:(\S+)$/)
1235        {
1236            return "<a href=http://db.yeastgenome.org/cgi-bin/locus.pl?locus=$1>$sgd</a>";
1237        }
1238        return $sgd;
1239    }
1240    
1241    
1242    
1243    
1244    sub set_map_links {
1245        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1246        my($cgi,$x) = @_;
1247        my($before,$match,$after);
1248    
1249        my $org = ($cgi->param('org') || $cgi->param('genome') || "");
1250    
1251        if ($x =~ /^(.*)(MAP\d+)(.*)/s)
1252        {
1253            $before = $1;
1254            $match = $2;
1255            $after = $3;
1256            return &set_map_links($cgi,$before) . &map_link($cgi,$match,$org) . &set_map_links($cgi,$after);
1257        }
1258        return $x;
1259    }
1260    
1261    
1262    
1263    sub map_link {
1264        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1265        my($cgi,$map,$org) = @_;
1266    
1267        $user = $cgi->param('user');
1268        $user = $user ? $user : "";
1269        $org = $org ? $org : "";
1270    
1271        my $url = "show_kegg_map.cgi?user=$user&map=$map&org=$org";
1272    #rel    my $url = &FIG::cgi_url() . "/show_kegg_map.cgi?user=$user&map=$map&org=$org";
1273        my $link = "<a href=\"$url\">$map</a>";
1274        return $link;
1275    }
1276    
1277    sub java_buttons {
1278        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1279      ## ADDED BY RAE
1280      # Provides code to include check all/first half/second half/none for javascrspt
1281      # this takes two variables - the form name provided in start_form with the
1282      # -name => field and the checkbox name
1283      my ($form, $button)=@_;
1284    
1285      $java_script="<input type=\"button\" name=\"CheckAll\" value=\"Check All\"\nonClick=\"checkAll(document.$form.$button)\">\n";
1286      $java_script.="<input type=\"button\" name=\"CheckFirst\" value=\"Check First Half\"\nonClick=\"checkFirst(document.$form.$button)\">\n";
1287      $java_script.="<input type=\"button\" name=\"CheckSecond\" value=\"Check Second Half\"\nonClick=\"checkSecond(document.$form.$button)\">\n";
1288      $java_script.="<input type=\"button\" name=\"UnCheckAll\" value=\"Uncheck All\"\nonClick=\"uncheckAll(document.$form.$button)\">\n";
1289    
1290      return $java_script;
1291    }
1292    
1293    sub sub_link {
1294        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1295        my($cgi,$sub) = @_;
1296        my($sub_link);
1297    
1298        my $user = $cgi->param('user');
1299        if ($user)
1300        {
1301            my $esc_sub = uri_escape( $sub );
1302            $sub_link = "<a href=./subsys.cgi?ssa_name=$esc_sub&request=show_ssa&user=$user>$sub</a>";
1303        }
1304        else
1305        {
1306            $sub_link = $sub;
1307        }
1308        return $sub_link;
1309    }
1310    
1311    sub reaction_link {
1312        my($reaction) = @_;
1313    
1314        if ($reaction =~ /^R\d+/)
1315        {
1316            return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?rn+$reaction\" target=reaction$$>$reaction</a>";
1317        }
1318        return $reaction;
1319    }
1320    
1321    sub html_for_assignments {
1322        my($fig,$user,$peg_sets) = @_;
1323        my $i;
1324    
1325        my @vals = ();
1326        my $set = 1;
1327        foreach $peg_set (@$peg_sets)
1328        {
1329            for ($i=0; ($i < @$peg_set); $i++)
1330            {
1331                $peg = $peg_set->[$i];
1332                push(@vals,'show=' . join("@",($set,$i+1,$peg,&FIG::abbrev($fig->org_of($peg)),"")));
1333            }
1334            $set++;
1335        }
1336    
1337        $ENV{'REQUEST_METHOD'} = 'GET';
1338        $ENV{'QUERY_STRING'} = join('&',('request=show_commentary',"uni=1","user=$user",@vals));
1339        my $out = join("",`$FIG_Config::fig/CGI/chromosomal_clusters.cgi`);
1340        $out =~ s/^.*?<form/<form/si;
1341        $out =~ s/^(.*)<table.*/$1/si;
1342        return $out;
1343    }
1344    
1345    =head1 rss_feed
1346    
1347    Add something to the RSS feed. The rss feeds are stored in the Html directory, and there are several RSS feeds:
1348            SEED.rss                - everything gets written here
1349            SEEDgenomes.rss                 - whenever a genome is added to the SEED
1350            SEEDsubsystems.rss      - whenever a subsystem is edited (or should this be added?)
1351    
1352    
1353    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.
1354    
1355    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.
1356    
1357    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.
1358    
1359    The has can have these keys:
1360    
1361    REQUIRED:
1362    title       : the title. This is usually what is seen by the user in the pull down menu
1363    description : a more complete description that is often seen is rss viewers but not always
1364    link        : link to the item that was added/edited
1365    All other keys are treated as optional RSS arguments and written to the file.
1366    
1367    At most, $max_entries recent entries are stored in the rss file, and this is currently 50.
1368    
1369    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.
1370    
1371    
1372    =cut
1373    
1374    sub rss_feed {
1375     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1376     my ($files, $args)=@_;
1377    
1378     # how many entries to store in the file
1379     my $max_entries=50;
1380    
1381     foreach my $a (keys %$args) {if ($a =~ /^-(.*)/) {my $b=$1; $args->{$b}=$args->{$a}; delete $args->{$a}}}
1382    
1383     my $filepath=$FIG_Config::fig."/CGI/Html/rss";
1384     # check for the directory and if not, make it
1385     mkdir $filepath unless (-d $filepath);
1386    
1387     # note that $info is a hash of references to hashes that are written out as headers in the file
1388     my $info=
1389     {
1390      "SEED.rss" =>
1391       {
1392            title           => "The SEED",
1393            description     => "Latest news from the SEED",
1394            link            => "Html/rss/SEED.rss",
1395       },
1396    
1397      "SEEDsubsystems.rss" =>
1398      {
1399            title           => "SEED Subsystems",
1400            description     => "Recently updated SEED subsystems",
1401            link            => "Html/rss/SEEDsubsystems.rss",
1402      },
1403    
1404      "SEEDsubsystems.rss" =>
1405      {
1406            title           => "SEED Genomes",
1407            description     => "Genomes recently added to the SEED",
1408            link            => &FIG::cgi_url()."/Html/rss/SEEDsubsystems.rss",
1409      },
1410    
1411     };
1412    
1413    
1414     # build the new xml
1415     my $xml = "\t<item>\n";
1416     foreach my $qw ("title", "description", "link") {
1417      unless ($args->{$qw}) {
1418       print STDERR "You need to include a $qw tag in your RSS description\n";
1419       return(0);
1420      }
1421      # we need to do something a bit funky with the link. We can't have ampersands in the <link> </link> in valid html
1422      # so we are going to pull out the links and uri_escape just the part after the .cgi
1423      if ($qw eq "link")
1424      {
1425       $args->{$qw} =~ /^(.*?\.cgi.)(.*)$/;
1426       $args->{$qw} = $1.uri_escape($2) if ($1 && $2);
1427      }
1428    
1429      $xml .= "\t\t<$qw>".$args->{$qw}."</$qw>\n";
1430      delete $args->{$qw};
1431     }
1432    
1433     foreach my $tag (grep {!/type/i} keys %$args)
1434     {
1435      $xml .= "\t\t<$tag>".$args->{$tag}."</$tag>\n";
1436     }
1437    
1438     $xml .= "\t</item>\n";
1439    
1440    
1441     my @files=("SEED.rss");
1442     if ($args->{"type"}) {push @files, "SEED.$type.rss"}
1443    
1444     foreach my $file ("SEED.rss", @$files)
1445     {
1446      if (-e "$filepath/$file")
1447      {
1448       my @out; # the new content of the file
1449       my $itemcount=0; # how many <item> </item>'s are we keeping
1450       my $initem; # are we in an item?
1451       open(IN, "$filepath/$file") || die "Can't open $filepath/$file";
1452       while (<IN>)
1453       {
1454        if (/\<item\>/) {
1455         push @out, $xml, unless ($itemcount);
1456         $itemcount++;
1457         $initem=1;
1458        }
1459        if (/\<\/item\>/) {$initem=0; next if ($itemcount > $max_entries)}
1460        next if ($initem && $itemcount > $max_entries);
1461        push @out, $_;
1462       }
1463       close IN;
1464       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1465       print OUT @out;
1466      }
1467      else
1468      {
1469       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1470       print OUT "<?xml version=\"1.0\"?>\n<rss version=\"2.0\">\n<channel>\n";
1471       if ($info->{$file})
1472       {
1473         # we're going to sanity check each of the three options we output, just to be sure
1474         foreach my $qw ("title", "description", "link")
1475         {
1476           if ($info->{$file}->{$qw})
1477           {
1478              print OUT "<$qw>", $info->{$file}->{$qw}, "</$qw>\n";
1479           } else {
1480              print STDERR "Please add a $qw for $file\n"; print OUT "<$qw>$file</$qw>\n";
1481           }
1482         }
1483       }
1484       else {
1485        print STDERR "Please define title, link, and description information for $file\n";
1486        print OUT "<title>$file</title>\n<description>An RSS feed</description>\n<link>", &FIG::cgi_url, "</link>\n";
1487       }
1488       print OUT "\n", $xml;
1489       print OUT "\n", "</channel>\n</rss>\n"
1490      }
1491     }
1492    }
1493    
1494    
1495    
1496    1;
1497    
 1  

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.71

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3