[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.39, Sun Mar 20 00:08:39 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 show_page {  sub new
13      my($cgi,$html,$no_home) = @_;  {
14      my $i;      my($class) = @_;
15    
16      #      my $self = {};
     # Find the HTML header  
     #  
17    
18        return bless $self, $class;
19    }
20    
21    sub compute_html_header
22    {
23        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
24        my($additional_insert,$user) = @_;
25      my $html_hdr_file = "./Html/html.hdr";      my $html_hdr_file = "./Html/html.hdr";
26      if (! -f $html_hdr_file)      if (! -f $html_hdr_file)
27      {      {
28          $html_hdr_file = "$FIG_Config::fig/CGI/Html/html.hdr";          $html_hdr_file = "$FIG_Config::fig/CGI/Html/html.hdr";
29      }      }
30        my @html_hdr = &FIG::file_read($html_hdr_file);
31        push( @html_hdr, "<br><a href=\"index.cgi?user=$user\">FIG search</a>\n" );
32    
33        if (@html_hdr)
34        {
35            my $insert_stuff;
36            my @ver = &FIG::file_head("$FIG_Config::fig_disk/CURRENT_RELEASE", 1);
37            my $ver = $ver[0];
38            chomp $ver;
39            if ($ver =~ /^cvs\.(\d+)$/)
40            {
41                my $d = asctime(localtime($1));
42                chomp($d);
43                $ver .=  " ($d)";
44            }
45            my $host = &FIG::get_local_hostname();
46            $insert_stuff = "SEED version <b>$ver</b> on $host";
47            if ($additional_insert)
48            {
49                $insert_stuff .= "<br>" . $additional_insert;
50            }
51    
52            for $_ (@html_hdr)
53            {
54                s,(href|img\s+src)="/FIG/,\1="$FIG_Config::cgi_base,g;
55                if ($_ eq "<!-- HEADER_INSERT -->\n")
56                {
57                    $_ = $insert_stuff;
58                }
59            }
60        }
61    
62        return @html_hdr;
63    }
64    
65    sub show_page {
66        #warn "SHOWPAGE: cgi=", Dumper(@_);
67        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
68        my($cgi,$html,$no_home, $alt_header, $css, $javasrc) = @_;
69        my $i;
70    
71    
72        # ARGUMENTS:
73        #     $cgi is the CGI method
74        #     $html is an array with all the html in it. It is just joined by "\n" (and not <br> or <p>
75        #     $no_home eliminates ONLY the bottom FIG search link in a page
76        #     $alt_header is a reference to an array for an alternate header banner that you can replace the standard one with
77        #     $css is a reference to a hash. The key is the name of the CSS sheet and the value is the URL of that sheet. Note the usual rules about relative css urls
78        #               the sheet named "Default" is considered to be the default style sheet, and if this is not set it points at $FIG_Config::HTML/css/default.css
79        #               the sheet named "Sans Serif" is considered to the the first alternate, and if this is not set it points at $FIG_Config::HTML/css/sanserif.css
80        #     $javasrc is a reference to an array of URLs to javascripts to be included (e.g. "/FIG/Html/css/styleswitcher.js")
81        #
82        # Find the HTML header
83        #
84    
85      my $html_tail_file = "./Html/html.tail";      my $html_tail_file = "./Html/html.tail";
86      if (! -f $html_tail_file)      if (! -f $html_tail_file)
# Line 27  Line 88 
88          $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";          $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";
89      }      }
90    
91        my $user = $cgi->param('user') || "";
92        my @html_hdr;
93        if ($alt_header && ref($alt_header) eq "ARRAY")
94        {
95           @html_hdr = @$alt_header;
96        }
97        else
98        {
99            @html_hdr = compute_html_header(undef,$user);
100        }
101    
102    
103      print $cgi->header;      print $cgi->header;
104    
# Line 145  Line 217 
217      #      #
218      #  <BODY> goes after last head line      #  <BODY> goes after last head line
219      #      #
220        #  RAE:
221        #  Added the javascript for the buttons immediately after body.
222        #  Note if no buttons are added we still (at the moment) add the script,
223        #  but it only adds a little text (495 characters) to the html and noone will notice!
224    
225      if ( $body_line < 0 )      if ( $body_line < 0 )
226      {      {
227            my $js=&javascript;
228          $body_line = $last_head_line + 1;          $body_line = $last_head_line + 1;
229          splice( @$html, $body_line, 0, "<BODY>\n" );          splice( @$html, $body_line, 0, "<BODY>\n$js\n" );
230      }      }
231    
232      #      #
233      #  Seed page header (if it exists) goes after <BODY>      #  Seed page header (if it exists) goes after <BODY>
234      #      #
235    
236      if ( -f $html_hdr_file )      if (@html_hdr)
237      {      {
238          splice( @$html, $body_line + 1, 0, `cat $html_hdr_file` );          splice( @$html, $body_line + 1, 0, @html_hdr );
239      }      }
240    
241      #      #
# Line 171  Line 248 
248          splice( @$html, $body_line, 0, "</HEAD>\n" );          splice( @$html, $body_line, 0, "</HEAD>\n" );
249      }      }
250    
251        # RAE:
252        # Add css here
253        # Note that at the moment I define these two sheets here. I think this should be moved out, but I want to try it and see what happens
254        # css has the format
255        # <link rel='stylesheet' title='default' href='/css/default.css' type='text/css'>
256    
257        # convert the default key to the right case. and eliminate dups
258        foreach my $k (keys %$css) {if (lc($k) eq "default") {$css->{'Default'}=$css->{$k}}}
259    
260        if (!$css || !$css->{'Default'})
261        {
262           $css->{'Default'}="/FIG/Html/css/default.css";
263        }
264        if (!$css->{"Sans Serif"})
265        {
266           $css->{'Sans Serif'}="/FIG/Html/css/sanserif.css";
267        }
268        my $csstext = "<link rel='stylesheet' title='default' href='".$css->{'Default'}."' type='text/css'>\n";
269        $csstext   .= "<link rel='alternate stylesheet' title='Sans Serif' href='".$css->{'Sans Serif'}."' type='text/css'>\n";
270    
271        foreach my $k (keys %$css)
272        {
273           next if (lc($k) eq "default" || lc($k) eq "sans serif");
274           $csstext .= "<link rel='alternate stylesheet' title='$k' href='".$css->{$k}."' type='text/css'>\n";
275        }
276    
277    
278        # RAE: also added support for external javascripts here.
279        # we are cluttering the HTML code with all the javascripts when they could easily be in external files
280        # this solution allows us to source other files
281    
282        # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts
283        if ($javasrc && ref($javasrc) eq "ARRAY") {
284         foreach my $script (@$javasrc) {
285          $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";
286         }
287        }
288    
289    
290    
291        splice( @$html, $head_end_line, 1, "$csstext</HEAD>\n" );  # note here I am replacing the </head> line. Could be bad...? But it doesn't increment everything else.
292    
293      #      #
294      #  <BASE ...> goes before </HEAD>      #  <BASE ...> goes before </HEAD>
295      #      #
# Line 183  Line 302 
302          #  only, or every update?), I provide an alternative derivation          #  only, or every update?), I provide an alternative derivation
303          #  from $cgi_url. -- GJO          #  from $cgi_url. -- GJO
304          #          #
305            # BASE href needs to be absolute. RDO.
306          my $base_url = $FIG_Config::cgi_base;          #
307          if ( ! $base_url )                      # if cgi_base was not defined          #
308          {          $base_url = &FIG::cgi_url;
309              $base_url = $FIG_Config::cgi_url;   # get the full cgi url  #       my $base_url = $FIG_Config::cgi_base;
310              $base_url =~ s~^http://[^/]*~~;     # remove protocol and host  #       if ( ! $base_url )                      # if cgi_base was not defined
311              $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash  #       {
312          }  #           $base_url = $FIG_Config::cgi_url;   # get the full cgi url
313    #           $base_url =~ s~^http://[^/]*~~;     # remove protocol and host
314    #           $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash
315    #       }
316    
317          $base_line = $head_end_line;          $base_line = $head_end_line;
318          splice( @$html, $base_line, 0, "<BASE href=\"$base_url\">\n" );          splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );
319      }      }
320    
321      #      #
# Line 228  Line 350 
350      }      }
351    
352      #      #
353        # See if we have a site-specific tail (for disclaimers, etc).
354        #
355    
356        my $site_tail = "$FIG_Config::fig_disk/config/site_tail.html";
357        my $site_fh;
358        if (open($site_fh, "<$site_tail"))
359        {
360            push(@tail, <$site_fh>);
361            close($site_fh);
362        }
363    
364        #
365      #  Figure out where to insert The SEED tail.  Before </body>,      #  Figure out where to insert The SEED tail.  Before </body>,
366      #  or before </html>, or at end of page.      #  or before </html>, or at end of page.
367      #      #
# Line 255  Line 389 
389          splice( @$html, $i, 0, @tags );          splice( @$html, $i, 0, @tags );
390      }      }
391    
392        # RAE the chomp will return any new lines at the ends of elements in the array, and then we can join  with a "\n"
393        # this is because somethings put newlines in, and others don't. This should make nicer looking html
394        #chomp(@$html);
395        #print join "\n", @$html;
396    
397        # Apparently the above still breaks things. This is the correct code:
398      print @$html;      print @$html;
399  }  }
400    
401  sub make_table {  sub make_table {
402      my($col_hdrs,$tab,$title,$instr) = @_;      my($col_hdrs,$tab,$title, %options ) = @_;
403      my(@tab);      my(@tab);
404    
405      push( @tab, "\n<table border>\n",      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";
406        push( @tab, "\n<table $border>\n",
407                  "\t<caption><b>$title</b></caption>\n",                  "\t<caption><b>$title</b></caption>\n",
408                  "\t<tr>\n\t\t<th>"                  "\t<tr>\n\t\t"
409                . join( "</th>\n\t\t<th>", @$col_hdrs )                . join( "\n", map { &expand($_, "th") } @$col_hdrs )
410                . "</th>\n\t</tr>\n"                . "\n\t</tr>\n"
411          );          );
412      my($i,$nowrap);      my($i);
   
     for ($i=0; ($i < @$instr) && ($instr->[$i] !~ /nowrap/); $i++) {}  
     $nowrap = ($i == @$instr) ? "" : " nowrap";  
413    
414      my $row;      my $row;
415      foreach $row (@$tab)      foreach $row (@$tab)
416      {      {
417          push( @tab, "\t<tr>\n"          push( @tab, "\t<tr>\n"
418                    . join( "\n", map { &expand($_,$nowrap) } @$row )                    . join( "\n", map { &expand($_) } @$row )
419                    . "\n\t</tr>\n"                    . "\n\t</tr>\n"
420              );              );
421      }      }
# Line 286  Line 424 
424  }  }
425    
426  sub expand {  sub expand {
427      my($x,$nowrap) = @_;      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
428        my($x, $tag) = @_;
429    
430        $tag = "td" unless $tag;
431        my $endtag=$tag;
432        # RAE modified this so that you can pass in a reference to an array where the first element is the data to
433        # display and the second element is optional things like colspan and align. Note that in this case you need to include the td
434        # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]
435        if (ref($x) eq "ARRAY") {($x, $tag)=@$x; if ($tag =~ /td/) {$endtag = "td"}}
436    
437      if ($x =~ /^\@([^:]+)\:([^:]+)\:(.*)$/)      if ($x =~ /^\@([^:]+)\:(.*)$/)
438      {      {
439          return "\t\t<td$nowrap $1=\"$2\">$3</td>";          return "\t\t<$tag $1>$2</$endtag>";
440      }      }
441      else      else
442      {      {
443          return "\t\t<td$nowrap>$x</td>";          return "\t\t<$tag>$x</$endtag>";
444        }
445    }
446    
447    sub set_ec_links {
448        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
449        my($cgi,$x) = @_;
450        my($before,$match,$after);
451    
452        if ($x =~ /^(.*)(EC \d+\.\d+\.\d+\.\d+)(.*)/s)
453        {
454            $before = $1;
455            $match = $2;
456            $after = $3;
457            return &set_ec_links($cgi,$before) . &HTML::ec_link($match) . &set_ec_links($cgi,$after);
458      }      }
459        return $x;
460  }  }
461    
462  sub ec_link {  sub ec_link {
463        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
464      my($role) = @_;      my($role) = @_;
465    
466      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)
# Line 312  Line 474 
474  }  }
475    
476  sub role_link {  sub role_link {
477        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
478      my($cgi,$role) = @_;      my($cgi,$role) = @_;
479    
480      my $roleR = ($role =~ /^(\d+\.\d+\.\d+\.\d+)\s+-\s+/) ? $1 : $role;      my $roleR = ($role =~ /^(\d+\.\d+\.\d+\.\d+)\s+-\s+/) ? $1 : $role;
# Line 322  Line 485 
485      return "<a href=$link>$role</a>";      return "<a href=$link>$role</a>";
486  }  }
487    
488    #
489    # Local means to eliminate the fig|org.peg from the
490    # text of the link.
491    #
492  sub fid_link {  sub fid_link {
493        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
494      my($cgi,$fid,$local,$just_url) = @_;      my($cgi,$fid,$local,$just_url) = @_;
495      my($n);      my($n);
496    
# Line 347  Line 515 
515          my $user = $cgi->param('user');          my $user = $cgi->param('user');
516          if (! $user) { $user = "" }          if (! $user) { $user = "" }
517          my $trans = $cgi->param('translate') ? "&translate=1" : "";          my $trans = $cgi->param('translate') ? "&translate=1" : "";
518          my $link = $cgi->url() . "?prot=$fid&user=$user$trans";          my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
519          $link =~ s/[a-z_A-Z]+\.cgi\?/protein.cgi?/;          my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
520            $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
521            #
522            # Elimin the p2p part if we're in that subdir. Ugh.
523            #
524            $link =~ s,p2p/protein.cgi,protein.cgi,;
525    
526          if ($just_url)          if ($just_url)
527          {          {
528              return $link;              return $link;
# Line 362  Line 536 
536  }  }
537    
538  sub family_link {  sub family_link {
539        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
540      my($family,$user) = @_;      my($family,$user) = @_;
541    
542      return $family;      return $family;
# Line 370  Line 545 
545  use URI::Escape;  use URI::Escape;
546    
547  sub get_html {  sub get_html {
548        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
549      my( $url, $type, $kv_pairs) = @_;      my( $url, $type, $kv_pairs) = @_;
550      my( $encoded, $ua, $args, @args, $out, @output, $x );      my( $encoded, $ua, $args, @args, $out, @output, $x );
551    
552      $ua = new LWP::UserAgent;      $ua = new LWP::UserAgent;
553      $ua->timeout( 900 );      $ua->timeout( 900 );
   
554      if ($type =~/post/i)      if ($type =~/post/i)
555      {      {
556          $args = [];          $args = [];
# Line 435  Line 610 
610  }  }
611    
612  sub trim_output {  sub trim_output {
613        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
614      my($out) = @_;      my($out) = @_;
615      my $i;      my $i;
616    
# Line 472  Line 648 
648  }  }
649    
650  sub set_prot_links {  sub set_prot_links {
651        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
652      my($cgi,$x) = @_;      my($cgi,$x) = @_;
653      my($before,$match,$after);      my($before,$match,$after);
654    
655      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)$/)      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)/s)
656      {      {
657          $before = $1;          $before = $1;
658          $match = $2;          $match = $2;
659          $after = $3;          $after = $3;
660          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);
661      }      }
662      elsif ($x =~ /^(.*)(gi\|\d+)(.*)$/)      elsif ($x =~ /^(.*)\b([NXYZA]P_[0-9\.]+)\b(.*)/s)
663      {      {
664          $before = $1;          $before = $1;
665          $match = $2;          $match = $2;
666          $after = $3;          $after = $3;
667          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);
668      }      }
669      elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)$/)      elsif ($x =~ /^(.*)(gi\|\d+)(.*)/s)
670      {      {
671          $before = $1;          $before = $1;
672          $match = $2;          $match = $2;
673          $after = $3;          $after = $3;
674          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);
675      }      }
676      elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)$/)      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
677      {      {
678          $before = $1;          $before = $1;
679          $match = $2;          $match = $2;
680          $after = $3;          $after = $3;
681          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);
682        }
683        elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)/s)
684        {
685            $before = $1;
686            $match = $2;
687            $after = $3;
688            return &set_prot_links($cgi,$before) . &HTML::sp_link($cgi,$match) . &set_prot_links($cgi,$after);
689        }
690        elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)/s)
691        {
692            $before = $1;
693            $match = $2;
694            $after = $3;
695            return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after);
696        }
697        elsif ($x =~ /^(.*)(kegg\|[a-z]{2,4}:[a-zA-Z_0-9]+)(.*)/s)
698        {
699            $before = $1;
700            $match = $2;
701            $after = $3;
702            return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after);
703      }      }
704      return $x;      return $x;
705  }  }
706    
707    sub refseq_link {
708        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
709        my($cgi,$id) = @_;
710    
711        if ($id =~ /^[NXYZA]P_/)
712        {
713            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id>$id</a>";
714        }
715    }
716    
717  sub gi_link {  sub gi_link {
718        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
719      my($cgi,$gi) = @_;      my($cgi,$gi) = @_;
720    
721      if ($gi =~ /^gi\|(\d+)$/)      if ($gi =~ /^gi\|(\d+)$/)
# Line 516  Line 725 
725      return $gi;      return $gi;
726  }  }
727    
728    sub uni_link {
729        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
730        my($cgi,$uni) = @_;
731    
732        if ($uni =~ /^uni\|(\S+)$/)
733        {
734            return "<a href=http://www.pir.uniprot.org/cgi-bin/upEntry?id=$1>$uni</a>";
735        }
736        return $uni;
737    }
738    
739  sub sp_link {  sub sp_link {
740        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
741      my($cgi,$sp) = @_;      my($cgi,$sp) = @_;
742    
743      if ($sp =~ /^sp\|(\S+)$/)      if ($sp =~ /^sp\|(\S+)$/)
# Line 527  Line 748 
748  }  }
749    
750  sub pir_link {  sub pir_link {
751        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
752      my($cgi,$pir) = @_;      my($cgi,$pir) = @_;
753    
754      if ($pir =~ /^pirnr\|(NF\d+)$/)      if ($pir =~ /^pirnr\|(NF\d+)$/)
# Line 536  Line 758 
758      return $pir;      return $pir;
759  }  }
760    
761    sub kegg_link {
762        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
763        my($cgi,$kegg) = @_;
764    
765        if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)
766        {
767            return "<a href=http://www.genome.ad.jp/dbget-bin/www_bget?$1+$2>$kegg</a>";
768        }
769        return $kegg;
770    }
771    
772    sub set_map_links {
773        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
774        my($cgi,$x) = @_;
775        my($before,$match,$after);
776    
777        my $org = ($cgi->param('org') || $cgi->param('genome') || "");
778    
779        if ($x =~ /^(.*)(MAP\d+)(.*)/s)
780        {
781            $before = $1;
782            $match = $2;
783            $after = $3;
784            return &set_map_links($cgi,$before) . &map_link($cgi,$match,$org) . &set_map_links($cgi,$after);
785        }
786        return $x;
787    }
788    
789    sub map_link {
790        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
791        my($cgi,$map,$org) = @_;
792    
793        $user = $cgi->param('user');
794        $user = $user ? $user : "";
795        $org = $org ? $org : "";
796        my $url = "$FIG_Config::cgi_url/show_kegg_map.cgi?user=$user&map=$map&org=$org";
797        my $link = "<a href=\"$url\">$map</a>";
798        return $link;
799    }
800    
801    sub javascript {
802        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
803            #### MODIFIED BY RAE TO ADD JAVA SUPPORT FOR CHECK ALL/UNCHECK ALL
804            # This routine takes three arguments, $html, $form, and $button
805            # $html is the ref to the array with the html in it
806            # $form is the name of the form. This must be added whenever start_form is called
807            # by including a -name entry. This is only used for the javascript
808            # $button is the name of the button that should be checked/unchecked.
809            #
810            # At the moment this add's four buttons:
811            # Check all, check's all
812            # Check first half will check the first 50% of the entries
813            # Check second half will check the second 50% of the entries
814            # Uncheck all will remove the checks.
815    
816            # Note that the other change is I added a -name=>'fig_checked' to the start_form
817            # field. The name is needed for the java script.
818            #
819    
820              $java_script=<<EOF;
821      <SCRIPT LANGUAGE="JavaScript">
822      <!-- Begin
823      function checkAll(field)
824      {
825       for (i = 0; i < field.length; i++)
826       field[i].checked = true ;
827      }
828    
829      function checkFirst(field)
830      {
831       for (i = 0; i < field.length/2; i++)
832       field[i].checked = true;
833      }
834    
835      function checkSecond(field)
836      {
837       for (i=Math.round(field.length/2); i < field.length; i++)
838       field[i].checked = true ;
839      }
840    
841      function uncheckAll(field)
842      {
843       for (i = 0; i < field.length; i++)
844       field[i].checked = false ;
845      }
846      //  End -->
847      </script>
848    EOF
849            return $java_script;
850    }
851    
852    sub java_buttons {
853        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
854      ## ADDED BY RAE
855      # Provides code to include check all/first half/second half/none for javascrspt
856      # this takes two variables - the form name provided in start_form with the
857      # -name => field and the checkbox name
858      my ($form, $button)=@_;
859    
860      $java_script="<input type=\"button\" name=\"CheckAll\" value=\"Check All\"\nonClick=\"checkAll(document.$form.$button)\">\n";
861      $java_script.="<input type=\"button\" name=\"CheckFirst\" value=\"Check First Half\"\nonClick=\"checkFirst(document.$form.$button)\">\n";
862      $java_script.="<input type=\"button\" name=\"CheckSecond\" value=\"Check Second Half\"\nonClick=\"checkSecond(document.$form.$button)\">\n";
863      $java_script.="<input type=\"button\" name=\"UnCheckAll\" value=\"Uncheck All\"\nonClick=\"uncheckAll(document.$form.$button)\">\n";
864    
865      return $java_script;
866    }
867    
868    sub sub_link {
869        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
870        my($cgi,$sub) = @_;
871        my($sub_link);
872    
873        my $user = $cgi->param('user');
874        if ($user)
875        {
876            $sub_link = "<a href=./subsys.cgi?ssa_name=$sub&request=show_ssa&user=$user>$sub</a>";
877        }
878        else
879        {
880            $sub_link = $sub;
881        }
882        return $sub_link;
883    }
884    
885  1  1

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3