[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.20, Mon Aug 23 21:46:44 2004 UTC
# Line 6  Line 6 
6  use LWP::Simple;  use LWP::Simple;
7  use URI::URL;  use URI::URL;
8  use HTTP::Request::Common;  use HTTP::Request::Common;
9    use POSIX;
10    
11  sub show_page {  sub show_page {
12      my($cgi,$html,$no_home) = @_;      my($cgi,$html,$no_home) = @_;
# Line 27  Line 28 
28          $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";          $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";
29      }      }
30    
31        my @html_hdr = &FIG::file_read($html_hdr_file);
32        my $user = $cgi->param('user') || "";
33        push( @html_hdr, "<br><a href=\"index.cgi?user=$user\">FIG search</a>\n" );
34    
35        if (@html_hdr)
36        {
37            my $insert_stuff;
38            my @ver = &FIG::file_head("$FIG_Config::fig_disk/CURRENT_RELEASE", 1);
39            my $ver = $ver[0];
40            chomp $ver;
41            if ($ver =~ /^cvs\.(\d+)$/)
42            {
43                my $d = asctime(localtime($1));
44                chomp($d);
45                $ver .=  " ($d)";
46            }
47            my $host = &FIG::get_local_hostname();
48            $insert_stuff = "SEED version <b>$ver</b> on $host";
49    
50            for $_ (@html_hdr)
51            {
52                s,(href|img\s+src)="/FIG/,\1="$FIG_Config::cgi_base,g;
53                if ($_ eq "<!-- HEADER_INSERT -->\n")
54                {
55                    $_ = $insert_stuff;
56                }
57            }
58        }
59    
60    
61      print $cgi->header;      print $cgi->header;
62    
# Line 145  Line 175 
175      #      #
176      #  <BODY> goes after last head line      #  <BODY> goes after last head line
177      #      #
178        #  RAE: Added the javascript for the buttons immediately after body.
179        #  Note if no buttons are added we still (at the moment) add the script,
180        #  but it only adds a little text (495 characters) to the html and noone will notice!
181    
182      if ( $body_line < 0 )      if ( $body_line < 0 )
183      {      {
184            my $js=&javascript;
185          $body_line = $last_head_line + 1;          $body_line = $last_head_line + 1;
186          splice( @$html, $body_line, 0, "<BODY>\n" );          splice( @$html, $body_line, 0, "<BODY>\n$js\n" );
187      }      }
188    
189      #      #
190      #  Seed page header (if it exists) goes after <BODY>      #  Seed page header (if it exists) goes after <BODY>
191      #      #
192    
193      if ( -f $html_hdr_file )      if (@html_hdr)
194      {      {
195          splice( @$html, $body_line + 1, 0, `cat $html_hdr_file` );          splice( @$html, $body_line + 1, 0, @html_hdr );
196      }      }
197    
198      #      #
# Line 183  Line 217 
217          #  only, or every update?), I provide an alternative derivation          #  only, or every update?), I provide an alternative derivation
218          #  from $cgi_url. -- GJO          #  from $cgi_url. -- GJO
219          #          #
220            # BASE href needs to be absolute. RDO.
221          my $base_url = $FIG_Config::cgi_base;          #
222          if ( ! $base_url )                      # if cgi_base was not defined          #
223          {          $base_url = &FIG::cgi_url;
224              $base_url = $FIG_Config::cgi_url;   # get the full cgi url  #       my $base_url = $FIG_Config::cgi_base;
225              $base_url =~ s~^http://[^/]*~~;     # remove protocol and host  #       if ( ! $base_url )                      # if cgi_base was not defined
226              $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash  #       {
227          }  #           $base_url = $FIG_Config::cgi_url;   # get the full cgi url
228    #           $base_url =~ s~^http://[^/]*~~;     # remove protocol and host
229    #           $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash
230    #       }
231    
232          $base_line = $head_end_line;          $base_line = $head_end_line;
233          splice( @$html, $base_line, 0, "<BASE href=\"$base_url\">\n" );          splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );
234      }      }
235    
236      #      #
# Line 259  Line 296 
296  }  }
297    
298  sub make_table {  sub make_table {
299      my($col_hdrs,$tab,$title,$instr) = @_;      my($col_hdrs,$tab,$title, %options ) = @_;
300      my(@tab);      my(@tab);
301    
302      push( @tab, "\n<table border>\n",      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";
303        push( @tab, "\n<table $border>\n",
304                  "\t<caption><b>$title</b></caption>\n",                  "\t<caption><b>$title</b></caption>\n",
305                  "\t<tr>\n\t\t<th>"                  "\t<tr>\n\t\t<th>"
306                . join( "</th>\n\t\t<th>", @$col_hdrs )                . join( "</th>\n\t\t<th>", @$col_hdrs )
307                . "</th>\n\t</tr>\n"                . "</th>\n\t</tr>\n"
308          );          );
309      my($i,$nowrap);      my($i);
   
     for ($i=0; ($i < @$instr) && ($instr->[$i] !~ /nowrap/); $i++) {}  
     $nowrap = ($i == @$instr) ? "" : " nowrap";  
310    
311      my $row;      my $row;
312      foreach $row (@$tab)      foreach $row (@$tab)
313      {      {
314          push( @tab, "\t<tr>\n"          push( @tab, "\t<tr>\n"
315                    . join( "\n", map { &expand($_,$nowrap) } @$row )                    . join( "\n", map { &expand($_) } @$row )
316                    . "\n\t</tr>\n"                    . "\n\t</tr>\n"
317              );              );
318      }      }
# Line 286  Line 321 
321  }  }
322    
323  sub expand {  sub expand {
324      my($x,$nowrap) = @_;      my($x) = @_;
325    
326      if ($x =~ /^\@([^:]+)\:([^:]+)\:(.*)$/)      if ($x =~ /^\@([^:]+)\:(.*)$/)
327      {      {
328          return "\t\t<td$nowrap $1=\"$2\">$3</td>";          return "\t\t<td $1>$2</td>";
329      }      }
330      else      else
331      {      {
332          return "\t\t<td$nowrap>$x</td>";          return "\t\t<td>$x</td>";
333        }
334    }
335    
336    sub set_ec_links {
337        my($cgi,$x) = @_;
338        my($before,$match,$after);
339    
340        if ($x =~ /^(.*)(EC \d+\.\d+\.\d+\.\d+)(.*)/s)
341        {
342            $before = $1;
343            $match = $2;
344            $after = $3;
345            return &set_ec_links($cgi,$before) . &HTML::ec_link($match) . &set_ec_links($cgi,$after);
346      }      }
347        return $x;
348  }  }
349    
350  sub ec_link {  sub ec_link {
# Line 322  Line 371 
371      return "<a href=$link>$role</a>";      return "<a href=$link>$role</a>";
372  }  }
373    
374    #
375    # Local means to eliminate the fig|org.peg from the
376    # text of the link.
377    #
378  sub fid_link {  sub fid_link {
379      my($cgi,$fid,$local,$just_url) = @_;      my($cgi,$fid,$local,$just_url) = @_;
380      my($n);      my($n);
# Line 348  Line 401 
401          if (! $user) { $user = "" }          if (! $user) { $user = "" }
402          my $trans = $cgi->param('translate') ? "&translate=1" : "";          my $trans = $cgi->param('translate') ? "&translate=1" : "";
403          my $link = $cgi->url() . "?prot=$fid&user=$user$trans";          my $link = $cgi->url() . "?prot=$fid&user=$user$trans";
404          $link =~ s/[a-z_A-Z]+\.cgi\?/protein.cgi?/;          $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
405            #
406            # Elimin the p2p part if we're in that subdir. Ugh.
407            #
408            $link =~ s,p2p/protein.cgi,protein.cgi,;
409    
410          if ($just_url)          if ($just_url)
411          {          {
412              return $link;              return $link;
# Line 475  Line 533 
533      my($cgi,$x) = @_;      my($cgi,$x) = @_;
534      my($before,$match,$after);      my($before,$match,$after);
535    
536      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)$/)      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)/s)
537      {      {
538          $before = $1;          $before = $1;
539          $match = $2;          $match = $2;
540          $after = $3;          $after = $3;
541          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);
542      }      }
543      elsif ($x =~ /^(.*)(gi\|\d+)(.*)$/)      elsif ($x =~ /^(.*)\b([NXYZA]P_[0-9\.]+)\b(.*)/s)
544      {      {
545          $before = $1;          $before = $1;
546          $match = $2;          $match = $2;
547          $after = $3;          $after = $3;
548          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);
549      }      }
550      elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)$/)      elsif ($x =~ /^(.*)(gi\|\d+)(.*)/s)
551      {      {
552          $before = $1;          $before = $1;
553          $match = $2;          $match = $2;
554          $after = $3;          $after = $3;
555          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);
556      }      }
557      elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)$/)      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
558      {      {
559          $before = $1;          $before = $1;
560          $match = $2;          $match = $2;
561          $after = $3;          $after = $3;
562          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);
563        }
564        elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)/s)
565        {
566            $before = $1;
567            $match = $2;
568            $after = $3;
569            return &set_prot_links($cgi,$before) . &HTML::sp_link($cgi,$match) . &set_prot_links($cgi,$after);
570        }
571        elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)/s)
572        {
573            $before = $1;
574            $match = $2;
575            $after = $3;
576            return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after);
577        }
578        elsif ($x =~ /^(.*)(kegg\|[a-z]{2,4}:[a-zA-Z_0-9]+)(.*)/s)
579        {
580            $before = $1;
581            $match = $2;
582            $after = $3;
583            return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after);
584      }      }
585      return $x;      return $x;
586  }  }
587    
588    sub refseq_link {
589        my($cgi,$id) = @_;
590    
591        if ($id =~ /^[NXYZA]P_/)
592        {
593            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id>$id</a>";
594        }
595    }
596    
597  sub gi_link {  sub gi_link {
598      my($cgi,$gi) = @_;      my($cgi,$gi) = @_;
599    
# Line 516  Line 604 
604      return $gi;      return $gi;
605  }  }
606    
607    sub uni_link {
608        my($cgi,$uni) = @_;
609    
610        if ($uni =~ /^uni\|(\S+)$/)
611        {
612            return "<a href=http://www.pir.uniprot.org/cgi-bin/upEntry?id=$1>$uni</a>";
613        }
614        return $uni;
615    }
616    
617  sub sp_link {  sub sp_link {
618      my($cgi,$sp) = @_;      my($cgi,$sp) = @_;
619    
# Line 536  Line 634 
634      return $pir;      return $pir;
635  }  }
636    
637    sub kegg_link {
638        my($cgi,$kegg) = @_;
639    
640        if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)
641        {
642            return "<a href=http://www.genome.ad.jp/dbget-bin/www_bget?$1+$2>$kegg</a>";
643        }
644        return $kegg;
645    }
646    
647    sub set_map_links {
648        my($cgi,$x) = @_;
649        my($before,$match,$after);
650    
651        my $org = ($cgi->param('org') || $cgi->param('genome') || "");
652    
653        if ($x =~ /^(.*)(MAP\d+)(.*)/s)
654        {
655            $before = $1;
656            $match = $2;
657            $after = $3;
658            return &set_map_links($cgi,$before) . &map_link($cgi,$match,$org) . &set_map_links($cgi,$after);
659        }
660        return $x;
661    }
662    
663    sub map_link {
664        my($cgi,$map,$org) = @_;
665    
666        $user = $cgi->param('user');
667        $user = $user ? $user : "";
668        $org = $org ? $org : "";
669        my $url = "$FIG_Config::cgi_url/show_kegg_map.cgi?user=$user&map=$map&org=$org";
670        my $link = "<a href=\"$url\">$map</a>";
671        return $link;
672    }
673    
674    sub javascript {
675            #### MODIFIED BY RAE TO ADD JAVA SUPPORT FOR CHECK ALL/UNCHECK ALL
676            # This routine takes three arguments, $html, $form, and $button
677            # $html is the ref to the array with the html in it
678            # $form is the name of the form. This must be added whenever start_form is called
679            # by including a -name entry. This is only used for the javascript
680            # $button is the name of the button that should be checked/unchecked.
681            #
682            # At the moment this add's four buttons:
683            # Check all, check's all
684            # Check first half will check the first 50% of the entries
685            # Check second half will check the second 50% of the entries
686            # Uncheck all will remove the checks.
687    
688            # Note that the other change is I added a -name=>'fig_checked' to the start_form
689            # field. The name is needed for the java script.
690            #
691    
692              $java_script=<<EOF;
693      <SCRIPT LANGUAGE="JavaScript">
694      <!-- Begin
695      function checkAll(field)
696      {
697       for (i = 0; i < field.length; i++)
698       field[i].checked = true ;
699      }
700    
701      function checkFirst(field)
702      {
703       for (i = 0; i < field.length/2; i++)
704       field[i].checked = true;
705      }
706    
707      function checkSecond(field)
708      {
709       for (i=Math.round(field.length/2); i < field.length; i++)
710       field[i].checked = true ;
711      }
712    
713      function uncheckAll(field)
714      {
715       for (i = 0; i < field.length; i++)
716       field[i].checked = false ;
717      }
718      //  End -->
719      </script>
720    EOF
721            return $java_script;
722    }
723    
724    sub java_buttons {
725      ## ADDED BY RAE
726      # Provides code to include check all/first half/second half/none for javascrspt
727      # this takes two variables - the form name provided in start_form with the
728      # -name => field and the checkbox name
729      my ($form, $button)=@_;
730    
731      $java_script="<input type=\"button\" name=\"CheckAll\" value=\"Check All\"\nonClick=\"checkAll(document.$form.$button)\">\n";
732      $java_script.="<input type=\"button\" name=\"CheckFirst\" value=\"Check First Half\"\nonClick=\"checkFirst(document.$form.$button)\">\n";
733      $java_script.="<input type=\"button\" name=\"CheckSecond\" value=\"Check Second Half\"\nonClick=\"checkSecond(document.$form.$button)\">\n";
734      $java_script.="<input type=\"button\" name=\"UnCheckAll\" value=\"Uncheck All\"\nonClick=\"uncheckAll(document.$form.$button)\">\n";
735    
736      return $java_script;
737    }
738    
739  1  1

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3