[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.72, Mon Dec 5 19:06:30 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        push( @tab, "\n<table $border $width>\n",
525                  "\t<caption><b>$title</b></caption>\n",                  "\t<caption><b>$title</b></caption>\n",
526                  "\t<tr>\n\t\t<th>"                  "\t<tr>\n\t\t"
527                . join( "</th>\n\t\t<th>", @$col_hdrs )                . join( "\n", map { &expand($_, "th") } @$col_hdrs )
528                . "</th>\n\t</tr>\n"                . "\n\t</tr>\n"
529          );          );
530      my($i,$nowrap);      my($i);
   
     for ($i=0; ($i < @$instr) && ($instr->[$i] !~ /nowrap/); $i++) {}  
     $nowrap = ($i == @$instr) ? "" : " nowrap";  
531    
532      my $row;      my $row;
533      foreach $row (@$tab)      foreach $row (@$tab)
534      {      {
535          push( @tab, "\t<tr>\n"          push( @tab, "\t<tr>\n"
536                    . join( "\n", map { &expand($_,$nowrap) } @$row )                    . join( "\n", map { &expand($_) } @$row )
537                    . "\n\t</tr>\n"                    . "\n\t</tr>\n"
538              );              );
539      }      }
# Line 286  Line 542 
542  }  }
543    
544  sub expand {  sub expand {
545      my($x,$nowrap) = @_;      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
546        my( $x, $tag ) = @_;
547    
548        $tag = "td" unless $tag;
549        my $endtag = $tag;
550    
551        # RAE modified this so that you can pass in a reference to an array where
552        # the first element is the data to display and the second element is optional
553        # things like colspan and align. Note that in this case you need to include the td
554        # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]
555    
556      if ($x =~ /^\@([^:]+)\:([^:]+)\:(.*)$/)      # per GJO's request modified this line so it can take any tag.
557        if ( ref($x) eq "ARRAY" ) { ($x, $tag) = @$x; $tag =~ /^(\S+)/; $endtag = $1 }
558    
559        if ( $x =~ /^\@([^:]+)\:(.*)$/ )
560      {      {
561          return "\t\t<td$nowrap $1=\"$2\">$3</td>";          return "\t\t<$tag $1>$2</$endtag>";
562      }      }
563      else      else
564      {      {
565          return "\t\t<td$nowrap>$x</td>";          return "\t\t<$tag>$x</$endtag>";
566        }
567    }
568    
569    
570    =head2 merge_table_rows()
571    
572    Merge table rows together. This will merge a table so that adjacent cells with the same content will only be shown once.
573    
574    Something like this:
575    
576        -----------------------
577        |    1     |    a     |
578        -----------------------
579        |    1     |    b     |
580        -----------------------
581        |    2     |    c     |
582        -----------------------
583        |    3     |    d     |
584        -----------------------
585        |    4     |    d     |
586        -----------------------
587        |    5     |    d     |
588        -----------------------
589    
590    Will become:
591    
592        -----------------------
593        |          |    a     |
594        |    1     |-----------
595        |          |    b     |
596        -----------------------
597        |    2     |    c     |
598        -----------------------
599        |    3     |          |
600        ------------          |
601        |    4     |    5     |
602        ------------          |
603        |    5     |          |
604        -----------------------
605    
606    
607    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.
608    
609     $tab=&HTML::merge_table_rows($tab);
610    
611     or
612    
613     $skip=(1=>1, 3=>1, 5=>1);
614     $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
615    
616    
617    =cut
618    
619    
620    
621    
622    sub merge_table_rows {
623     # RAE:
624     # Experimental piece of code. We often want to have rows or columns were cells are merged. It just looks so much nicer
625     # this block should merge adjacent rows that have the same text in them.
626     # use like this:
627     #      $tab=&HTML::merge_table_rows($tab);
628     # before you do a make_table call
629    
630     my $self=shift if UNIVERSAL::isa($_[0],__PACKAGE__);
631     my ($tab, $skip)=@_;
632    
633     my $newtable;
634     my $lastrow;
635     my $rowspan;
636     my $refs;
637    
638     for (my $y=0; $y <= $#$tab; $y++) {
639     #$y is the row in the table;
640      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
641       # this is the user definable columns not to merge
642       if ($skip->{$x})
643       {
644        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
645        next;
646       }
647    
648       #$x is the column in the table
649       # if the column in the row we are looking at is the same as the column in the previous row, we don't add
650       # this cell to $newtable. Instead we increment the rowspan of the previous row by one
651    
652       # handle cells that are references to arrays
653       if (ref($tab->[$y]->[$x]) eq "ARRAY") {$refs->[$y]->[$x]=$tab->[$y]->[$x]->[1]; $tab->[$y]->[$x]=$tab->[$y]->[$x]->[0]}
654    
655       # now we go back through the table looking where to draw the merge line:
656       my $lasty=$y;
657       while ($lasty >= 0 && $tab->[$y]->[$x] eq $tab->[$lasty]->[$x]) {$lasty--}
658       $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
659       if ($lasty == $y) {
660        # we always want to have something in rows that may otherwise be empty but should be there (see below)
661        unless ($tab->[$y]->[$x]) {$tab->[$y]->[$x]=" &nbsp; "}
662        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
663       }
664       else {$rowspan->[$lasty]->[$x]++}
665      }
666     }
667    
668     # now just join everything back together
669     for (my $y=0; $y <= $#$tab; $y++) {
670      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
671       if ($rowspan->[$y]->[$x]) {
672        if ($refs->[$y]->[$x]) {$refs->[$y]->[$x] .= " rowspan=". ($rowspan->[$y]->[$x]+1)}
673        else {$refs->[$y]->[$x] = "td rowspan=". ($rowspan->[$y]->[$x]+1)}
674        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
675       }
676       elsif ($newtable->[$y]->[$x] && $refs->[$y]->[$x]) {
677        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
678       }
679      }
680     }
681    
682    
683     # finally we have to remove any completely empty cells that have been added by the array mechanism
684     # (e.g. if you define $a->[2] then $a->[0] and $a->[1] are now undef).
685     # that is why in the loop above I replace empty cells with nbsp. They are now not undef!
686     # I am sure that Gary can do this in one line, but I am hacking.
687     my @trimmed;
688     foreach my $a (@$newtable) {
689      my @row;
690      foreach my $b (@$a) {
691       push @row, $b if ($b);
692      }
693      push @trimmed, \@row;
694     }
695    
696     return \@trimmed;
697    }
698    
699    
700    
701    
702    sub set_ec_links {
703        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
704        my($cgi,$x) = @_;
705        my($before,$match,$after);
706    
707        if ($x =~ /^(.*)(EC \d+\.\d+\.\d+\.\d+)(.*)/s)
708        {
709            $before = $1;
710            $match = $2;
711            $after = $3;
712            return &set_ec_links($cgi,$before) . &HTML::ec_link($match) . &set_ec_links($cgi,$after);
713      }      }
714        return $x;
715  }  }
716    
717  sub ec_link {  sub ec_link {
718        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
719      my($role) = @_;      my($role) = @_;
720    
721      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)
# Line 312  Line 729 
729  }  }
730    
731  sub role_link {  sub role_link {
732        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
733      my($cgi,$role) = @_;      my($cgi,$role) = @_;
734    
735      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 740 
740      return "<a href=$link>$role</a>";      return "<a href=$link>$role</a>";
741  }  }
742    
743    #
744    # Local means to eliminate the fig|org.peg from the
745    # text of the link.
746    #
747  sub fid_link {  sub fid_link {
748        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
749      my($cgi,$fid,$local,$just_url) = @_;      my($cgi,$fid,$local,$just_url) = @_;
750      my($n);      my($n);
751    
752        my $top = top_link();
753    
754      if ($fid =~ /^fig\|\d+\.\d+\.([a-z]+)\.(\d+)/)      if ($fid =~ /^fig\|\d+\.\d+\.([a-z]+)\.(\d+)/)
755      {      {
756          if ($local)          if ($local)
# Line 343  Line 768 
768          {          {
769              $n = $fid;              $n = $fid;
770          }          }
771          if ($1 ne "peg") { return $n }  
772            my $link;
773            #added to format prophage and path island links to feature.cgi
774            if ($1 ne "peg")
775            {
776               my $user = $cgi->param('user');
777               if (! $user) { $user = "" }
778               my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
779               $link = "$top/feature.cgi?feature=$fid&user=$user$trans$sprout";
780               $link =~ s/[a-z_A-Z0-9]+\.cgi\?/feature.cgi?/;
781            }
782            else
783            {
784          my $user = $cgi->param('user');          my $user = $cgi->param('user');
785          if (! $user) { $user = "" }          if (! $user) { $user = "" }
786          my $trans = $cgi->param('translate') ? "&translate=1" : "";          my $trans = $cgi->param('translate') ? "&translate=1" : "";
787          my $link = $cgi->url() . "?prot=$fid&user=$user$trans";              my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
788          $link =~ s/[a-z_A-Z]+\.cgi\?/protein.cgi?/;  ###a
789    
790    ### This used to be
791    ###     my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
792    ###
793    ### The cost became prohibitive in the subsystem spreadsheets.  Hence, we cache the value
794    ###
795    ### RAO
796    
797                #if (! $cgi_url) { $cgi_url = &FIG::cgi_url }
798                #$link = $cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
799                $link = "$top/protein.cgi?prot=$fid&user=$user$trans$sprout";
800                $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
801            }
802          if ($just_url)          if ($just_url)
803          {          {
804              return $link;              return $link;
# Line 362  Line 812 
812  }  }
813    
814  sub family_link {  sub family_link {
815        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
816      my($family,$user) = @_;      my($family,$user) = @_;
817    
818      return $family;      return $family;
819  }  }
820    
 use URI::Escape;  
821    
822  sub get_html {  sub get_html {
823        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
824      my( $url, $type, $kv_pairs) = @_;      my( $url, $type, $kv_pairs) = @_;
825      my( $encoded, $ua, $args, @args, $out, @output, $x );      my( $encoded, $ua, $args, @args, $out, @output, $x );
826    
827      $ua = new LWP::UserAgent;      $ua = new LWP::UserAgent;
828      $ua->timeout( 900 );      $ua->timeout( 900 );
   
829      if ($type =~/post/i)      if ($type =~/post/i)
830      {      {
831          $args = [];          $args = [];
# Line 435  Line 885 
885  }  }
886    
887  sub trim_output {  sub trim_output {
888        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
889      my($out) = @_;      my($out) = @_;
890      my $i;      my $i;
891    
# Line 472  Line 923 
923  }  }
924    
925  sub set_prot_links {  sub set_prot_links {
926        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
927      my($cgi,$x) = @_;      my($cgi,$x) = @_;
928      my($before,$match,$after);      my($before,$match,$after);
929    
930      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)$/)      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)/s)
931        {
932            $before = $1;
933            $match = $2;
934            $after = $3;
935            return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after);
936        }
937        elsif ($x =~ /^(.*)\b([NXYZA][PM]_[0-9\.]+)\b(.*)/s)
938        {
939            $before = $1;
940            $match = $2;
941            $after = $3;
942            return &set_prot_links($cgi,$before) . &HTML::refseq_link($cgi,$match) . &set_prot_links($cgi,$after);
943        }
944        elsif ($x =~ /^(.*)(gi\|\d+)(.*)/s)
945        {
946            $before = $1;
947            $match = $2;
948            $after = $3;
949            return &set_prot_links($cgi,$before) . &HTML::gi_link($cgi,$match) . &set_prot_links($cgi,$after);
950        }
951        elsif ($x =~ /^(.*)(tigr\|[0-9a-zA-Z]+)(.*)/s)
952        {
953            $before = $1;
954            $match = $2;
955            $after = $3;
956            return &set_prot_links($cgi,$before) . &HTML::tigr_link($cgi,$match) . &set_prot_links($cgi,$after);
957        }
958        elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
959        {
960            $before = $1;
961            $match = $2;
962            $after = $3;
963            return &set_prot_links($cgi,$before) . &HTML::uni_link($cgi,$match) . &set_prot_links($cgi,$after);
964        }
965        elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)/s)
966        {
967            $before = $1;
968            $match = $2;
969            $after = $3;
970            return &set_prot_links($cgi,$before) . &HTML::sp_link($cgi,$match) . &set_prot_links($cgi,$after);
971        }
972        elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)/s)
973        {
974            $before = $1;
975            $match = $2;
976            $after = $3;
977            return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after);
978        }
979        elsif ($x =~ /^(.*)(kegg\|[a-z]{2,4}:[a-zA-Z_0-9]+)(.*)/s)
980        {
981            $before = $1;
982            $match = $2;
983            $after = $3;
984            return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after);
985        }
986        elsif ($x =~ /^(.*)(Ensembl[a-zA-Z]+:[a-zA-Z_0-9\.]+)(.*)/s)
987      {      {
988          $before = $1;          $before = $1;
989          $match = $2;          $match = $2;
990          $after = $3;          $after = $3;
991          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);
992      }      }
993      elsif ($x =~ /^(.*)(gi\|\d+)(.*)$/)      elsif ($x =~ /^(.*)(EntrezGene:[a-zA-Z_0-9\.]+)(.*)/s)
994      {      {
995          $before = $1;          $before = $1;
996          $match = $2;          $match = $2;
997          $after = $3;          $after = $3;
998          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);
999      }      }
1000      elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)$/)      elsif ($x =~ /^(.*)(MIM:[a-zA-Z_0-9\.]+)(.*)/s)
1001      {      {
1002          $before = $1;          $before = $1;
1003          $match = $2;          $match = $2;
1004          $after = $3;          $after = $3;
1005          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);
1006      }      }
1007      elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)$/)      elsif ($x =~ /^(.*)(UniGene:[a-zA-Z_0-9\.]+)(.*)/s)
1008      {      {
1009          $before = $1;          $before = $1;
1010          $match = $2;          $match = $2;
1011          $after = $3;          $after = $3;
1012          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);
1013        }
1014        elsif ($x =~ /^(.*)(IPI:[a-zA-Z_0-9\.]+)(.*)/s)
1015        {
1016            $before = $1;
1017            $match = $2;
1018            $after = $3;
1019            return &set_prot_links($cgi,$before) . &HTML::ipi_link($cgi,$match) . &set_prot_links($cgi,$after);
1020        }
1021        elsif ($x =~ /^(.*)(WP:[a-zA-Z_0-9\.]+)(.*)/s)
1022        {
1023            #wormbase
1024    
1025            $before = $1;
1026            $match = $2;
1027            $after = $3;
1028            return &set_prot_links($cgi,$before) . &HTML::wp_link($cgi,$match) . &set_prot_links($cgi,$after);
1029        }
1030        elsif ($x =~ /^(.*)(FB:[a-zA-Z_0-9\.]+)(.*)/s)
1031        {
1032            #flybase
1033    
1034            $before = $1;
1035            $match = $2;
1036            $after = $3;
1037            return &set_prot_links($cgi,$before) . &HTML::fb_link($cgi,$match) . &set_prot_links($cgi,$after);
1038        }
1039        elsif ($x =~ /^(.*)(FlyBaseORFNames:[a-zA-Z_0-9\.]+)(.*)/s)
1040        {
1041            #flybase
1042    
1043            $before = $1;
1044            $match = $2;
1045            $after = $3;
1046            return &set_prot_links($cgi,$before) . &HTML::fborf_link($cgi,$match) . &set_prot_links($cgi,$after);
1047        }
1048        elsif ($x =~ /^(.*)(SGD_LOCUS:[a-zA-Z_0-9\.]+)(.*)/s)
1049        {
1050            #flybase
1051    
1052            $before = $1;
1053            $match = $2;
1054            $after = $3;
1055            return &set_prot_links($cgi,$before) . &HTML::sgd_link($cgi,$match) . &set_prot_links($cgi,$after);
1056      }      }
1057      return $x;      return $x;
1058  }  }
1059    
1060    sub refseq_link {
1061        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1062        my($cgi,$id) = @_;
1063    
1064        if ($id =~ /^[NXYZA]P_/)
1065        {
1066            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id>$id</a>";
1067        }
1068        elsif ($id =~ /^[NXYZA]M_/)
1069        {
1070            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=nuccore&cmd=search&term=$id>$id</a>";
1071        }
1072    }
1073    
1074  sub gi_link {  sub gi_link {
1075        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1076      my($cgi,$gi) = @_;      my($cgi,$gi) = @_;
1077    
1078      if ($gi =~ /^gi\|(\d+)$/)      if ($gi =~ /^gi\|(\d+)$/)
# Line 516  Line 1082 
1082      return $gi;      return $gi;
1083  }  }
1084    
1085    sub tigr_link {
1086        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1087        my($cgi,$tigr) = @_;
1088    
1089        if ($tigr =~ /^tigr\|([0-9a-zA-Z]+)$/)
1090        {
1091            return "<a href=\"http://pathema.tigr.org/tigr-scripts/CMR/GenePage.cgi?locus=$1\">$tigr</a>";
1092        }
1093        return $tigr;
1094    }
1095    
1096    sub uni_link {
1097        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1098        my($cgi,$uni) = @_;
1099    
1100        if ($uni =~ /^uni\|(\S+)$/)
1101        {
1102            return "<a href=http://www.pir.uniprot.org/cgi-bin/upEntry?id=$1>$uni</a>";
1103        }
1104        return $uni;
1105    }
1106    
1107  sub sp_link {  sub sp_link {
1108        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1109      my($cgi,$sp) = @_;      my($cgi,$sp) = @_;
1110    
1111      if ($sp =~ /^sp\|(\S+)$/)      if ($sp =~ /^sp\|(\S+)$/)
# Line 527  Line 1116 
1116  }  }
1117    
1118  sub pir_link {  sub pir_link {
1119        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1120      my($cgi,$pir) = @_;      my($cgi,$pir) = @_;
1121    
1122      if ($pir =~ /^pirnr\|(NF\d+)$/)      if ($pir =~ /^pirnr\|(NF\d+)$/)
# Line 536  Line 1126 
1126      return $pir;      return $pir;
1127  }  }
1128    
1129    sub kegg_link {
1130        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1131        my($cgi,$kegg) = @_;
1132    
1133        if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)
1134        {
1135            return "<a href=http://www.genome.ad.jp/dbget-bin/www_bget?$1+$2>$kegg</a>";
1136        }
1137        return $kegg;
1138    }
1139    
1140    sub ensembl_link {
1141        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1142        my($cgi,$ensembl) = @_;
1143    
1144        if ($ensembl =~ /^(\S+):(\S+)$/)
1145        {
1146            my $what=$1;
1147            my $key=$2;
1148            my $idx="all";
1149            if ($what eq "EnsemblGene") { $idx = "Gene" }
1150            if ($what eq "EnsemblTranscript") { $idx = "all" }
1151            if ($what eq "EnsemblProtein") { $idx = "all" }
1152    
1153            #I really want to get right to the transcript and peptide pages, but
1154            #can't see how to do that without knowing the org name too, which
1155            #I don't know at this point. (ensembl org name, not real org name)
1156    
1157            return "<a href=http://www.ensembl.org/Homo_sapiens/textview?species=all&idx=$idx&q=$key>$ensembl</a>";
1158        }
1159        return $ensembl;
1160    }
1161    
1162    sub entrezgene_link {
1163        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1164        my($cgi,$entrezgene) = @_;
1165    
1166        if ($entrezgene =~ /^EntrezGene:(\S+)$/)
1167        {
1168            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=gene&cmd=Retrieve&dopt=full_report&list_uids=$1>$entrezgene</a>";
1169        }
1170        return $entrezgene;
1171    }
1172    
1173    sub mim_link {
1174        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1175        my($cgi,$mim) = @_;
1176    
1177        if ($mim =~ /^MIM:(\S+)$/)
1178        {
1179            return "<a href=http://www3.ncbi.nlm.nih.gov/entrez/dispomim.cgi?id=$1>$mim</a>";
1180        }
1181        return $mim;
1182    }
1183    
1184    sub unigene_link {
1185        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1186        my($cgi,$unigene) = @_;
1187    
1188        if ($unigene =~ /^UniGene:(\S+)$/)
1189        {
1190            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=unigene&cmd=search&term=$1>$unigene</a>";
1191        }
1192        return $unigene;
1193    }
1194    
1195    sub ipi_link {
1196        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1197        my($cgi,$ipi) = @_;
1198    
1199        if ($ipi =~ /^IPI:(\S+)$/)
1200        {
1201            return "<a href=http://srs.ebi.ac.uk/srsbin/cgi-bin/wgetz?-id+AEoS1R8Jnn+-e+[IPI:\'$1\']+-qnum+1+-enum+1>$ipi</a>";
1202        }
1203        return $ipi;
1204    }
1205    
1206    sub wp_link {
1207        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1208        my($cgi,$wp) = @_;
1209    
1210        #wormbase
1211    
1212        if ($wp =~ /^WP:(\S+)$/)
1213        {
1214            return "<a href=http://www.wormbase.org/db/searches/basic?class=Any&query=$1&Search=Search>$wp</a>";
1215        }
1216        return $wp;
1217    }
1218    
1219    sub fb_link {
1220        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1221        my($cgi,$fb) = @_;
1222    
1223        #flybase
1224    
1225        if ($fb =~ /^FB:(\S+)$/)
1226        {
1227            return "<a href=http://flybase.bio.indiana.edu/.bin/fbidq.html?$1>$fb</a>";
1228        }
1229        return $fb;
1230    }
1231    
1232    sub fborf_link {
1233        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1234        my($cgi,$fb) = @_;
1235    
1236        #flybase
1237    
1238        if ($fb =~ /^FlyBaseORFNames:(\S+)$/)
1239        {
1240            return "<a href=http://flybase.bio.indiana.edu/.bin/fbidq.html?$1>$fb</a>";
1241        }
1242        return $fb;
1243    }
1244    
1245    sub sgd_link {
1246        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1247        my($cgi,$sgd) = @_;
1248    
1249        #yeast
1250    
1251        if ($sgd =~ /^SGD_LOCUS:(\S+)$/)
1252        {
1253            return "<a href=http://db.yeastgenome.org/cgi-bin/locus.pl?locus=$1>$sgd</a>";
1254        }
1255        return $sgd;
1256    }
1257    
1258    
1259    
1260    
1261    sub set_map_links {
1262        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1263        my($cgi,$x) = @_;
1264        my($before,$match,$after);
1265    
1266        my $org = ($cgi->param('org') || $cgi->param('genome') || "");
1267    
1268        if ($x =~ /^(.*)(MAP\d+)(.*)/s)
1269        {
1270            $before = $1;
1271            $match = $2;
1272            $after = $3;
1273            return &set_map_links($cgi,$before) . &map_link($cgi,$match,$org) . &set_map_links($cgi,$after);
1274        }
1275        return $x;
1276    }
1277    
1278    
1279    
1280    sub map_link {
1281        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1282        my($cgi,$map,$org) = @_;
1283    
1284        $user = $cgi->param('user');
1285        $user = $user ? $user : "";
1286        $org = $org ? $org : "";
1287    
1288        my $url = "show_kegg_map.cgi?user=$user&map=$map&org=$org";
1289    #rel    my $url = &FIG::cgi_url() . "/show_kegg_map.cgi?user=$user&map=$map&org=$org";
1290        my $link = "<a href=\"$url\">$map</a>";
1291        return $link;
1292    }
1293    
1294    sub java_buttons {
1295        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1296      ## ADDED BY RAE
1297      # Provides code to include check all/first half/second half/none for javascrspt
1298      # this takes two variables - the form name provided in start_form with the
1299      # -name => field and the checkbox name
1300      my ($form, $button)=@_;
1301    
1302      $java_script="<input type=\"button\" name=\"CheckAll\" value=\"Check All\"\nonClick=\"checkAll(document.$form.$button)\">\n";
1303      $java_script.="<input type=\"button\" name=\"CheckFirst\" value=\"Check First Half\"\nonClick=\"checkFirst(document.$form.$button)\">\n";
1304      $java_script.="<input type=\"button\" name=\"CheckSecond\" value=\"Check Second Half\"\nonClick=\"checkSecond(document.$form.$button)\">\n";
1305      $java_script.="<input type=\"button\" name=\"UnCheckAll\" value=\"Uncheck All\"\nonClick=\"uncheckAll(document.$form.$button)\">\n";
1306    
1307      return $java_script;
1308    }
1309    
1310    sub sub_link {
1311        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1312        my($cgi,$sub) = @_;
1313        my($sub_link);
1314    
1315        my $user = $cgi->param('user');
1316        if ($user)
1317        {
1318            my $esc_sub = uri_escape( $sub );
1319            $sub_link = "<a href=./subsys.cgi?ssa_name=$esc_sub&request=show_ssa&user=$user>$sub</a>";
1320        }
1321        else
1322        {
1323            $sub_link = $sub;
1324        }
1325        return $sub_link;
1326    }
1327    
1328    sub reaction_link {
1329        my($reaction) = @_;
1330    
1331        if ($reaction =~ /^R\d+/)
1332        {
1333            return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?rn+$reaction\" target=reaction$$>$reaction</a>";
1334        }
1335        return $reaction;
1336    }
1337    
1338    sub html_for_assignments {
1339        my($fig,$user,$peg_sets) = @_;
1340        my $i;
1341    
1342        my @vals = ();
1343        my $set = 1;
1344        foreach $peg_set (@$peg_sets)
1345        {
1346            for ($i=0; ($i < @$peg_set); $i++)
1347            {
1348                $peg = $peg_set->[$i];
1349                push(@vals,'show=' . join("@",($set,$i+1,$peg,&FIG::abbrev($fig->org_of($peg)),"")));
1350            }
1351            $set++;
1352        }
1353    
1354        $ENV{'REQUEST_METHOD'} = 'GET';
1355        $ENV{'QUERY_STRING'} = join('&',('request=show_commentary',"uni=1","user=$user",@vals));
1356        my $out = join("",`$FIG_Config::fig/CGI/chromosomal_clusters.cgi`);
1357        $out =~ s/^.*?<form/<form/si;
1358        $out =~ s/^(.*)<table.*/$1/si;
1359        return $out;
1360    }
1361    
1362    =head1 rss_feed
1363    
1364    Add something to the RSS feed. The rss feeds are stored in the Html directory, and there are several RSS feeds:
1365            SEED.rss                - everything gets written here
1366            SEEDgenomes.rss                 - whenever a genome is added to the SEED
1367            SEEDsubsystems.rss      - whenever a subsystem is edited (or should this be added?)
1368    
1369    
1370    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.
1371    
1372    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.
1373    
1374    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.
1375    
1376    The has can have these keys:
1377    
1378    REQUIRED:
1379    title       : the title. This is usually what is seen by the user in the pull down menu
1380    description : a more complete description that is often seen is rss viewers but not always
1381    link        : link to the item that was added/edited
1382    All other keys are treated as optional RSS arguments and written to the file.
1383    
1384    At most, $max_entries recent entries are stored in the rss file, and this is currently 50.
1385    
1386    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.
1387    
1388    
1389    =cut
1390    
1391    sub rss_feed {
1392     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1393     my ($files, $args)=@_;
1394    
1395     # how many entries to store in the file
1396     my $max_entries=50;
1397    
1398     foreach my $a (keys %$args) {if ($a =~ /^-(.*)/) {my $b=$1; $args->{$b}=$args->{$a}; delete $args->{$a}}}
1399    
1400     my $filepath=$FIG_Config::fig."/CGI/Html/rss";
1401     # check for the directory and if not, make it
1402     mkdir $filepath unless (-d $filepath);
1403    
1404     # note that $info is a hash of references to hashes that are written out as headers in the file
1405     my $info=
1406     {
1407      "SEED.rss" =>
1408       {
1409            title           => "The SEED",
1410            description     => "Latest news from the SEED",
1411            link            => "Html/rss/SEED.rss",
1412       },
1413    
1414      "SEEDsubsystems.rss" =>
1415      {
1416            title           => "SEED Subsystems",
1417            description     => "Recently updated SEED subsystems",
1418            link            => "Html/rss/SEEDsubsystems.rss",
1419      },
1420    
1421      "SEEDsubsystems.rss" =>
1422      {
1423            title           => "SEED Genomes",
1424            description     => "Genomes recently added to the SEED",
1425            link            => &FIG::cgi_url()."/Html/rss/SEEDsubsystems.rss",
1426      },
1427    
1428     };
1429    
1430    
1431     # build the new xml
1432     my $xml = "\t<item>\n";
1433     foreach my $qw ("title", "description", "link") {
1434      unless ($args->{$qw}) {
1435       print STDERR "You need to include a $qw tag in your RSS description\n";
1436       return(0);
1437      }
1438      # we need to do something a bit funky with the link. We can't have ampersands in the <link> </link> in valid html
1439      # so we are going to pull out the links and uri_escape just the part after the .cgi
1440      if ($qw eq "link")
1441      {
1442       $args->{$qw} =~ /^(.*?\.cgi.)(.*)$/;
1443       $args->{$qw} = $1.uri_escape($2) if ($1 && $2);
1444      }
1445    
1446      $xml .= "\t\t<$qw>".$args->{$qw}."</$qw>\n";
1447      delete $args->{$qw};
1448     }
1449    
1450     foreach my $tag (grep {!/type/i} keys %$args)
1451     {
1452      $xml .= "\t\t<$tag>".$args->{$tag}."</$tag>\n";
1453     }
1454    
1455     $xml .= "\t</item>\n";
1456    
1457    
1458     my @files=("SEED.rss");
1459     if ($args->{"type"}) {push @files, "SEED.$type.rss"}
1460    
1461     foreach my $file ("SEED.rss", @$files)
1462     {
1463      if (-e "$filepath/$file")
1464      {
1465       my @out; # the new content of the file
1466       my $itemcount=0; # how many <item> </item>'s are we keeping
1467       my $initem; # are we in an item?
1468       open(IN, "$filepath/$file") || die "Can't open $filepath/$file";
1469       while (<IN>)
1470       {
1471        if (/\<item\>/) {
1472         push @out, $xml, unless ($itemcount);
1473         $itemcount++;
1474         $initem=1;
1475        }
1476        if (/\<\/item\>/) {$initem=0; next if ($itemcount > $max_entries)}
1477        next if ($initem && $itemcount > $max_entries);
1478        push @out, $_;
1479       }
1480       close IN;
1481       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1482       print OUT @out;
1483      }
1484      else
1485      {
1486       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1487       print OUT "<?xml version=\"1.0\"?>\n<rss version=\"2.0\">\n<channel>\n";
1488       if ($info->{$file})
1489       {
1490         # we're going to sanity check each of the three options we output, just to be sure
1491         foreach my $qw ("title", "description", "link")
1492         {
1493           if ($info->{$file}->{$qw})
1494           {
1495              print OUT "<$qw>", $info->{$file}->{$qw}, "</$qw>\n";
1496           } else {
1497              print STDERR "Please add a $qw for $file\n"; print OUT "<$qw>$file</$qw>\n";
1498           }
1499         }
1500       }
1501       else {
1502        print STDERR "Please define title, link, and description information for $file\n";
1503        print OUT "<title>$file</title>\n<description>An RSS feed</description>\n<link>", &FIG::cgi_url, "</link>\n";
1504       }
1505       print OUT "\n", $xml;
1506       print OUT "\n", "</channel>\n</rss>\n"
1507      }
1508     }
1509    }
1510    
1511    
1512    
1513    1;
1514    
 1  

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3