[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.41, Thu Apr 28 20:56:37 2005 UTC revision 1.54, Thu Aug 18 19:16:03 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;
# Line 22  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 45  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 53  Line 64 
64          for $_ (@html_hdr)          for $_ (@html_hdr)
65          {          {
66              s,(href|img\s+src)="/FIG/,\1="$FIG_Config::cgi_base,g;              s,(href|img\s+src)="/FIG/,\1="$FIG_Config::cgi_base,g;
67                s,(\?user\=)\",$1$user",;
68              if ($_ eq "<!-- HEADER_INSERT -->\n")              if ($_ eq "<!-- HEADER_INSERT -->\n")
69              {              {
70                  $_ = $insert_stuff;                  $_ = $insert_stuff;
# Line 69  Line 81 
81      my($cgi,$html,$no_home, $alt_header, $css, $javasrc) = @_;      my($cgi,$html,$no_home, $alt_header, $css, $javasrc) = @_;
82      my $i;      my $i;
83    
   
84      # ARGUMENTS:      # ARGUMENTS:
85      #     $cgi is the CGI method      #     $cgi is the CGI method
86      #     $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 83  Line 94 
94      # Find the HTML header      # Find the HTML header
95      #      #
96    
97      my $html_tail_file = "./Html/html.tail";      my $html_tail_file = "./Html/$tail_name";
98      if (! -f $html_tail_file)      if (! -f $html_tail_file)
99      {      {
100          $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";          $html_tail_file = "$FIG_Config::fig/CGI/Html/$tail_name";
101      }      }
102    
103      my $user = $cgi->param('user') || "";      my $user = $cgi->param('user') || "";
# Line 222  Line 233 
233      #  Added the javascript for the buttons immediately after body.      #  Added the javascript for the buttons immediately after body.
234      #  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,
235      #  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!
236        #  RAE: This is now deprecated because everything is in an external file, FIG.js, included later
237    
238      if ( $body_line < 0 )      if ( $body_line < 0 )
239      {      {
         my $js=&javascript;  
240          $body_line = $last_head_line + 1;          $body_line = $last_head_line + 1;
241          splice( @$html, $body_line, 0, "<BODY>\n$js\n" );          splice( @$html, $body_line, 0, "<BODY>\n" );
242      }      }
243    
244      #      #
# Line 261  Line 272 
272    
273      if (!$css || !$css->{'Default'})      if (!$css || !$css->{'Default'})
274      {      {
275         $css->{'Default'}="/FIG/Html/css/default.css";         $css->{'Default'} = &FIG::cgi_url() . "/Html/css/default.css";
276      }      }
277      if (!$css->{"Sans Serif"})      if (!$css->{"Sans Serif"})
278      {      {
279         $css->{'Sans Serif'}="/FIG/Html/css/sanserif.css";         $css->{'Sans Serif'} = &FIG::cgi_url() . "/Html/css/sanserif.css";
280      }      }
281      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";
282      $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 281  Line 292 
292      # we are cluttering the HTML code with all the javascripts when they could easily be in external files      # we are cluttering the HTML code with all the javascripts when they could easily be in external files
293      # this solution allows us to source other files      # this solution allows us to source other files
294    
295        # the file FIG.js contains most of the java script we use routinely. Every browser will just cache this and so
296        # it will reduce our overhead.
297    
298      # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts      # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts
299      if ($javasrc && ref($javasrc) eq "ARRAY") {      push @$javasrc, &FIG::cgi_url() . "/Html/css/FIG.js";
300       foreach my $script (@$javasrc) {       foreach my $script (@$javasrc) {
301        $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";        $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";
302       }       }
     }  
303    
304    
305    
# Line 367  Line 380 
380      #  Figure out where to insert The SEED tail.  Before </body>,      #  Figure out where to insert The SEED tail.  Before </body>,
381      #  or before </html>, or at end of page.      #  or before </html>, or at end of page.
382      #      #
   
383      my @tags = ();      my @tags = ();
384        # Check for a tracing queue.
385        my $traceString = QTrace("HTML");
386        if ($traceString) {
387            push @tags, $traceString;
388        }
389      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}
390      if ($i >= @$html)        # </body> not found; look for </html>      if ($i >= @$html)        # </body> not found; look for </html>
391      {      {
# Line 400  Line 416 
416      #      #
417      # Apparently the above still breaks things. This is the correct code:      # Apparently the above still breaks things. This is the correct code:
418    
419      print @$html;      foreach $_ (@$html)
420        {
421            print $_;
422        }
423    
424  }  }
425    
426  sub make_table {  sub make_table {
# Line 440  Line 460 
460      # things like colspan and align. Note that in this case you need to include the td      # things like colspan and align. Note that in this case you need to include the td
461      # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]      # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]
462    
463      if ( ref($x) eq "ARRAY" ) { ($x, $tag) = @$x; if ($tag =~ /td/) { $endtag = "td" } }      # per GJO's request modified this line so it can take any tag.
464        if ( ref($x) eq "ARRAY" ) { ($x, $tag) = @$x; $tag =~ /^(\S+)/; $endtag = $1 }
465    
466      if ( $x =~ /^\@([^:]+)\:(.*)$/ )      if ( $x =~ /^\@([^:]+)\:(.*)$/ )
467      {      {
# Line 452  Line 473 
473      }      }
474  }  }
475    
476    
477    sub merge_table_rows {
478     # RAE:
479     # Experimental piece of code. We often want to have rows or columns were cells are merged. It just looks so much nicer
480     # this block should merge adjacent rows that have the same text in them.
481     # use like this:
482     #      $tab=&HTML::merge_table_rows($tab);
483     # before you do a make_table call
484    
485     my $self=shift if UNIVERSAL::isa($_[0],__PACKAGE__);
486     my ($tab)=@_;
487    
488     my $newtable;
489     my $lastrow;
490     my $rowspan;
491     my $refs;
492    
493     for (my $y=0; $y <= $#$tab; $y++) {
494     #$y is the row in the table;
495      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
496       #$x is the column in the table
497       # if the column in the row we are looking at is the same as the column in the previous row, we don't add
498       # this cell to $newtable. Instead we increment the rowspan of the previous row by one
499    
500       # handle cells that are references to arrays
501       if (ref($tab->[$y]->[$x]) eq "ARRAY") {$refs->[$y]->[$x]=$tab->[$y]->[$x]->[1]; $tab->[$y]->[$x]=$tab->[$y]->[$x]->[0]}
502    
503       # now we go back through the table looking where to draw the merge line:
504       my $lasty=$y;
505       while ($lasty >= 0 && $tab->[$y]->[$x] eq $tab->[$lasty]->[$x]) {$lasty--}
506       $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
507       if ($lasty == $y) {
508        # we always want to have something in rows that may otherwise be empty but should be there (see below)
509        unless ($tab->[$y]->[$x]) {$tab->[$y]->[$x]=" &nbsp; "}
510        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
511       }
512       else {$rowspan->[$lasty]->[$x]++}
513      }
514     }
515    
516     # now just join everything back together
517     for (my $y=0; $y <= $#$tab; $y++) {
518      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
519       if ($rowspan->[$y]->[$x]) {
520        if ($refs->[$y]->[$x]) {$refs->[$y]->[$x] .= " rowspan=". ($rowspan->[$y]->[$x]+1)}
521        else {$refs->[$y]->[$x] = "td rowspan=". ($rowspan->[$y]->[$x]+1)}
522        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
523       }
524       elsif ($newtable->[$y]->[$x] && $refs->[$y]->[$x]) {
525        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
526       }
527      }
528     }
529    
530    
531     # finally we have to remove any completely empty cells that have been added by the array mechanism
532     # (e.g. if you define $a->[2] then $a->[0] and $a->[1] are now undef).
533     # that is why in the loop above I replace empty cells with nbsp. They are now not undef!
534     # I am sure that Gary can do this in one line, but I am hacking.
535     my @trimmed;
536     foreach my $a (@$newtable) {
537      my @row;
538      foreach my $b (@$a) {
539       push @row, $b if ($b);
540      }
541      push @trimmed, \@row;
542     }
543    
544     return \@trimmed;
545    }
546    
547    
548    
549    
550  sub set_ec_links {  sub set_ec_links {
551      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
552      my($cgi,$x) = @_;      my($cgi,$x) = @_;
# Line 680  Line 775 
775          $after = $3;          $after = $3;
776          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);
777      }      }
778        elsif ($x =~ /^(.*)(tigr\|[0-9a-zA-Z]+)(.*)/s)
779        {
780            $before = $1;
781            $match = $2;
782            $after = $3;
783            return &set_prot_links($cgi,$before) . &HTML::tigr_link($cgi,$match) . &set_prot_links($cgi,$after);
784        }
785      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
786      {      {
787          $before = $1;          $before = $1;
# Line 732  Line 834 
834      return $gi;      return $gi;
835  }  }
836    
837    sub tigr_link {
838        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
839        my($cgi,$tigr) = @_;
840    
841        if ($tigr =~ /^tigr\|([0-9a-zA-Z]+)$/)
842        {
843            return "<a href=\"http://pathema.tigr.org/tigr-scripts/CMR/GenePage.cgi?locus=$1\">$tigr</a>";
844        }
845        return $tigr;
846    }
847    
848  sub uni_link {  sub uni_link {
849      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
850      my($cgi,$uni) = @_;      my($cgi,$uni) = @_;
# Line 800  Line 913 
913      $user = $cgi->param('user');      $user = $cgi->param('user');
914      $user = $user ? $user : "";      $user = $user ? $user : "";
915      $org = $org ? $org : "";      $org = $org ? $org : "";
916      my $url = "$FIG_Config::cgi_url/show_kegg_map.cgi?user=$user&map=$map&org=$org";  
917        my $url = &FIG::cgi_url() . "/show_kegg_map.cgi?user=$user&map=$map&org=$org";
918      my $link = "<a href=\"$url\">$map</a>";      my $link = "<a href=\"$url\">$map</a>";
919      return $link;      return $link;
920  }  }
921    
 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;  
 }  
   
