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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3