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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3