[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.37, Tue Mar 15 22:29:27 2005 UTC revision 1.89, Wed Apr 5 18:42:12 2006 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;  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;  use POSIX;
30    
31    
32    my $top_link_cache;
33    
34    
35  sub new  sub new
36  {  {
37      my($class) = @_;      my($class) = @_;
# Line 18  Line 41 
41      return bless $self, $class;      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  sub compute_html_header
77  {  {
78      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
79      my($additional_insert,$user) = @_;      my($additional_insert, $user, %options ) = @_;
80      my $html_hdr_file = "./Html/html.hdr";  
81        local $/ = "\n";
82    
83        my $header_name = $options{header_name} ? $options{header_name} : "html.hdr";
84        my $tail_name = $options{tail_name} ? $options{tail_name} : "html.tail";
85    
86        my $html_hdr_file = "./Html/$header_name";
87      if (! -f $html_hdr_file)      if (! -f $html_hdr_file)
88      {      {
89          $html_hdr_file = "$FIG_Config::fig/CGI/Html/html.hdr";          $html_hdr_file = "$FIG_Config::fig/CGI/Html/$header_name";
90      }      }
91      my @html_hdr = &FIG::file_read($html_hdr_file);      my @html_hdr = &FIG::file_read($html_hdr_file);
92      push( @html_hdr, "<br><a href=\"index.cgi?user=$user\">FIG search</a>\n" );  
93        # for my $k (sort keys %ENV) { warn "$k = $ENV{$k}\n"; }
94    
95        #
96        # Determine if this is a toplevel cgi or one in one of the subdirs (currently
97        # just /p2p).
98        #
99    
100        my @parts = split(/\//, $ENV{SCRIPT_NAME});
101        my $top;
102        if ($parts[-2] eq 'FIG')
103        {
104            $top = '.';
105    #       warn "toplevel @parts\n";
106        }
107        elsif ($parts[-3] eq 'FIG')
108        {
109            $top = '..';
110    #       warn "subdir @parts\n";
111        }
112        else
113        {
114            $top = $FIG_Config::cgi_base;
115    #       warn "other @parts\n";
116        }
117    
118        $options{no_fig_search} or push( @html_hdr, "<br><a href=\"$top/index.cgi?user=$user\">FIG search</a>\n" );
119    
120      if (@html_hdr)      if (@html_hdr)
121      {      {
122          my $insert_stuff;          my $insert_stuff;
123    
124            if (not $options{no_release_info})
125            {
126          my @ver = &FIG::file_head("$FIG_Config::fig_disk/CURRENT_RELEASE", 1);          my @ver = &FIG::file_head("$FIG_Config::fig_disk/CURRENT_RELEASE", 1);
127          my $ver = $ver[0];          my $ver = $ver[0];
128          chomp $ver;          chomp $ver;
# Line 44  Line 134 
134          }          }
135          my $host = &FIG::get_local_hostname();          my $host = &FIG::get_local_hostname();
136          $insert_stuff = "SEED version <b>$ver</b> on $host";          $insert_stuff = "SEED version <b>$ver</b> on $host";
137            }
138    
139          if ($additional_insert)          if ($additional_insert)
140          {          {
141              $insert_stuff .= "<br>" . $additional_insert;              $insert_stuff .= "<br>" . $additional_insert;
# Line 51  Line 143 
143    
144          for $_ (@html_hdr)          for $_ (@html_hdr)
145          {          {
146              s,(href|img\s+src)="/FIG/,\1="$FIG_Config::cgi_base,g;              s,(href|img\s+src)="/FIG/,$1="$top/,g;
147                    s,(\?user\=)\",$1$user",;
148              if ($_ eq "<!-- HEADER_INSERT -->\n")              if ($_ eq "<!-- HEADER_INSERT -->\n")
149              {              {
150                  $_ = $insert_stuff;                  $_ = $insert_stuff;
# Line 65  Line 158 
158  sub show_page {  sub show_page {
159      #warn "SHOWPAGE: cgi=", Dumper(@_);      #warn "SHOWPAGE: cgi=", Dumper(@_);
160      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
161      my($cgi,$html,$no_home, $alt_header, $css) = @_;      my($cgi,$html,$no_home, $alt_header, $css, $javasrc, $cookie, $options) = @_;
162      my $i;      my $i;
163    
164        my $top = top_link();
165    
166      # ARGUMENTS:      # ARGUMENTS:
167      #     $cgi is the CGI method      #     $cgi is the CGI method
# Line 77  Line 171 
171      #     $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      #     $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
172      #               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      #               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
173      #               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      #               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
174        #     $javasrc is a reference to an array of URLs to javascripts to be included (e.g. "FIG/Html/css/styleswitcher.js")
175        #     $cookie is the name and value of the cookie to set. Note that you should probably use raelib->cookie to get/set your cookies
176        #     $options is a reference to a hash of options that you can pass around the pages
177      #      #
178      # Find the HTML header      # Find the HTML header
179      #      #
180    
181      my $html_tail_file = "./Html/html.tail";      my $html_tail_file = "./Html/$tail_name";
182      if (! -f $html_tail_file)      if (! -f $html_tail_file)
183      {      {
184          $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";          $html_tail_file = "$FIG_Config::fig/CGI/Html/$tail_name";
185      }      }
186    
187      my $user = $cgi->param('user') || "";      my $user = $cgi->param('user') || "";
188      my @html_hdr;      my @html_hdr;
189      if ($alt_header)      if ($alt_header && ref($alt_header) eq "ARRAY")
190      {      {
191         @html_hdr = @$alt_header;         @html_hdr = @$alt_header;
192      }      }
193      else      else
194      {      {
195          @html_hdr = compute_html_header(undef,$user);          @html_hdr = compute_html_header(undef,$user,%$options);
196      }      }
197    
198        # RAE: I am offloading the handling of cookies to CGI.pm since I don't know how they are set up.
199        # This modification adds the cookies if necessary
200    
201        # Note: 3/10/05 commented this line out pending the discussion of adding cookies into the seed that we are waiting to see about
202        # to add cookies back in replace these two header lines with each other
203    
204      print $cgi->header;      #print $cgi->header(-cookie=>$cookie);
205        print $cgi->header();
206    
207      #      #
208      #  The SEED header file goes immediately after <BODY>.  Figure out      #  The SEED header file goes immediately after <BODY>.  Figure out
# Line 118  Line 220 
220                       meta     => 1,                       meta     => 1,
221                       nextid   => 1,                       nextid   => 1,
222                       style    => 1,                       style    => 1,
223                       title    => 1                       title    => 1,
224                     );                     );
225    
226      #      #
# Line 161  Line 263 
263          if ( $html->[$i] =~ /\<body[^0-9a-z]/i )          if ( $html->[$i] =~ /\<body[^0-9a-z]/i )
264          {          {
265              $body_line = $i;              $body_line = $i;
266              $last;              last;
267          }          }
268    
269          #  Now the general case.          #  Now the general case.
# Line 221  Line 323 
323      #  Added the javascript for the buttons immediately after body.      #  Added the javascript for the buttons immediately after body.
324      #  Note if no buttons are added we still (at the moment) add the script,      #  Note if no buttons are added we still (at the moment) add the script,
325      #  but it only adds a little text (495 characters) to the html and noone will notice!      #  but it only adds a little text (495 characters) to the html and noone will notice!
326        #  RAE: This is now deprecated because everything is in an external file, FIG.js, included later
327    
328      if ( $body_line < 0 )      if ( $body_line < 0 )
329      {      {
         my $js=&javascript;  
330          $body_line = $last_head_line + 1;          $body_line = $last_head_line + 1;
331          splice( @$html, $body_line, 0, "<BODY>\n$js\n" );          splice( @$html, $body_line, 0, "<BODY>\n" );
332      }      }
333    
334      #      #
# Line 250  Line 352 
352    
353      # RAE:      # RAE:
354      # Add css here      # Add css here
355      # Note that at the moment I define these two sheets here. I think this should be moved out, but I want to try it and see what happens      # Note that at the moment I define these two sheets here. I think this should
356      # css has the format      # be moved out, but I want to try it and see what happens.  css has the format:
357        #
358      # <link rel='stylesheet' title='default' href='/css/default.css' type='text/css'>      # <link rel='stylesheet' title='default' href='/css/default.css' type='text/css'>
359    
360      # convert the default key to the right case. and eliminate dups      # convert the default key to the right case. and eliminate dups
# Line 259  Line 362 
362    
363      if (!$css || !$css->{'Default'})      if (!$css || !$css->{'Default'})
364      {      {
365         $css->{'Default'}="/FIG/Html/css/default.css";         $css->{'Default'} = "Html/css/default.css";
366      }      }
367      if (!$css->{"Sans Serif"})      if (!$css->{"Sans Serif"})
368      {      {
369         $css->{'Sans Serif'}="/FIG/Html/css/sanserif.css";         $css->{'Sans Serif'} = "Html/css/sanserif.css";
370      }      }
371    
372      my $csstext = "<link rel='stylesheet' title='default' href='".$css->{'Default'}."' type='text/css'>\n";      my $csstext = "<link rel='stylesheet' title='default' href='".$css->{'Default'}."' type='text/css'>\n";
373      $csstext   .= "<link rel='alternate stylesheet' title='Sans Serif' href='".$css->{'Sans Serif'}."' type='text/css'>\n";      $csstext   .= "<link rel='alternate stylesheet' title='Sans Serif' href='".$css->{'Sans Serif'}."' type='text/css'>\n";
374    
375      foreach my $k (keys %$css)      foreach my $k (keys %$css)
376      {      {
377         next if (lc($k) eq "default" || lc($k) eq "sans serif");         next if (lc($k) eq "default" || lc($k) eq "sans serif");
378         $csstext .= "<link rel='stylesheet' title='$k' href='".$css->{$k}."' type='text/css'>\n";         $csstext .= "<link rel='alternate stylesheet' title='$k' href='".$css->{$k}."' type='text/css'>\n";
379      }      }
380    
381        $csstext   .= "<link rel='alternate'  title='SEED RSS feeds' href='Html/rss/SEED.rss' type='application/rss+xml'>\n";
382    
383        # RAE: also added support for external javascripts here.
384        # we are cluttering the HTML code with all the javascripts when they could easily be in external files
385        # this solution allows us to source other files
386    
387        # the file FIG.js contains most of the java script we use routinely. Every browser will just cache this and so
388        # it will reduce our overhead.
389    
390        # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts
391        push @$javasrc, "Html/css/FIG.js";
392        foreach my $script (@$javasrc) {
393            $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";
394        }
395    
396    
397    
398      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.      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.
399    
400      #      #
# Line 300  Line 422 
422  #       }  #       }
423    
424          $base_line = $head_end_line;          $base_line = $head_end_line;
425          splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );          #
426            # RDO 2005-1006. Remove this so proxying works better.
427            #
428    #        splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );
429      }      }
430    
431      #      #
# Line 350  Line 475 
475      #  Figure out where to insert The SEED tail.  Before </body>,      #  Figure out where to insert The SEED tail.  Before </body>,
476      #  or before </html>, or at end of page.      #  or before </html>, or at end of page.
477      #      #
   
478      my @tags = ();      my @tags = ();
479        # Check for a tracing queue.
480        my $traceString = QTrace("HTML");
481        if ($traceString) {
482            push @tags, $traceString;
483        }
484      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}
485      if ($i >= @$html)        # </body> not found; look for </html>      if ($i >= @$html)        # </body> not found; look for </html>
486      {      {
# Line 374  Line 502 
502          splice( @$html, $i, 0, @tags );          splice( @$html, $i, 0, @tags );
503      }      }
504    
505      # RAE the chomp will return any new lines at the ends of elements in the array, and then we can join  with a "\n"      # RAE the chomp will return any new lines at the ends of elements in the array,
506      # this is because somethings put newlines in, and others don't. This should make nicer looking html      # and then we can join  with a "\n". This is because somethings put newlines in,
507        # and others don't. This should make nicer looking html
508        #
509      #chomp(@$html);      #chomp(@$html);
510      #print join "\n", @$html;      #print join "\n", @$html;
511        #
512      # Apparently the above still breaks things. This is the correct code:      # Apparently the above still breaks things. This is the correct code:
513      print @$html;  
514        foreach $_ (@$html)
515        {
516            print $_;
517        }
518    
519  }  }
520    
521  sub make_table {  sub make_table {
# Line 388  Line 523 
523      my(@tab);      my(@tab);
524    
525      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";
526      push( @tab, "\n<table $border>\n",      my $width = defined $options{width} ? "width=\"$options{width}\"" : undef;
527        my $class = defined $options{class} ? "class=\"$options{class}\"" : undef;
528        push( @tab, "\n<table $border $width $class>\n",
529                  "\t<caption><b>$title</b></caption>\n",                  "\t<caption><b>$title</b></caption>\n",
530                  "\t<tr>\n\t\t"                  "\t<tr>\n\t\t"
531                . join( "\n", map { &expand($_, "th") } @$col_hdrs )                . join( "\n", map { &expand($_, "th") } @$col_hdrs )
# Line 408  Line 545 
545      return join("",@tab);      return join("",@tab);
546  }  }
547    
548    sub abstract_coupling_table {
549        my($cgi,$prot,$coupling) = @_;
550        my %fc;
551    
552        my $col_hdrs = ["coupled to","Score","Type of Coupling", "Type-specific Data"];
553        my $tab = [];
554        my %by_peg;
555        foreach my $x (@$coupling)
556        {
557            my($peg2,$psc,$type,$extra) = @$x;
558            if (($type !~ /^[ID]FC$/) || (! $fc{$peg2}))
559            {
560                if ($type =~  /^[ID]FC$/)
561                {
562                    $fc{$peg2} = 1;
563                }
564    
565                $by_peg{$peg2} += $psc;
566            }
567        }
568    
569        foreach my $x (sort { ($by_peg{$b->[0]} <=> $by_peg{$a->[0]})
570                              or ($a->[0] cmp $b->[0])
571                              or ($b->[1] <=> $a->[1])
572                              or ($a->[2] cmp $b->[2]) } @$coupling)
573        {
574            my($peg2,$psc,$type,$extra) = @$x;
575            push(@$tab,[&fid_link($cgi,$peg2,1),$psc,$type,&set_prot_links($cgi,join(", ",@$extra))]);
576        }
577    
578    
579         my $help = "<a href=\"Html/abstract_coupling.html\" target=\"SEED_or_SPROUT_help\">for help</a>";
580    #    my @html = &make_table($col_hdrs,$tab,"Abstract Coupling Data for $prot");
581    #    push(@html,"<hr>\n",$cgi->h3($help),"<br>");
582    #    return @html;
583    
584        return &make_table($col_hdrs,$tab,"Abstract Coupling Data for $prot [$help]");
585    }
586    
587  sub expand {  sub expand {
588      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
589      my($x, $tag) = @_;      my($x, $tag) = @_;
590    
591      $tag = "td" unless $tag;      $tag = "td" unless $tag;
592      my $endtag=$tag;      my $endtag=$tag;
593      # RAE modified this so that you can pass in a reference to an array where the first element is the data to  
594      # display and the second element is optional things like colspan and align. Note that in this case you need to include the td      # RAE modified this so that you can pass in a reference to an array where
595        # the first element is the data to display and the second element is optional
596        # things like colspan and align. Note that in this case you need to include the td
597      # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]      # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]
598      if (ref($x) eq "ARRAY") {($x, $tag)=@$x; if ($tag =~ /td/) {$endtag = "td"}}  
599        # per GJO's request modified this line so it can take any tag.
600        if ( ref($x) eq "ARRAY" ) { ($x, $tag) = @$x; $tag =~ /^(\S+)/; $endtag = $1 }
601    
602      if ($x =~ /^\@([^:]+)\:(.*)$/)      if ($x =~ /^\@([^:]+)\:(.*)$/)
603      {      {
# Line 429  Line 609 
609      }      }
610  }  }
611    
612    
613    =head2 merge_table_rows()
614    
615    Merge table rows together. This will merge a table so that adjacent cells with the same content will only be shown once.
616    
617    Something like this:
618    
619        -----------------------
620        |    1     |    a     |
621        -----------------------
622        |    1     |    b     |
623        -----------------------
624        |    2     |    c     |
625        -----------------------
626        |    3     |    d     |
627        -----------------------
628        |    4     |    d     |
629        -----------------------
630        |    5     |    d     |
631        -----------------------
632    
633    Will become:
634    
635        -----------------------
636        |          |    a     |
637        |    1     |-----------
638        |          |    b     |
639        -----------------------
640        |    2     |    c     |
641        -----------------------
642        |    3     |          |
643        ------------          |
644        |    4     |    5     |
645        ------------          |
646        |    5     |          |
647        -----------------------
648    
649    
650    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.
651    
652     $tab=&HTML::merge_table_rows($tab);
653    
654     or
655    
656     $skip=(1=>1, 3=>1, 5=>1);
657     $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
658    
659    
660    =cut
661    
662    
663    
664    
665    sub merge_table_rows {
666     # RAE:
667     # Experimental piece of code. We often want to have rows or columns were cells are merged. It just looks so much nicer
668     # this block should merge adjacent rows that have the same text in them.
669     # use like this:
670     #      $tab=&HTML::merge_table_rows($tab);
671     # before you do a make_table call
672    
673     my $self=shift if UNIVERSAL::isa($_[0],__PACKAGE__);
674     my ($tab, $skip)=@_;
675    
676     my $newtable;
677     my $lastrow;
678     my $rowspan;
679     my $refs;
680    
681     for (my $y=0; $y <= $#$tab; $y++) {
682     #$y is the row in the table;
683      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
684       # this is the user definable columns not to merge
685       if ($skip->{$x})
686       {
687        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
688        next;
689       }
690    
691       #$x is the column in the table
692       # if the column in the row we are looking at is the same as the column in the previous row, we don't add
693       # this cell to $newtable. Instead we increment the rowspan of the previous row by one
694    
695       # handle cells that are references to arrays
696       if (ref($tab->[$y]->[$x]) eq "ARRAY") {$refs->[$y]->[$x]=$tab->[$y]->[$x]->[1]; $tab->[$y]->[$x]=$tab->[$y]->[$x]->[0]}
697    
698       # now we go back through the table looking where to draw the merge line:
699       my $lasty=$y;
700       while ($lasty >= 0 && $tab->[$y]->[$x] eq $tab->[$lasty]->[$x]) {$lasty--}
701       $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
702       if ($lasty == $y) {
703        # we always want to have something in rows that may otherwise be empty but should be there (see below)
704        unless ($tab->[$y]->[$x]) {$tab->[$y]->[$x]=" &nbsp; "}
705        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
706       }
707       else {$rowspan->[$lasty]->[$x]++}
708      }
709     }
710    
711     # now just join everything back together
712     for (my $y=0; $y <= $#$tab; $y++) {
713      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
714       if ($rowspan->[$y]->[$x]) {
715        if ($refs->[$y]->[$x]) {$refs->[$y]->[$x] .= " rowspan=". ($rowspan->[$y]->[$x]+1)}
716        else {$refs->[$y]->[$x] = "td rowspan=". ($rowspan->[$y]->[$x]+1)}
717        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
718       }
719       elsif ($newtable->[$y]->[$x] && $refs->[$y]->[$x]) {
720        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
721       }
722      }
723     }
724    
725    
726     # finally we have to remove any completely empty cells that have been added by the array mechanism
727     # (e.g. if you define $a->[2] then $a->[0] and $a->[1] are now undef).
728     # that is why in the loop above I replace empty cells with nbsp. They are now not undef!
729     # I am sure that Gary can do this in one line, but I am hacking.
730     my @trimmed;
731     foreach my $a (@$newtable) {
732      my @row;
733      foreach my $b (@$a) {
734       push @row, $b if ($b);
735      }
736      push @trimmed, \@row;
737     }
738    
739     return \@trimmed;
740    }
741    
742    
743    
744    
745  sub set_ec_links {  sub set_ec_links {
746      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
747      my($cgi,$x) = @_;      my($cgi,$x) = @_;
# Line 479  Line 792 
792      my($cgi,$fid,$local,$just_url) = @_;      my($cgi,$fid,$local,$just_url) = @_;
793      my($n);      my($n);
794    
795        my $top = top_link();
796    
797      if ($fid =~ /^fig\|\d+\.\d+\.([a-z]+)\.(\d+)/)      if ($fid =~ /^fig\|\d+\.\d+\.([a-z]+)\.(\d+)/)
798      {      {
799          if ($local)          if ($local)
# Line 496  Line 811 
811          {          {
812              $n = $fid;              $n = $fid;
813          }          }
814          if ($1 ne "peg") { return $n }  
815            my $link;
816            #added to format prophage and path island links to feature.cgi
817            if ($1 ne "peg")
818            {
819               my $user = $cgi->param('user');
820               if (! $user) { $user = "" }
821               my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
822               $link = "$top/feature.cgi?feature=$fid&user=$user$trans$sprout";
823               $link =~ s/[a-z_A-Z0-9]+\.cgi\?/feature.cgi?/;
824            }
825            else
826            {
827          my $user = $cgi->param('user');          my $user = $cgi->param('user');
828          if (! $user) { $user = "" }          if (! $user) { $user = "" }
829          my $trans = $cgi->param('translate') ? "&translate=1" : "";          my $trans = $cgi->param('translate') ? "&translate=1" : "";
830          my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";          my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
831          my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";  ###a
         $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;  
         #  
         # Elimin the p2p part if we're in that subdir. Ugh.  
         #  
         $link =~ s,p2p/protein.cgi,protein.cgi,;  
832    
833    ### This used to be
834    ###     my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
835    ###
836    ### The cost became prohibitive in the subsystem spreadsheets.  Hence, we cache the value
837    ###
838    ### RAO
839    
840                #if (! $cgi_url) { $cgi_url = &FIG::cgi_url }
841                #$link = $cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
842                $link = "$top/protein.cgi?prot=$fid&user=$user$trans$sprout";
843                $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
844            }
845          if ($just_url)          if ($just_url)
846          {          {
847              return $link;              return $link;
848          }          }
849          else          else
850          {          {
851              return "<a href=$link>$n</a>";              return "<a href='$link'>$n</a>";
852          }          }
853      }      }
854      return $fid;      return $fid;
# Line 527  Line 861 
861      return $family;      return $family;
862  }  }
863    
 use URI::Escape;  
864    
865  sub get_html {  sub get_html {
866      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
# Line 644  Line 977 
977          $after = $3;          $after = $3;
978          return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after);          return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after);
979      }      }
980      elsif ($x =~ /^(.*)\b([NXYZA]P_[0-9\.]+)\b(.*)/s)      elsif ($x =~ /^(.*)\b([NXYZA][PM]_[0-9\.]+)\b(.*)/s)
981      {      {
982          $before = $1;          $before = $1;
983          $match = $2;          $match = $2;
# Line 658  Line 991 
991          $after = $3;          $after = $3;
992          return &set_prot_links($cgi,$before) . &HTML::gi_link($cgi,$match) . &set_prot_links($cgi,$after);          return &set_prot_links($cgi,$before) . &HTML::gi_link($cgi,$match) . &set_prot_links($cgi,$after);
993      }      }
994        elsif ($x =~ /^(.*)(tigr\|\w+)(.*)/s)
995        {
996            $before = $1;
997            $match = $2;
998            $after = $3;
999            return &set_prot_links($cgi,$before) . &HTML::tigr_link($cgi,$match) . &set_prot_links($cgi,$after);
1000        }
1001        elsif ($x =~ /^(.*)\b(eric\|\S+)\b(.*)/s)
1002        {
1003            $before = $1;
1004            $match = $2;
1005            $after = $3;
1006            return &set_prot_links($cgi,$before) . &HTML::eric_link($cgi,$match) . &set_prot_links($cgi,$after);
1007        }
1008    
1009        elsif ($x =~ /^(.*)\bbhb\|.*?\b(.*)/s)
1010        {
1011            $before = $1;
1012            $match = $2;
1013            $after = $3;
1014            return &set_prot_links($cgi,$before) . &HTML::bhb_link($cgi,$match) . &set_prot_links($cgi,$after);
1015        }
1016    
1017        elsif ($x =~ /^(.*)\bapidb\|.*?\..*\b(.*)/s)
1018        {
1019            $before = $1;
1020            $match = $2;
1021            $after = $3;
1022            return &set_prot_links($cgi,$before) . &HTML::apidb_link($cgi,$match) . &set_prot_links($cgi,$after);
1023        }
1024    
1025        elsif ($x =~ /^(.*)\bpatric\|.*?\b(.*)/s)
1026        {
1027            $before = $1;
1028            $match = $2;
1029            $after = $3;
1030            return &set_prot_links($cgi,$before) . &HTML::patric_link($cgi,$match) . &set_prot_links($cgi,$after);
1031        }
1032    
1033        elsif ($x =~ /^(.*)\bvbrc\|.*?\b(.*)/s)
1034        {
1035            $before = $1;
1036            $match = $2;
1037            $after = $3;
1038            return &set_prot_links($cgi,$before) . &HTML::vbrc_link($cgi,$match) . &set_prot_links($cgi,$after);
1039        }
1040    
1041        elsif ($x =~ /^(.*)\bvectorbase\|.*?\b(.*)/s)
1042        {
1043            $before = $1;
1044            $match = $2;
1045            $after = $3;
1046            return &set_prot_links($cgi,$before) . &HTML::vectorbase_link($cgi,$match) . &set_prot_links($cgi,$after);
1047        }
1048      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
1049      {      {
1050          $before = $1;          $before = $1;
# Line 686  Line 1073 
1073          $after = $3;          $after = $3;
1074          return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after);          return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after);
1075      }      }
1076        elsif ($x =~ /^(.*)(Ensembl[a-zA-Z]+:[a-zA-Z_0-9\.]+)(.*)/s)
1077        {
1078            $before = $1;
1079            $match = $2;
1080            $after = $3;
1081            return &set_prot_links($cgi,$before) . &HTML::ensembl_link($cgi,$match) . &set_prot_links($cgi,$after);
1082        }
1083        elsif ($x =~ /^(.*)(EntrezGene:[a-zA-Z_0-9\.]+)(.*)/s)
1084        {
1085            $before = $1;
1086            $match = $2;
1087            $after = $3;
1088            return &set_prot_links($cgi,$before) . &HTML::entrezgene_link($cgi,$match) . &set_prot_links($cgi,$after);
1089        }
1090        elsif ($x =~ /^(.*)(MIM:[a-zA-Z_0-9\.]+)(.*)/s)
1091        {
1092            $before = $1;
1093            $match = $2;
1094            $after = $3;
1095            return &set_prot_links($cgi,$before) . &HTML::mim_link($cgi,$match) . &set_prot_links($cgi,$after);
1096        }
1097        elsif ($x =~ /^(.*)(HGNC:[a-zA-Z_0-9\.]+)(.*)/s)
1098        {
1099            $before = $1;
1100            $match = $2;
1101            $after = $3;
1102            return &set_prot_links($cgi,$before) . &HTML::hgnc_link($cgi,$match) . &set_prot_links($cgi,$after);
1103        }
1104        elsif ($x =~ /^(.*)(UniGene:[a-zA-Z_0-9\.]+)(.*)/s)
1105        {
1106            $before = $1;
1107            $match = $2;
1108            $after = $3;
1109            return &set_prot_links($cgi,$before) . &HTML::unigene_link($cgi,$match) . &set_prot_links($cgi,$after);
1110        }
1111    # IPI stopped working. turn off for now.
1112    #    elsif ($x =~ /^(.*)(IPI:[a-zA-Z_0-9\.]+)(.*)/s)
1113    #    {
1114    #        $before = $1;
1115    #        $match = $2;
1116    #        $after = $3;
1117    #        return &set_prot_links($cgi,$before) . &HTML::ipi_link($cgi,$match) . &set_prot_links($cgi,$after);
1118    #    }
1119        elsif ($x =~ /^(.*)(WP:[a-zA-Z_0-9\.]+)(.*)/s)
1120        {
1121            #wormbase
1122    
1123            $before = $1;
1124            $match = $2;
1125            $after = $3;
1126            return &set_prot_links($cgi,$before) . &HTML::wp_link($cgi,$match) . &set_prot_links($cgi,$after);
1127        }
1128        elsif ($x =~ /^(.*)(FB:[a-zA-Z_0-9\.]+)(.*)/s)
1129        {
1130            #flybase
1131    
1132            $before = $1;
1133            $match = $2;
1134            $after = $3;
1135            return &set_prot_links($cgi,$before) . &HTML::fb_link($cgi,$match) . &set_prot_links($cgi,$after);
1136        }
1137        elsif ($x =~ /^(.*)(FlyBaseORFNames:[a-zA-Z_0-9\.]+)(.*)/s)
1138        {
1139            #flybase
1140    
1141            $before = $1;
1142            $match = $2;
1143            $after = $3;
1144            return &set_prot_links($cgi,$before) . &HTML::fborf_link($cgi,$match) . &set_prot_links($cgi,$after);
1145        }
1146        elsif ($x =~ /^(.*)(SGD_LOCUS:[a-zA-Z_0-9\.]+)(.*)/s)
1147        {
1148            #flybase
1149    
1150            $before = $1;
1151            $match = $2;
1152            $after = $3;
1153            return &set_prot_links($cgi,$before) . &HTML::sgd_link($cgi,$match) . &set_prot_links($cgi,$after);
1154        }
1155      return $x;      return $x;
1156  }  }
1157    
# Line 697  Line 1163 
1163      {      {
1164          return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id>$id</a>";          return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id>$id</a>";
1165      }      }
1166        elsif ($id =~ /^[NXYZA]M_/)
1167        {
1168            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=nuccore&cmd=search&term=$id>$id</a>";
1169        }
1170  }  }
1171    
1172  sub gi_link {  sub gi_link {
# Line 710  Line 1180 
1180      return $gi;      return $gi;
1181  }  }
1182    
1183    sub tigr_link {
1184        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1185        my($cgi,$tigr) = @_;
1186    
1187        if ($tigr =~ /^tigr\|(NT|ntbp|ntbpA|BA|BMAA|BXB|GBA)(\w+)$/)
1188        {
1189            my $id=$1.$2;
1190            return "<a href=\"http://pathema.tigr.org/tigr-scripts/pathema/shared/GenePage.cgi?locus=$id\">$tigr</a> (Pathema)";
1191        }
1192        elsif ($tigr =~ /^tigr\|(\S+)$/)
1193        {
1194            return "<a href=\"http://www.tigr.org/tigr-scripts/CMR2/GenePage.spl?locus=$1\">$tigr</a>";
1195        }
1196        return $tigr;
1197    }
1198    
1199    sub eric_link {
1200        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1201        my($cgi,$eric) = @_;
1202    
1203        if ($eric =~ /^eric\|(\S+)/)
1204        {
1205            return "<a href=\"https://asap.ahabs.wisc.edu/asap/feature_info.php?FeatureID=$1\">$eric</a>";
1206        }
1207        return $eric;
1208    }
1209    
1210    sub bhb_link {
1211        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1212        my($cgi,$bhb) = @_;
1213    
1214        return "<a href=\"http://www.biohealthbase.org\">$bhb</a>";
1215    }
1216    
1217    sub apidb_link {
1218        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1219        my($cgi,$api) = @_;
1220    
1221        if ($api =~ /apidb\|(.*?)\.(.*)$/)
1222        {
1223            return "<a href=\"http://www.apidb.org/cgi-bin/redirect.cgi?taxon_id=$1&source_id=$2\">$api</a>";
1224        }
1225        return $api;
1226    }
1227    
1228    sub patric_link {
1229        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1230        my($cgi,$patric) = @_;
1231    
1232        if ($patric =~ /patric\|(.*)/)
1233        {
1234            return "<a href=\"https://patric.vbi.vt.edu/software/curationTool/gep/pgiCuration.php?locus_name=$1\">$patric</a>";
1235        }
1236        return $patric;
1237    }
1238    
1239    sub vbrc_link {
1240        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1241        my($cgi,$vbrc) = @_;
1242    
1243        if ($vbrc =~ /vbrc\|(.*)/)
1244        {
1245            return "<a href=\"http://www.biovirus.org/gene_detail.asp?name=$1\">$vbrc</a>";
1246        }
1247        return $vbrc;
1248    }
1249    
1250    sub vectorbase_link {
1251        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1252        my($cgi,$vec) = @_;
1253        return "<a href=\"http://www.vectorbase.org\">$vec</a>";
1254    }
1255    
1256    
1257  sub uni_link {  sub uni_link {
1258      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1259      my($cgi,$uni) = @_;      my($cgi,$uni) = @_;
# Line 754  Line 1298 
1298      return $kegg;      return $kegg;
1299  }  }
1300    
1301    sub ensembl_link {
1302        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1303        my($cgi,$ensembl) = @_;
1304    
1305        if ($ensembl =~ /^(\S+):(\S+)$/)
1306        {
1307            my $what=$1;
1308            my $key=$2;
1309            my $idx="All";
1310            if ($what eq "EnsemblGene") { $idx = "Gene" }
1311            if ($what eq "EnsemblTranscript") { $idx = "All" }
1312            if ($what eq "EnsemblProtein") { $idx = "All" }
1313    
1314            #I really want to get right to the transcript and peptide pages, but
1315            #can't see how to do that without knowing the org name too, which
1316            #I don't know at this point. (ensembl org name, not real org name)
1317    
1318            return "<a href=http://www.ensembl.org/Homo_sapiens/searchview?species=all&idx=$idx&q=$key>$ensembl</a>";
1319        }
1320        return $ensembl;
1321    }
1322    
1323    sub entrezgene_link {
1324        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1325        my($cgi,$entrezgene) = @_;
1326    
1327        if ($entrezgene =~ /^EntrezGene:(\S+)$/)
1328        {
1329            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=gene&cmd=Retrieve&dopt=full_report&list_uids=$1>$entrezgene</a>";
1330        }
1331        return $entrezgene;
1332    }
1333    
1334    sub mim_link {
1335        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1336        my($cgi,$mim) = @_;
1337    
1338        if ($mim =~ /^MIM:(\S+)$/)
1339        {
1340            return "<a href=http://www3.ncbi.nlm.nih.gov/entrez/dispomim.cgi?id=$1>$mim</a>";
1341        }
1342        return $mim;
1343    }
1344    
1345    sub hgnc_link {
1346        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1347        my($cgi,$hgnc) = @_;
1348    
1349        if ($hgnc =~ /^HGNC:(\S+)$/)
1350        {
1351            return "<a href=http://www.gene.ucl.ac.uk/cgi-bin/nomenclature/searchgenes.pl?field=symbol&anchor=equals&match=$1&symbol_search=Search&number=50&format=html&sortby=symbol>$hgnc</a>";
1352        }
1353        return $mim;
1354    }
1355    
1356    sub unigene_link {
1357        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1358        my($cgi,$unigene) = @_;
1359    
1360        if ($unigene =~ /^UniGene:(\S+)$/)
1361        {
1362            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=unigene&cmd=search&term=$1>$unigene</a>";
1363        }
1364        return $unigene;
1365    }
1366    
1367    sub ipi_link {
1368        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1369        my($cgi,$ipi) = @_;
1370    
1371        if ($ipi =~ /^IPI:(\S+)$/)
1372        {
1373            return "<a href=http://srs.ebi.ac.uk/srsbin/cgi-bin/wgetz?-id+AEoS1R8Jnn+-e+[IPI:\'$1\']+-qnum+1+-enum+1>$ipi</a>";
1374        }
1375        return $ipi;
1376    }
1377    
1378    sub wp_link {
1379        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1380        my($cgi,$wp) = @_;
1381    
1382        #wormbase
1383    
1384        if ($wp =~ /^WP:(\S+)$/)
1385        {
1386            return "<a href=http://www.wormbase.org/db/searches/basic?class=Any&query=$1&Search=Search>$wp</a>";
1387        }
1388        return $wp;
1389    }
1390    
1391    sub fb_link {
1392        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1393        my($cgi,$fb) = @_;
1394    
1395        #flybase
1396    
1397        if ($fb =~ /^FB:(\S+)$/)
1398        {
1399            return "<a href=http://flybase.bio.indiana.edu/.bin/fbidq.html?$1>$fb</a>";
1400        }
1401        return $fb;
1402    }
1403    
1404    sub fborf_link {
1405        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1406        my($cgi,$fb) = @_;
1407    
1408        #flybase
1409    
1410        if ($fb =~ /^FlyBaseORFNames:(\S+)$/)
1411        {
1412            return "<a href=http://flybase.bio.indiana.edu/.bin/fbidq.html?$1>$fb</a>";
1413        }
1414        return $fb;
1415    }
1416    
1417    sub sgd_link {
1418        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1419        my($cgi,$sgd) = @_;
1420    
1421        #yeast
1422    
1423        if ($sgd =~ /^SGD_LOCUS:(\S+)$/)
1424        {
1425            return "<a href=http://db.yeastgenome.org/cgi-bin/locus.pl?locus=$1>$sgd</a>";
1426        }
1427        return $sgd;
1428    }
1429    
1430    
1431    
1432    
1433  sub set_map_links {  sub set_map_links {
1434      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1435      my($cgi,$x) = @_;      my($cgi,$x) = @_;
# Line 771  Line 1447 
1447      return $x;      return $x;
1448  }  }
1449    
1450    
1451    
1452  sub map_link {  sub map_link {
1453      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1454      my($cgi,$map,$org) = @_;      my($cgi,$map,$org) = @_;
# Line 778  Line 1456 
1456      $user = $cgi->param('user');      $user = $cgi->param('user');
1457      $user = $user ? $user : "";      $user = $user ? $user : "";
1458      $org = $org ? $org : "";      $org = $org ? $org : "";
1459      my $url = "$FIG_Config::cgi_url/show_kegg_map.cgi?user=$user&map=$map&org=$org";  
1460        my $url = "show_kegg_map.cgi?user=$user&map=$map&org=$org";
1461    #rel    my $url = &FIG::cgi_url() . "/show_kegg_map.cgi?user=$user&map=$map&org=$org";
1462      my $link = "<a href=\"$url\">$map</a>";      my $link = "<a href=\"$url\">$map</a>";
1463      return $link;      return $link;
1464  }  }
1465    
 sub javascript {  
     shift if UNIVERSAL::isa($_[0],__PACKAGE__);  
         #### MODIFIED BY RAE TO ADD JAVA SUPPORT FOR CHECK ALL/UNCHECK ALL  
         # This routine takes three arguments, $html, $form, and $button  
         # $html is the ref to the array with the html in it  
         # $form is the name of the form. This must be added whenever start_form is called  
         # by including a -name entry. This is only used for the javascript  
         # $button is the name of the button that should be checked/unchecked.  
         #  
         # At the moment this add's four buttons:  
         # Check all, check's all  
         # Check first half will check the first 50% of the entries  
         # Check second half will check the second 50% of the entries  
         # Uncheck all will remove the checks.  
   
         # Note that the other change is I added a -name=>'fig_checked' to the start_form  
         # field. The name is needed for the java script.  
         #  
   
           $java_script=<<EOF;  
   <SCRIPT LANGUAGE="JavaScript">  
   <!-- Begin  
   function checkAll(field)  
   {  
    for (i = 0; i < field.length; i++)  
    field[i].checked = true ;  
   }  
   
   function checkFirst(field)  
   {  
    for (i = 0; i < field.length/2; i++)  
    field[i].checked = true;  
   }  
   
   function checkSecond(field)  
   {  
    for (i=Math.round(field.length/2); i < field.length; i++)  
    field[i].checked = true ;  
   }  
   
   function uncheckAll(field)  
   {  
    for (i = 0; i < field.length; i++)  
    field[i].checked = false ;  
   }  
   //  End -->  
   </script>  
 EOF  
         return $java_script;  
 }  
   
