[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.26, Fri Dec 17 21:32:57 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($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<th>"
330                . join( "</th>\n\t\t<th>", @$col_hdrs )                . join( "</th>\n\t\t<th>", @$col_hdrs )
331                . "</th>\n\t</tr>\n"                . "</th>\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) = @_;
349    
350      if ($x =~ /^\@([^:]+)\:([^:]+)\:(.*)$/)      if ($x =~ /^\@([^:]+)\:(.*)$/)
351      {      {
352          return "\t\t<td$nowrap $1=\"$2\">$3</td>";          return "\t\t<td $1>$2</td>";
353      }      }
354      else      else
355      {      {
356          return "\t\t<td$nowrap>$x</td>";          return "\t\t<td>$x</td>";
357      }      }
358  }  }
359    
360    sub set_ec_links {
361        my($cgi,$x) = @_;
362        my($before,$match,$after);
363    
364        if ($x =~ /^(.*)(EC \d+\.\d+\.\d+\.\d+)(.*)/s)
365        {
366            $before = $1;
367            $match = $2;
368            $after = $3;
369            return &set_ec_links($cgi,$before) . &HTML::ec_link($match) . &set_ec_links($cgi,$after);
370        }
371        return $x;
372    }
373    
374  sub ec_link {  sub ec_link {
375      my($role) = @_;      my($role) = @_;
376    
# Line 322  Line 395 
395      return "<a href=$link>$role</a>";      return "<a href=$link>$role</a>";
396  }  }
397    
398    #
399    # Local means to eliminate the fig|org.peg from the
400    # text of the link.
401    #
402  sub fid_link {  sub fid_link {
403      my($cgi,$fid,$local,$just_url) = @_;      my($cgi,$fid,$local,$just_url) = @_;
404      my($n);      my($n);
# Line 347  Line 424 
424          my $user = $cgi->param('user');          my $user = $cgi->param('user');
425          if (! $user) { $user = "" }          if (! $user) { $user = "" }
426          my $trans = $cgi->param('translate') ? "&translate=1" : "";          my $trans = $cgi->param('translate') ? "&translate=1" : "";
427          my $link = $cgi->url() . "?prot=$fid&user=$user$trans";          my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans";
428          $link =~ s/[a-z_A-Z]+\.cgi\?/protein.cgi?/;          $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
429            #
430            # Elimin the p2p part if we're in that subdir. Ugh.
431            #
432            $link =~ s,p2p/protein.cgi,protein.cgi,;
433    
434          if ($just_url)          if ($just_url)
435          {          {
436              return $link;              return $link;
# Line 475  Line 557 
557      my($cgi,$x) = @_;      my($cgi,$x) = @_;
558      my($before,$match,$after);      my($before,$match,$after);
559    
560      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)$/)      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)/s)
561        {
562            $before = $1;
563            $match = $2;
564            $after = $3;
565            return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after);
566        }
567        elsif ($x =~ /^(.*)\b([NXYZA]P_[0-9\.]+)\b(.*)/s)
568        {
569            $before = $1;
570            $match = $2;
571            $after = $3;
572            return &set_prot_links($cgi,$before) . &HTML::refseq_link($cgi,$match) . &set_prot_links($cgi,$after);
573        }
574        elsif ($x =~ /^(.*)(gi\|\d+)(.*)/s)
575      {      {
576          $before = $1;          $before = $1;
577          $match = $2;          $match = $2;
578          $after = $3;          $after = $3;
579          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);
580      }      }
581      elsif ($x =~ /^(.*)(gi\|\d+)(.*)$/)      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
582      {      {
583          $before = $1;          $before = $1;
584          $match = $2;          $match = $2;
585          $after = $3;          $after = $3;
586          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);
587      }      }
588      elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)$/)      elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)/s)
589      {      {
590          $before = $1;          $before = $1;
591          $match = $2;          $match = $2;
592          $after = $3;          $after = $3;
593          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);
594      }      }
595      elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)$/)      elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)/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::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);
601        }
602        elsif ($x =~ /^(.*)(kegg\|[a-z]{2,4}:[a-zA-Z_0-9]+)(.*)/s)
603        {
604            $before = $1;
605            $match = $2;
606            $after = $3;
607            return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after);
608      }      }
609      return $x;      return $x;
610  }  }
611    
612    sub refseq_link {
613        my($cgi,$id) = @_;
614    
615        if ($id =~ /^[NXYZA]P_/)
616        {
617            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id>$id</a>";
618        }
619    }
620    
621  sub gi_link {  sub gi_link {
622      my($cgi,$gi) = @_;      my($cgi,$gi) = @_;
623    
# Line 516  Line 628 
628      return $gi;      return $gi;
629  }  }
630    
631    sub uni_link {
632        my($cgi,$uni) = @_;
633    
634        if ($uni =~ /^uni\|(\S+)$/)
635        {
636            return "<a href=http://www.pir.uniprot.org/cgi-bin/upEntry?id=$1>$uni</a>";
637        }
638        return $uni;
639    }
640    
641  sub sp_link {  sub sp_link {
642      my($cgi,$sp) = @_;      my($cgi,$sp) = @_;
643    
# Line 536  Line 658 
658      return $pir;      return $pir;
659  }  }
660    
661    sub kegg_link {
662        my($cgi,$kegg) = @_;
663    
664        if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)
665        {
666            return "<a href=http://www.genome.ad.jp/dbget-bin/www_bget?$1+$2>$kegg</a>";
667        }
668        return $kegg;
669    }
670    
671    sub set_map_links {
672        my($cgi,$x) = @_;
673        my($before,$match,$after);
674    
675        my $org = ($cgi->param('org') || $cgi->param('genome') || "");
676    
677        if ($x =~ /^(.*)(MAP\d+)(.*)/s)
678        {
679            $before = $1;
680            $match = $2;
681            $after = $3;
682            return &set_map_links($cgi,$before) . &map_link($cgi,$match,$org) . &set_map_links($cgi,$after);
683        }
684        return $x;
685    }
686    
687    sub map_link {
688        my($cgi,$map,$org) = @_;
689    
690        $user = $cgi->param('user');
691        $user = $user ? $user : "";
692        $org = $org ? $org : "";
693        my $url = "$FIG_Config::cgi_url/show_kegg_map.cgi?user=$user&map=$map&org=$org";
694        my $link = "<a href=\"$url\">$map</a>";
695        return $link;
696    }
697    
698    sub javascript {
699            #### MODIFIED BY RAE TO ADD JAVA SUPPORT FOR CHECK ALL/UNCHECK ALL
700            # This routine takes three arguments, $html, $form, and $button
701            # $html is the ref to the array with the html in it
702            # $form is the name of the form. This must be added whenever start_form is called
703            # by including a -name entry. This is only used for the javascript
704            # $button is the name of the button that should be checked/unchecked.
705            #
706            # At the moment this add's four buttons:
707            # Check all, check's all
708            # Check first half will check the first 50% of the entries
709            # Check second half will check the second 50% of the entries
710            # Uncheck all will remove the checks.
711    
712            # Note that the other change is I added a -name=>'fig_checked' to the start_form
713            # field. The name is needed for the java script.
714            #
715    
716              $java_script=<<EOF;
717      <SCRIPT LANGUAGE="JavaScript">
718      <!-- Begin
719      function checkAll(field)
720      {
721       for (i = 0; i < field.length; i++)
722       field[i].checked = true ;
723      }
724    
725      function checkFirst(field)
726      {
727       for (i = 0; i < field.length/2; i++)
728       field[i].checked = true;
729      }
730    
731      function checkSecond(field)
732      {
733       for (i=Math.round(field.length/2); i < field.length; i++)
734       field[i].checked = true ;
735      }
736    
737      function uncheckAll(field)
738      {
739       for (i = 0; i < field.length; i++)
740       field[i].checked = false ;
741      }
742      //  End -->
743      </script>
744    EOF
745            return $java_script;
746    }
747    
748    sub java_buttons {
749      ## ADDED BY RAE
750      # Provides code to include check all/first half/second half/none for javascrspt
751      # this takes two variables - the form name provided in start_form with the
752      # -name => field and the checkbox name
753      my ($form, $button)=@_;
754    
755      $java_script="<input type=\"button\" name=\"CheckAll\" value=\"Check All\"\nonClick=\"checkAll(document.$form.$button)\">\n";
756      $java_script.="<input type=\"button\" name=\"CheckFirst\" value=\"Check First Half\"\nonClick=\"checkFirst(document.$form.$button)\">\n";
757      $java_script.="<input type=\"button\" name=\"CheckSecond\" value=\"Check Second Half\"\nonClick=\"checkSecond(document.$form.$button)\">\n";
758      $java_script.="<input type=\"button\" name=\"UnCheckAll\" value=\"Uncheck All\"\nonClick=\"uncheckAll(document.$form.$button)\">\n";
759    
760      return $java_script;
761    }
762    
763    sub sub_link {
764        my($cgi,$sub) = @_;
765        my($sub_link);
766    
767        my $user = $cgi->param('user');
768        if ($user)
769        {
770            $sub_link = "<a href=./subsys.cgi?ssa_name=$sub&request=show_ssa&user=$user>$sub</a>";
771        }
772        else
773        {
774            $sub_link = $sub;
775        }
776        return $sub_link;
777    }
778    
779  1  1

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3