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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3