[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.6, Sun Mar 21 02:20:55 2004 UTC revision 1.31, Fri Feb 18 19:31:12 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::URL;  use URI::URL;
9  use HTTP::Request::Common;  use HTTP::Request::Common;
10    use POSIX;
11    
12  sub show_page {  sub new
13      my($cgi,$html,$no_home) = @_;  {
14      my $i;      my($class) = @_;
15    
16      #      my $self = {};
17      # Find the HTML header  
18      #      return bless $self, $class;
19    }
20    
21    sub compute_html_header
22    {
23        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
24        my($additional_insert) = @_;
25      my $html_hdr_file = "./Html/html.hdr";      my $html_hdr_file = "./Html/html.hdr";
26      if (! -f $html_hdr_file)      if (! -f $html_hdr_file)
27      {      {
28          $html_hdr_file = "$FIG_Config::fig/CGI/Html/html.hdr";          $html_hdr_file = "$FIG_Config::fig/CGI/Html/html.hdr";
29      }      }
30        my @html_hdr = &FIG::file_read($html_hdr_file);
31        push( @html_hdr, "<br><a href=\"index.cgi?user=$user\">FIG search</a>\n" );
32    
33        if (@html_hdr)
34        {
35            my $insert_stuff;
36            my @ver = &FIG::file_head("$FIG_Config::fig_disk/CURRENT_RELEASE", 1);
37            my $ver = $ver[0];
38            chomp $ver;
39            if ($ver =~ /^cvs\.(\d+)$/)
40            {
41                my $d = asctime(localtime($1));
42                chomp($d);
43                $ver .=  " ($d)";
44            }
45            my $host = &FIG::get_local_hostname();
46            $insert_stuff = "SEED version <b>$ver</b> on $host";
47            if ($additional_insert)
48            {
49                $insert_stuff .= "<br>" . $additional_insert;
50            }
51    
52            for $_ (@html_hdr)
53            {
54                s,(href|img\s+src)="/FIG/,\1="$FIG_Config::cgi_base,g;
55                if ($_ eq "<!-- HEADER_INSERT -->\n")
56                {
57                    $_ = $insert_stuff;
58                }
59            }
60        }
61    
62        return @html_hdr;
63    }
64    
65    sub show_page {
66        warn "SHOWPAGE: cgi=", Dumper(@_);
67        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
68        my($cgi,$html,$no_home) = @_;
69        my $i;
70    
71        #
72        # Find the HTML header
73        #
74    
75      my $html_tail_file = "./Html/html.tail";      my $html_tail_file = "./Html/html.tail";
76      if (! -f $html_tail_file)      if (! -f $html_tail_file)
# Line 27  Line 78 
78          $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";          $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";
79      }      }
80    
81        my @html_hdr = compute_html_header();
82    
83        my $user = $cgi->param('user') || "";
84    
85      print $cgi->header;      print $cgi->header;
86    
# Line 145  Line 199 
199      #      #
200      #  <BODY> goes after last head line      #  <BODY> goes after last head line
201      #      #
202        #  RAE: Added the javascript for the buttons immediately after body.
203        #  Note if no buttons are added we still (at the moment) add the script,
204        #  but it only adds a little text (495 characters) to the html and noone will notice!
205    
206      if ( $body_line < 0 )      if ( $body_line < 0 )
207      {      {
208            my $js=&javascript;
209          $body_line = $last_head_line + 1;          $body_line = $last_head_line + 1;
210          splice( @$html, $body_line, 0, "<BODY>\n" );          splice( @$html, $body_line, 0, "<BODY>\n$js\n" );
211      }      }
212    
213      #      #
214      #  Seed page header (if it exists) goes after <BODY>      #  Seed page header (if it exists) goes after <BODY>
215      #      #
216    
217      if ( -f $html_hdr_file )      if (@html_hdr)
218      {      {
219          splice( @$html, $body_line + 1, 0, `cat $html_hdr_file` );          splice( @$html, $body_line + 1, 0, @html_hdr );
220      }      }
221    
222      #      #
# Line 183  Line 241 
241          #  only, or every update?), I provide an alternative derivation          #  only, or every update?), I provide an alternative derivation
242          #  from $cgi_url. -- GJO          #  from $cgi_url. -- GJO
243          #          #
244            # BASE href needs to be absolute. RDO.
245          my $base_url = $FIG_Config::cgi_base;          #
246          if ( ! $base_url )                      # if cgi_base was not defined          #
247          {          $base_url = &FIG::cgi_url;
248              $base_url = $FIG_Config::cgi_url;   # get the full cgi url  #       my $base_url = $FIG_Config::cgi_base;
249              $base_url =~ s~^http://[^/]*~~;     # remove protocol and host  #       if ( ! $base_url )                      # if cgi_base was not defined
250              $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash  #       {
251          }  #           $base_url = $FIG_Config::cgi_url;   # get the full cgi url
252    #           $base_url =~ s~^http://[^/]*~~;     # remove protocol and host
253    #           $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash
254    #       }
255    
256          $base_line = $head_end_line;          $base_line = $head_end_line;
257          splice( @$html, $base_line, 0, "<BASE href=\"$base_url\">\n" );          splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );
258      }      }
259    
260      #      #
# Line 228  Line 289 
289      }      }
290    
291      #      #
292        # See if we have a site-specific tail (for disclaimers, etc).
293        #
294    
295        my $site_tail = "$FIG_Config::fig_disk/config/site_tail.html";
296        my $site_fh;
297        if (open($site_fh, "<$site_tail"))
298        {
299            push(@tail, <$site_fh>);
300            close($site_fh);
301        }
302    
303        #
304      #  Figure out where to insert The SEED tail.  Before </body>,      #  Figure out where to insert The SEED tail.  Before </body>,
305      #  or before </html>, or at end of page.      #  or before </html>, or at end of page.
306      #      #
# Line 259  Line 332 
332  }  }
333    
334  sub make_table {  sub make_table {
335      my($col_hdrs,$tab,$title,$instr) = @_;      my($col_hdrs,$tab,$title, %options ) = @_;
336      my(@tab);      my(@tab);
337    
338      push( @tab, "\n<table border>\n",      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";
339        push( @tab, "\n<table $border>\n",
340                  "\t<caption><b>$title</b></caption>\n",                  "\t<caption><b>$title</b></caption>\n",
341                  "\t<tr>\n\t\t<th>"                  "\t<tr>\n\t\t"
342                . join( "</th>\n\t\t<th>", @$col_hdrs )                . join( "\n", map { &expand($_, "th") } @$col_hdrs )
343                . "</th>\n\t</tr>\n"                . "\n\t</tr>\n"
344          );          );
345      my($i,$nowrap);      my($i);
   
     for ($i=0; ($i < @$instr) && ($instr->[$i] !~ /nowrap/); $i++) {}  
     $nowrap = ($i == @$instr) ? "" : " nowrap";  
346    
347      my $row;      my $row;
348      foreach $row (@$tab)      foreach $row (@$tab)
349      {      {
350          push( @tab, "\t<tr>\n"          push( @tab, "\t<tr>\n"
351                    . join( "\n", map { &expand($_,$nowrap) } @$row )                    . join( "\n", map { &expand($_) } @$row )
352                    . "\n\t</tr>\n"                    . "\n\t</tr>\n"
353              );              );
354      }      }
# Line 286  Line 357 
357  }  }
358    
359  sub expand {  sub expand {
360      my($x,$nowrap) = @_;      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
361        my($x, $tag) = @_;
362    
363      if ($x =~ /^\@([^:]+)\:([^:]+)\:(.*)$/)      $tag = "td" unless $tag;
364        my $endtag=$tag;
365        # RAE modified this so that you can pass in a reference to an array where the first element is the data to
366        # display and the second element is optional things like colspan and align. Note that in this case you need to include the td
367        # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]
368        if (ref($x) eq "ARRAY") {($x, $tag)=@$x; if ($tag =~ /td/) {$endtag = "td"}}
369    
370        if ($x =~ /^\@([^:]+)\:(.*)$/)
371      {      {
372          return "\t\t<td$nowrap $1=\"$2\">$3</td>";          return "\t\t<$tag $1>$2</$endtag>";
373      }      }
374      else      else
375      {      {
376          return "\t\t<td$nowrap>$x</td>";          return "\t\t<$tag>$x</$endtag>";
377      }      }
378  }  }
379    
380    sub set_ec_links {
381        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
382        my($cgi,$x) = @_;
383        my($before,$match,$after);
384    
385        if ($x =~ /^(.*)(EC \d+\.\d+\.\d+\.\d+)(.*)/s)
386        {
387            $before = $1;
388            $match = $2;
389            $after = $3;
390            return &set_ec_links($cgi,$before) . &HTML::ec_link($match) . &set_ec_links($cgi,$after);
391        }
392        return $x;
393    }
394    
395  sub ec_link {  sub ec_link {
396        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
397      my($role) = @_;      my($role) = @_;
398    
399      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)
# Line 312  Line 407 
407  }  }
408    
409  sub role_link {  sub role_link {
410        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
411      my($cgi,$role) = @_;      my($cgi,$role) = @_;
412    
413      my $roleR = ($role =~ /^(\d+\.\d+\.\d+\.\d+)\s+-\s+/) ? $1 : $role;      my $roleR = ($role =~ /^(\d+\.\d+\.\d+\.\d+)\s+-\s+/) ? $1 : $role;
# Line 322  Line 418 
418      return "<a href=$link>$role</a>";      return "<a href=$link>$role</a>";
419  }  }
420    
421    #
422    # Local means to eliminate the fig|org.peg from the
423    # text of the link.
424    #
425  sub fid_link {  sub fid_link {
426        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
427      my($cgi,$fid,$local,$just_url) = @_;      my($cgi,$fid,$local,$just_url) = @_;
428      my($n);      my($n);
429    
# Line 347  Line 448 
448          my $user = $cgi->param('user');          my $user = $cgi->param('user');
449          if (! $user) { $user = "" }          if (! $user) { $user = "" }
450          my $trans = $cgi->param('translate') ? "&translate=1" : "";          my $trans = $cgi->param('translate') ? "&translate=1" : "";
451          my $link = $cgi->url() . "?prot=$fid&user=$user$trans";          my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
452          $link =~ s/[a-z_A-Z]+\.cgi\?/protein.cgi?/;          my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
453            $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
454            #
455            # Elimin the p2p part if we're in that subdir. Ugh.
456            #
457            $link =~ s,p2p/protein.cgi,protein.cgi,;
458    
459          if ($just_url)          if ($just_url)
460          {          {
461              return $link;              return $link;
# Line 362  Line 469 
469  }  }
470    
471  sub family_link {  sub family_link {
472        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
473      my($family,$user) = @_;      my($family,$user) = @_;
474    
475      return $family;      return $family;
# Line 370  Line 478 
478  use URI::Escape;  use URI::Escape;
479    
480  sub get_html {  sub get_html {
481        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
482      my( $url, $type, $kv_pairs) = @_;      my( $url, $type, $kv_pairs) = @_;
483      my( $encoded, $ua, $args, @args, $out, @output, $x );      my( $encoded, $ua, $args, @args, $out, @output, $x );
484    
485      $ua = new LWP::UserAgent;      $ua = new LWP::UserAgent;
486      $ua->timeout( 900 );      $ua->timeout( 900 );
   
487      if ($type =~/post/i)      if ($type =~/post/i)
488      {      {
489          $args = [];          $args = [];
# Line 435  Line 543 
543  }  }
544    
545  sub trim_output {  sub trim_output {
546        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
547      my($out) = @_;      my($out) = @_;
548      my $i;      my $i;
549    
# Line 472  Line 581 
581  }  }
582    
583  sub set_prot_links {  sub set_prot_links {
584        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
585      my($cgi,$x) = @_;      my($cgi,$x) = @_;
586      my($before,$match,$after);      my($before,$match,$after);
587    
588      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)$/)      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)/s)
589        {
590            $before = $1;
591            $match = $2;
592            $after = $3;
593            return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after);
594        }
595        elsif ($x =~ /^(.*)\b([NXYZA]P_[0-9\.]+)\b(.*)/s)
596      {      {
597          $before = $1;          $before = $1;
598          $match = $2;          $match = $2;
599          $after = $3;          $after = $3;
600          return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";          return &set_prot_links($cgi,$before) . &HTML::refseq_link($cgi,$match) . &set_prot_links($cgi,$after);
601      }      }
602      elsif ($x =~ /^(.*)(gi\|\d+)(.*)$/)      elsif ($x =~ /^(.*)(gi\|\d+)(.*)/s)
603      {      {
604          $before = $1;          $before = $1;
605          $match = $2;          $match = $2;
606          $after = $3;          $after = $3;
607          return &set_prot_links($cgi,$before) . &HTML::gi_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";          return &set_prot_links($cgi,$before) . &HTML::gi_link($cgi,$match) . &set_prot_links($cgi,$after);
608      }      }
609      elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)$/)      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
610      {      {
611          $before = $1;          $before = $1;
612          $match = $2;          $match = $2;
613          $after = $3;          $after = $3;
614          return &set_prot_links($cgi,$before) . &HTML::sp_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";          return &set_prot_links($cgi,$before) . &HTML::uni_link($cgi,$match) . &set_prot_links($cgi,$after);
615      }      }
616      elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)$/)      elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)/s)
617      {      {
618          $before = $1;          $before = $1;
619          $match = $2;          $match = $2;
620          $after = $3;          $after = $3;
621          return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";          return &set_prot_links($cgi,$before) . &HTML::sp_link($cgi,$match) . &set_prot_links($cgi,$after);
622        }
623        elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)/s)
624        {
625            $before = $1;
626            $match = $2;
627            $after = $3;
628            return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after);
629        }
630        elsif ($x =~ /^(.*)(kegg\|[a-z]{2,4}:[a-zA-Z_0-9]+)(.*)/s)
631        {
632            $before = $1;
633            $match = $2;
634            $after = $3;
635            return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after);
636      }      }
637      return $x;      return $x;
638  }  }
639    
640    sub refseq_link {
641        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
642        my($cgi,$id) = @_;
643    
644        if ($id =~ /^[NXYZA]P_/)
645        {
646            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id>$id</a>";
647        }
648    }
649    
650  sub gi_link {  sub gi_link {
651        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
652      my($cgi,$gi) = @_;      my($cgi,$gi) = @_;
653    
654      if ($gi =~ /^gi\|(\d+)$/)      if ($gi =~ /^gi\|(\d+)$/)
# Line 516  Line 658 
658      return $gi;      return $gi;
659  }  }
660    
661    sub uni_link {
662        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
663        my($cgi,$uni) = @_;
664    
665        if ($uni =~ /^uni\|(\S+)$/)
666        {
667            return "<a href=http://www.pir.uniprot.org/cgi-bin/upEntry?id=$1>$uni</a>";
668        }
669        return $uni;
670    }
671    
672  sub sp_link {  sub sp_link {
673        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
674      my($cgi,$sp) = @_;      my($cgi,$sp) = @_;
675    
676      if ($sp =~ /^sp\|(\S+)$/)      if ($sp =~ /^sp\|(\S+)$/)
# Line 527  Line 681 
681  }  }
682    
683  sub pir_link {  sub pir_link {
684        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
685      my($cgi,$pir) = @_;      my($cgi,$pir) = @_;
686    
687      if ($pir =~ /^pirnr\|(NF\d+)$/)      if ($pir =~ /^pirnr\|(NF\d+)$/)
# Line 536  Line 691 
691      return $pir;      return $pir;
692  }  }
693    
694    sub kegg_link {
695        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
696        my($cgi,$kegg) = @_;
697    
698        if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)
699        {
700            return "<a href=http://www.genome.ad.jp/dbget-bin/www_bget?$1+$2>$kegg</a>";
701        }
702        return $kegg;
703    }
704    
705    sub set_map_links {
706        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
707        my($cgi,$x) = @_;
708        my($before,$match,$after);
709    
710        my $org = ($cgi->param('org') || $cgi->param('genome') || "");
711    
712        if ($x =~ /^(.*)(MAP\d+)(.*)/s)
713        {
714            $before = $1;
715            $match = $2;
716            $after = $3;
717            return &set_map_links($cgi,$before) . &map_link($cgi,$match,$org) . &set_map_links($cgi,$after);
718        }
719        return $x;
720    }
721    
722    sub map_link {
723        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
724        my($cgi,$map,$org) = @_;
725    
726        $user = $cgi->param('user');
727        $user = $user ? $user : "";
728        $org = $org ? $org : "";
729        my $url = "$FIG_Config::cgi_url/show_kegg_map.cgi?user=$user&map=$map&org=$org";
730        my $link = "<a href=\"$url\">$map</a>";
731        return $link;
732    }
733    
734    sub javascript {
735        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
736            #### MODIFIED BY RAE TO ADD JAVA SUPPORT FOR CHECK ALL/UNCHECK ALL
737            # This routine takes three arguments, $html, $form, and $button
738            # $html is the ref to the array with the html in it
739            # $form is the name of the form. This must be added whenever start_form is called
740            # by including a -name entry. This is only used for the javascript
741            # $button is the name of the button that should be checked/unchecked.
742            #
743            # At the moment this add's four buttons:
744            # Check all, check's all
745            # Check first half will check the first 50% of the entries
746            # Check second half will check the second 50% of the entries
747            # Uncheck all will remove the checks.
748    
749            # Note that the other change is I added a -name=>'fig_checked' to the start_form
750            # field. The name is needed for the java script.
751            #
752    
753              $java_script=<<EOF;
754      <SCRIPT LANGUAGE="JavaScript">
755      <!-- Begin
756      function checkAll(field)
757      {
758       for (i = 0; i < field.length; i++)
759       field[i].checked = true ;
760      }
761    
762      function checkFirst(field)
763      {
764       for (i = 0; i < field.length/2; i++)
765       field[i].checked = true;
766      }
767    
768      function checkSecond(field)
769      {
770       for (i=Math.round(field.length/2); i < field.length; i++)
771       field[i].checked = true ;
772      }
773    
774      function uncheckAll(field)
775      {
776       for (i = 0; i < field.length; i++)
777       field[i].checked = false ;
778      }
779      //  End -->
780      </script>
781    EOF
782            return $java_script;
783    }
784    
785    sub java_buttons {
786        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
787      ## ADDED BY RAE
788      # Provides code to include check all/first half/second half/none for javascrspt
789      # this takes two variables - the form name provided in start_form with the
790      # -name => field and the checkbox name
791      my ($form, $button)=@_;
792    
793      $java_script="<input type=\"button\" name=\"CheckAll\" value=\"Check All\"\nonClick=\"checkAll(document.$form.$button)\">\n";
794      $java_script.="<input type=\"button\" name=\"CheckFirst\" value=\"Check First Half\"\nonClick=\"checkFirst(document.$form.$button)\">\n";
795      $java_script.="<input type=\"button\" name=\"CheckSecond\" value=\"Check Second Half\"\nonClick=\"checkSecond(document.$form.$button)\">\n";
796      $java_script.="<input type=\"button\" name=\"UnCheckAll\" value=\"Uncheck All\"\nonClick=\"uncheckAll(document.$form.$button)\">\n";
797    
798      return $java_script;
799    }
800    
801    sub sub_link {
802        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
803        my($cgi,$sub) = @_;
804        my($sub_link);
805    
806        my $user = $cgi->param('user');
807        if ($user)
808        {
809            $sub_link = "<a href=./subsys.cgi?ssa_name=$sub&request=show_ssa&user=$user>$sub</a>";
810        }
811        else
812        {
813            $sub_link = $sub;
814        }
815        return $sub_link;
816    }
817    
818  1  1

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.31

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3