[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.28, Thu Jan 13 17:32:51 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 compute_html_header
13    {
14        my($additional_insert) = @_;
15        my $html_hdr_file = "./Html/html.hdr";
16        if (! -f $html_hdr_file)
17        {
18            $html_hdr_file = "$FIG_Config::fig/CGI/Html/html.hdr";
19        }
20        my @html_hdr = &FIG::file_read($html_hdr_file);
21        push( @html_hdr, "<br><a href=\"index.cgi?user=$user\">FIG search</a>\n" );
22    
23        if (@html_hdr)
24        {
25            my $insert_stuff;
26            my @ver = &FIG::file_head("$FIG_Config::fig_disk/CURRENT_RELEASE", 1);
27            my $ver = $ver[0];
28            chomp $ver;
29            if ($ver =~ /^cvs\.(\d+)$/)
30            {
31                my $d = asctime(localtime($1));
32                chomp($d);
33                $ver .=  " ($d)";
34            }
35            my $host = &FIG::get_local_hostname();
36            $insert_stuff = "SEED version <b>$ver</b> on $host";
37            if ($additional_insert)
38            {
39                $insert_stuff .= "<br>" . $additional_insert;
40            }
41    
42            for $_ (@html_hdr)
43            {
44                s,(href|img\s+src)="/FIG/,\1="$FIG_Config::cgi_base,g;
45                if ($_ eq "<!-- HEADER_INSERT -->\n")
46                {
47                    $_ = $insert_stuff;
48                }
49            }
50        }
51    
52        return @html_hdr;
53    }
54    
55  sub show_page {  sub show_page {
56      my($cgi,$html,$no_home) = @_;      my($cgi,$html,$no_home) = @_;
# Line 15  Line 60 
60      # Find the HTML header      # Find the HTML header
61      #      #
62    
     my $html_hdr_file = "./Html/html.hdr";  
     if (! -f $html_hdr_file)  
     {  
         $html_hdr_file = "$FIG_Config::fig/CGI/Html/html.hdr";  
     }  
   
63      my $html_tail_file = "./Html/html.tail";      my $html_tail_file = "./Html/html.tail";
64      if (! -f $html_tail_file)      if (! -f $html_tail_file)
65      {      {
66          $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";          $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";
67      }      }
68    
69        my @html_hdr = compute_html_header();
70    
71        my $user = $cgi->param('user') || "";
72    
73      print $cgi->header;      print $cgi->header;
74    
# Line 145  Line 187 
187      #      #
188      #  <BODY> goes after last head line      #  <BODY> goes after last head line
189      #      #
190        #  RAE: Added the javascript for the buttons immediately after body.
191        #  Note if no buttons are added we still (at the moment) add the script,
192        #  but it only adds a little text (495 characters) to the html and noone will notice!
193    
194      if ( $body_line < 0 )      if ( $body_line < 0 )
195      {      {
196            my $js=&javascript;
197          $body_line = $last_head_line + 1;          $body_line = $last_head_line + 1;
198          splice( @$html, $body_line, 0, "<BODY>\n" );          splice( @$html, $body_line, 0, "<BODY>\n$js\n" );
199      }      }
200    
201      #      #
202      #  Seed page header (if it exists) goes after <BODY>      #  Seed page header (if it exists) goes after <BODY>
203      #      #
204    
205      if ( -f $html_hdr_file )      if (@html_hdr)
206      {      {
207          splice( @$html, $body_line + 1, 0, `cat $html_hdr_file` );          splice( @$html, $body_line + 1, 0, @html_hdr );
208      }      }
209    
210      #      #
# Line 183  Line 229 
229          #  only, or every update?), I provide an alternative derivation          #  only, or every update?), I provide an alternative derivation
230          #  from $cgi_url. -- GJO          #  from $cgi_url. -- GJO
231          #          #
232            # BASE href needs to be absolute. RDO.
233          my $base_url = $FIG_Config::cgi_base;          #
234          if ( ! $base_url )                      # if cgi_base was not defined          #
235          {          $base_url = &FIG::cgi_url;
236              $base_url = $FIG_Config::cgi_url;   # get the full cgi url  #       my $base_url = $FIG_Config::cgi_base;
237              $base_url =~ s~^http://[^/]*~~;     # remove protocol and host  #       if ( ! $base_url )                      # if cgi_base was not defined
238              $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash  #       {
239          }  #           $base_url = $FIG_Config::cgi_url;   # get the full cgi url
240    #           $base_url =~ s~^http://[^/]*~~;     # remove protocol and host
241    #           $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash
242    #       }
243    
244          $base_line = $head_end_line;          $base_line = $head_end_line;
245          splice( @$html, $base_line, 0, "<BASE href=\"$base_url\">\n" );          splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );
246      }      }
247    
248      #      #
# Line 228  Line 277 
277      }      }
278    
279      #      #
280        # See if we have a site-specific tail (for disclaimers, etc).
281        #
282    
283        my $site_tail = "$FIG_Config::fig_disk/config/site_tail.html";
284        my $site_fh;
285        if (open($site_fh, "<$site_tail"))
286        {
287            push(@tail, <$site_fh>);
288            close($site_fh);
289        }
290    
291        #
292      #  Figure out where to insert The SEED tail.  Before </body>,      #  Figure out where to insert The SEED tail.  Before </body>,
293      #  or before </html>, or at end of page.      #  or before </html>, or at end of page.
294      #      #
# Line 259  Line 320 
320  }  }
321    
322  sub make_table {  sub make_table {
323      my($col_hdrs,$tab,$title,$instr) = @_;      my($col_hdrs,$tab,$title, %options ) = @_;
324      my(@tab);      my(@tab);
325    
326      push( @tab, "\n<table border>\n",      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";
327        push( @tab, "\n<table $border>\n",
328                  "\t<caption><b>$title</b></caption>\n",                  "\t<caption><b>$title</b></caption>\n",
329                  "\t<tr>\n\t\t<th>"                  "\t<tr>\n\t\t"
330                . join( "</th>\n\t\t<th>", @$col_hdrs )                . join( "\n", map { &expand($_, "th") } @$col_hdrs )
331                . "</th>\n\t</tr>\n"                . "\n\t</tr>\n"
332          );          );
333      my($i,$nowrap);      my($i);
   
     for ($i=0; ($i < @$instr) && ($instr->[$i] !~ /nowrap/); $i++) {}  
     $nowrap = ($i == @$instr) ? "" : " nowrap";  
334    
335      my $row;      my $row;
336      foreach $row (@$tab)      foreach $row (@$tab)
337      {      {
338          push( @tab, "\t<tr>\n"          push( @tab, "\t<tr>\n"
339                    . join( "\n", map { &expand($_,$nowrap) } @$row )                    . join( "\n", map { &expand($_) } @$row )
340                    . "\n\t</tr>\n"                    . "\n\t</tr>\n"
341              );              );
342      }      }
# Line 286  Line 345 
345  }  }
346    
347  sub expand {  sub expand {
348      my($x,$nowrap) = @_;      my($x, $tag) = @_;
349    
350        $tag = "td" unless $tag;
351    
352      if ($x =~ /^\@([^:]+)\:([^:]+)\:(.*)$/)      if ($x =~ /^\@([^:]+)\:(.*)$/)
353      {      {
354          return "\t\t<td$nowrap $1=\"$2\">$3</td>";          return "\t\t<$tag $1>$2</$tag>";
355      }      }
356      else      else
357      {      {
358          return "\t\t<td$nowrap>$x</td>";          return "\t\t<$tag>$x</$tag>";
359      }      }
360  }  }
361    
362    sub set_ec_links {
363        my($cgi,$x) = @_;
364        my($before,$match,$after);
365    
366        if ($x =~ /^(.*)(EC \d+\.\d+\.\d+\.\d+)(.*)/s)
367        {
368            $before = $1;
369            $match = $2;
370            $after = $3;
371            return &set_ec_links($cgi,$before) . &HTML::ec_link($match) . &set_ec_links($cgi,$after);
372        }
373        return $x;
374    }
375    
376  sub ec_link {  sub ec_link {
377      my($role) = @_;      my($role) = @_;
378    
# Line 322  Line 397 
397      return "<a href=$link>$role</a>";      return "<a href=$link>$role</a>";
398  }  }
399    
400    #
401    # Local means to eliminate the fig|org.peg from the
402    # text of the link.
403    #
404  sub fid_link {  sub fid_link {
405      my($cgi,$fid,$local,$just_url) = @_;      my($cgi,$fid,$local,$just_url) = @_;
406      my($n);      my($n);
# Line 347  Line 426 
426          my $user = $cgi->param('user');          my $user = $cgi->param('user');
427          if (! $user) { $user = "" }          if (! $user) { $user = "" }
428          my $trans = $cgi->param('translate') ? "&translate=1" : "";          my $trans = $cgi->param('translate') ? "&translate=1" : "";
429          my $link = $cgi->url() . "?prot=$fid&user=$user$trans";          my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
430          $link =~ s/[a-z_A-Z]+\.cgi\?/protein.cgi?/;          my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
431            $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
432            #
433            # Elimin the p2p part if we're in that subdir. Ugh.
434            #
435            $link =~ s,p2p/protein.cgi,protein.cgi,;
436    
437          if ($just_url)          if ($just_url)
438          {          {
439              return $link;              return $link;
# Line 475  Line 560 
560      my($cgi,$x) = @_;      my($cgi,$x) = @_;
561      my($before,$match,$after);      my($before,$match,$after);
562    
563      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)$/)      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)/s)
564        {
565            $before = $1;
566            $match = $2;
567            $after = $3;
568            return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after);
569        }
570        elsif ($x =~ /^(.*)\b([NXYZA]P_[0-9\.]+)\b(.*)/s)
571        {
572            $before = $1;
573            $match = $2;
574            $after = $3;
575            return &set_prot_links($cgi,$before) . &HTML::refseq_link($cgi,$match) . &set_prot_links($cgi,$after);
576        }
577        elsif ($x =~ /^(.*)(gi\|\d+)(.*)/s)
578      {      {
579          $before = $1;          $before = $1;
580          $match = $2;          $match = $2;
581          $after = $3;          $after = $3;
582          return &set_prot_links($cgi,$before) . &HTML::fid_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);
583      }      }
584      elsif ($x =~ /^(.*)(gi\|\d+)(.*)$/)      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
585      {      {
586          $before = $1;          $before = $1;
587          $match = $2;          $match = $2;
588          $after = $3;          $after = $3;
589          return &set_prot_links($cgi,$before) . &HTML::gi_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);
590      }      }
591      elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)$/)      elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)/s)
592      {      {
593          $before = $1;          $before = $1;
594          $match = $2;          $match = $2;
595          $after = $3;          $after = $3;
596          return &set_prot_links($cgi,$before) . &HTML::sp_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);
597      }      }
598      elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)$/)      elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)/s)
599      {      {
600          $before = $1;          $before = $1;
601          $match = $2;          $match = $2;
602          $after = $3;          $after = $3;
603          return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";          return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after);
604        }
605        elsif ($x =~ /^(.*)(kegg\|[a-z]{2,4}:[a-zA-Z_0-9]+)(.*)/s)
606        {
607            $before = $1;
608            $match = $2;
609            $after = $3;
610            return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after);
611      }      }
612      return $x;      return $x;
613  }  }
614    
615    sub refseq_link {
616        my($cgi,$id) = @_;
617    
618        if ($id =~ /^[NXYZA]P_/)
619        {
620            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id>$id</a>";
621        }
622    }
623    
624  sub gi_link {  sub gi_link {
625      my($cgi,$gi) = @_;      my($cgi,$gi) = @_;
626    
# Line 516  Line 631 
631      return $gi;      return $gi;
632  }  }
633    
634    sub uni_link {
635        my($cgi,$uni) = @_;
636    
637        if ($uni =~ /^uni\|(\S+)$/)
638        {
639            return "<a href=http://www.pir.uniprot.org/cgi-bin/upEntry?id=$1>$uni</a>";
640        }
641        return $uni;
642    }
643    
644  sub sp_link {  sub sp_link {
645      my($cgi,$sp) = @_;      my($cgi,$sp) = @_;
646    
# Line 536  Line 661 
661      return $pir;      return $pir;
662  }  }
663    
664    sub kegg_link {
665        my($cgi,$kegg) = @_;
666    
667        if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)
668        {
669            return "<a href=http://www.genome.ad.jp/dbget-bin/www_bget?$1+$2>$kegg</a>";
670        }
671        return $kegg;
672    }
673    
674    sub set_map_links {
675        my($cgi,$x) = @_;
676        my($before,$match,$after);
677    
678        my $org = ($cgi->param('org') || $cgi->param('genome') || "");
679    
680        if ($x =~ /^(.*)(MAP\d+)(.*)/s)
681        {
682            $before = $1;
683            $match = $2;
684            $after = $3;
685            return &set_map_links($cgi,$before) . &map_link($cgi,$match,$org) . &set_map_links($cgi,$after);
686        }
687        return $x;
688    }
689    
690    sub map_link {
691        my($cgi,$map,$org) = @_;
692    
693        $user = $cgi->param('user');
694        $user = $user ? $user : "";
695        $org = $org ? $org : "";
696        my $url = "$FIG_Config::cgi_url/show_kegg_map.cgi?user=$user&map=$map&org=$org";
697        my $link = "<a href=\"$url\">$map</a>";
698        return $link;
699    }
700    
701    sub javascript {
702            #### MODIFIED BY RAE TO ADD JAVA SUPPORT FOR CHECK ALL/UNCHECK ALL
703            # This routine takes three arguments, $html, $form, and $button
704            # $html is the ref to the array with the html in it
705            # $form is the name of the form. This must be added whenever start_form is called
706            # by including a -name entry. This is only used for the javascript
707            # $button is the name of the button that should be checked/unchecked.
708            #
709            # At the moment this add's four buttons:
710            # Check all, check's all
711            # Check first half will check the first 50% of the entries
712            # Check second half will check the second 50% of the entries
713            # Uncheck all will remove the checks.
714    
715            # Note that the other change is I added a -name=>'fig_checked' to the start_form
716            # field. The name is needed for the java script.
717            #
718    
719              $java_script=<<EOF;
720      <SCRIPT LANGUAGE="JavaScript">
721      <!-- Begin
722      function checkAll(field)
723      {
724       for (i = 0; i < field.length; i++)
725       field[i].checked = true ;
726      }
727    
728      function checkFirst(field)
729      {
730       for (i = 0; i < field.length/2; i++)
731       field[i].checked = true;
732      }
733    
734      function checkSecond(field)
735      {
736       for (i=Math.round(field.length/2); i < field.length; i++)
737       field[i].checked = true ;
738      }
739    
740      function uncheckAll(field)
741      {
742       for (i = 0; i < field.length; i++)
743       field[i].checked = false ;
744      }
745      //  End -->
746      </script>
747    EOF
748            return $java_script;
749    }
750    
751    sub java_buttons {
752      ## ADDED BY RAE
753      # Provides code to include check all/first half/second half/none for javascrspt
754      # this takes two variables - the form name provided in start_form with the
755      # -name => field and the checkbox name
756      my ($form, $button)=@_;
757    
758      $java_script="<input type=\"button\" name=\"CheckAll\" value=\"Check All\"\nonClick=\"checkAll(document.$form.$button)\">\n";
759      $java_script.="<input type=\"button\" name=\"CheckFirst\" value=\"Check First Half\"\nonClick=\"checkFirst(document.$form.$button)\">\n";
760      $java_script.="<input type=\"button\" name=\"CheckSecond\" value=\"Check Second Half\"\nonClick=\"checkSecond(document.$form.$button)\">\n";
761      $java_script.="<input type=\"button\" name=\"UnCheckAll\" value=\"Uncheck All\"\nonClick=\"uncheckAll(document.$form.$button)\">\n";
762    
763      return $java_script;
764    }
765    
766    sub sub_link {
767        my($cgi,$sub) = @_;
768        my($sub_link);
769    
770        my $user = $cgi->param('user');
771        if ($user)
772        {
773            $sub_link = "<a href=./subsys.cgi?ssa_name=$sub&request=show_ssa&user=$user>$sub</a>";
774        }
775        else
776        {
777            $sub_link = $sub;
778        }
779        return $sub_link;
780    }
781    
782  1  1

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3