[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.36, Tue Mar 15 21:01:14 2005 UTC revision 1.67, Wed Oct 12 21:53:22 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        # for my $k (sort keys %ENV) { warn "$k = $ENV{$k}\n"; }
40    
41        #
42        # Determine if this is a toplevel cgi or one in one of the subdirs (currently
43        # just /p2p).
44        #
45    
46        my @parts = split(/\//, $ENV{SCRIPT_NAME});
47        my $top;
48        if ($parts[-2] eq 'FIG')
49        {
50            $top = '.';
51    #       warn "toplevel @parts\n";
52        }
53        elsif ($parts[-3] eq 'FIG')
54        {
55            $top = '..';
56    #       warn "subdir @parts\n";
57        }
58        else
59        {
60            $top = $FIG_Config::cgi_base;
61    #       warn "other @parts\n";
62        }
63    
64        $options{no_fig_search} or push( @html_hdr, "<br><a href=\"$top/index.cgi?user=$user\">FIG search</a>\n" );
65    
66      if (@html_hdr)      if (@html_hdr)
67      {      {
68          my $insert_stuff;          my $insert_stuff;
69    
70            if (not $options{no_release_info})
71            {
72          my @ver = &FIG::file_head("$FIG_Config::fig_disk/CURRENT_RELEASE", 1);          my @ver = &FIG::file_head("$FIG_Config::fig_disk/CURRENT_RELEASE", 1);
73          my $ver = $ver[0];          my $ver = $ver[0];
74          chomp $ver;          chomp $ver;
# Line 44  Line 80 
80          }          }
81          my $host = &FIG::get_local_hostname();          my $host = &FIG::get_local_hostname();
82          $insert_stuff = "SEED version <b>$ver</b> on $host";          $insert_stuff = "SEED version <b>$ver</b> on $host";
83            }
84    
85          if ($additional_insert)          if ($additional_insert)
86          {          {
87              $insert_stuff .= "<br>" . $additional_insert;              $insert_stuff .= "<br>" . $additional_insert;
# Line 51  Line 89 
89    
90          for $_ (@html_hdr)          for $_ (@html_hdr)
91          {          {
92              s,(href|img\s+src)="/FIG/,\1="$FIG_Config::cgi_base,g;              s,(href|img\s+src)="/FIG/,\1="$top/,g;
93                s,(\?user\=)\",$1$user",;
94              if ($_ eq "<!-- HEADER_INSERT -->\n")              if ($_ eq "<!-- HEADER_INSERT -->\n")
95              {              {
96                  $_ = $insert_stuff;                  $_ = $insert_stuff;
# Line 65  Line 104 
104  sub show_page {  sub show_page {
105      #warn "SHOWPAGE: cgi=", Dumper(@_);      #warn "SHOWPAGE: cgi=", Dumper(@_);
106      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
107      my($cgi,$html,$no_home, $alt_header, $css) = @_;      my($cgi,$html,$no_home, $alt_header, $css, $javasrc, $cookie) = @_;
108      my $i;      my $i;
109    
   
110      # ARGUMENTS:      # ARGUMENTS:
111      #     $cgi is the CGI method      #     $cgi is the CGI method
112      #     $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 115 
115      #     $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
116      #               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
117      #               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
118        #     $javasrc is a reference to an array of URLs to javascripts to be included (e.g. "/FIG/Html/css/styleswitcher.js")
119        #     $cookie is the name and value of the cookie to set. Note that you should probably use raelib->cookie to get/set your cookies
120      #      #
121      # Find the HTML header      # Find the HTML header
122      #      #
123    
124      my $html_tail_file = "./Html/html.tail";      my $html_tail_file = "./Html/$tail_name";
125      if (! -f $html_tail_file)      if (! -f $html_tail_file)
126      {      {
127          $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";          $html_tail_file = "$FIG_Config::fig/CGI/Html/$tail_name";
128      }      }
129    
130      my $user = $cgi->param('user') || "";      my $user = $cgi->param('user') || "";
131      my @html_hdr;      my @html_hdr;
132      if ($alt_header)      if ($alt_header && ref($alt_header) eq "ARRAY")
133      {      {
134         @html_hdr = @$alt_header;         @html_hdr = @$alt_header;
135      }      }
# Line 99  Line 138 
138          @html_hdr = compute_html_header(undef,$user);          @html_hdr = compute_html_header(undef,$user);
139      }      }
140    
141        # RAE: I am offloading the handling of cookies to CGI.pm since I don't know how they are set up.
142        # This modification adds the cookies if necessary
143    
144        # Note: 3/10/05 commented this line out pending the discussion of adding cookies into the seed that we are waiting to see about
145        # to add cookies back in replace these two header lines with each other
146    
147      print $cgi->header;      #print $cgi->header(-cookie=>$cookie);
148        print $cgi->header();
149    
150      #      #
151      #  The SEED header file goes immediately after <BODY>.  Figure out      #  The SEED header file goes immediately after <BODY>.  Figure out
# Line 118  Line 163 
163                       meta     => 1,                       meta     => 1,
164                       nextid   => 1,                       nextid   => 1,
165                       style    => 1,                       style    => 1,
166                       title    => 1                       title    => 1,
167                     );                     );
168    
169      #      #
# Line 221  Line 266 
266      #  Added the javascript for the buttons immediately after body.      #  Added the javascript for the buttons immediately after body.
267      #  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,
268      #  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!
269        #  RAE: This is now deprecated because everything is in an external file, FIG.js, included later
270    
271      if ( $body_line < 0 )      if ( $body_line < 0 )
272      {      {
         my $js=&javascript;  
273          $body_line = $last_head_line + 1;          $body_line = $last_head_line + 1;
274          splice( @$html, $body_line, 0, "<BODY>\n$js\n" );          splice( @$html, $body_line, 0, "<BODY>\n" );
275      }      }
276    
277      #      #
# Line 250  Line 295 
295    
296      # RAE:      # RAE:
297      # Add css here      # Add css here
298      # 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
299      # css has the format      # be moved out, but I want to try it and see what happens.  css has the format:
300        #
301      # <link rel='stylesheet' title='default' href='/css/default.css' type='text/css'>      # <link rel='stylesheet' title='default' href='/css/default.css' type='text/css'>
302    
303      # 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 305 
305    
306      if (!$css || !$css->{'Default'})      if (!$css || !$css->{'Default'})
307      {      {
308         $css->{'Default'}="/FIG/Html/css/default.css";         $css->{'Default'} = &FIG::cgi_url() . "/Html/css/default.css";
309      }      }
310      if (!$css->{"Sans Serif"})      if (!$css->{"Sans Serif"})
311      {      {
312         $css->{'Sans Serif'}="/FIG/Html/css/sanserif.css";         $css->{'Sans Serif'} = &FIG::cgi_url() . "/Html/css/sanserif.css";
313      }      }
314    
315      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";
316      $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";
317    
318      foreach my $k (keys %$css)      foreach my $k (keys %$css)
319      {      {
320         next if (lc($k) eq "default" || lc($k) eq "sans serif");         next if (lc($k) eq "default" || lc($k) eq "sans serif");
321         $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";
322        }
323    
324        $csstext   .= "<link rel='alternate'  title='SEED RSS feeds' href='".&FIG::cgi_url()."/Html/rss/SEED.rss' type='application/rss+xml'>\n";
325    
326        # RAE: also added support for external javascripts here.
327        # we are cluttering the HTML code with all the javascripts when they could easily be in external files
328        # this solution allows us to source other files
329    
330        # the file FIG.js contains most of the java script we use routinely. Every browser will just cache this and so
331        # it will reduce our overhead.
332    
333        # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts
334        push @$javasrc, &FIG::cgi_url() . "/Html/css/FIG.js";
335        foreach my $script (@$javasrc) {
336            $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";
337      }      }
338    
339    
340    
341      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.
342    
343      #      #
# Line 300  Line 365 
365  #       }  #       }
366    
367          $base_line = $head_end_line;          $base_line = $head_end_line;
368          splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );          #
369            # RDO 2005-1006. Remove this so proxying works better.
370            #
371    #        splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );
372      }      }
373    
374      #      #
# Line 350  Line 418 
418      #  Figure out where to insert The SEED tail.  Before </body>,      #  Figure out where to insert The SEED tail.  Before </body>,
419      #  or before </html>, or at end of page.      #  or before </html>, or at end of page.
420      #      #
   
421      my @tags = ();      my @tags = ();
422        # Check for a tracing queue.
423        my $traceString = QTrace("HTML");
424        if ($traceString) {
425            push @tags, $traceString;
426        }
427      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}
428      if ($i >= @$html)        # </body> not found; look for </html>      if ($i >= @$html)        # </body> not found; look for </html>
429      {      {
# Line 374  Line 445 
445          splice( @$html, $i, 0, @tags );          splice( @$html, $i, 0, @tags );
446      }      }
447    
448      # 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,
449      # 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,
450      chomp(@$html);      # and others don't. This should make nicer looking html
451      print join "\n", @$html;      #
452        # chomp(@$html);
453        # print join "\n", @$html;
454        #
455        # Apparently the above still breaks things. This is the correct code:
456    
457        foreach $_ (@$html)
458        {
459            print $_;
460        }
461    
462  }  }
463    
464  sub make_table {  sub make_table {
# Line 385  Line 466 
466      my(@tab);      my(@tab);
467    
468      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";
469      push( @tab, "\n<table $border>\n",      my $width = defined $options{width} ? "width=\"$options{width}\"" : undef;
470        push( @tab, "\n<table $border $width>\n",
471                  "\t<caption><b>$title</b></caption>\n",                  "\t<caption><b>$title</b></caption>\n",
472                  "\t<tr>\n\t\t"                  "\t<tr>\n\t\t"
473                . join( "\n", map { &expand($_, "th") } @$col_hdrs )                . join( "\n", map { &expand($_, "th") } @$col_hdrs )
# Line 411  Line 493 
493    
494      $tag = "td" unless $tag;      $tag = "td" unless $tag;
495      my $endtag=$tag;      my $endtag=$tag;
496      # RAE modified this so that you can pass in a reference to an array where the first element is the data to  
497      # 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
498        # the first element is the data to display and the second element is optional
499        # things like colspan and align. Note that in this case you need to include the td
500      # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]      # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]
501      if (ref($x) eq "ARRAY") {($x, $tag)=@$x; if ($tag =~ /td/) {$endtag = "td"}}  
502        # per GJO's request modified this line so it can take any tag.
503        if ( ref($x) eq "ARRAY" ) { ($x, $tag) = @$x; $tag =~ /^(\S+)/; $endtag = $1 }
504    
505      if ($x =~ /^\@([^:]+)\:(.*)$/)      if ($x =~ /^\@([^:]+)\:(.*)$/)
506      {      {
# Line 426  Line 512 
512      }      }
513  }  }
514    
515    
516    =head2 merge_table_rows()
517    
518    Merge table rows together. This will merge a table so that adjacent cells with the same content will only be shown once.
519    
520    Something like this:
521    
522        -----------------------
523        |    1     |    a     |
524        -----------------------
525        |    1     |    b     |
526        -----------------------
527        |    2     |    c     |
528        -----------------------
529        |    3     |    d     |
530        -----------------------
531        |    4     |    d     |
532        -----------------------
533        |    5     |    d     |
534        -----------------------
535    
536    Will become:
537    
538        -----------------------
539        |          |    a     |
540        |    1     |-----------
541        |          |    b     |
542        -----------------------
543        |    2     |    c     |
544        -----------------------
545        |    3     |          |
546        ------------          |
547        |    4     |    5     |
548        ------------          |
549        |    5     |          |
550        -----------------------
551    
552    
553    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.
554    
555     $tab=&HTML::merge_table_rows($tab);
556    
557     or
558    
559     $skip=(1=>1, 3=>1, 5=>1);
560     $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
561    
562    
563    =cut
564    
565    
566    
567    
568    sub merge_table_rows {
569     # RAE:
570     # Experimental piece of code. We often want to have rows or columns were cells are merged. It just looks so much nicer
571     # this block should merge adjacent rows that have the same text in them.
572     # use like this:
573     #      $tab=&HTML::merge_table_rows($tab);
574     # before you do a make_table call
575    
576     my $self=shift if UNIVERSAL::isa($_[0],__PACKAGE__);
577     my ($tab, $skip)=@_;
578    
579     my $newtable;
580     my $lastrow;
581     my $rowspan;
582     my $refs;
583    
584     for (my $y=0; $y <= $#$tab; $y++) {
585     #$y is the row in the table;
586      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
587       # this is the user definable columns not to merge
588       if ($skip->{$x})
589       {
590        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
591        next;
592       }
593    
594       #$x is the column in the table
595       # if the column in the row we are looking at is the same as the column in the previous row, we don't add
596       # this cell to $newtable. Instead we increment the rowspan of the previous row by one
597    
598       # handle cells that are references to arrays
599       if (ref($tab->[$y]->[$x]) eq "ARRAY") {$refs->[$y]->[$x]=$tab->[$y]->[$x]->[1]; $tab->[$y]->[$x]=$tab->[$y]->[$x]->[0]}
600    
601       # now we go back through the table looking where to draw the merge line:
602       my $lasty=$y;
603       while ($lasty >= 0 && $tab->[$y]->[$x] eq $tab->[$lasty]->[$x]) {$lasty--}
604       $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
605       if ($lasty == $y) {
606        # we always want to have something in rows that may otherwise be empty but should be there (see below)
607        unless ($tab->[$y]->[$x]) {$tab->[$y]->[$x]=" &nbsp; "}
608        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
609       }
610       else {$rowspan->[$lasty]->[$x]++}
611      }
612     }
613    
614     # now just join everything back together
615     for (my $y=0; $y <= $#$tab; $y++) {
616      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
617       if ($rowspan->[$y]->[$x]) {
618        if ($refs->[$y]->[$x]) {$refs->[$y]->[$x] .= " rowspan=". ($rowspan->[$y]->[$x]+1)}
619        else {$refs->[$y]->[$x] = "td rowspan=". ($rowspan->[$y]->[$x]+1)}
620        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
621       }
622       elsif ($newtable->[$y]->[$x] && $refs->[$y]->[$x]) {
623        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
624       }
625      }
626     }
627    
628    
629     # finally we have to remove any completely empty cells that have been added by the array mechanism
630     # (e.g. if you define $a->[2] then $a->[0] and $a->[1] are now undef).
631     # that is why in the loop above I replace empty cells with nbsp. They are now not undef!
632     # I am sure that Gary can do this in one line, but I am hacking.
633     my @trimmed;
634     foreach my $a (@$newtable) {
635      my @row;
636      foreach my $b (@$a) {
637       push @row, $b if ($b);
638      }
639      push @trimmed, \@row;
640     }
641    
642     return \@trimmed;
643    }
644    
645    
646    
647    
648  sub set_ec_links {  sub set_ec_links {
649      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
650      my($cgi,$x) = @_;      my($cgi,$x) = @_;
# Line 493  Line 712 
712          {          {
713              $n = $fid;              $n = $fid;
714          }          }
715          if ($1 ne "peg") { return $n }  
716            my $link;
717            #added to format prophage and path island links to feature.cgi
718            if ($1 ne "peg")
719            {
720               my $user = $cgi->param('user');
721               if (! $user) { $user = "" }
722               my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
723               $link = "feature.cgi?feature=$fid&user=$user$trans$sprout";
724               $link =~ s/[a-z_A-Z0-9]+\.cgi\?/feature.cgi?/;
725            }
726            else
727            {
728          my $user = $cgi->param('user');          my $user = $cgi->param('user');
729          if (! $user) { $user = "" }          if (! $user) { $user = "" }
730          my $trans = $cgi->param('translate') ? "&translate=1" : "";          my $trans = $cgi->param('translate') ? "&translate=1" : "";
731          my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";          my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
732          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,;  
733    
734    ### This used to be
735    ###     my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
736    ###
737    ### The cost became prohibitive in the subsystem spreadsheets.  Hence, we cache the value
738    ###
739    ### RAO
740    
741                #if (! $cgi_url) { $cgi_url = &FIG::cgi_url }
742                #$link = $cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
743                $link = "protein.cgi?prot=$fid&user=$user$trans$sprout";
744                $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
745            }
746          if ($just_url)          if ($just_url)
747          {          {
748              return $link;              return $link;
# Line 524  Line 762 
762      return $family;      return $family;
763  }  }
764    
 use URI::Escape;  
765    
766  sub get_html {  sub get_html {
767      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
# Line 655  Line 892 
892          $after = $3;          $after = $3;
893          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);
894      }      }
895        elsif ($x =~ /^(.*)(tigr\|[0-9a-zA-Z]+)(.*)/s)
896        {
897            $before = $1;
898            $match = $2;
899            $after = $3;
900            return &set_prot_links($cgi,$before) . &HTML::tigr_link($cgi,$match) . &set_prot_links($cgi,$after);
901        }
902      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
903      {      {
904          $before = $1;          $before = $1;
# Line 707  Line 951 
951      return $gi;      return $gi;
952  }  }
953    
954    sub tigr_link {
955        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
956        my($cgi,$tigr) = @_;
957    
958        if ($tigr =~ /^tigr\|([0-9a-zA-Z]+)$/)
959        {
960            return "<a href=\"http://pathema.tigr.org/tigr-scripts/CMR/GenePage.cgi?locus=$1\">$tigr</a>";
961        }
962        return $tigr;
963    }
964    
965  sub uni_link {  sub uni_link {
966      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
967      my($cgi,$uni) = @_;      my($cgi,$uni) = @_;
# Line 775  Line 1030 
1030      $user = $cgi->param('user');      $user = $cgi->param('user');
1031      $user = $user ? $user : "";      $user = $user ? $user : "";
1032      $org = $org ? $org : "";      $org = $org ? $org : "";
1033      my $url = "$FIG_Config::cgi_url/show_kegg_map.cgi?user=$user&map=$map&org=$org";  
1034        my $url = "show_kegg_map.cgi?user=$user&map=$map&org=$org";
1035    #rel    my $url = &FIG::cgi_url() . "/show_kegg_map.cgi?user=$user&map=$map&org=$org";
1036      my $link = "<a href=\"$url\">$map</a>";      my $link = "<a href=\"$url\">$map</a>";
1037      return $link;      return $link;
1038  }  }
1039    
 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;  
 }  
   
