[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.14, Sat Jun 26 14:27:01 2004 UTC revision 1.41, Thu Apr 28 20:56:37 2005 UTC
# Line 1  Line 1 
1  package HTML;  package HTML;
2    
3    use FIG;
4  use Carp;  use Carp;
5  use Data::Dumper;  use Data::Dumper;
6  use LWP::UserAgent;  use LWP::UserAgent;
7  use LWP::Simple;  use LWP::Simple;
8    use URI::Escape;  # uri_escape()
9  use URI::URL;  use URI::URL;
10  use HTTP::Request::Common;  use HTTP::Request::Common;
11    use POSIX;
12    
13  sub show_page {  sub new
14      my($cgi,$html,$no_home) = @_;  {
15      my $i;      my($class) = @_;
16    
17      #      my $self = {};
18      # Find the HTML header  
19      #      return bless $self, $class;
20    }
21    
22    sub compute_html_header
23    {
24        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
25        my($additional_insert,$user) = @_;
26      my $html_hdr_file = "./Html/html.hdr";      my $html_hdr_file = "./Html/html.hdr";
27      if (! -f $html_hdr_file)      if (! -f $html_hdr_file)
28      {      {
29          $html_hdr_file = "$FIG_Config::fig/CGI/Html/html.hdr";          $html_hdr_file = "$FIG_Config::fig/CGI/Html/html.hdr";
30      }      }
31        my @html_hdr = &FIG::file_read($html_hdr_file);
32        push( @html_hdr, "<br><a href=\"index.cgi?user=$user\">FIG search</a>\n" );
33    
34        if (@html_hdr)
35        {
36            my $insert_stuff;
37            my @ver = &FIG::file_head("$FIG_Config::fig_disk/CURRENT_RELEASE", 1);
38            my $ver = $ver[0];
39            chomp $ver;
40            if ($ver =~ /^cvs\.(\d+)$/)
41            {
42                my $d = asctime(localtime($1));
43                chomp($d);
44                $ver .=  " ($d)";
45            }
46            my $host = &FIG::get_local_hostname();
47            $insert_stuff = "SEED version <b>$ver</b> on $host";
48            if ($additional_insert)
49            {
50                $insert_stuff .= "<br>" . $additional_insert;
51            }
52    
53            for $_ (@html_hdr)
54            {
55                s,(href|img\s+src)="/FIG/,\1="$FIG_Config::cgi_base,g;
56                if ($_ eq "<!-- HEADER_INSERT -->\n")
57                {
58                    $_ = $insert_stuff;
59                }
60            }
61        }
62    
63        return @html_hdr;
64    }
65    
66    sub show_page {
67        #warn "SHOWPAGE: cgi=", Dumper(@_);
68        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
69        my($cgi,$html,$no_home, $alt_header, $css, $javasrc) = @_;
70        my $i;
71    
72    
73        # ARGUMENTS:
74        #     $cgi is the CGI method
75        #     $html is an array with all the html in it. It is just joined by "\n" (and not <br> or <p>
76        #     $no_home eliminates ONLY the bottom FIG search link in a page
77        #     $alt_header is a reference to an array for an alternate header banner that you can replace the standard one with
78        #     $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
79        #               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
80        #               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
81        #     $javasrc is a reference to an array of URLs to javascripts to be included (e.g. "/FIG/Html/css/styleswitcher.js")
82        #
83        # Find the HTML header
84        #
85    
86      my $html_tail_file = "./Html/html.tail";      my $html_tail_file = "./Html/html.tail";
87      if (! -f $html_tail_file)      if (! -f $html_tail_file)
# Line 27  Line 89 
89          $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";          $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";
90      }      }
91    
92        my $user = $cgi->param('user') || "";
93        my @html_hdr;
94        if ($alt_header && ref($alt_header) eq "ARRAY")
95        {
96           @html_hdr = @$alt_header;
97        }
98        else
99        {
100            @html_hdr = compute_html_header(undef,$user);
101        }
102    
103    
104      print $cgi->header;      print $cgi->header;
105    
# Line 145  Line 218 
218      #      #
219      #  <BODY> goes after last head line      #  <BODY> goes after last head line
220      #      #
221        #  RAE:
222        #  Added the javascript for the buttons immediately after body.
223        #  Note if no buttons are added we still (at the moment) add the script,
224        #  but it only adds a little text (495 characters) to the html and noone will notice!
225    
226      if ( $body_line < 0 )      if ( $body_line < 0 )
227      {      {
228            my $js=&javascript;
229          $body_line = $last_head_line + 1;          $body_line = $last_head_line + 1;
230          splice( @$html, $body_line, 0, "<BODY>\n" );          splice( @$html, $body_line, 0, "<BODY>\n$js\n" );
231      }      }
232    
233      #      #
234      #  Seed page header (if it exists) goes after <BODY>      #  Seed page header (if it exists) goes after <BODY>
235      #      #
236    
237      if ( -f $html_hdr_file )      if (@html_hdr)
238      {      {
239          splice( @$html, $body_line + 1, 0, `cat $html_hdr_file` );          splice( @$html, $body_line + 1, 0, @html_hdr );
240      }      }
241    
242      #      #
# Line 171  Line 249 
249          splice( @$html, $body_line, 0, "</HEAD>\n" );          splice( @$html, $body_line, 0, "</HEAD>\n" );
250      }      }
251    
252        # RAE:
253        # Add css here
254        # Note that at the moment I define these two sheets here. I think this should
255        # be moved out, but I want to try it and see what happens.  css has the format:
256        #
257        # <link rel='stylesheet' title='default' href='/css/default.css' type='text/css'>
258    
259        # convert the default key to the right case. and eliminate dups
260        foreach my $k (keys %$css) {if (lc($k) eq "default") {$css->{'Default'}=$css->{$k}}}
261    
262        if (!$css || !$css->{'Default'})
263        {
264           $css->{'Default'}="/FIG/Html/css/default.css";
265        }
266        if (!$css->{"Sans Serif"})
267        {
268           $css->{'Sans Serif'}="/FIG/Html/css/sanserif.css";
269        }
270        my $csstext = "<link rel='stylesheet' title='default' href='".$css->{'Default'}."' type='text/css'>\n";
271        $csstext   .= "<link rel='alternate stylesheet' title='Sans Serif' href='".$css->{'Sans Serif'}."' type='text/css'>\n";
272    
273        foreach my $k (keys %$css)
274        {
275           next if (lc($k) eq "default" || lc($k) eq "sans serif");
276           $csstext .= "<link rel='alternate stylesheet' title='$k' href='".$css->{$k}."' type='text/css'>\n";
277        }
278    
279    
280        # RAE: also added support for external javascripts here.
281        # we are cluttering the HTML code with all the javascripts when they could easily be in external files
282        # this solution allows us to source other files
283    
284        # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts
285        if ($javasrc && ref($javasrc) eq "ARRAY") {
286         foreach my $script (@$javasrc) {
287          $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";
288         }
289        }
290    
291    
292    
293        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.
294    
295      #      #
296      #  <BASE ...> goes before </HEAD>      #  <BASE ...> goes before </HEAD>
297      #      #
# Line 231  Line 352 
352      }      }
353    
354      #      #
355        # See if we have a site-specific tail (for disclaimers, etc).
356        #
357    
358        my $site_tail = "$FIG_Config::fig_disk/config/site_tail.html";
359        my $site_fh;
360        if (open($site_fh, "<$site_tail"))
361        {
362            push(@tail, <$site_fh>);
363            close($site_fh);
364        }
365    
366        #
367      #  Figure out where to insert The SEED tail.  Before </body>,      #  Figure out where to insert The SEED tail.  Before </body>,
368      #  or before </html>, or at end of page.      #  or before </html>, or at end of page.
369      #      #
# Line 258  Line 391 
391          splice( @$html, $i, 0, @tags );          splice( @$html, $i, 0, @tags );
392      }      }
393    
394        # RAE the chomp will return any new lines at the ends of elements in the array,
395        # and then we can join  with a "\n". This is because somethings put newlines in,
396        # and others don't. This should make nicer looking html
397        #
398        # chomp(@$html);
399        # print join "\n", @$html;
400        #
401        # Apparently the above still breaks things. This is the correct code:
402    
403      print @$html;      print @$html;
404  }  }
405    
406  sub make_table {  sub make_table {
407      my($col_hdrs,$tab,$title) = @_;      my($col_hdrs,$tab,$title, %options ) = @_;
408      my(@tab);      my(@tab);
409    
410      push( @tab, "\n<table border>\n",      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";
411        push( @tab, "\n<table $border>\n",
412                  "\t<caption><b>$title</b></caption>\n",                  "\t<caption><b>$title</b></caption>\n",
413                  "\t<tr>\n\t\t<th>"                  "\t<tr>\n\t\t"
414                . join( "</th>\n\t\t<th>", @$col_hdrs )                . join( "\n", map { &expand($_, "th") } @$col_hdrs )
415                . "</th>\n\t</tr>\n"                . "\n\t</tr>\n"
416          );          );
417      my($i);      my($i);
418    
# Line 286  Line 429 
429  }  }
430    
431  sub expand {  sub expand {
432      my($x) = @_;      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
433        my( $x, $tag ) = @_;
434    
435        $tag = "td" unless $tag;
436        my $endtag = $tag;
437    
438        # RAE modified this so that you can pass in a reference to an array where
439        # the first element is the data to display and the second element is optional
440        # things like colspan and align. Note that in this case you need to include the td
441        # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]
442    
443        if ( ref($x) eq "ARRAY" ) { ($x, $tag) = @$x; if ($tag =~ /td/) { $endtag = "td" } }
444    
445      if ($x =~ /^\@([^:]+)\:(.*)$/)      if ($x =~ /^\@([^:]+)\:(.*)$/)
446      {      {
447          return "\t\t<td $1>$2</td>";          return "\t\t<$tag $1>$2</$endtag>";
448      }      }
449      else      else
450      {      {
451          return "\t\t<td>$x</td>";          return "\t\t<$tag>$x</$endtag>";
452      }      }
453  }  }
454    
455  sub set_ec_links {  sub set_ec_links {
456        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
457      my($cgi,$x) = @_;      my($cgi,$x) = @_;
458      my($before,$match,$after);      my($before,$match,$after);
459    
# Line 313  Line 468 
468  }  }
469    
470  sub ec_link {  sub ec_link {
471        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
472      my($role) = @_;      my($role) = @_;
473    
474      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)
# Line 326  Line 482 
482  }  }
483    
484  sub role_link {  sub role_link {
485        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
486      my($cgi,$role) = @_;      my($cgi,$role) = @_;
487    
488      my $roleR = ($role =~ /^(\d+\.\d+\.\d+\.\d+)\s+-\s+/) ? $1 : $role;      my $roleR = ($role =~ /^(\d+\.\d+\.\d+\.\d+)\s+-\s+/) ? $1 : $role;
# Line 341  Line 498 
498  # text of the link.  # text of the link.
499  #  #
500  sub fid_link {  sub fid_link {
501        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
502      my($cgi,$fid,$local,$just_url) = @_;      my($cgi,$fid,$local,$just_url) = @_;
503      my($n);      my($n);
504    
# Line 365  Line 523 
523          my $user = $cgi->param('user');          my $user = $cgi->param('user');
524          if (! $user) { $user = "" }          if (! $user) { $user = "" }
525          my $trans = $cgi->param('translate') ? "&translate=1" : "";          my $trans = $cgi->param('translate') ? "&translate=1" : "";
526          my $link = $cgi->url() . "?prot=$fid&user=$user$trans";          my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
527            my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
528          $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;          $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
529            #
530            # Elimin the p2p part if we're in that subdir. Ugh.
531            #
532            $link =~ s,p2p/protein.cgi,protein.cgi,;
533    
534          if ($just_url)          if ($just_url)
535          {          {
536              return $link;              return $link;
# Line 380  Line 544 
544  }  }
545    
546  sub family_link {  sub family_link {
547        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
548      my($family,$user) = @_;      my($family,$user) = @_;
549    
550      return $family;      return $family;
551  }  }
552    
 use URI::Escape;  
553    
554  sub get_html {  sub get_html {
555        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
556      my( $url, $type, $kv_pairs) = @_;      my( $url, $type, $kv_pairs) = @_;
557      my( $encoded, $ua, $args, @args, $out, @output, $x );      my( $encoded, $ua, $args, @args, $out, @output, $x );
558    
559      $ua = new LWP::UserAgent;      $ua = new LWP::UserAgent;
560      $ua->timeout( 900 );      $ua->timeout( 900 );
   
561      if ($type =~/post/i)      if ($type =~/post/i)
562      {      {
563          $args = [];          $args = [];
# Line 453  Line 617 
617  }  }
618    
619  sub trim_output {  sub trim_output {
620        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
621      my($out) = @_;      my($out) = @_;
622      my $i;      my $i;
623    
# Line 490  Line 655 
655  }  }
656    
657  sub set_prot_links {  sub set_prot_links {
658        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
659      my($cgi,$x) = @_;      my($cgi,$x) = @_;
660      my($before,$match,$after);      my($before,$match,$after);
661    
# Line 500  Line 666 
666          $after = $3;          $after = $3;
667          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);
668      }      }
669        elsif ($x =~ /^(.*)\b([NXYZA]P_[0-9\.]+)\b(.*)/s)
670        {
671            $before = $1;
672            $match = $2;
673            $after = $3;
674            return &set_prot_links($cgi,$before) . &HTML::refseq_link($cgi,$match) . &set_prot_links($cgi,$after);
675        }
676      elsif ($x =~ /^(.*)(gi\|\d+)(.*)/s)      elsif ($x =~ /^(.*)(gi\|\d+)(.*)/s)
677      {      {
678          $before = $1;          $before = $1;
# Line 538  Line 711 
711      return $x;      return $x;
712  }  }
713    
714    sub refseq_link {
715        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
716        my($cgi,$id) = @_;
717    
718        if ($id =~ /^[NXYZA]P_/)
719        {
720            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id>$id</a>";
721        }
722    }
723    
724  sub gi_link {  sub gi_link {
725        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
726      my($cgi,$gi) = @_;      my($cgi,$gi) = @_;
727    
728      if ($gi =~ /^gi\|(\d+)$/)      if ($gi =~ /^gi\|(\d+)$/)
# Line 549  Line 733 
733  }  }
734    
735  sub uni_link {  sub uni_link {
736        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
737      my($cgi,$uni) = @_;      my($cgi,$uni) = @_;
738    
739      if ($uni =~ /^uni\|(\S+)$/)      if ($uni =~ /^uni\|(\S+)$/)
# Line 559  Line 744 
744  }  }
745    
746  sub sp_link {  sub sp_link {
747        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
748      my($cgi,$sp) = @_;      my($cgi,$sp) = @_;
749    
750      if ($sp =~ /^sp\|(\S+)$/)      if ($sp =~ /^sp\|(\S+)$/)
# Line 569  Line 755 
755  }  }
756    
757  sub pir_link {  sub pir_link {
758        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
759      my($cgi,$pir) = @_;      my($cgi,$pir) = @_;
760    
761      if ($pir =~ /^pirnr\|(NF\d+)$/)      if ($pir =~ /^pirnr\|(NF\d+)$/)
# Line 579  Line 766 
766  }  }
767    
768  sub kegg_link {  sub kegg_link {
769        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
770      my($cgi,$kegg) = @_;      my($cgi,$kegg) = @_;
771    
772      if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)      if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)
# Line 589  Line 777 
777  }  }
778    
779  sub set_map_links {  sub set_map_links {
780        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
781      my($cgi,$x) = @_;      my($cgi,$x) = @_;
782      my($before,$match,$after);      my($before,$match,$after);
783    
# Line 605  Line 794 
794  }  }
795    
796  sub map_link {  sub map_link {
797        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
798      my($cgi,$map,$org) = @_;      my($cgi,$map,$org) = @_;
799    
800      $user = $cgi->param('user');      $user = $cgi->param('user');
# Line 615  Line 805 
805      return $link;      return $link;
806  }  }
807    
808    sub javascript {
809        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
810            #### MODIFIED BY RAE TO ADD JAVA SUPPORT FOR CHECK ALL/UNCHECK ALL
811            # This routine takes three arguments, $html, $form, and $button
812            # $html is the ref to the array with the html in it
813            # $form is the name of the form. This must be added whenever start_form is called
814            # by including a -name entry. This is only used for the javascript
815            # $button is the name of the button that should be checked/unchecked.
816            #
817            # At the moment this add's four buttons:
818            # Check all, check's all
819            # Check first half will check the first 50% of the entries
820            # Check second half will check the second 50% of the entries
821            # Uncheck all will remove the checks.
822    
823            # Note that the other change is I added a -name=>'fig_checked' to the start_form
824            # field. The name is needed for the java script.
825            #
826    
827              $java_script=<<EOF;
828      <SCRIPT LANGUAGE="JavaScript">
829      <!-- Begin
830      function checkAll(field)
831      {
832       for (i = 0; i < field.length; i++)
833       field[i].checked = true ;
834      }
835    
836      function checkFirst(field)
837      {
838       for (i = 0; i < field.length/2; i++)
839       field[i].checked = true;
840      }
841    
842      function checkSecond(field)
843      {
844       for (i=Math.round(field.length/2); i < field.length; i++)
845       field[i].checked = true ;
846      }
847    
848      function uncheckAll(field)
849      {
850       for (i = 0; i < field.length; i++)
851       field[i].checked = false ;
852      }
853      //  End -->
854      </script>
855    EOF
856            return $java_script;
857    }
858    
859    sub java_buttons {
860        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
861      ## ADDED BY RAE
862      # Provides code to include check all/first half/second half/none for javascrspt
863      # this takes two variables - the form name provided in start_form with the
864      # -name => field and the checkbox name
865      my ($form, $button)=@_;
866    
867      $java_script="<input type=\"button\" name=\"CheckAll\" value=\"Check All\"\nonClick=\"checkAll(document.$form.$button)\">\n";
868      $java_script.="<input type=\"button\" name=\"CheckFirst\" value=\"Check First Half\"\nonClick=\"checkFirst(document.$form.$button)\">\n";
869      $java_script.="<input type=\"button\" name=\"CheckSecond\" value=\"Check Second Half\"\nonClick=\"checkSecond(document.$form.$button)\">\n";
870      $java_script.="<input type=\"button\" name=\"UnCheckAll\" value=\"Uncheck All\"\nonClick=\"uncheckAll(document.$form.$button)\">\n";
871    
872      return $java_script;
873    }
874    
875    sub sub_link {
876        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
877        my($cgi,$sub) = @_;
878        my($sub_link);
879    
880        my $user = $cgi->param('user');
881        if ($user)
882        {
883            my $esc_sub = uri_escape( $sub );
884            $sub_link = "<a href=./subsys.cgi?ssa_name=$esc_sub&request=show_ssa&user=$user>$sub</a>";
885        }
886        else
887        {
888            $sub_link = $sub;
889        }
890        return $sub_link;
891    }
892    
893  1  1

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3