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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3