1466  sub java_buttons {  sub java_buttons {
1467      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1468    ## ADDED BY RAE    ## ADDED BY RAE
# Line 856  Line 1485 
1485      my($sub_link);      my($sub_link);
1486    
1487      my $user = $cgi->param('user');      my $user = $cgi->param('user');
1488        my $esc_sub = uri_escape( $sub );
1489        $sub =~ s/\_/ /g;
1490      if ($user)      if ($user)
1491      {      {
1492          $sub_link = "<a href=./subsys.cgi?ssa_name=$sub&request=show_ssa&user=$user>$sub</a>";          $sub_link = "<a href=./subsys.cgi?ssa_name=$esc_sub&request=show_ssa&user=$user>$sub</a>";
1493      }      }
1494      else      else
1495      {      {
1496          $sub_link = $sub;          $sub_link = "<a href=\"display_subsys.cgi?ssa_name=$esc_sub&request=show_ssa&sort=by_phylo\">$sub</a>";
1497      }      }
1498      return $sub_link;      return $sub_link;
1499  }  }
1500    
1501  1  sub reaction_link {
1502        my($reaction) = @_;
1503    
1504        if ($reaction =~ /^R\d+/)
1505        {
1506            return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?rn+$reaction\" target=reaction$$>$reaction</a>";
1507        }
1508        return $reaction;
1509    }
1510    
1511    sub html_for_assignments {
1512        my($fig,$user,$peg_sets) = @_;
1513        my $i;
1514    
1515        my @vals = ();
1516        my $set = 1;
1517        foreach $peg_set (@$peg_sets)
1518        {
1519            for ($i=0; ($i < @$peg_set); $i++)
1520            {
1521                $peg = $peg_set->[$i];
1522                push(@vals,'show=' . join("@",($set,$i+1,$peg,&FIG::abbrev($fig->org_of($peg)),"")));
1523            }
1524            $set++;
1525        }
1526    
1527        $ENV{'REQUEST_METHOD'} = 'GET';
1528        $ENV{'QUERY_STRING'} = join('&',('request=show_commentary',"uni=1","user=$user",@vals));
1529        my $out = join("",`$FIG_Config::fig/CGI/chromosomal_clusters.cgi`);
1530        $out =~ s/^.*?<form/<form/si;
1531        $out =~ s/^(.*)<table.*/$1/si;
1532        return $out;
1533    }
1534    
1535    =head1 rss_feed
1536    
1537    Add something to the RSS feed. The rss feeds are stored in the Html directory, and there are several RSS feeds:
1538            SEED.rss                - everything gets written here
1539            SEEDgenomes.rss                 - whenever a genome is added to the SEED
1540            SEEDsubsystems.rss      - whenever a subsystem is edited (or should this be added?)
1541    
1542    
1543    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.
1544    
1545    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.
1546    
1547    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.
1548    
1549    The has can have these keys:
1550    
1551    REQUIRED:
1552    title       : the title. This is usually what is seen by the user in the pull down menu
1553    description : a more complete description that is often seen is rss viewers but not always
1554    link        : link to the item that was added/edited
1555    All other keys are treated as optional RSS arguments and written to the file.
1556    
1557    At most, $max_entries recent entries are stored in the rss file, and this is currently 50.
1558    
1559    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.
1560    
1561    
1562    =cut
1563    
1564    sub rss_feed {
1565     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1566     my ($files, $args)=@_;
1567    
1568     # how many entries to store in the file
1569     my $max_entries=50;
1570    
1571     foreach my $a (keys %$args) {if ($a =~ /^-(.*)/) {my $b=$1; $args->{$b}=$args->{$a}; delete $args->{$a}}}
1572    
1573     my $filepath=$FIG_Config::fig."/CGI/Html/rss";
1574     # check for the directory and if not, make it
1575     mkdir $filepath unless (-d $filepath);
1576    
1577     # note that $info is a hash of references to hashes that are written out as headers in the file
1578     my $info=
1579     {
1580      "SEED.rss" =>
1581       {
1582            title           => "The SEED",
1583            description     => "Latest news from the SEED",
1584            link            => "Html/rss/SEED.rss",
1585       },
1586    
1587      "SEEDsubsystems.rss" =>
1588      {
1589            title           => "SEED Subsystems",
1590            description     => "Recently updated SEED subsystems",
1591            link            => "Html/rss/SEEDsubsystems.rss",
1592      },
1593    
1594      "SEEDsubsystems.rss" =>
1595      {
1596            title           => "SEED Genomes",
1597            description     => "Genomes recently added to the SEED",
1598            link            => &FIG::cgi_url()."/Html/rss/SEEDsubsystems.rss",
1599      },
1600    
1601     };
1602    
1603    
1604     # build the new xml
1605     my $xml = "\t<item>\n";
1606     foreach my $qw ("title", "description", "link") {
1607      unless ($args->{$qw}) {
1608       print STDERR "You need to include a $qw tag in your RSS description\n";
1609       return(0);
1610      }
1611      # we need to do something a bit funky with the link. We can't have ampersands in the <link> </link> in valid html
1612      # so we are going to pull out the links and uri_escape just the part after the .cgi
1613      if ($qw eq "link")
1614      {
1615       $args->{$qw} =~ /^(.*?\.cgi.)(.*)$/;
1616       $args->{$qw} = $1.uri_escape($2) if ($1 && $2);
1617      }
1618    
1619      $xml .= "\t\t<$qw>".$args->{$qw}."</$qw>\n";
1620      delete $args->{$qw};
1621     }
1622    
1623     foreach my $tag (grep {!/type/i} keys %$args)
1624     {
1625      $xml .= "\t\t<$tag>".$args->{$tag}."</$tag>\n";
1626     }
1627    
1628     $xml .= "\t</item>\n";
1629    
1630    
1631     my @files=("SEED.rss");
1632     if ($args->{"type"}) {push @files, "SEED.$type.rss"}
1633    
1634     foreach my $file ("SEED.rss", @$files)
1635     {
1636      if (-e "$filepath/$file")
1637      {
1638       my @out; # the new content of the file
1639       my $itemcount=0; # how many <item> </item>'s are we keeping
1640       my $initem; # are we in an item?
1641       open(IN, "$filepath/$file") || die "Can't open $filepath/$file";
1642       while (<IN>)
1643       {
1644        if (/\<item\>/) {
1645         push @out, $xml, unless ($itemcount);
1646         $itemcount++;
1647         $initem=1;
1648        }
1649        if (/\<\/item\>/) {$initem=0; next if ($itemcount > $max_entries)}
1650        next if ($initem && $itemcount > $max_entries);
1651        push @out, $_;
1652       }
1653       close IN;
1654       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1655       print OUT @out;
1656      }
1657      else
1658      {
1659       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1660       print OUT "<?xml version=\"1.0\"?>\n<rss version=\"2.0\">\n<channel>\n";
1661       if ($info->{$file})
1662       {
1663         # we're going to sanity check each of the three options we output, just to be sure
1664         foreach my $qw ("title", "description", "link")
1665         {
1666           if ($info->{$file}->{$qw})
1667           {
1668              print OUT "<$qw>", $info->{$file}->{$qw}, "</$qw>\n";
1669           } else {
1670              print STDERR "Please add a $qw for $file\n"; print OUT "<$qw>$file</$qw>\n";
1671           }
1672         }
1673       }
1674       else {
1675        print STDERR "Please define title, link, and description information for $file\n";
1676        print OUT "<title>$file</title>\n<description>An RSS feed</description>\n<link>", &FIG::cgi_url, "</link>\n";
1677       }
1678       print OUT "\n", $xml;
1679       print OUT "\n", "</channel>\n</rss>\n"
1680      }
1681     }
1682    }
1683    
1684    
1685    
1686    1;
1687    

Legend:
Removed from v.1.37  
changed lines
  Added in v.1.89

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3