[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.71, Wed Nov 2 21:58:00 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    my $top_link_cache;
16    
17    
18  sub new  sub new
19  {  {
20      my($class) = @_;      my($class) = @_;
# Line 18  Line 24 
24      return bless $self, $class;      return bless $self, $class;
25  }  }
26    
27    sub top_link
28    {
29    
30        #
31        # Determine if this is a toplevel cgi or one in one of the subdirs (currently
32        # just /p2p).
33        #
34    
35        return $top_link_cache if ($top_link_cache);
36    
37        my @parts = split(/\//, $ENV{SCRIPT_NAME});
38        my $top;
39        if ($parts[-2] eq 'FIG')
40        {
41            $top = '.';
42    #       warn "toplevel @parts\n";
43        }
44        elsif ($parts[-3] eq 'FIG')
45        {
46            $top = '..';
47    #       warn "subdir @parts\n";
48        }
49        else
50        {
51            $top = $FIG_Config::cgi_base;
52    #       warn "other @parts\n";
53        }
54    
55        $top_link_cache = $top;
56        return $top;
57    }
58    
59  sub compute_html_header  sub compute_html_header
60  {  {
61      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
62      my($additional_insert,$user) = @_;      my($additional_insert, $user, %options ) = @_;
63      my $html_hdr_file = "./Html/html.hdr";  
64        my $header_name = $options{header_name} ? $options{header_name} : "html.hdr";
65        my $tail_name = $options{tail_name} ? $options{tail_name} : "html.tail";
66    
67        my $html_hdr_file = "./Html/$header_name";
68      if (! -f $html_hdr_file)      if (! -f $html_hdr_file)
69      {      {
70          $html_hdr_file = "$FIG_Config::fig/CGI/Html/html.hdr";          $html_hdr_file = "$FIG_Config::fig/CGI/Html/$header_name";
71      }      }
72      my @html_hdr = &FIG::file_read($html_hdr_file);      my @html_hdr = &FIG::file_read($html_hdr_file);
73      push( @html_hdr, "<br><a href=\"index.cgi?user=$user\">FIG search</a>\n" );  
74        # for my $k (sort keys %ENV) { warn "$k = $ENV{$k}\n"; }
75    
76        #
77        # Determine if this is a toplevel cgi or one in one of the subdirs (currently
78        # just /p2p).
79        #
80    
81        my @parts = split(/\//, $ENV{SCRIPT_NAME});
82        my $top;
83        if ($parts[-2] eq 'FIG')
84        {
85            $top = '.';
86    #       warn "toplevel @parts\n";
87        }
88        elsif ($parts[-3] eq 'FIG')
89        {
90            $top = '..';
91    #       warn "subdir @parts\n";
92        }
93        else
94        {
95            $top = $FIG_Config::cgi_base;
96    #       warn "other @parts\n";
97        }
98    
99        $options{no_fig_search} or push( @html_hdr, "<br><a href=\"$top/index.cgi?user=$user\">FIG search</a>\n" );
100    
101      if (@html_hdr)      if (@html_hdr)
102      {      {
103          my $insert_stuff;          my $insert_stuff;
104    
105            if (not $options{no_release_info})
106            {
107          my @ver = &FIG::file_head("$FIG_Config::fig_disk/CURRENT_RELEASE", 1);          my @ver = &FIG::file_head("$FIG_Config::fig_disk/CURRENT_RELEASE", 1);
108          my $ver = $ver[0];          my $ver = $ver[0];
109          chomp $ver;          chomp $ver;
# Line 44  Line 115 
115          }          }
116          my $host = &FIG::get_local_hostname();          my $host = &FIG::get_local_hostname();
117          $insert_stuff = "SEED version <b>$ver</b> on $host";          $insert_stuff = "SEED version <b>$ver</b> on $host";
118            }
119    
120          if ($additional_insert)          if ($additional_insert)
121          {          {
122              $insert_stuff .= "<br>" . $additional_insert;              $insert_stuff .= "<br>" . $additional_insert;
# Line 51  Line 124 
124    
125          for $_ (@html_hdr)          for $_ (@html_hdr)
126          {          {
127              s,(href|img\s+src)="/FIG/,\1="$FIG_Config::cgi_base,g;              s,(href|img\s+src)="/FIG/,$1="$top/,g;
128                    s,(\?user\=)\",$1$user",;
129              if ($_ eq "<!-- HEADER_INSERT -->\n")              if ($_ eq "<!-- HEADER_INSERT -->\n")
130              {              {
131                  $_ = $insert_stuff;                  $_ = $insert_stuff;
# Line 65  Line 139 
139  sub show_page {  sub show_page {
140      #warn "SHOWPAGE: cgi=", Dumper(@_);      #warn "SHOWPAGE: cgi=", Dumper(@_);
141      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
142      my($cgi,$html,$no_home, $alt_header, $css) = @_;      my($cgi,$html,$no_home, $alt_header, $css, $javasrc, $cookie) = @_;
143      my $i;      my $i;
144    
145        my $top = top_link();
146    
147      # ARGUMENTS:      # ARGUMENTS:
148      #     $cgi is the CGI method      #     $cgi is the CGI method
# Line 77  Line 152 
152      #     $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
153      #               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
154      #               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
155        #     $javasrc is a reference to an array of URLs to javascripts to be included (e.g. "/FIG/Html/css/styleswitcher.js")
156        #     $cookie is the name and value of the cookie to set. Note that you should probably use raelib->cookie to get/set your cookies
157      #      #
158      # Find the HTML header      # Find the HTML header
159      #      #
160    
161      my $html_tail_file = "./Html/html.tail";      my $html_tail_file = "./Html/$tail_name";
162      if (! -f $html_tail_file)      if (! -f $html_tail_file)
163      {      {
164          $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";          $html_tail_file = "$FIG_Config::fig/CGI/Html/$tail_name";
165      }      }
166    
167      my $user = $cgi->param('user') || "";      my $user = $cgi->param('user') || "";
168      my @html_hdr;      my @html_hdr;
169      if ($alt_header)      if ($alt_header && ref($alt_header) eq "ARRAY")
170      {      {
171         @html_hdr = @$alt_header;         @html_hdr = @$alt_header;
172      }      }
# Line 99  Line 175 
175          @html_hdr = compute_html_header(undef,$user);          @html_hdr = compute_html_header(undef,$user);
176      }      }
177    
178        # RAE: I am offloading the handling of cookies to CGI.pm since I don't know how they are set up.
179        # This modification adds the cookies if necessary
180    
181        # Note: 3/10/05 commented this line out pending the discussion of adding cookies into the seed that we are waiting to see about
182        # to add cookies back in replace these two header lines with each other
183    
184      print $cgi->header;      #print $cgi->header(-cookie=>$cookie);
185        print $cgi->header();
186    
187      #      #
188      #  The SEED header file goes immediately after <BODY>.  Figure out      #  The SEED header file goes immediately after <BODY>.  Figure out
# Line 118  Line 200 
200                       meta     => 1,                       meta     => 1,
201                       nextid   => 1,                       nextid   => 1,
202                       style    => 1,                       style    => 1,
203                       title    => 1                       title    => 1,
204                     );                     );
205    
206      #      #
# Line 161  Line 243 
243          if ( $html->[$i] =~ /\<body[^0-9a-z]/i )          if ( $html->[$i] =~ /\<body[^0-9a-z]/i )
244          {          {
245              $body_line = $i;              $body_line = $i;
246              $last;              last;
247          }          }
248    
249          #  Now the general case.          #  Now the general case.
# Line 221  Line 303 
303      #  Added the javascript for the buttons immediately after body.      #  Added the javascript for the buttons immediately after body.
304      #  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,
305      #  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!
306        #  RAE: This is now deprecated because everything is in an external file, FIG.js, included later
307    
308      if ( $body_line < 0 )      if ( $body_line < 0 )
309      {      {
         my $js=&javascript;  
310          $body_line = $last_head_line + 1;          $body_line = $last_head_line + 1;
311          splice( @$html, $body_line, 0, "<BODY>\n$js\n" );          splice( @$html, $body_line, 0, "<BODY>\n" );
312      }      }
313    
314      #      #
# Line 250  Line 332 
332    
333      # RAE:      # RAE:
334      # Add css here      # Add css here
335      # 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
336      # css has the format      # be moved out, but I want to try it and see what happens.  css has the format:
337        #
338      # <link rel='stylesheet' title='default' href='/css/default.css' type='text/css'>      # <link rel='stylesheet' title='default' href='/css/default.css' type='text/css'>
339    
340      # 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 342 
342    
343      if (!$css || !$css->{'Default'})      if (!$css || !$css->{'Default'})
344      {      {
345         $css->{'Default'}="/FIG/Html/css/default.css";         $css->{'Default'} = "$top/Html/css/default.css";
346      }      }
347      if (!$css->{"Sans Serif"})      if (!$css->{"Sans Serif"})
348      {      {
349         $css->{'Sans Serif'}="/FIG/Html/css/sanserif.css";         $css->{'Sans Serif'} = "$top/Html/css/sanserif.css";
350      }      }
351    
352      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";
353      $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";
354    
355      foreach my $k (keys %$css)      foreach my $k (keys %$css)
356      {      {
357         next if (lc($k) eq "default" || lc($k) eq "sans serif");         next if (lc($k) eq "default" || lc($k) eq "sans serif");
358         $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";
359      }      }
360    
361        $csstext   .= "<link rel='alternate'  title='SEED RSS feeds' href='$top/Html/rss/SEED.rss' type='application/rss+xml'>\n";
362    
363        # RAE: also added support for external javascripts here.
364        # we are cluttering the HTML code with all the javascripts when they could easily be in external files
365        # this solution allows us to source other files
366    
367        # the file FIG.js contains most of the java script we use routinely. Every browser will just cache this and so
368        # it will reduce our overhead.
369    
370        # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts
371        push @$javasrc, "$top/Html/css/FIG.js";
372        foreach my $script (@$javasrc) {
373            $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";
374        }
375    
376    
377    
378      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.
379    
380      #      #
# Line 300  Line 402 
402  #       }  #       }
403    
404          $base_line = $head_end_line;          $base_line = $head_end_line;
405          splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );          #
406            # RDO 2005-1006. Remove this so proxying works better.
407            #
408    #        splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );
409      }      }
410    
411      #      #
# Line 350  Line 455 
455      #  Figure out where to insert The SEED tail.  Before </body>,      #  Figure out where to insert The SEED tail.  Before </body>,
456      #  or before </html>, or at end of page.      #  or before </html>, or at end of page.
457      #      #
   
458      my @tags = ();      my @tags = ();
459        # Check for a tracing queue.
460        my $traceString = QTrace("HTML");
461        if ($traceString) {
462            push @tags, $traceString;
463        }
464      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}
465      if ($i >= @$html)        # </body> not found; look for </html>      if ($i >= @$html)        # </body> not found; look for </html>
466      {      {
# Line 374  Line 482 
482          splice( @$html, $i, 0, @tags );          splice( @$html, $i, 0, @tags );
483      }      }
484    
485      # 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,
486      # 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,
487      chomp(@$html);      # and others don't. This should make nicer looking html
488      print join "\n", @$html;      #
489        # chomp(@$html);
490        # print join "\n", @$html;
491        #
492        # Apparently the above still breaks things. This is the correct code:
493    
494        foreach $_ (@$html)
495        {
496            print $_;
497        }
498    
499  }  }
500    
501  sub make_table {  sub make_table {
# Line 385  Line 503 
503      my(@tab);      my(@tab);
504    
505      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";
506      push( @tab, "\n<table $border>\n",      my $width = defined $options{width} ? "width=\"$options{width}\"" : undef;
507        push( @tab, "\n<table $border $width>\n",
508                  "\t<caption><b>$title</b></caption>\n",                  "\t<caption><b>$title</b></caption>\n",
509                  "\t<tr>\n\t\t"                  "\t<tr>\n\t\t"
510                . join( "\n", map { &expand($_, "th") } @$col_hdrs )                . join( "\n", map { &expand($_, "th") } @$col_hdrs )
# Line 411  Line 530 
530    
531      $tag = "td" unless $tag;      $tag = "td" unless $tag;
532      my $endtag=$tag;      my $endtag=$tag;
533      # RAE modified this so that you can pass in a reference to an array where the first element is the data to  
534      # 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
535        # the first element is the data to display and the second element is optional
536        # things like colspan and align. Note that in this case you need to include the td
537      # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]      # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]
538      if (ref($x) eq "ARRAY") {($x, $tag)=@$x; if ($tag =~ /td/) {$endtag = "td"}}  
539        # per GJO's request modified this line so it can take any tag.
540        if ( ref($x) eq "ARRAY" ) { ($x, $tag) = @$x; $tag =~ /^(\S+)/; $endtag = $1 }
541    
542      if ($x =~ /^\@([^:]+)\:(.*)$/)      if ($x =~ /^\@([^:]+)\:(.*)$/)
543      {      {
# Line 426  Line 549 
549      }      }
550  }  }
551    
552    
553    =head2 merge_table_rows()
554    
555    Merge table rows together. This will merge a table so that adjacent cells with the same content will only be shown once.
556    
557    Something like this:
558    
559        -----------------------
560        |    1     |    a     |
561        -----------------------
562        |    1     |    b     |
563        -----------------------
564        |    2     |    c     |
565        -----------------------
566        |    3     |    d     |
567        -----------------------
568        |    4     |    d     |
569        -----------------------
570        |    5     |    d     |
571        -----------------------
572    
573    Will become:
574    
575        -----------------------
576        |          |    a     |
577        |    1     |-----------
578        |          |    b     |
579        -----------------------
580        |    2     |    c     |
581        -----------------------
582        |    3     |          |
583        ------------          |
584        |    4     |    5     |
585        ------------          |
586        |    5     |          |
587        -----------------------
588    
589    
590    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.
591    
592     $tab=&HTML::merge_table_rows($tab);
593    
594     or
595    
596     $skip=(1=>1, 3=>1, 5=>1);
597     $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
598    
599    
600    =cut
601    
602    
603    
604    
605    sub merge_table_rows {
606     # RAE:
607     # Experimental piece of code. We often want to have rows or columns were cells are merged. It just looks so much nicer
608     # this block should merge adjacent rows that have the same text in them.
609     # use like this:
610     #      $tab=&HTML::merge_table_rows($tab);
611     # before you do a make_table call
612    
613     my $self=shift if UNIVERSAL::isa($_[0],__PACKAGE__);
614     my ($tab, $skip)=@_;
615    
616     my $newtable;
617     my $lastrow;
618     my $rowspan;
619     my $refs;
620    
621     for (my $y=0; $y <= $#$tab; $y++) {
622     #$y is the row in the table;
623      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
624       # this is the user definable columns not to merge
625       if ($skip->{$x})
626       {
627        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
628        next;
629       }
630    
631       #$x is the column in the table
632       # if the column in the row we are looking at is the same as the column in the previous row, we don't add
633       # this cell to $newtable. Instead we increment the rowspan of the previous row by one
634    
635       # handle cells that are references to arrays
636       if (ref($tab->[$y]->[$x]) eq "ARRAY") {$refs->[$y]->[$x]=$tab->[$y]->[$x]->[1]; $tab->[$y]->[$x]=$tab->[$y]->[$x]->[0]}
637    
638       # now we go back through the table looking where to draw the merge line:
639       my $lasty=$y;
640       while ($lasty >= 0 && $tab->[$y]->[$x] eq $tab->[$lasty]->[$x]) {$lasty--}
641       $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
642       if ($lasty == $y) {
643        # we always want to have something in rows that may otherwise be empty but should be there (see below)
644        unless ($tab->[$y]->[$x]) {$tab->[$y]->[$x]=" &nbsp; "}
645        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
646       }
647       else {$rowspan->[$lasty]->[$x]++}
648      }
649     }
650    
651     # now just join everything back together
652     for (my $y=0; $y <= $#$tab; $y++) {
653      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
654       if ($rowspan->[$y]->[$x]) {
655        if ($refs->[$y]->[$x]) {$refs->[$y]->[$x] .= " rowspan=". ($rowspan->[$y]->[$x]+1)}
656        else {$refs->[$y]->[$x] = "td rowspan=". ($rowspan->[$y]->[$x]+1)}
657        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
658       }
659       elsif ($newtable->[$y]->[$x] && $refs->[$y]->[$x]) {
660        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
661       }
662      }
663     }
664    
665    
666     # finally we have to remove any completely empty cells that have been added by the array mechanism
667     # (e.g. if you define $a->[2] then $a->[0] and $a->[1] are now undef).
668     # that is why in the loop above I replace empty cells with nbsp. They are now not undef!
669     # I am sure that Gary can do this in one line, but I am hacking.
670     my @trimmed;
671     foreach my $a (@$newtable) {
672      my @row;
673      foreach my $b (@$a) {
674       push @row, $b if ($b);
675      }
676      push @trimmed, \@row;
677     }
678    
679     return \@trimmed;
680    }
681    
682    
683    
684    
685  sub set_ec_links {  sub set_ec_links {
686      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
687      my($cgi,$x) = @_;      my($cgi,$x) = @_;
# Line 476  Line 732 
732      my($cgi,$fid,$local,$just_url) = @_;      my($cgi,$fid,$local,$just_url) = @_;
733      my($n);      my($n);
734    
735        my $top = top_link();
736    
737      if ($fid =~ /^fig\|\d+\.\d+\.([a-z]+)\.(\d+)/)      if ($fid =~ /^fig\|\d+\.\d+\.([a-z]+)\.(\d+)/)
738      {      {
739          if ($local)          if ($local)
# Line 493  Line 751 
751          {          {
752              $n = $fid;              $n = $fid;
753          }          }
754          if ($1 ne "peg") { return $n }  
755            my $link;
756            #added to format prophage and path island links to feature.cgi
757            if ($1 ne "peg")
758            {
759               my $user = $cgi->param('user');
760               if (! $user) { $user = "" }
761               my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
762               $link = "$top/feature.cgi?feature=$fid&user=$user$trans$sprout";
763               $link =~ s/[a-z_A-Z0-9]+\.cgi\?/feature.cgi?/;
764            }
765            else
766            {
767          my $user = $cgi->param('user');          my $user = $cgi->param('user');
768          if (! $user) { $user = "" }          if (! $user) { $user = "" }
769          my $trans = $cgi->param('translate') ? "&translate=1" : "";          my $trans = $cgi->param('translate') ? "&translate=1" : "";
770          my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";          my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
771          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,;  
772    
773    ### This used to be
774    ###     my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
775    ###
776    ### The cost became prohibitive in the subsystem spreadsheets.  Hence, we cache the value
777    ###
778    ### RAO
779    
780                #if (! $cgi_url) { $cgi_url = &FIG::cgi_url }
781                #$link = $cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
782                $link = "$top/protein.cgi?prot=$fid&user=$user$trans$sprout";
783                $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
784            }
785          if ($just_url)          if ($just_url)
786          {          {
787              return $link;              return $link;
# Line 524  Line 801 
801      return $family;      return $family;
802  }  }
803    
 use URI::Escape;  
804    
805  sub get_html {  sub get_html {
806      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
# Line 641  Line 917 
917          $after = $3;          $after = $3;
918          return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after);          return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after);
919      }      }
920      elsif ($x =~ /^(.*)\b([NXYZA]P_[0-9\.]+)\b(.*)/s)      elsif ($x =~ /^(.*)\b([NXYZA][PM]_[0-9\.]+)\b(.*)/s)
921      {      {
922          $before = $1;          $before = $1;
923          $match = $2;          $match = $2;
# Line 655  Line 931 
931          $after = $3;          $after = $3;
932          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);
933      }      }
934        elsif ($x =~ /^(.*)(tigr\|[0-9a-zA-Z]+)(.*)/s)
935        {
936            $before = $1;
937            $match = $2;
938            $after = $3;
939            return &set_prot_links($cgi,$before) . &HTML::tigr_link($cgi,$match) . &set_prot_links($cgi,$after);
940        }
941      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
942      {      {
943          $before = $1;          $before = $1;
# Line 683  Line 966 
966          $after = $3;          $after = $3;
967          return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after);          return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after);
968      }      }
969        elsif ($x =~ /^(.*)(Ensembl[a-zA-Z]+:[a-zA-Z_0-9\.]+)(.*)/s)
970        {
971            $before = $1;
972            $match = $2;
973            $after = $3;
974            return &set_prot_links($cgi,$before) . &HTML::ensembl_link($cgi,$match) . &set_prot_links($cgi,$after);
975        }
976        elsif ($x =~ /^(.*)(EntrezGene:[a-zA-Z_0-9\.]+)(.*)/s)
977        {
978            $before = $1;
979            $match = $2;
980            $after = $3;
981            return &set_prot_links($cgi,$before) . &HTML::entrezgene_link($cgi,$match) . &set_prot_links($cgi,$after);
982        }
983        elsif ($x =~ /^(.*)(MIM:[a-zA-Z_0-9\.]+)(.*)/s)
984        {
985            $before = $1;
986            $match = $2;
987            $after = $3;
988            return &set_prot_links($cgi,$before) . &HTML::mim_link($cgi,$match) . &set_prot_links($cgi,$after);
989        }
990        elsif ($x =~ /^(.*)(UniGene:[a-zA-Z_0-9\.]+)(.*)/s)
991        {
992            $before = $1;
993            $match = $2;
994            $after = $3;
995            return &set_prot_links($cgi,$before) . &HTML::unigene_link($cgi,$match) . &set_prot_links($cgi,$after);
996        }
997        elsif ($x =~ /^(.*)(IPI:[a-zA-Z_0-9\.]+)(.*)/s)
998        {
999            $before = $1;
1000            $match = $2;
1001            $after = $3;
1002            return &set_prot_links($cgi,$before) . &HTML::ipi_link($cgi,$match) . &set_prot_links($cgi,$after);
1003        }
1004        elsif ($x =~ /^(.*)(WP:[a-zA-Z_0-9\.]+)(.*)/s)
1005        {
1006            #wormbase
1007    
1008            $before = $1;
1009            $match = $2;
1010            $after = $3;
1011            return &set_prot_links($cgi,$before) . &HTML::wp_link($cgi,$match) . &set_prot_links($cgi,$after);
1012        }
1013        elsif ($x =~ /^(.*)(FB:[a-zA-Z_0-9\.]+)(.*)/s)
1014        {
1015            #flybase
1016    
1017            $before = $1;
1018            $match = $2;
1019            $after = $3;
1020            return &set_prot_links($cgi,$before) . &HTML::fb_link($cgi,$match) . &set_prot_links($cgi,$after);
1021        }
1022        elsif ($x =~ /^(.*)(FlyBaseORFNames:[a-zA-Z_0-9\.]+)(.*)/s)
1023        {
1024            #flybase
1025    
1026            $before = $1;
1027            $match = $2;
1028            $after = $3;
1029            return &set_prot_links($cgi,$before) . &HTML::fborf_link($cgi,$match) . &set_prot_links($cgi,$after);
1030        }
1031        elsif ($x =~ /^(.*)(SGD_LOCUS:[a-zA-Z_0-9\.]+)(.*)/s)
1032        {
1033            #flybase
1034    
1035            $before = $1;
1036            $match = $2;
1037            $after = $3;
1038            return &set_prot_links($cgi,$before) . &HTML::sgd_link($cgi,$match) . &set_prot_links($cgi,$after);
1039        }
1040      return $x;      return $x;
1041  }  }
1042    
# Line 694  Line 1048 
1048      {      {
1049          return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id>$id</a>";          return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id>$id</a>";
1050      }      }
1051        elsif ($id =~ /^[NXYZA]M_/)
1052        {
1053            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=nuccore&cmd=search&term=$id>$id</a>";
1054        }
1055  }  }
1056    
1057  sub gi_link {  sub gi_link {
# Line 707  Line 1065 
1065      return $gi;      return $gi;
1066  }  }
1067    
1068    sub tigr_link {
1069        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1070        my($cgi,$tigr) = @_;
1071    
1072        if ($tigr =~ /^tigr\|([0-9a-zA-Z]+)$/)
1073        {
1074            return "<a href=\"http://pathema.tigr.org/tigr-scripts/CMR/GenePage.cgi?locus=$1\">$tigr</a>";
1075        }
1076        return $tigr;
1077    }
1078    
1079  sub uni_link {  sub uni_link {
1080      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1081      my($cgi,$uni) = @_;      my($cgi,$uni) = @_;
# Line 751  Line 1120 
1120      return $kegg;      return $kegg;
1121  }  }
1122    
1123    sub ensembl_link {
1124        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1125        my($cgi,$ensembl) = @_;
1126    
1127        if ($ensembl =~ /^(\S+):(\S+)$/)
1128        {
1129            my $what=$1;
1130            my $key=$2;
1131            my $idx="all";
1132            if ($what eq "EnsemblGene") { $idx = "Gene" }
1133            if ($what eq "EnsemblTranscript") { $idx = "all" }
1134            if ($what eq "EnsemblProtein") { $idx = "all" }
1135    
1136            #I really want to get right to the transcript and peptide pages, but
1137            #can't see how to do that without knowing the org name too, which
1138            #I don't know at this point. (ensembl org name, not real org name)
1139    
1140            return "<a href=http://www.ensembl.org/Homo_sapiens/textview?species=all&idx=$idx&q=$key>$ensembl</a>";
1141        }
1142        return $ensembl;
1143    }
1144    
1145    sub entrezgene_link {
1146        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1147        my($cgi,$entrezgene) = @_;
1148    
1149        if ($entrezgene =~ /^EntrezGene:(\S+)$/)
1150        {
1151            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=gene&cmd=Retrieve&dopt=full_report&list_uids=$1>$entrezgene</a>";
1152        }
1153        return $entrezgene;
1154    }
1155    
1156    sub mim_link {
1157        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1158        my($cgi,$mim) = @_;
1159    
1160        if ($mim =~ /^MIM:(\S+)$/)
1161        {
1162            return "<a href=http://www3.ncbi.nlm.nih.gov/entrez/dispomim.cgi?id=$1>$mim</a>";
1163        }
1164        return $mim;
1165    }
1166    
1167    sub unigene_link {
1168        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1169        my($cgi,$unigene) = @_;
1170    
1171        if ($unigene =~ /^UniGene:(\S+)$/)
1172        {
1173            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=unigene&cmd=search&term=$1>$unigene</a>";
1174        }
1175        return $unigene;
1176    }
1177    
1178    sub ipi_link {
1179        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1180        my($cgi,$ipi) = @_;
1181    
1182        if ($ipi =~ /^IPI:(\S+)$/)
1183        {
1184            return "<a href=http://srs.ebi.ac.uk/srsbin/cgi-bin/wgetz?-id+AEoS1R8Jnn+-e+[IPI:\'$1\']+-qnum+1+-enum+1>$ipi</a>";
1185        }
1186        return $ipi;
1187    }
1188    
1189    sub wp_link {
1190        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1191        my($cgi,$wp) = @_;
1192    
1193        #wormbase
1194    
1195        if ($wp =~ /^WP:(\S+)$/)
1196        {
1197            return "<a href=http://www.wormbase.org/db/searches/basic?class=Any&query=$1&Search=Search>$wp</a>";
1198        }
1199        return $wp;
1200    }
1201    
1202    sub fb_link {
1203        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1204        my($cgi,$fb) = @_;
1205    
1206        #flybase
1207    
1208        if ($fb =~ /^FB:(\S+)$/)
1209        {
1210            return "<a href=http://flybase.bio.indiana.edu/.bin/fbidq.html?$1>$fb</a>";
1211        }
1212        return $fb;
1213    }
1214    
1215    sub fborf_link {
1216        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1217        my($cgi,$fb) = @_;
1218    
1219        #flybase
1220    
1221        if ($fb =~ /^FlyBaseORFNames:(\S+)$/)
1222        {
1223            return "<a href=http://flybase.bio.indiana.edu/.bin/fbidq.html?$1>$fb</a>";
1224        }
1225        return $fb;
1226    }
1227    
1228    sub sgd_link {
1229        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1230        my($cgi,$sgd) = @_;
1231    
1232        #yeast
1233    
1234        if ($sgd =~ /^SGD_LOCUS:(\S+)$/)
1235        {
1236            return "<a href=http://db.yeastgenome.org/cgi-bin/locus.pl?locus=$1>$sgd</a>";
1237        }
1238        return $sgd;
1239    }
1240    
1241    
1242    
1243    
1244  sub set_map_links {  sub set_map_links {
1245      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1246      my($cgi,$x) = @_;      my($cgi,$x) = @_;
# Line 768  Line 1258 
1258      return $x;      return $x;
1259  }  }
1260    
1261    
1262    
1263  sub map_link {  sub map_link {
1264      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1265      my($cgi,$map,$org) = @_;      my($cgi,$map,$org) = @_;
# Line 775  Line 1267 
1267      $user = $cgi->param('user');      $user = $cgi->param('user');
1268      $user = $user ? $user : "";      $user = $user ? $user : "";
1269      $org = $org ? $org : "";      $org = $org ? $org : "";
1270      my $url = "$FIG_Config::cgi_url/show_kegg_map.cgi?user=$user&map=$map&org=$org";  
1271        my $url = "show_kegg_map.cgi?user=$user&map=$map&org=$org";
1272    #rel    my $url = &FIG::cgi_url() . "/show_kegg_map.cgi?user=$user&map=$map&org=$org";
1273      my $link = "<a href=\"$url\">$map</a>";      my $link = "<a href=\"$url\">$map</a>";
1274      return $link;      return $link;
1275  }  }
1276    
 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;  
 }  
   
