[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.41, Thu Apr 28 20:56:37 2005 UTC revision 1.64, Sat Oct 8 14:14:47 2005 UTC
# Line 1  Line 1 
1  package HTML;  package HTML;
2    
3    use Tracer;
4  use FIG;  use FIG;
5  use Carp;  use Carp;
6  use Data::Dumper;  use Data::Dumper;
# Line 10  Line 11 
11  use HTTP::Request::Common;  use HTTP::Request::Common;
12  use POSIX;  use POSIX;
13    
14    
15  sub new  sub new
16  {  {
17      my($class) = @_;      my($class) = @_;
# Line 22  Line 24 
24  sub compute_html_header  sub compute_html_header
25  {  {
26      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
27      my($additional_insert,$user) = @_;      my($additional_insert, $user, %options ) = @_;
28      my $html_hdr_file = "./Html/html.hdr";  
29        my $header_name = $options{header_name} ? $options{header_name} : "html.hdr";
30        my $tail_name = $options{tail_name} ? $options{tail_name} : "html.tail";
31    
32        my $html_hdr_file = "./Html/$header_name";
33      if (! -f $html_hdr_file)      if (! -f $html_hdr_file)
34      {      {
35          $html_hdr_file = "$FIG_Config::fig/CGI/Html/html.hdr";          $html_hdr_file = "$FIG_Config::fig/CGI/Html/$header_name";
36      }      }
37      my @html_hdr = &FIG::file_read($html_hdr_file);      my @html_hdr = &FIG::file_read($html_hdr_file);
38      push( @html_hdr, "<br><a href=\"index.cgi?user=$user\">FIG search</a>\n" );  
39        $options{no_fig_search} or push( @html_hdr, "<br><a href=\"index.cgi?user=$user\">FIG search</a>\n" );
40    
41      if (@html_hdr)      if (@html_hdr)
42      {      {
43          my $insert_stuff;          my $insert_stuff;
44    
45            if (not $options{no_release_info})
46            {
47          my @ver = &FIG::file_head("$FIG_Config::fig_disk/CURRENT_RELEASE", 1);          my @ver = &FIG::file_head("$FIG_Config::fig_disk/CURRENT_RELEASE", 1);
48          my $ver = $ver[0];          my $ver = $ver[0];
49          chomp $ver;          chomp $ver;
# Line 45  Line 55 
55          }          }
56          my $host = &FIG::get_local_hostname();          my $host = &FIG::get_local_hostname();
57          $insert_stuff = "SEED version <b>$ver</b> on $host";          $insert_stuff = "SEED version <b>$ver</b> on $host";
58            }
59    
60          if ($additional_insert)          if ($additional_insert)
61          {          {
62              $insert_stuff .= "<br>" . $additional_insert;              $insert_stuff .= "<br>" . $additional_insert;
# Line 53  Line 65 
65          for $_ (@html_hdr)          for $_ (@html_hdr)
66          {          {
67              s,(href|img\s+src)="/FIG/,\1="$FIG_Config::cgi_base,g;              s,(href|img\s+src)="/FIG/,\1="$FIG_Config::cgi_base,g;
68                s,(\?user\=)\",$1$user",;
69              if ($_ eq "<!-- HEADER_INSERT -->\n")              if ($_ eq "<!-- HEADER_INSERT -->\n")
70              {              {
71                  $_ = $insert_stuff;                  $_ = $insert_stuff;
# Line 66  Line 79 
79  sub show_page {  sub show_page {
80      #warn "SHOWPAGE: cgi=", Dumper(@_);      #warn "SHOWPAGE: cgi=", Dumper(@_);
81      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
82      my($cgi,$html,$no_home, $alt_header, $css, $javasrc) = @_;      my($cgi,$html,$no_home, $alt_header, $css, $javasrc, $cookie) = @_;
83      my $i;      my $i;
84    
   
85      # ARGUMENTS:      # ARGUMENTS:
86      #     $cgi is the CGI method      #     $cgi is the CGI method
87      #     $html is an array with all the html in it. It is just joined by "\n" (and not <br> or <p>      #     $html is an array with all the html in it. It is just joined by "\n" (and not <br> or <p>
# Line 79  Line 91 
91      #               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
92      #               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
93      #     $javasrc is a reference to an array of URLs to javascripts to be included (e.g. "/FIG/Html/css/styleswitcher.js")      #     $javasrc is a reference to an array of URLs to javascripts to be included (e.g. "/FIG/Html/css/styleswitcher.js")
94        #     $cookie is the name and value of the cookie to set. Note that you should probably use raelib->cookie to get/set your cookies
95      #      #
96      # Find the HTML header      # Find the HTML header
97      #      #
98    
99      my $html_tail_file = "./Html/html.tail";      my $html_tail_file = "./Html/$tail_name";
100      if (! -f $html_tail_file)      if (! -f $html_tail_file)
101      {      {
102          $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";          $html_tail_file = "$FIG_Config::fig/CGI/Html/$tail_name";
103      }      }
104    
105      my $user = $cgi->param('user') || "";      my $user = $cgi->param('user') || "";
# Line 100  Line 113 
113          @html_hdr = compute_html_header(undef,$user);          @html_hdr = compute_html_header(undef,$user);
114      }      }
115    
116        # RAE: I am offloading the handling of cookies to CGI.pm since I don't know how they are set up.
117        # This modification adds the cookies if necessary
118    
119      print $cgi->header;      # Note: 3/10/05 commented this line out pending the discussion of adding cookies into the seed that we are waiting to see about
120        # to add cookies back in replace these two header lines with each other
121    
122        #print $cgi->header(-cookie=>$cookie);
123        print $cgi->header();
124    
125      #      #
126      #  The SEED header file goes immediately after <BODY>.  Figure out      #  The SEED header file goes immediately after <BODY>.  Figure out
# Line 119  Line 138 
138                       meta     => 1,                       meta     => 1,
139                       nextid   => 1,                       nextid   => 1,
140                       style    => 1,                       style    => 1,
141                       title    => 1                       title    => 1,
142                     );                     );
143    
144      #      #
# Line 222  Line 241 
241      #  Added the javascript for the buttons immediately after body.      #  Added the javascript for the buttons immediately after body.
242      #  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,
243      #  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!
244        #  RAE: This is now deprecated because everything is in an external file, FIG.js, included later
245    
246      if ( $body_line < 0 )      if ( $body_line < 0 )
247      {      {
         my $js=&javascript;  
248          $body_line = $last_head_line + 1;          $body_line = $last_head_line + 1;
249          splice( @$html, $body_line, 0, "<BODY>\n$js\n" );          splice( @$html, $body_line, 0, "<BODY>\n" );
250      }      }
251    
252      #      #
# Line 261  Line 280 
280    
281      if (!$css || !$css->{'Default'})      if (!$css || !$css->{'Default'})
282      {      {
283         $css->{'Default'}="/FIG/Html/css/default.css";         $css->{'Default'} = &FIG::cgi_url() . "/Html/css/default.css";
284      }      }
285      if (!$css->{"Sans Serif"})      if (!$css->{"Sans Serif"})
286      {      {
287         $css->{'Sans Serif'}="/FIG/Html/css/sanserif.css";         $css->{'Sans Serif'} = &FIG::cgi_url() . "/Html/css/sanserif.css";
288      }      }
289    
290      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";
291      $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";
292    
# Line 276  Line 296 
296         $csstext .= "<link rel='alternate stylesheet' title='$k' href='".$css->{$k}."' type='text/css'>\n";         $csstext .= "<link rel='alternate stylesheet' title='$k' href='".$css->{$k}."' type='text/css'>\n";
297      }      }
298    
299        $csstext   .= "<link rel='alternate'  title='SEED RSS feeds' href='".&FIG::cgi_url()."/Html/rss/SEED.rss' type='application/rss+xml'>\n";
300    
301      # RAE: also added support for external javascripts here.      # RAE: also added support for external javascripts here.
302      # we are cluttering the HTML code with all the javascripts when they could easily be in external files      # we are cluttering the HTML code with all the javascripts when they could easily be in external files
303      # this solution allows us to source other files      # this solution allows us to source other files
304    
305        # the file FIG.js contains most of the java script we use routinely. Every browser will just cache this and so
306        # it will reduce our overhead.
307    
308      # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts      # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts
309      if ($javasrc && ref($javasrc) eq "ARRAY") {      push @$javasrc, &FIG::cgi_url() . "/Html/css/FIG.js";
310       foreach my $script (@$javasrc) {       foreach my $script (@$javasrc) {
311        $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";        $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";
312       }       }
     }  
313    
314    
315    
# Line 317  Line 340 
340  #       }  #       }
341    
342          $base_line = $head_end_line;          $base_line = $head_end_line;
343          splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );          #
344            # RDO 2005-1006. Remove this so proxying works better.
345            #
346    #        splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );
347      }      }
348    
349      #      #
# Line 367  Line 393 
393      #  Figure out where to insert The SEED tail.  Before </body>,      #  Figure out where to insert The SEED tail.  Before </body>,
394      #  or before </html>, or at end of page.      #  or before </html>, or at end of page.
395      #      #
   
396      my @tags = ();      my @tags = ();
397        # Check for a tracing queue.
398        my $traceString = QTrace("HTML");
399        if ($traceString) {
400            push @tags, $traceString;
401        }
402      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}
403      if ($i >= @$html)        # </body> not found; look for </html>      if ($i >= @$html)        # </body> not found; look for </html>
404      {      {
# Line 400  Line 429 
429      #      #
430      # Apparently the above still breaks things. This is the correct code:      # Apparently the above still breaks things. This is the correct code:
431    
432      print @$html;      foreach $_ (@$html)
433        {
434            print $_;
435        }
436    
437  }  }
438    
439  sub make_table {  sub make_table {
# Line 408  Line 441 
441      my(@tab);      my(@tab);
442    
443      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";
444      push( @tab, "\n<table $border>\n",      my $width = defined $options{width} ? "width=\"$options{width}\"" : undef;
445        push( @tab, "\n<table $border $width>\n",
446                  "\t<caption><b>$title</b></caption>\n",                  "\t<caption><b>$title</b></caption>\n",
447                  "\t<tr>\n\t\t"                  "\t<tr>\n\t\t"
448                . join( "\n", map { &expand($_, "th") } @$col_hdrs )                . join( "\n", map { &expand($_, "th") } @$col_hdrs )
# Line 440  Line 474 
474      # things like colspan and align. Note that in this case you need to include the td      # things like colspan and align. Note that in this case you need to include the td
475      # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]      # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]
476    
477      if ( ref($x) eq "ARRAY" ) { ($x, $tag) = @$x; if ($tag =~ /td/) { $endtag = "td" } }      # per GJO's request modified this line so it can take any tag.
478        if ( ref($x) eq "ARRAY" ) { ($x, $tag) = @$x; $tag =~ /^(\S+)/; $endtag = $1 }
479    
480      if ( $x =~ /^\@([^:]+)\:(.*)$/ )      if ( $x =~ /^\@([^:]+)\:(.*)$/ )
481      {      {
# Line 452  Line 487 
487      }      }
488  }  }
489    
490    
491    =head2 merge_table_rows()
492    
493    Merge table rows together. This will merge a table so that adjacent cells with the same content will only be shown once.
494    
495    Something like this:
496    
497        -----------------------
498        |    1     |    a     |
499        -----------------------
500        |    1     |    b     |
501        -----------------------
502        |    2     |    c     |
503        -----------------------
504        |    3     |    d     |
505        -----------------------
506        |    4     |    d     |
507        -----------------------
508        |    5     |    d     |
509        -----------------------
510    
511    Will become:
512    
513        -----------------------
514        |          |    a     |
515        |    1     |-----------
516        |          |    b     |
517        -----------------------
518        |    2     |    c     |
519        -----------------------
520        |    3     |          |
521        ------------          |
522        |    4     |    5     |
523        ------------          |
524        |    5     |          |
525        -----------------------
526    
527    
528    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.
529    
530     $tab=&HTML::merge_table_rows($tab);
531    
532     or
533    
534     $skip=(1=>1, 3=>1, 5=>1);
535     $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
536    
537    
538    =cut
539    
540    
541    
542    
543    sub merge_table_rows {
544     # RAE:
545     # Experimental piece of code. We often want to have rows or columns were cells are merged. It just looks so much nicer
546     # this block should merge adjacent rows that have the same text in them.
547     # use like this:
548     #      $tab=&HTML::merge_table_rows($tab);
549     # before you do a make_table call
550    
551     my $self=shift if UNIVERSAL::isa($_[0],__PACKAGE__);
552     my ($tab, $skip)=@_;
553    
554     my $newtable;
555     my $lastrow;
556     my $rowspan;
557     my $refs;
558    
559     for (my $y=0; $y <= $#$tab; $y++) {
560     #$y is the row in the table;
561      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
562       # this is the user definable columns not to merge
563       if ($skip->{$x})
564       {
565        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
566        next;
567       }
568    
569       #$x is the column in the table
570       # if the column in the row we are looking at is the same as the column in the previous row, we don't add
571       # this cell to $newtable. Instead we increment the rowspan of the previous row by one
572    
573       # handle cells that are references to arrays
574       if (ref($tab->[$y]->[$x]) eq "ARRAY") {$refs->[$y]->[$x]=$tab->[$y]->[$x]->[1]; $tab->[$y]->[$x]=$tab->[$y]->[$x]->[0]}
575    
576       # now we go back through the table looking where to draw the merge line:
577       my $lasty=$y;
578       while ($lasty >= 0 && $tab->[$y]->[$x] eq $tab->[$lasty]->[$x]) {$lasty--}
579       $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
580       if ($lasty == $y) {
581        # we always want to have something in rows that may otherwise be empty but should be there (see below)
582        unless ($tab->[$y]->[$x]) {$tab->[$y]->[$x]=" &nbsp; "}
583        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
584       }
585       else {$rowspan->[$lasty]->[$x]++}
586      }
587     }
588    
589     # now just join everything back together
590     for (my $y=0; $y <= $#$tab; $y++) {
591      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
592       if ($rowspan->[$y]->[$x]) {
593        if ($refs->[$y]->[$x]) {$refs->[$y]->[$x] .= " rowspan=". ($rowspan->[$y]->[$x]+1)}
594        else {$refs->[$y]->[$x] = "td rowspan=". ($rowspan->[$y]->[$x]+1)}
595        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
596       }
597       elsif ($newtable->[$y]->[$x] && $refs->[$y]->[$x]) {
598        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
599       }
600      }
601     }
602    
603    
604     # finally we have to remove any completely empty cells that have been added by the array mechanism
605     # (e.g. if you define $a->[2] then $a->[0] and $a->[1] are now undef).
606     # that is why in the loop above I replace empty cells with nbsp. They are now not undef!
607     # I am sure that Gary can do this in one line, but I am hacking.
608     my @trimmed;
609     foreach my $a (@$newtable) {
610      my @row;
611      foreach my $b (@$a) {
612       push @row, $b if ($b);
613      }
614      push @trimmed, \@row;
615     }
616    
617     return \@trimmed;
618    }
619    
620    
621    
622    
623  sub set_ec_links {  sub set_ec_links {
624      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
625      my($cgi,$x) = @_;      my($cgi,$x) = @_;
# Line 519  Line 687 
687          {          {
688              $n = $fid;              $n = $fid;
689          }          }
690          if ($1 ne "peg") { return $n }  
691            my $link;
692            #added to format prophage and path island links to feature.cgi
693            if ($1 ne "peg")
694            {
695               my $user = $cgi->param('user');
696               if (! $user) { $user = "" }
697               my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
698               $link = &FIG::cgi_url . "/feature.cgi?feature=$fid&user=$user$trans$sprout";
699               $link =~ s/[a-z_A-Z0-9]+\.cgi\?/feature.cgi?/;
700            }
701            else
702            {
703          my $user = $cgi->param('user');          my $user = $cgi->param('user');
704          if (! $user) { $user = "" }          if (! $user) { $user = "" }
705          my $trans = $cgi->param('translate') ? "&translate=1" : "";          my $trans = $cgi->param('translate') ? "&translate=1" : "";
706          my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";          my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
707          my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";  ###a
708    
709    ### This used to be
710    ###     my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
711    ###
712    ### The cost became prohibitive in the subsystem spreadsheets.  Hence, we cache the value
713    ###
714    ### RAO
715    
716                #if (! $cgi_url) { $cgi_url = &FIG::cgi_url }
717                #$link = $cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
718                $link = "protein.cgi?prot=$fid&user=$user$trans$sprout";
719          $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;          $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
720          #          #
721          # Elimin the p2p part if we're in that subdir. Ugh.          # Elimin the p2p part if we're in that subdir. Ugh.
722          #          #
723          $link =~ s,p2p/protein.cgi,protein.cgi,;          $link =~ s,p2p/protein.cgi,protein.cgi,;
724            }
725          if ($just_url)          if ($just_url)
726          {          {
727              return $link;              return $link;
# Line 680  Line 871 
871          $after = $3;          $after = $3;
872          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);
873      }      }
874        elsif ($x =~ /^(.*)(tigr\|[0-9a-zA-Z]+)(.*)/s)
875        {
876            $before = $1;
877            $match = $2;
878            $after = $3;
879            return &set_prot_links($cgi,$before) . &HTML::tigr_link($cgi,$match) . &set_prot_links($cgi,$after);
880        }
881      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
882      {      {
883          $before = $1;          $before = $1;
# Line 732  Line 930 
930      return $gi;      return $gi;
931  }  }
932    
933    sub tigr_link {
934        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
935        my($cgi,$tigr) = @_;
936    
937        if ($tigr =~ /^tigr\|([0-9a-zA-Z]+)$/)
938        {
939            return "<a href=\"http://pathema.tigr.org/tigr-scripts/CMR/GenePage.cgi?locus=$1\">$tigr</a>";
940        }
941        return $tigr;
942    }
943    
944  sub uni_link {  sub uni_link {
945      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
946      my($cgi,$uni) = @_;      my($cgi,$uni) = @_;
# Line 800  Line 1009 
1009      $user = $cgi->param('user');      $user = $cgi->param('user');
1010      $user = $user ? $user : "";      $user = $user ? $user : "";
1011      $org = $org ? $org : "";      $org = $org ? $org : "";
1012      my $url = "$FIG_Config::cgi_url/show_kegg_map.cgi?user=$user&map=$map&org=$org";  
1013        my $url = "show_kegg_map.cgi?user=$user&map=$map&org=$org";
1014    #rel    my $url = &FIG::cgi_url() . "/show_kegg_map.cgi?user=$user&map=$map&org=$org";
1015      my $link = "<a href=\"$url\">$map</a>";      my $link = "<a href=\"$url\">$map</a>";
1016      return $link;      return $link;
1017  }  }
1018    
 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;  
 }  
   
1019  sub java_buttons {  sub java_buttons {
1020      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1021    ## ADDED BY RAE    ## ADDED BY RAE
# Line 890  Line 1050 
1050      return $sub_link;      return $sub_link;
1051  }  }
1052    
1053  1  sub reaction_link {
1054        my($reaction) = @_;
1055    
1056        if ($reaction =~ /^R\d+/)
1057        {
1058            return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?rn+$reaction\" target=reaction$$>$reaction</a>";
1059        }
1060        return $reaction;
1061    }
1062    
1063    sub html_for_assignments {
1064        my($fig,$user,$peg_sets) = @_;
1065        my $i;
1066    
1067        my @vals = ();
1068        my $set = 1;
1069        foreach $peg_set (@$peg_sets)
1070        {
1071            for ($i=0; ($i < @$peg_set); $i++)
1072            {
1073                $peg = $peg_set->[$i];
1074                push(@vals,'show=' . join("@",($set,$i+1,$peg,&FIG::abbrev($fig->org_of($peg)),"")));
1075            }
1076            $set++;
1077        }
1078    
1079        $ENV{'REQUEST_METHOD'} = 'GET';
1080        $ENV{'QUERY_STRING'} = join('&',('request=show_commentary',"uni=1","user=$user",@vals));
1081        my $out = join("",`$FIG_Config::fig/CGI/chromosomal_clusters.cgi`);
1082        $out =~ s/^.*?<form/<form/si;
1083        $out =~ s/^(.*)<table.*/$1/si;
1084        return $out;
1085    }
1086    
1087    =head1 rss_feed
1088    
1089    Add something to the RSS feed. The rss feeds are stored in the Html directory, and there are several RSS feeds:
1090            SEED.rss                - everything gets written here
1091            SEEDgenomes.rss                 - whenever a genome is added to the SEED
1092            SEEDsubsystems.rss      - whenever a subsystem is edited (or should this be added?)
1093    
1094    
1095    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.
1096    
1097    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.
1098    
1099    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.
1100    
1101    The has can have these keys:
1102    
1103    REQUIRED:
1104    title       : the title. This is usually what is seen by the user in the pull down menu
1105    description : a more complete description that is often seen is rss viewers but not always
1106    link        : link to the item that was added/edited
1107    All other keys are treated as optional RSS arguments and written to the file. At most, 10 recent entries are stored in the rss file.
1108    
1109    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.
1110    
1111    
1112    =cut
1113    
1114    sub rss_feed {
1115     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1116     my ($files, $args)=@_;
1117     foreach my $a (keys %$args) {if ($a =~ /^-(.*)/) {my $b=$1; $args->{$b}=$args->{$a}; delete $args->{$a}}}
1118    
1119     my $filepath=$FIG_Config::fig."/CGI/Html/rss";
1120     # check for the directory and if not, make it
1121     mkdir $filepath unless (-d $filepath);
1122    
1123     # note that $info is a hash of references to hashes that are written out as headers in the file
1124     my $info=
1125     {
1126      "SEED.rss" =>
1127       {
1128            title           => "The SEED",
1129            description     => "Latest news from the SEED",
1130            link            => &FIG::cgi_url()."/Html/rss/SEED.rss",
1131       },
1132    
1133      "SEEDsubsystems.rss" =>
1134      {
1135            title           => "SEED Subsystems",
1136            description     => "Recently updated SEED subsystems",
1137            link            => &FIG::cgi_url()."/Html/rss/SEEDsubsystems.rss",
1138      },
1139    
1140      "SEEDsubsystems.rss" =>
1141      {
1142            title           => "SEED Genomes",
1143            description     => "Genomes recently added to the SEED",
1144            link            => &FIG::cgi_url()."/Html/rss/SEEDsubsystems.rss",
1145      },
1146    
1147     };
1148    
1149    
1150     # build the new xml
1151     my $xml = "\t<item>\n";
1152     foreach my $qw ("title", "description", "link") {
1153      unless ($args->{$qw}) {
1154       print STDERR "You need to include a $qw tag in your RSS description\n";
1155       return(0);
1156      }
1157      # we need to do something a bit funky with the link. We can't have ampersands in the <link> </link> in valid html
1158      # so we are going to pull out the links and uri_escape just the part after the .cgi
1159      if ($qw eq "link")
1160      {
1161       $args->{$qw} =~ /^(.*?\.cgi.)(.*)$/;
1162       print STDERR "Got ->>$1<<- and ->>$2<<-\n";
1163       $args->{$qw} = $1.uri_escape($2) if ($1 && $2);
1164      }
1165    
1166      $xml .= "\t\t<$qw>".$args->{$qw}."</$qw>\n";
1167      delete $args->{$qw};
1168     }
1169    
1170     foreach my $tag (grep {!/type/i} keys %$args)
1171     {
1172      $xml .= "\t\t<$tag>".$args->{$tag}."</$tag>\n";
1173     }
1174    
1175     $xml .= "\t</item>\n";
1176    
1177    
1178     my @files=("SEED.rss");
1179     if ($args->{"type"}) {push @files, "SEED.$type.rss"}
1180    
1181     foreach my $file ("SEED.rss", @$files)
1182     {
1183      if (-e "$filepath/$file")
1184      {
1185       my @out; # the new content of the file
1186       my $itemcount=0; # how many <item> </item>'s are we keeping
1187       my $initem; # are we in an item?
1188       open(IN, "$filepath/$file") || die "Can't open $filepath/$file";
1189       while (<IN>)
1190       {
1191        if (/\<item\>/) {
1192         push @out, $xml, unless ($itemcount);
1193         $itemcount++;
1194         $initem=1;
1195        }
1196        if (/\<\/item\>/) {$initem=0; next if ($itemcount > 9)}
1197        next if ($initem && $itemcount > 9);
1198        push @out, $_;
1199       }
1200       close IN;
1201       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1202       print OUT @out;
1203      }
1204      else
1205      {
1206       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1207       print OUT "<?xml version=\"1.0\"?>\n<rss version=\"2.0\">\n<channel>\n";
1208       if ($info->{$file})
1209       {
1210         # we're going to sanity check each of the three options we output, just to be sure
1211         foreach my $qw ("title", "description", "link")
1212         {
1213           if ($info->{$file}->{$qw})
1214           {
1215              print OUT "<$qw>", $info->{$file}->{$qw}, "</$qw>\n";
1216           } else {
1217              print STDERR "Please add a $qw for $file\n"; print OUT "<$qw>$file</$qw>\n";
1218           }
1219         }
1220       }
1221       else {
1222        print STDERR "Please define title, link, and description information for $file\n";
1223        print OUT "<title>$file</title>\n<description>An RSS feed</description>\n<link>", &FIG::cgi_url, "</link>\n";
1224       }
1225       print OUT "\n", $xml;
1226       print OUT "\n", "</channel>\n</rss>\n"
1227      }
1228     }
1229    }
1230    
1231    
1232    
1233    1;
1234    

Legend:
Removed from v.1.41  
changed lines
  Added in v.1.64

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3