[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.62, Mon Oct 3 23:22:48 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;
7  use LWP::UserAgent;  use LWP::UserAgent;
8  use LWP::Simple;  use LWP::Simple;
9    use URI::Escape;  # uri_escape()
10  use URI::URL;  use URI::URL;
11  use HTTP::Request::Common;  use HTTP::Request::Common;
12  use POSIX;  use POSIX;
13    
14    
15  sub new  sub new
16  {  {
17      my($class) = @_;      my($class) = @_;
# Line 21  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 44  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 52  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 65  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) = @_;      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 77  Line 90 
90      #     $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
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")
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') || "";
106      my @html_hdr;      my @html_hdr;
107      if ($alt_header)      if ($alt_header && ref($alt_header) eq "ARRAY")
108      {      {
109         @html_hdr = @$alt_header;         @html_hdr = @$alt_header;
110      }      }
# Line 99  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      print $cgi->header;      # This modification adds the cookies if necessary
118        print $cgi->header(-cookie=>$cookie);
119    
120      #      #
121      #  The SEED header file goes immediately after <BODY>.  Figure out      #  The SEED header file goes immediately after <BODY>.  Figure out
# Line 118  Line 133 
133                       meta     => 1,                       meta     => 1,
134                       nextid   => 1,                       nextid   => 1,
135                       style    => 1,                       style    => 1,
136                       title    => 1                       title    => 1,
137                     );                     );
138    
139      #      #
# Line 221  Line 236 
236      #  Added the javascript for the buttons immediately after body.      #  Added the javascript for the buttons immediately after body.
237      #  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,
238      #  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!
239        #  RAE: This is now deprecated because everything is in an external file, FIG.js, included later
240    
241      if ( $body_line < 0 )      if ( $body_line < 0 )
242      {      {
         my $js=&javascript;  
243          $body_line = $last_head_line + 1;          $body_line = $last_head_line + 1;
244          splice( @$html, $body_line, 0, "<BODY>\n$js\n" );          splice( @$html, $body_line, 0, "<BODY>\n" );
245      }      }
246    
247      #      #
# Line 250  Line 265 
265    
266      # RAE:      # RAE:
267      # Add css here      # Add css here
268      # 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
269      # css has the format      # be moved out, but I want to try it and see what happens.  css has the format:
270        #
271      # <link rel='stylesheet' title='default' href='/css/default.css' type='text/css'>      # <link rel='stylesheet' title='default' href='/css/default.css' type='text/css'>
272    
273      # 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 275 
275    
276      if (!$css || !$css->{'Default'})      if (!$css || !$css->{'Default'})
277      {      {
278         $css->{'Default'}="/FIG/Html/css/default.css";         $css->{'Default'} = &FIG::cgi_url() . "/Html/css/default.css";
279      }      }
280      if (!$css->{"Sans Serif"})      if (!$css->{"Sans Serif"})
281      {      {
282         $css->{'Sans Serif'}="/FIG/Html/css/sanserif.css";         $css->{'Sans Serif'} = &FIG::cgi_url() . "/Html/css/sanserif.css";
283      }      }
284    
285      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";
286      $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";
287    
288      foreach my $k (keys %$css)      foreach my $k (keys %$css)
289      {      {
290         next if (lc($k) eq "default" || lc($k) eq "sans serif");         next if (lc($k) eq "default" || lc($k) eq "sans serif");
291         $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";
292        }
293    
294        $csstext   .= "<link rel='alternate'  title='SEED RSS feeds' href='".&FIG::cgi_url()."/Html/rss/SEED.rss' type='application/rss+xml'>\n";
295    
296        # RAE: also added support for external javascripts here.
297        # we are cluttering the HTML code with all the javascripts when they could easily be in external files
298        # this solution allows us to source other files
299    
300        # the file FIG.js contains most of the java script we use routinely. Every browser will just cache this and so
301        # it will reduce our overhead.
302    
303        # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts
304        push @$javasrc, &FIG::cgi_url() . "/Html/css/FIG.js";
305        foreach my $script (@$javasrc) {
306            $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";
307      }      }
308    
309    
310    
311      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.
312    
313      #      #
# Line 350  Line 385 
385      #  Figure out where to insert The SEED tail.  Before </body>,      #  Figure out where to insert The SEED tail.  Before </body>,
386      #  or before </html>, or at end of page.      #  or before </html>, or at end of page.
387      #      #
   
388      my @tags = ();      my @tags = ();
389        # Check for a tracing queue.
390        my $traceString = QTrace("HTML");
391        if ($traceString) {
392            push @tags, $traceString;
393        }
394      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}
395      if ($i >= @$html)        # </body> not found; look for </html>      if ($i >= @$html)        # </body> not found; look for </html>
396      {      {
# Line 374  Line 412 
412          splice( @$html, $i, 0, @tags );          splice( @$html, $i, 0, @tags );
413      }      }
414    
415      # 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,
416      # 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,
417        # and others don't. This should make nicer looking html
418        #
419      #chomp(@$html);      #chomp(@$html);
420      #print join "\n", @$html;      #print join "\n", @$html;
421        #
422      # Apparently the above still breaks things. This is the correct code:      # Apparently the above still breaks things. This is the correct code:
423      print @$html;  
424        foreach $_ (@$html)
425        {
426            print $_;
427        }
428    
429  }  }
430    
431  sub make_table {  sub make_table {
# Line 388  Line 433 
433      my(@tab);      my(@tab);
434    
435      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";
436      push( @tab, "\n<table $border>\n",      my $width = defined $options{width} ? "width=\"$options{width}\"" : undef;
437        push( @tab, "\n<table $border $width>\n",
438                  "\t<caption><b>$title</b></caption>\n",                  "\t<caption><b>$title</b></caption>\n",
439                  "\t<tr>\n\t\t"                  "\t<tr>\n\t\t"
440                . join( "\n", map { &expand($_, "th") } @$col_hdrs )                . join( "\n", map { &expand($_, "th") } @$col_hdrs )
# Line 414  Line 460 
460    
461      $tag = "td" unless $tag;      $tag = "td" unless $tag;
462      my $endtag=$tag;      my $endtag=$tag;
463      # RAE modified this so that you can pass in a reference to an array where the first element is the data to  
464      # 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
465        # the first element is the data to display and the second element is optional
466        # things like colspan and align. Note that in this case you need to include the td
467      # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]      # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]
468      if (ref($x) eq "ARRAY") {($x, $tag)=@$x; if ($tag =~ /td/) {$endtag = "td"}}  
469        # per GJO's request modified this line so it can take any tag.
470        if ( ref($x) eq "ARRAY" ) { ($x, $tag) = @$x; $tag =~ /^(\S+)/; $endtag = $1 }
471    
472      if ($x =~ /^\@([^:]+)\:(.*)$/)      if ($x =~ /^\@([^:]+)\:(.*)$/)
473      {      {
# Line 429  Line 479 
479      }      }
480  }  }
481    
482    
483    =head2 merge_table_rows()
484    
485    Merge table rows together. This will merge a table so that adjacent cells with the same content will only be shown once.
486    
487    Something like this:
488    
489        -----------------------
490        |    1     |    a     |
491        -----------------------
492        |    1     |    b     |
493        -----------------------
494        |    2     |    c     |
495        -----------------------
496        |    3     |    d     |
497        -----------------------
498        |    4     |    d     |
499        -----------------------
500        |    5     |    d     |
501        -----------------------
502    
503    Will become:
504    
505        -----------------------
506        |          |    a     |
507        |    1     |-----------
508        |          |    b     |
509        -----------------------
510        |    2     |    c     |
511        -----------------------
512        |    3     |          |
513        ------------          |
514        |    4     |    5     |
515        ------------          |
516        |    5     |          |
517        -----------------------
518    
519    
520    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.
521    
522     $tab=&HTML::merge_table_rows($tab);
523    
524     or
525    
526     $skip=(1=>1, 3=>1, 5=>1);
527     $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
528    
529    
530    =cut
531    
532    
533    
534    
535    sub merge_table_rows {
536     # RAE:
537     # Experimental piece of code. We often want to have rows or columns were cells are merged. It just looks so much nicer
538     # this block should merge adjacent rows that have the same text in them.
539     # use like this:
540     #      $tab=&HTML::merge_table_rows($tab);
541     # before you do a make_table call
542    
543     my $self=shift if UNIVERSAL::isa($_[0],__PACKAGE__);
544     my ($tab, $skip)=@_;
545    
546     my $newtable;
547     my $lastrow;
548     my $rowspan;
549     my $refs;
550    
551     for (my $y=0; $y <= $#$tab; $y++) {
552     #$y is the row in the table;
553      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
554       # this is the user definable columns not to merge
555       if ($skip->{$x})
556       {
557        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
558        next;
559       }
560    
561       #$x is the column in the table
562       # if the column in the row we are looking at is the same as the column in the previous row, we don't add
563       # this cell to $newtable. Instead we increment the rowspan of the previous row by one
564    
565       # handle cells that are references to arrays
566       if (ref($tab->[$y]->[$x]) eq "ARRAY") {$refs->[$y]->[$x]=$tab->[$y]->[$x]->[1]; $tab->[$y]->[$x]=$tab->[$y]->[$x]->[0]}
567    
568       # now we go back through the table looking where to draw the merge line:
569       my $lasty=$y;
570       while ($lasty >= 0 && $tab->[$y]->[$x] eq $tab->[$lasty]->[$x]) {$lasty--}
571       $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
572       if ($lasty == $y) {
573        # we always want to have something in rows that may otherwise be empty but should be there (see below)
574        unless ($tab->[$y]->[$x]) {$tab->[$y]->[$x]=" &nbsp; "}
575        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
576       }
577       else {$rowspan->[$lasty]->[$x]++}
578      }
579     }
580    
581     # now just join everything back together
582     for (my $y=0; $y <= $#$tab; $y++) {
583      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
584       if ($rowspan->[$y]->[$x]) {
585        if ($refs->[$y]->[$x]) {$refs->[$y]->[$x] .= " rowspan=". ($rowspan->[$y]->[$x]+1)}
586        else {$refs->[$y]->[$x] = "td rowspan=". ($rowspan->[$y]->[$x]+1)}
587        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
588       }
589       elsif ($newtable->[$y]->[$x] && $refs->[$y]->[$x]) {
590        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
591       }
592      }
593     }
594    
595    
596     # finally we have to remove any completely empty cells that have been added by the array mechanism
597     # (e.g. if you define $a->[2] then $a->[0] and $a->[1] are now undef).
598     # that is why in the loop above I replace empty cells with nbsp. They are now not undef!
599     # I am sure that Gary can do this in one line, but I am hacking.
600     my @trimmed;
601     foreach my $a (@$newtable) {
602      my @row;
603      foreach my $b (@$a) {
604       push @row, $b if ($b);
605      }
606      push @trimmed, \@row;
607     }
608    
609     return \@trimmed;
610    }
611    
612    
613    
614    
615  sub set_ec_links {  sub set_ec_links {
616      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
617      my($cgi,$x) = @_;      my($cgi,$x) = @_;
# Line 496  Line 679 
679          {          {
680              $n = $fid;              $n = $fid;
681          }          }
682          if ($1 ne "peg") { return $n }  
683            my $link;
684            #added to format prophage and path island links to feature.cgi
685            if ($1 ne "peg")
686            {
687               my $user = $cgi->param('user');
688               if (! $user) { $user = "" }
689               my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
690               $link = &FIG::cgi_url . "/feature.cgi?feature=$fid&user=$user$trans$sprout";
691               $link =~ s/[a-z_A-Z0-9]+\.cgi\?/feature.cgi?/;
692            }
693            else
694            {
695          my $user = $cgi->param('user');          my $user = $cgi->param('user');
696          if (! $user) { $user = "" }          if (! $user) { $user = "" }
697          my $trans = $cgi->param('translate') ? "&translate=1" : "";          my $trans = $cgi->param('translate') ? "&translate=1" : "";
698          my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";          my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
699          my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";  ###a
700    
701    ### This used to be
702    ###     my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
703    ###
704    ### The cost became prohibitive in the subsystem spreadsheets.  Hence, we cache the value
705    ###
706    ### RAO
707    
708                if (! $cgi_url) { $cgi_url = &FIG::cgi_url }
709                $link = $cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
710          $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;          $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
711          #          #
712          # Elimin the p2p part if we're in that subdir. Ugh.          # Elimin the p2p part if we're in that subdir. Ugh.
713          #          #
714          $link =~ s,p2p/protein.cgi,protein.cgi,;          $link =~ s,p2p/protein.cgi,protein.cgi,;
715            }
716          if ($just_url)          if ($just_url)
717          {          {
718              return $link;              return $link;
# Line 527  Line 732 
732      return $family;      return $family;
733  }  }
734    
 use URI::Escape;  
735    
736  sub get_html {  sub get_html {
737      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
# Line 658  Line 862 
862          $after = $3;          $after = $3;
863          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);
864      }      }
865        elsif ($x =~ /^(.*)(tigr\|[0-9a-zA-Z]+)(.*)/s)
866        {
867            $before = $1;
868            $match = $2;
869            $after = $3;
870            return &set_prot_links($cgi,$before) . &HTML::tigr_link($cgi,$match) . &set_prot_links($cgi,$after);
871        }
872      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
873      {      {
874          $before = $1;          $before = $1;
# Line 710  Line 921 
921      return $gi;      return $gi;
922  }  }
923    
924    sub tigr_link {
925        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
926        my($cgi,$tigr) = @_;
927    
928        if ($tigr =~ /^tigr\|([0-9a-zA-Z]+)$/)
929        {
930            return "<a href=\"http://pathema.tigr.org/tigr-scripts/CMR/GenePage.cgi?locus=$1\">$tigr</a>";
931        }
932        return $tigr;
933    }
934    
935  sub uni_link {  sub uni_link {
936      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
937      my($cgi,$uni) = @_;      my($cgi,$uni) = @_;
# Line 778  Line 1000 
1000      $user = $cgi->param('user');      $user = $cgi->param('user');
1001      $user = $user ? $user : "";      $user = $user ? $user : "";
1002      $org = $org ? $org : "";      $org = $org ? $org : "";
1003      my $url = "$FIG_Config::cgi_url/show_kegg_map.cgi?user=$user&map=$map&org=$org";  
1004        my $url = &FIG::cgi_url() . "/show_kegg_map.cgi?user=$user&map=$map&org=$org";
1005      my $link = "<a href=\"$url\">$map</a>";      my $link = "<a href=\"$url\">$map</a>";
1006      return $link;      return $link;
1007  }  }
1008    
 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;  
 }  
   