1040  sub java_buttons {  sub java_buttons {
1041      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1042    ## ADDED BY RAE    ## ADDED BY RAE
# Line 855  Line 1061 
1061      my $user = $cgi->param('user');      my $user = $cgi->param('user');
1062      if ($user)      if ($user)
1063      {      {
1064          $sub_link = "<a href=./subsys.cgi?ssa_name=$sub&request=show_ssa&user=$user>$sub</a>";          my $esc_sub = uri_escape( $sub );
1065            $sub_link = "<a href=./subsys.cgi?ssa_name=$esc_sub&request=show_ssa&user=$user>$sub</a>";
1066      }      }
1067      else      else
1068      {      {
# Line 864  Line 1071 
1071      return $sub_link;      return $sub_link;
1072  }  }
1073    
1074  1  sub reaction_link {
1075        my($reaction) = @_;
1076    
1077        if ($reaction =~ /^R\d+/)
1078        {
1079            return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?rn+$reaction\" target=reaction$$>$reaction</a>";
1080        }
1081        return $reaction;
1082    }
1083    
1084    sub html_for_assignments {
1085        my($fig,$user,$peg_sets) = @_;
1086        my $i;
1087    
1088        my @vals = ();
1089        my $set = 1;
1090        foreach $peg_set (@$peg_sets)
1091        {
1092            for ($i=0; ($i < @$peg_set); $i++)
1093            {
1094                $peg = $peg_set->[$i];
1095                push(@vals,'show=' . join("@",($set,$i+1,$peg,&FIG::abbrev($fig->org_of($peg)),"")));
1096            }
1097            $set++;
1098        }
1099    
1100        $ENV{'REQUEST_METHOD'} = 'GET';
1101        $ENV{'QUERY_STRING'} = join('&',('request=show_commentary',"uni=1","user=$user",@vals));
1102        my $out = join("",`$FIG_Config::fig/CGI/chromosomal_clusters.cgi`);
1103        $out =~ s/^.*?<form/<form/si;
1104        $out =~ s/^(.*)<table.*/$1/si;
1105        return $out;
1106    }
1107    
1108    =head1 rss_feed
1109    
1110    Add something to the RSS feed. The rss feeds are stored in the Html directory, and there are several RSS feeds:
1111            SEED.rss                - everything gets written here
1112            SEEDgenomes.rss                 - whenever a genome is added to the SEED
1113            SEEDsubsystems.rss      - whenever a subsystem is edited (or should this be added?)
1114    
1115    
1116    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.
1117    
1118    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.
1119    
1120    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.
1121    
1122    The has can have these keys:
1123    
1124    REQUIRED:
1125    title       : the title. This is usually what is seen by the user in the pull down menu
1126    description : a more complete description that is often seen is rss viewers but not always
1127    link        : link to the item that was added/edited
1128    All other keys are treated as optional RSS arguments and written to the file.
1129    
1130    At most, $max_entries recent entries are stored in the rss file, and this is currently 50.
1131    
1132    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.
1133    
1134    
1135    =cut
1136    
1137    sub rss_feed {
1138     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1139     my ($files, $args)=@_;
1140    
1141     # how many entries to store in the file
1142     my $max_entries=50;
1143    
1144     foreach my $a (keys %$args) {if ($a =~ /^-(.*)/) {my $b=$1; $args->{$b}=$args->{$a}; delete $args->{$a}}}
1145    
1146     my $filepath=$FIG_Config::fig."/CGI/Html/rss";
1147     # check for the directory and if not, make it
1148     mkdir $filepath unless (-d $filepath);
1149    
1150     # note that $info is a hash of references to hashes that are written out as headers in the file
1151     my $info=
1152     {
1153      "SEED.rss" =>
1154       {
1155            title           => "The SEED",
1156            description     => "Latest news from the SEED",
1157            link            => "Html/rss/SEED.rss",
1158       },
1159    
1160      "SEEDsubsystems.rss" =>
1161      {
1162            title           => "SEED Subsystems",
1163            description     => "Recently updated SEED subsystems",
1164            link            => "Html/rss/SEEDsubsystems.rss",
1165      },
1166    
1167      "SEEDsubsystems.rss" =>
1168      {
1169            title           => "SEED Genomes",
1170            description     => "Genomes recently added to the SEED",
1171            link            => &FIG::cgi_url()."/Html/rss/SEEDsubsystems.rss",
1172      },
1173    
1174     };
1175    
1176    
1177     # build the new xml
1178     my $xml = "\t<item>\n";
1179     foreach my $qw ("title", "description", "link") {
1180      unless ($args->{$qw}) {
1181       print STDERR "You need to include a $qw tag in your RSS description\n";
1182       return(0);
1183      }
1184      # we need to do something a bit funky with the link. We can't have ampersands in the <link> </link> in valid html
1185      # so we are going to pull out the links and uri_escape just the part after the .cgi
1186      if ($qw eq "link")
1187      {
1188       $args->{$qw} =~ /^(.*?\.cgi.)(.*)$/;
1189       $args->{$qw} = $1.uri_escape($2) if ($1 && $2);
1190      }
1191    
1192      $xml .= "\t\t<$qw>".$args->{$qw}."</$qw>\n";
1193      delete $args->{$qw};
1194     }
1195    
1196     foreach my $tag (grep {!/type/i} keys %$args)
1197     {
1198      $xml .= "\t\t<$tag>".$args->{$tag}."</$tag>\n";
1199     }
1200    
1201     $xml .= "\t</item>\n";
1202    
1203    
1204     my @files=("SEED.rss");
1205     if ($args->{"type"}) {push @files, "SEED.$type.rss"}
1206    
1207     foreach my $file ("SEED.rss", @$files)
1208     {
1209      if (-e "$filepath/$file")
1210      {
1211       my @out; # the new content of the file
1212       my $itemcount=0; # how many <item> </item>'s are we keeping
1213       my $initem; # are we in an item?
1214       open(IN, "$filepath/$file") || die "Can't open $filepath/$file";
1215       while (<IN>)
1216       {
1217        if (/\<item\>/) {
1218         push @out, $xml, unless ($itemcount);
1219         $itemcount++;
1220         $initem=1;
1221        }
1222        if (/\<\/item\>/) {$initem=0; next if ($itemcount > $max_entries)}
1223        next if ($initem && $itemcount > $max_entries);
1224        push @out, $_;
1225       }
1226       close IN;
1227       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1228       print OUT @out;
1229      }
1230      else
1231      {
1232       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1233       print OUT "<?xml version=\"1.0\"?>\n<rss version=\"2.0\">\n<channel>\n";
1234       if ($info->{$file})
1235       {
1236         # we're going to sanity check each of the three options we output, just to be sure
1237         foreach my $qw ("title", "description", "link")
1238         {
1239           if ($info->{$file}->{$qw})
1240           {
1241              print OUT "<$qw>", $info->{$file}->{$qw}, "</$qw>\n";
1242           } else {
1243              print STDERR "Please add a $qw for $file\n"; print OUT "<$qw>$file</$qw>\n";
1244           }
1245         }
1246       }
1247       else {
1248        print STDERR "Please define title, link, and description information for $file\n";
1249        print OUT "<title>$file</title>\n<description>An RSS feed</description>\n<link>", &FIG::cgi_url, "</link>\n";
1250       }
1251       print OUT "\n", $xml;
1252       print OUT "\n", "</channel>\n</rss>\n"
1253      }
1254     }
1255    }
1256    
1257    
1258    
1259    1;
1260    

Legend:
Removed from v.1.36  
changed lines
  Added in v.1.67

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3