[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.30, Wed Feb 16 18:59:21 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;
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
16    {
17        my($class) = @_;
18    
19        my $self = {};
20    
21        return bless $self, $class;
22    }
23    
24  sub compute_html_header  sub compute_html_header
25  {  {
26      my($additional_insert) = @_;      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
27      my $html_hdr_file = "./Html/html.hdr";      my($additional_insert, $user, %options ) = @_;
28    
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 34  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 42  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 53  Line 77 
77  }  }
78    
79  sub show_page {  sub show_page {
80      my($cgi,$html,$no_home) = @_;      #warn "SHOWPAGE: cgi=", Dumper(@_);
81        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
82        my($cgi,$html,$no_home, $alt_header, $css, $javasrc, $cookie) = @_;
83      my $i;      my $i;
84    
85        # ARGUMENTS:
86        #     $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>
88        #     $no_home eliminates ONLY the bottom FIG search link in a page
89        #     $alt_header is a reference to an array for an alternate header banner that you can replace the standard one with
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
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
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
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    
     my @html_hdr = compute_html_header();  
   
105      my $user = $cgi->param('user') || "";      my $user = $cgi->param('user') || "";
106        my @html_hdr;
107        if ($alt_header && ref($alt_header) eq "ARRAY")
108        {
109           @html_hdr = @$alt_header;
110        }
111        else
112        {
113            @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 88  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 187  Line 237 
237      #      #
238      #  <BODY> goes after last head line      #  <BODY> goes after last head line
239      #      #
240      #  RAE: Added the javascript for the buttons immediately after body.      #  RAE:
241        #  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 217  Line 268 
268          splice( @$html, $body_line, 0, "</HEAD>\n" );          splice( @$html, $body_line, 0, "</HEAD>\n" );
269      }      }
270    
271        # RAE:
272        # Add css here
273        # Note that at the moment I define these two sheets here. I think this should
274        # be moved out, but I want to try it and see what happens.  css has the format:
275        #
276        # <link rel='stylesheet' title='default' href='/css/default.css' type='text/css'>
277    
278        # convert the default key to the right case. and eliminate dups
279        foreach my $k (keys %$css) {if (lc($k) eq "default") {$css->{'Default'}=$css->{$k}}}
280    
281        if (!$css || !$css->{'Default'})
282        {
283           $css->{'Default'} = &FIG::cgi_url() . "/Html/css/default.css";
284        }
285        if (!$css->{"Sans Serif"})
286        {
287           $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";
291        $csstext   .= "<link rel='alternate stylesheet' title='Sans Serif' href='".$css->{'Sans Serif'}."' type='text/css'>\n";
292    
293        foreach my $k (keys %$css)
294        {
295           next if (lc($k) eq "default" || lc($k) eq "sans serif");
296           $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.
302        # 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
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
309        push @$javasrc, &FIG::cgi_url() . "/Html/css/FIG.js";
310        foreach my $script (@$javasrc) {
311            $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";
312        }
313    
314    
315    
316        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.
317    
318      #      #
319      #  <BASE ...> goes before </HEAD>      #  <BASE ...> goes before </HEAD>
320      #      #
# Line 242  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 292  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 316  Line 420 
420          splice( @$html, $i, 0, @tags );          splice( @$html, $i, 0, @tags );
421      }      }
422    
423      print @$html;      # RAE the chomp will return any new lines at the ends of elements in the array,
424        # and then we can join  with a "\n". This is because somethings put newlines in,
425        # and others don't. This should make nicer looking html
426        #
427        # chomp(@$html);
428        # print join "\n", @$html;
429        #
430        # Apparently the above still breaks things. This is the correct code:
431    
432        foreach $_ (@$html)
433        {
434            print $_;
435        }
436    
437  }  }
438    
439  sub make_table {  sub make_table {
# Line 324  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 345  Line 463 
463  }  }
464    
465  sub expand {  sub expand {
466        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
467      my($x, $tag) = @_;      my($x, $tag) = @_;
468    
469      $tag = "td" unless $tag;      $tag = "td" unless $tag;
470      my $endtag=$tag;      my $endtag=$tag;
471      # RAE modified this so that you can pass in a reference to an array where the first element is the data to  
472      # 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
473        # the first element is the data to display and the second element is optional
474        # 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      if (ref($x) eq "ARRAY") {($x, $tag)=@$x; if ($tag =~ /td/) {$endtag = "td"}}  
477        # 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 364  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__);
625      my($cgi,$x) = @_;      my($cgi,$x) = @_;
626      my($before,$match,$after);      my($before,$match,$after);
627    
# Line 379  Line 636 
636  }  }
637    
638  sub ec_link {  sub ec_link {
639        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
640      my($role) = @_;      my($role) = @_;
641    
642      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)
# Line 392  Line 650 
650  }  }
651    
652  sub role_link {  sub role_link {
653        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
654      my($cgi,$role) = @_;      my($cgi,$role) = @_;
655    
656      my $roleR = ($role =~ /^(\d+\.\d+\.\d+\.\d+)\s+-\s+/) ? $1 : $role;      my $roleR = ($role =~ /^(\d+\.\d+\.\d+\.\d+)\s+-\s+/) ? $1 : $role;
# Line 407  Line 666 
666  # text of the link.  # text of the link.
667  #  #
668  sub fid_link {  sub fid_link {
669        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
670      my($cgi,$fid,$local,$just_url) = @_;      my($cgi,$fid,$local,$just_url) = @_;
671      my($n);      my($n);
672    
# Line 427  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 452  Line 735 
735  }  }
736    
737  sub family_link {  sub family_link {
738        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
739      my($family,$user) = @_;      my($family,$user) = @_;
740    
741      return $family;      return $family;
742  }  }
743    
 use URI::Escape;  
744    
745  sub get_html {  sub get_html {
746        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
747      my( $url, $type, $kv_pairs) = @_;      my( $url, $type, $kv_pairs) = @_;
748      my( $encoded, $ua, $args, @args, $out, @output, $x );      my( $encoded, $ua, $args, @args, $out, @output, $x );
749    
# Line 524  Line 808 
808  }  }
809    
810  sub trim_output {  sub trim_output {
811        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
812      my($out) = @_;      my($out) = @_;
813      my $i;      my $i;
814    
# Line 561  Line 846 
846  }  }
847    
848  sub set_prot_links {  sub set_prot_links {
849        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
850      my($cgi,$x) = @_;      my($cgi,$x) = @_;
851      my($before,$match,$after);      my($before,$match,$after);
852    
# Line 585  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 617  Line 910 
910  }  }
911    
912  sub refseq_link {  sub refseq_link {
913        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
914      my($cgi,$id) = @_;      my($cgi,$id) = @_;
915    
916      if ($id =~ /^[NXYZA]P_/)      if ($id =~ /^[NXYZA]P_/)
# Line 626  Line 920 
920  }  }
921    
922  sub gi_link {  sub gi_link {
923        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
924      my($cgi,$gi) = @_;      my($cgi,$gi) = @_;
925    
926      if ($gi =~ /^gi\|(\d+)$/)      if ($gi =~ /^gi\|(\d+)$/)
# Line 635  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__);
946      my($cgi,$uni) = @_;      my($cgi,$uni) = @_;
947    
948      if ($uni =~ /^uni\|(\S+)$/)      if ($uni =~ /^uni\|(\S+)$/)
# Line 646  Line 953 
953  }  }
954    
955  sub sp_link {  sub sp_link {
956        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
957      my($cgi,$sp) = @_;      my($cgi,$sp) = @_;
958    
959      if ($sp =~ /^sp\|(\S+)$/)      if ($sp =~ /^sp\|(\S+)$/)
# Line 656  Line 964 
964  }  }
965    
966  sub pir_link {  sub pir_link {
967        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
968      my($cgi,$pir) = @_;      my($cgi,$pir) = @_;
969    
970      if ($pir =~ /^pirnr\|(NF\d+)$/)      if ($pir =~ /^pirnr\|(NF\d+)$/)
# Line 666  Line 975 
975  }  }
976    
977  sub kegg_link {  sub kegg_link {
978        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
979      my($cgi,$kegg) = @_;      my($cgi,$kegg) = @_;
980    
981      if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)      if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)
# Line 676  Line 986 
986  }  }
987    
988  sub set_map_links {  sub set_map_links {
989        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
990      my($cgi,$x) = @_;      my($cgi,$x) = @_;
991      my($before,$match,$after);      my($before,$match,$after);
992    
# Line 692  Line 1003 
1003  }  }
1004    
1005  sub map_link {  sub map_link {
1006        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1007      my($cgi,$map,$org) = @_;      my($cgi,$map,$org) = @_;
1008    
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 {  
         #### 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__);
1021    ## ADDED BY RAE    ## ADDED BY RAE
1022    # Provides code to include check all/first half/second half/none for javascrspt    # Provides code to include check all/first half/second half/none for javascrspt
1023    # this takes two variables - the form name provided in start_form with the    # this takes two variables - the form name provided in start_form with the
# Line 768  Line 1033 
1033  }  }
1034    
1035  sub sub_link {  sub sub_link {
1036        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1037      my($cgi,$sub) = @_;      my($cgi,$sub) = @_;
1038      my($sub_link);      my($sub_link);
1039    
1040      my $user = $cgi->param('user');      my $user = $cgi->param('user');
1041      if ($user)      if ($user)
1042      {      {
1043          $sub_link = "<a href=./subsys.cgi?ssa_name=$sub&request=show_ssa&user=$user>$sub</a>";          my $esc_sub = uri_escape( $sub );
1044            $sub_link = "<a href=./subsys.cgi?ssa_name=$esc_sub&request=show_ssa&user=$user>$sub</a>";
1045      }      }
1046      else      else
1047      {      {
# Line 783  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.30  
changed lines
  Added in v.1.64

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3