1009  sub java_buttons {  sub java_buttons {
1010      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1011    ## ADDED BY RAE    ## ADDED BY RAE
# Line 858  Line 1030 
1030      my $user = $cgi->param('user');      my $user = $cgi->param('user');
1031      if ($user)      if ($user)
1032      {      {
1033          $sub_link = "<a href=./subsys.cgi?ssa_name=$sub&request=show_ssa&user=$user>$sub</a>";          my $esc_sub = uri_escape( $sub );
1034            $sub_link = "<a href=./subsys.cgi?ssa_name=$esc_sub&request=show_ssa&user=$user>$sub</a>";
1035      }      }
1036      else      else
1037      {      {
# Line 867  Line 1040 
1040      return $sub_link;      return $sub_link;
1041  }  }
1042    
1043  1  sub reaction_link {
1044        my($reaction) = @_;
1045    
1046        if ($reaction =~ /^R\d+/)
1047        {
1048            return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?rn+$reaction\" target=reaction$$>$reaction</a>";
1049        }
1050        return $reaction;
1051    }
1052    
1053    sub html_for_assignments {
1054        my($fig,$user,$peg_sets) = @_;
1055        my $i;
1056    
1057        my @vals = ();
1058        my $set = 1;
1059        foreach $peg_set (@$peg_sets)
1060        {
1061            for ($i=0; ($i < @$peg_set); $i++)
1062            {
1063                $peg = $peg_set->[$i];
1064                push(@vals,'show=' . join("@",($set,$i+1,$peg,&FIG::abbrev($fig->org_of($peg)),"")));
1065            }
1066            $set++;
1067        }
1068    
1069        $ENV{'REQUEST_METHOD'} = 'GET';
1070        $ENV{'QUERY_STRING'} = join('&',('request=show_commentary',"uni=1","user=$user",@vals));
1071        my $out = join("",`$FIG_Config::fig/CGI/chromosomal_clusters.cgi`);
1072        $out =~ s/^.*?<form/<form/si;
1073        $out =~ s/^(.*)<table.*/$1/si;
1074        return $out;
1075    }
1076    
1077    =head1 rss_feed
1078    
1079    Add something to the RSS feed. The rss feeds are stored in the Html directory, and there are several RSS feeds:
1080            SEED.rss                - everything gets written here
1081            SEEDgenomes.rss                 - whenever a genome is added to the SEED
1082            SEEDsubsystems.rss      - whenever a subsystem is edited (or should this be added?)
1083    
1084    
1085    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.
1086    
1087    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.
1088    
1089    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.
1090    
1091    The has can have these keys:
1092    
1093    REQUIRED:
1094    title       : the title. This is usually what is seen by the user in the pull down menu
1095    description : a more complete description that is often seen is rss viewers but not always
1096    link        : link to the item that was added/edited
1097    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.
1098    
1099    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.
1100    
1101    
1102    =cut
1103    
1104    sub rss_feed {
1105     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1106     my ($files, $args)=@_;
1107     foreach my $a (keys %$args) {if ($a =~ /^-(.*)/) {my $b=$1; $args->{$b}=$args->{$a}; delete $args->{$a}}}
1108    
1109     my $filepath=$FIG_Config::fig."/CGI/Html/rss";
1110     # check for the directory and if not, make it
1111     mkdir $filepath unless (-d $filepath);
1112    
1113     # note that $info is a hash of references to hashes that are written out as headers in the file
1114     my $info=
1115     {
1116      "SEED.rss" =>
1117       {
1118            title           => "The SEED",
1119            description     => "Latest news from the SEED",
1120            link            => &FIG::cgi_url()."/Html/rss/SEED.rss",
1121       },
1122    
1123      "SEEDsubsystems.rss" =>
1124      {
1125            title           => "SEED Subsystems",
1126            description     => "Recently updated SEED subsystems",
1127            link            => &FIG::cgi_url()."/Html/rss/SEEDsubsystems.rss",
1128      },
1129    
1130      "SEEDsubsystems.rss" =>
1131      {
1132            title           => "SEED Genomes",
1133            description     => "Genomes recently added to the SEED",
1134            link            => &FIG::cgi_url()."/Html/rss/SEEDsubsystems.rss",
1135      },
1136    
1137     };
1138    
1139    
1140     # build the new xml
1141     my $xml = "\t<item>\n";
1142     foreach my $qw ("title", "description", "link") {
1143      unless ($args->{$qw}) {
1144       print STDERR "You need to include a $qw tag in your RSS description\n";
1145       return(0);
1146      }
1147      # we need to do something a bit funky with the link. We can't have ampersands in the <link> </link> in valid html
1148      # so we are going to pull out the links and uri_escape just the part after the .cgi
1149      if ($qw eq "link")
1150      {
1151       $args->{$qw} =~ /^(.*?\.cgi.)(.*)$/;
1152       print STDERR "Got ->>$1<<- and ->>$2<<-\n";
1153       $args->{$qw} = $1.uri_escape($2) if ($1 && $2);
1154      }
1155    
1156      $xml .= "\t\t<$qw>".$args->{$qw}."</$qw>\n";
1157      delete $args->{$qw};
1158     }
1159    
1160     foreach my $tag (grep {!/type/i} keys %$args)
1161     {
1162      $xml .= "\t\t<$tag>".$args->{$tag}."</$tag>\n";
1163     }
1164    
1165     $xml .= "\t</item>\n";
1166    
1167    
1168     my @files=("SEED.rss");
1169     if ($args->{"type"}) {push @files, "SEED.$type.rss"}
1170    
1171     foreach my $file ("SEED.rss", @$files)
1172     {
1173      if (-e "$filepath/$file")
1174      {
1175       my @out; # the new content of the file
1176       my $itemcount=0; # how many <item> </item>'s are we keeping
1177       my $initem; # are we in an item?
1178       open(IN, "$filepath/$file") || die "Can't open $filepath/$file";
1179       while (<IN>)
1180       {
1181        if (/\<item\>/) {
1182         push @out, $xml, unless ($itemcount);
1183         $itemcount++;
1184         $initem=1;
1185        }
1186        if (/\<\/item\>/) {$initem=0; next if ($itemcount > 9)}
1187        next if ($initem && $itemcount > 9);
1188        push @out, $_;
1189       }
1190       close IN;
1191       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1192       print OUT @out;
1193      }
1194      else
1195      {
1196       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1197       print OUT "<?xml version=\"1.0\"?>\n<rss version=\"2.0\">\n<channel>\n";
1198       if ($info->{$file})
1199       {
1200         # we're going to sanity check each of the three options we output, just to be sure
1201         foreach my $qw ("title", "description", "link")
1202         {
1203           if ($info->{$file}->{$qw})
1204           {
1205              print OUT "<$qw>", $info->{$file}->{$qw}, "</$qw>\n";
1206           } else {
1207              print STDERR "Please add a $qw for $file\n"; print OUT "<$qw>$file</$qw>\n";
1208           }
1209         }
1210       }
1211       else {
1212        print STDERR "Please define title, link, and description information for $file\n";
1213        print OUT "<title>$file</title>\n<description>An RSS feed</description>\n<link>", &FIG::cgi_url, "</link>\n";
1214       }
1215       print OUT "\n", $xml;
1216       print OUT "\n", "</channel>\n</rss>\n"
1217      }
1218     }
1219    }
1220    
1221    
1222    
1223    1;
1224    

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3