922  sub java_buttons {  sub java_buttons {
923      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
924    ## ADDED BY RAE    ## ADDED BY RAE
# Line 890  Line 953 
953      return $sub_link;      return $sub_link;
954  }  }
955    
956    sub reaction_link {
957        my($reaction) = @_;
958    
959        if ($reaction =~ /^R\d+/)
960        {
961            return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?rn+$reaction\" target=reaction$$>$reaction</a>";
962        }
963        return $reaction;
964    }
965    
966    sub html_for_assignments {
967        my($fig,$user,$peg_sets) = @_;
968        my $i;
969    
970        my @vals = ();
971        my $set = 1;
972        foreach $peg_set (@$peg_sets)
973        {
974            for ($i=0; ($i < @$peg_set); $i++)
975            {
976                $peg = $peg_set->[$i];
977                push(@vals,'show=' . join("@",($set,$i+1,$peg,&FIG::abbrev($fig->org_of($peg)),"")));
978            }
979            $set++;
980        }
981    
982        $ENV{'REQUEST_METHOD'} = 'GET';
983        $ENV{'QUERY_STRING'} = join('&',('request=show_commentary',"uni=1","user=$user",@vals));
984        my $out = join("",`$FIG_Config::fig/CGI/chromosomal_clusters.cgi`);
985        $out =~ s/^.*?<form/<form/si;
986        $out =~ s/^(.*)<table.*/$1/si;
987        return $out;
988    }
989    
990  1  1

Legend:
Removed from v.1.41  
changed lines
  Added in v.1.54

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3