1277  sub java_buttons {  sub java_buttons {
1278      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1279    ## ADDED BY RAE    ## ADDED BY RAE
# Line 855  Line 1298 
1298      my $user = $cgi->param('user');      my $user = $cgi->param('user');
1299      if ($user)      if ($user)
1300      {      {
1301          $sub_link = "<a href=./subsys.cgi?ssa_name=$sub&request=show_ssa&user=$user>$sub</a>";          my $esc_sub = uri_escape( $sub );
1302            $sub_link = "<a href=./subsys.cgi?ssa_name=$esc_sub&request=show_ssa&user=$user>$sub</a>";
1303      }      }
1304      else      else
1305      {      {
# Line 864  Line 1308 
1308      return $sub_link;      return $sub_link;
1309  }  }
1310    
1311  1  sub reaction_link {
1312        my($reaction) = @_;
1313    
1314        if ($reaction =~ /^R\d+/)
1315        {
1316            return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?rn+$reaction\" target=reaction$$>$reaction</a>";
1317        }
1318        return $reaction;
1319    }
1320    
1321    sub html_for_assignments {
1322        my($fig,$user,$peg_sets) = @_;
1323        my $i;
1324    
1325        my @vals = ();
1326        my $set = 1;
1327        foreach $peg_set (@$peg_sets)
1328        {
1329            for ($i=0; ($i < @$peg_set); $i++)
1330            {
1331                $peg = $peg_set->[$i];
1332                push(@vals,'show=' . join("@",($set,$i+1,$peg,&FIG::abbrev($fig->org_of($peg)),"")));
1333            }
1334            $set++;
1335        }
1336    
1337        $ENV{'REQUEST_METHOD'} = 'GET';
1338        $ENV{'QUERY_STRING'} = join('&',('request=show_commentary',"uni=1","user=$user",@vals));
1339        my $out = join("",`$FIG_Config::fig/CGI/chromosomal_clusters.cgi`);
1340        $out =~ s/^.*?<form/<form/si;
1341        $out =~ s/^(.*)<table.*/$1/si;
1342        return $out;
1343    }
1344    
1345    =head1 rss_feed
1346    
1347    Add something to the RSS feed. The rss feeds are stored in the Html directory, and there are several RSS feeds:
1348            SEED.rss                - everything gets written here
1349            SEEDgenomes.rss                 - whenever a genome is added to the SEED
1350            SEEDsubsystems.rss      - whenever a subsystem is edited (or should this be added?)
1351    
1352    
1353    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.
1354    
1355    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.
1356    
1357    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.
1358    
1359    The has can have these keys:
1360    
1361    REQUIRED:
1362    title       : the title. This is usually what is seen by the user in the pull down menu
1363    description : a more complete description that is often seen is rss viewers but not always
1364    link        : link to the item that was added/edited
1365    All other keys are treated as optional RSS arguments and written to the file.
1366    
1367    At most, $max_entries recent entries are stored in the rss file, and this is currently 50.
1368    
1369    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.
1370    
1371    
1372    =cut
1373    
1374    sub rss_feed {
1375     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1376     my ($files, $args)=@_;
1377    
1378     # how many entries to store in the file
1379     my $max_entries=50;
1380    
1381     foreach my $a (keys %$args) {if ($a =~ /^-(.*)/) {my $b=$1; $args->{$b}=$args->{$a}; delete $args->{$a}}}
1382    
1383     my $filepath=$FIG_Config::fig."/CGI/Html/rss";
1384     # check for the directory and if not, make it
1385     mkdir $filepath unless (-d $filepath);
1386    
1387     # note that $info is a hash of references to hashes that are written out as headers in the file
1388     my $info=
1389     {
1390      "SEED.rss" =>
1391       {
1392            title           => "The SEED",
1393            description     => "Latest news from the SEED",
1394            link            => "Html/rss/SEED.rss",
1395       },
1396    
1397      "SEEDsubsystems.rss" =>
1398      {
1399            title           => "SEED Subsystems",
1400            description     => "Recently updated SEED subsystems",
1401            link            => "Html/rss/SEEDsubsystems.rss",
1402      },
1403    
1404      "SEEDsubsystems.rss" =>
1405      {
1406            title           => "SEED Genomes",
1407            description     => "Genomes recently added to the SEED",
1408            link            => &FIG::cgi_url()."/Html/rss/SEEDsubsystems.rss",
1409      },
1410    
1411     };
1412    
1413    
1414     # build the new xml
1415     my $xml = "\t<item>\n";
1416     foreach my $qw ("title", "description", "link") {
1417      unless ($args->{$qw}) {
1418       print STDERR "You need to include a $qw tag in your RSS description\n";
1419       return(0);
1420      }
1421      # we need to do something a bit funky with the link. We can't have ampersands in the <link> </link> in valid html
1422      # so we are going to pull out the links and uri_escape just the part after the .cgi
1423      if ($qw eq "link")
1424      {
1425       $args->{$qw} =~ /^(.*?\.cgi.)(.*)$/;
1426       $args->{$qw} = $1.uri_escape($2) if ($1 && $2);
1427      }
1428    
1429      $xml .= "\t\t<$qw>".$args->{$qw}."</$qw>\n";
1430      delete $args->{$qw};
1431     }
1432    
1433     foreach my $tag (grep {!/type/i} keys %$args)
1434     {
1435      $xml .= "\t\t<$tag>".$args->{$tag}."</$tag>\n";
1436     }
1437    
1438     $xml .= "\t</item>\n";
1439    
1440    
1441     my @files=("SEED.rss");
1442     if ($args->{"type"}) {push @files, "SEED.$type.rss"}
1443    
1444     foreach my $file ("SEED.rss", @$files)
1445     {
1446      if (-e "$filepath/$file")
1447      {
1448       my @out; # the new content of the file
1449       my $itemcount=0; # how many <item> </item>'s are we keeping
1450       my $initem; # are we in an item?
1451       open(IN, "$filepath/$file") || die "Can't open $filepath/$file";
1452       while (<IN>)
1453       {
1454        if (/\<item\>/) {
1455         push @out, $xml, unless ($itemcount);
1456         $itemcount++;
1457         $initem=1;
1458        }
1459        if (/\<\/item\>/) {$initem=0; next if ($itemcount > $max_entries)}
1460        next if ($initem && $itemcount > $max_entries);
1461        push @out, $_;
1462       }
1463       close IN;
1464       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1465       print OUT @out;
1466      }
1467      else
1468      {
1469       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1470       print OUT "<?xml version=\"1.0\"?>\n<rss version=\"2.0\">\n<channel>\n";
1471       if ($info->{$file})
1472       {
1473         # we're going to sanity check each of the three options we output, just to be sure
1474         foreach my $qw ("title", "description", "link")
1475         {
1476           if ($info->{$file}->{$qw})
1477           {
1478              print OUT "<$qw>", $info->{$file}->{$qw}, "</$qw>\n";
1479           } else {
1480              print STDERR "Please add a $qw for $file\n"; print OUT "<$qw>$file</$qw>\n";
1481           }
1482         }
1483       }
1484       else {
1485        print STDERR "Please define title, link, and description information for $file\n";
1486        print OUT "<title>$file</title>\n<description>An RSS feed</description>\n<link>", &FIG::cgi_url, "</link>\n";
1487       }
1488       print OUT "\n", $xml;
1489       print OUT "\n", "</channel>\n</rss>\n"
1490      }
1491     }
1492    }
1493    
1494    
1495    
1496    1;
1497    

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3