[Bio] / FigKernelPackages / HTML.pm Repository:
ViewVC logotype

Diff of /FigKernelPackages/HTML.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.37, Tue Mar 15 22:29:27 2005 UTC revision 1.52, Sat Aug 6 15:30:29 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;
# Line 21  Line 23 
23  sub compute_html_header  sub compute_html_header
24  {  {
25      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
26      my($additional_insert,$user) = @_;      my($additional_insert, $user, %options ) = @_;
27      my $html_hdr_file = "./Html/html.hdr";  
28        my $header_name = $options{header_name} ? $options{header_name} : "html.hdr";
29        my $tail_name = $options{tail_name} ? $options{tail_name} : "html.tail";
30    
31        my $html_hdr_file = "./Html/$header_name";
32      if (! -f $html_hdr_file)      if (! -f $html_hdr_file)
33      {      {
34          $html_hdr_file = "$FIG_Config::fig/CGI/Html/html.hdr";          $html_hdr_file = "$FIG_Config::fig/CGI/Html/$header_name";
35      }      }
36      my @html_hdr = &FIG::file_read($html_hdr_file);      my @html_hdr = &FIG::file_read($html_hdr_file);
37      push( @html_hdr, "<br><a href=\"index.cgi?user=$user\">FIG search</a>\n" );  
38        $options{no_fig_search} or push( @html_hdr, "<br><a href=\"index.cgi?user=$user\">FIG search</a>\n" );
39    
40      if (@html_hdr)      if (@html_hdr)
41      {      {
42          my $insert_stuff;          my $insert_stuff;
43    
44            if (not $options{no_release_info})
45            {
46          my @ver = &FIG::file_head("$FIG_Config::fig_disk/CURRENT_RELEASE", 1);          my @ver = &FIG::file_head("$FIG_Config::fig_disk/CURRENT_RELEASE", 1);
47          my $ver = $ver[0];          my $ver = $ver[0];
48          chomp $ver;          chomp $ver;
# Line 44  Line 54 
54          }          }
55          my $host = &FIG::get_local_hostname();          my $host = &FIG::get_local_hostname();
56          $insert_stuff = "SEED version <b>$ver</b> on $host";          $insert_stuff = "SEED version <b>$ver</b> on $host";
57            }
58    
59          if ($additional_insert)          if ($additional_insert)
60          {          {
61              $insert_stuff .= "<br>" . $additional_insert;              $insert_stuff .= "<br>" . $additional_insert;
# Line 65  Line 77 
77  sub show_page {  sub show_page {
78      #warn "SHOWPAGE: cgi=", Dumper(@_);      #warn "SHOWPAGE: cgi=", Dumper(@_);
79      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
80      my($cgi,$html,$no_home, $alt_header, $css) = @_;      my($cgi,$html,$no_home, $alt_header, $css, $javasrc) = @_;
81      my $i;      my $i;
82    
   
83      # ARGUMENTS:      # ARGUMENTS:
84      #     $cgi is the CGI method      #     $cgi is the CGI method
85      #     $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 88 
88      #     $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
89      #               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
90      #               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
91        #     $javasrc is a reference to an array of URLs to javascripts to be included (e.g. "/FIG/Html/css/styleswitcher.js")
92      #      #
93      # Find the HTML header      # Find the HTML header
94      #      #
95    
96      my $html_tail_file = "./Html/html.tail";      my $html_tail_file = "./Html/$tail_name";
97      if (! -f $html_tail_file)      if (! -f $html_tail_file)
98      {      {
99          $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";          $html_tail_file = "$FIG_Config::fig/CGI/Html/$tail_name";
100      }      }
101    
102      my $user = $cgi->param('user') || "";      my $user = $cgi->param('user') || "";
103      my @html_hdr;      my @html_hdr;
104      if ($alt_header)      if ($alt_header && ref($alt_header) eq "ARRAY")
105      {      {
106         @html_hdr = @$alt_header;         @html_hdr = @$alt_header;
107      }      }
# Line 221  Line 232 
232      #  Added the javascript for the buttons immediately after body.      #  Added the javascript for the buttons immediately after body.
233      #  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,
234      #  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!
235        #  RAE: This is now deprecated because everything is in an external file, FIG.js, included later
236    
237      if ( $body_line < 0 )      if ( $body_line < 0 )
238      {      {
         my $js=&javascript;  
239          $body_line = $last_head_line + 1;          $body_line = $last_head_line + 1;
240          splice( @$html, $body_line, 0, "<BODY>\n$js\n" );          splice( @$html, $body_line, 0, "<BODY>\n" );
241      }      }
242    
243      #      #
# Line 250  Line 261 
261    
262      # RAE:      # RAE:
263      # Add css here      # Add css here
264      # 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
265      # css has the format      # be moved out, but I want to try it and see what happens.  css has the format:
266        #
267      # <link rel='stylesheet' title='default' href='/css/default.css' type='text/css'>      # <link rel='stylesheet' title='default' href='/css/default.css' type='text/css'>
268    
269      # 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 271 
271    
272      if (!$css || !$css->{'Default'})      if (!$css || !$css->{'Default'})
273      {      {
274         $css->{'Default'}="/FIG/Html/css/default.css";         $css->{'Default'} = &FIG::cgi_url() . "/Html/css/default.css";
275      }      }
276      if (!$css->{"Sans Serif"})      if (!$css->{"Sans Serif"})
277      {      {
278         $css->{'Sans Serif'}="/FIG/Html/css/sanserif.css";         $css->{'Sans Serif'} = &FIG::cgi_url() . "/Html/css/sanserif.css";
279      }      }
280      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";
281      $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";
# Line 271  Line 283 
283      foreach my $k (keys %$css)      foreach my $k (keys %$css)
284      {      {
285         next if (lc($k) eq "default" || lc($k) eq "sans serif");         next if (lc($k) eq "default" || lc($k) eq "sans serif");
286         $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";
287      }      }
288    
289    
290        # RAE: also added support for external javascripts here.
291        # we are cluttering the HTML code with all the javascripts when they could easily be in external files
292        # this solution allows us to source other files
293    
294        # the file FIG.js contains most of the java script we use routinely. Every browser will just cache this and so
295        # it will reduce our overhead.
296    
297        # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts
298        push @$javasrc, &FIG::cgi_url() . "/Html/css/FIG.js";
299        foreach my $script (@$javasrc) {
300            $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";
301        }
302    
303    
304    
305      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.
306    
307      #      #
# Line 350  Line 379 
379      #  Figure out where to insert The SEED tail.  Before </body>,      #  Figure out where to insert The SEED tail.  Before </body>,
380      #  or before </html>, or at end of page.      #  or before </html>, or at end of page.
381      #      #
   
382      my @tags = ();      my @tags = ();
383        # Check for a tracing queue.
384        my $traceString = QTrace("HTML");
385        if ($traceString) {
386            push @tags, $traceString;
387        }
388      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}
389      if ($i >= @$html)        # </body> not found; look for </html>      if ($i >= @$html)        # </body> not found; look for </html>
390      {      {
# Line 374  Line 406 
406          splice( @$html, $i, 0, @tags );          splice( @$html, $i, 0, @tags );
407      }      }
408    
409      # 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,
410      # 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,
411        # and others don't. This should make nicer looking html
412        #
413      #chomp(@$html);      #chomp(@$html);
414      #print join "\n", @$html;      #print join "\n", @$html;
415        #
416      # Apparently the above still breaks things. This is the correct code:      # Apparently the above still breaks things. This is the correct code:
417      print @$html;  
418        foreach $_ (@$html)
419        {
420            print $_;
421        }
422    
423  }  }
424    
425  sub make_table {  sub make_table {
# Line 414  Line 453 
453    
454      $tag = "td" unless $tag;      $tag = "td" unless $tag;
455      my $endtag=$tag;      my $endtag=$tag;
456      # RAE modified this so that you can pass in a reference to an array where the first element is the data to  
457      # 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
458        # the first element is the data to display and the second element is optional
459        # things like colspan and align. Note that in this case you need to include the td
460      # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]      # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]
461      if (ref($x) eq "ARRAY") {($x, $tag)=@$x; if ($tag =~ /td/) {$endtag = "td"}}  
462        # per GJO's request modified this line so it can take any tag.
463        if ( ref($x) eq "ARRAY" ) { ($x, $tag) = @$x; $tag =~ /^(\S+)/; $endtag = $1 }
464    
465      if ($x =~ /^\@([^:]+)\:(.*)$/)      if ($x =~ /^\@([^:]+)\:(.*)$/)
466      {      {
# Line 429  Line 472 
472      }      }
473  }  }
474    
475    
476    sub merge_table_rows {
477     # RAE:
478     # Experimental piece of code. We often want to have rows or columns were cells are merged. It just looks so much nicer
479     # this block should merge adjacent rows that have the same text in them.
480     # use like this:
481     #      $tab=&HTML::merge_table_rows($tab);
482     # before you do a make_table call
483    
484     my $self=shift if UNIVERSAL::isa($_[0],__PACKAGE__);
485     my ($tab)=@_;
486    
487     my $newtable;
488     my $lastrow;
489     my $rowspan;
490     my $refs;
491    
492     for (my $y=0; $y <= $#$tab; $y++) {
493     #$y is the row in the table;
494      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
495       #$x is the column in the table
496       # if the column in the row we are looking at is the same as the column in the previous row, we don't add
497       # this cell to $newtable. Instead we increment the rowspan of the previous row by one
498    
499       # handle cells that are references to arrays
500       if (ref($tab->[$y]->[$x]) eq "ARRAY") {$refs->[$y]->[$x]=$tab->[$y]->[$x]->[1]; $tab->[$y]->[$x]=$tab->[$y]->[$x]->[0]}
501    
502       # now we go back through the table looking where to draw the merge line:
503       my $lasty=$y;
504       while ($lasty >= 0 && $tab->[$y]->[$x] eq $tab->[$lasty]->[$x]) {$lasty--}
505       $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
506       if ($lasty == $y) {
507        # we always want to have something in rows that may otherwise be empty but should be there (see below)
508        unless ($tab->[$y]->[$x]) {$tab->[$y]->[$x]=" &nbsp; "}
509        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
510       }
511       else {$rowspan->[$lasty]->[$x]++}
512      }
513     }
514    
515     # now just join everything back together
516     for (my $y=0; $y <= $#$tab; $y++) {
517      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
518       if ($rowspan->[$y]->[$x]) {
519        if ($refs->[$y]->[$x]) {$refs->[$y]->[$x] .= " rowspan=". ($rowspan->[$y]->[$x]+1)}
520        else {$refs->[$y]->[$x] = "td rowspan=". ($rowspan->[$y]->[$x]+1)}
521        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
522       }
523       elsif ($newtable->[$y]->[$x] && $refs->[$y]->[$x]) {
524        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
525       }
526      }
527     }
528    
529    
530     # finally we have to remove any completely empty cells that have been added by the array mechanism
531     # (e.g. if you define $a->[2] then $a->[0] and $a->[1] are now undef).
532     # that is why in the loop above I replace empty cells with nbsp. They are now not undef!
533     # I am sure that Gary can do this in one line, but I am hacking.
534     my @trimmed;
535     foreach my $a (@$newtable) {
536      my @row;
537      foreach my $b (@$a) {
538       push @row, $b if ($b);
539      }
540      push @trimmed, \@row;
541     }
542    
543     return \@trimmed;
544    }
545    
546    
547    
548    
549  sub set_ec_links {  sub set_ec_links {
550      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
551      my($cgi,$x) = @_;      my($cgi,$x) = @_;
# Line 527  Line 644 
644      return $family;      return $family;
645  }  }
646    
 use URI::Escape;  
647    
648  sub get_html {  sub get_html {
649      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
# Line 658  Line 774 
774          $after = $3;          $after = $3;
775          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);
776      }      }
777        elsif ($x =~ /^(.*)(tigr\|[0-9a-zA-Z]+)(.*)/s)
778        {
779            $before = $1;
780            $match = $2;
781            $after = $3;
782            return &set_prot_links($cgi,$before) . &HTML::tigr_link($cgi,$match) . &set_prot_links($cgi,$after);
783        }
784      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
785      {      {
786          $before = $1;          $before = $1;
# Line 710  Line 833 
833      return $gi;      return $gi;
834  }  }
835    
836    sub tigr_link {
837        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
838        my($cgi,$tigr) = @_;
839    
840        if ($tigr =~ /^tigr\|([0-9a-zA-Z]+)$/)
841        {
842            return "<a href=\"http://pathema.tigr.org/tigr-scripts/CMR/GenePage.cgi?locus=$1\">$tigr</a>";
843        }
844        return $tigr;
845    }
846    
847  sub uni_link {  sub uni_link {
848      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
849      my($cgi,$uni) = @_;      my($cgi,$uni) = @_;
# Line 778  Line 912 
912      $user = $cgi->param('user');      $user = $cgi->param('user');
913      $user = $user ? $user : "";      $user = $user ? $user : "";
914      $org = $org ? $org : "";      $org = $org ? $org : "";
915      my $url = "$FIG_Config::cgi_url/show_kegg_map.cgi?user=$user&map=$map&org=$org";  
916        my $url = &FIG::cgi_url() . "/show_kegg_map.cgi?user=$user&map=$map&org=$org";
917      my $link = "<a href=\"$url\">$map</a>";      my $link = "<a href=\"$url\">$map</a>";
918      return $link;      return $link;
919  }  }
920    
 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;  
 }  
   
921  sub java_buttons {  sub java_buttons {
922      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
923    ## ADDED BY RAE    ## ADDED BY RAE
# Line 858  Line 942 
942      my $user = $cgi->param('user');      my $user = $cgi->param('user');
943      if ($user)      if ($user)
944      {      {
945          $sub_link = "<a href=./subsys.cgi?ssa_name=$sub&request=show_ssa&user=$user>$sub</a>";          my $esc_sub = uri_escape( $sub );
946            $sub_link = "<a href=./subsys.cgi?ssa_name=$esc_sub&request=show_ssa&user=$user>$sub</a>";
947      }      }
948      else      else
949      {      {
# Line 867  Line 952 
952      return $sub_link;      return $sub_link;
953  }  }
954    
955    sub reaction_link {
956        my($reaction) = @_;
957    
958        if ($reaction =~ /^R\d+/)
959        {
960            return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?rn+$reaction\" target=reaction$$>$reaction</a>";
961        }
962        return $reaction;
963    }
964    
965  1  1

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3