[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.42, Tue May 3 17:38:50 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::Escape;  # uri_escape()
9  use URI::URL;  use URI::URL;
10  use HTTP::Request::Common;  use HTTP::Request::Common;
11    use POSIX;
12    
13    sub new
14    {
15        my($class) = @_;
16    
17        my $self = {};
18    
19        return bless $self, $class;
20    }
21    
22    sub compute_html_header
23    {
24        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
25        my($additional_insert, $user, %options ) = @_;
26    
27        my $header_name = $options{header_name} ? $options{header_name} : "html.hdr";
28        my $tail_name = $options{tail_name} ? $options{tail_name} : "html.tail";
29    
30        my $html_hdr_file = "./Html/$header_name";
31        if (! -f $html_hdr_file)
32        {
33            $html_hdr_file = "$FIG_Config::fig/CGI/Html/$header_name";
34        }
35        my @html_hdr = &FIG::file_read($html_hdr_file);
36    
37        $options{no_fig_search} or push( @html_hdr, "<br><a href=\"index.cgi?user=$user\">FIG search</a>\n" );
38    
39        if (@html_hdr)
40        {
41            my $insert_stuff;
42    
43            if (not $options{no_release_info})
44            {
45                my @ver = &FIG::file_head("$FIG_Config::fig_disk/CURRENT_RELEASE", 1);
46                my $ver = $ver[0];
47                chomp $ver;
48                if ($ver =~ /^cvs\.(\d+)$/)
49                {
50                    my $d = asctime(localtime($1));
51                    chomp($d);
52                    $ver .=  " ($d)";
53                }
54                my $host = &FIG::get_local_hostname();
55                $insert_stuff = "SEED version <b>$ver</b> on $host";
56            }
57    
58            if ($additional_insert)
59            {
60                $insert_stuff .= "<br>" . $additional_insert;
61            }
62    
63            for $_ (@html_hdr)
64            {
65                s,(href|img\s+src)="/FIG/,\1="$FIG_Config::cgi_base,g;
66                if ($_ eq "<!-- HEADER_INSERT -->\n")
67                {
68                    $_ = $insert_stuff;
69                }
70            }
71        }
72    
73        return @html_hdr;
74    }
75    
76  sub show_page {  sub show_page {
77      my($cgi,$html,$no_home) = @_;      #warn "SHOWPAGE: cgi=", Dumper(@_);
78        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
79        my($cgi,$html,$no_home, $alt_header, $css, $javasrc) = @_;
80      my $i;      my $i;
81    
82    
83        # ARGUMENTS:
84        #     $cgi is the CGI method
85        #     $html is an array with all the html in it. It is just joined by "\n" (and not <br> or <p>
86        #     $no_home eliminates ONLY the bottom FIG search link in a page
87        #     $alt_header is a reference to an array for an alternate header banner that you can replace the standard one with
88        #     $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
89        #               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
90        #               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
91        #     $javasrc is a reference to an array of URLs to javascripts to be included (e.g. "/FIG/Html/css/styleswitcher.js")
92      #      #
93      # Find the HTML header      # Find the HTML header
94      #      #
95    
96      my $html_hdr_file = "./Html/html.hdr";      my $html_tail_file = "./Html/$tail_name";
97      if (! -f $html_hdr_file)      if (! -f $html_tail_file)
98      {      {
99          $html_hdr_file = "$FIG_Config::fig/CGI/Html/html.hdr";          $html_tail_file = "$FIG_Config::fig/CGI/Html/$tail_name";
100      }      }
101    
102      my $html_tail_file = "./Html/html.tail";      my $user = $cgi->param('user') || "";
103      if (! -f $html_tail_file)      my @html_hdr;
104        if ($alt_header && ref($alt_header) eq "ARRAY")
105        {
106           @html_hdr = @$alt_header;
107        }
108        else
109      {      {
110          $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";          @html_hdr = compute_html_header(undef,$user);
111      }      }
112    
113    
# Line 145  Line 228 
228      #      #
229      #  <BODY> goes after last head line      #  <BODY> goes after last head line
230      #      #
231        #  RAE:
232        #  Added the javascript for the buttons immediately after body.
233        #  Note if no buttons are added we still (at the moment) add the script,
234        #  but it only adds a little text (495 characters) to the html and noone will notice!
235    
236      if ( $body_line < 0 )      if ( $body_line < 0 )
237      {      {
238            my $js=&javascript;
239          $body_line = $last_head_line + 1;          $body_line = $last_head_line + 1;
240          splice( @$html, $body_line, 0, "<BODY>\n" );          splice( @$html, $body_line, 0, "<BODY>\n$js\n" );
241      }      }
242    
243      #      #
244      #  Seed page header (if it exists) goes after <BODY>      #  Seed page header (if it exists) goes after <BODY>
245      #      #
246    
247      if ( -f $html_hdr_file )      if (@html_hdr)
248      {      {
249          splice( @$html, $body_line + 1, 0, `cat $html_hdr_file` );          splice( @$html, $body_line + 1, 0, @html_hdr );
250      }      }
251    
252      #      #
# Line 171  Line 259 
259          splice( @$html, $body_line, 0, "</HEAD>\n" );          splice( @$html, $body_line, 0, "</HEAD>\n" );
260      }      }
261    
262        # RAE:
263        # Add css here
264        # Note that at the moment I define these two sheets here. I think this should
265        # be moved out, but I want to try it and see what happens.  css has the format:
266        #
267        # <link rel='stylesheet' title='default' href='/css/default.css' type='text/css'>
268    
269        # convert the default key to the right case. and eliminate dups
270        foreach my $k (keys %$css) {if (lc($k) eq "default") {$css->{'Default'}=$css->{$k}}}
271    
272        if (!$css || !$css->{'Default'})
273        {
274           $css->{'Default'}="/FIG/Html/css/default.css";
275        }
276        if (!$css->{"Sans Serif"})
277        {
278           $css->{'Sans Serif'}="/FIG/Html/css/sanserif.css";
279        }
280        my $csstext = "<link rel='stylesheet' title='default' href='".$css->{'Default'}."' type='text/css'>\n";
281        $csstext   .= "<link rel='alternate stylesheet' title='Sans Serif' href='".$css->{'Sans Serif'}."' type='text/css'>\n";
282    
283        foreach my $k (keys %$css)
284        {
285           next if (lc($k) eq "default" || lc($k) eq "sans serif");
286           $csstext .= "<link rel='alternate stylesheet' title='$k' href='".$css->{$k}."' type='text/css'>\n";
287        }
288    
289    
290        # RAE: also added support for external javascripts here.
291        # we are cluttering the HTML code with all the javascripts when they could easily be in external files
292        # this solution allows us to source other files
293    
294        # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts
295        if ($javasrc && ref($javasrc) eq "ARRAY") {
296         foreach my $script (@$javasrc) {
297          $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";
298         }
299        }
300    
301    
302    
303        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.
304    
305      #      #
306      #  <BASE ...> goes before </HEAD>      #  <BASE ...> goes before </HEAD>
307      #      #
# Line 183  Line 314 
314          #  only, or every update?), I provide an alternative derivation          #  only, or every update?), I provide an alternative derivation
315          #  from $cgi_url. -- GJO          #  from $cgi_url. -- GJO
316          #          #
317            # BASE href needs to be absolute. RDO.
318          my $base_url = $FIG_Config::cgi_base;          #
319          if ( ! $base_url )                      # if cgi_base was not defined          #
320          {          $base_url = &FIG::cgi_url;
321              $base_url = $FIG_Config::cgi_url;   # get the full cgi url  #       my $base_url = $FIG_Config::cgi_base;
322              $base_url =~ s~^http://[^/]*~~;     # remove protocol and host  #       if ( ! $base_url )                      # if cgi_base was not defined
323              $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash  #       {
324          }  #           $base_url = $FIG_Config::cgi_url;   # get the full cgi url
325    #           $base_url =~ s~^http://[^/]*~~;     # remove protocol and host
326    #           $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash
327    #       }
328    
329          $base_line = $head_end_line;          $base_line = $head_end_line;
330          splice( @$html, $base_line, 0, "<BASE href=\"$base_url\">\n" );          splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );
331      }      }
332    
333      #      #
# Line 228  Line 362 
362      }      }
363    
364      #      #
365        # See if we have a site-specific tail (for disclaimers, etc).
366        #
367    
368        my $site_tail = "$FIG_Config::fig_disk/config/site_tail.html";
369        my $site_fh;
370        if (open($site_fh, "<$site_tail"))
371        {
372            push(@tail, <$site_fh>);
373            close($site_fh);
374        }
375    
376        #
377      #  Figure out where to insert The SEED tail.  Before </body>,      #  Figure out where to insert The SEED tail.  Before </body>,
378      #  or before </html>, or at end of page.      #  or before </html>, or at end of page.
379      #      #
# Line 255  Line 401 
401          splice( @$html, $i, 0, @tags );          splice( @$html, $i, 0, @tags );
402      }      }
403    
404        # RAE the chomp will return any new lines at the ends of elements in the array,
405        # and then we can join  with a "\n". This is because somethings put newlines in,
406        # and others don't. This should make nicer looking html
407        #
408        # chomp(@$html);
409        # print join "\n", @$html;
410        #
411        # Apparently the above still breaks things. This is the correct code:
412    
413      print @$html;      print @$html;
414  }  }
415    
416  sub make_table {  sub make_table {
417      my($col_hdrs,$tab,$title,$instr) = @_;      my($col_hdrs,$tab,$title, %options ) = @_;
418      my(@tab);      my(@tab);
419    
420      push( @tab, "\n<table border>\n",      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";
421        push( @tab, "\n<table $border>\n",
422                  "\t<caption><b>$title</b></caption>\n",                  "\t<caption><b>$title</b></caption>\n",
423                  "\t<tr>\n\t\t<th>"                  "\t<tr>\n\t\t"
424                . join( "</th>\n\t\t<th>", @$col_hdrs )                . join( "\n", map { &expand($_, "th") } @$col_hdrs )
425                . "</th>\n\t</tr>\n"                . "\n\t</tr>\n"
426          );          );
427      my($i,$nowrap);      my($i);
   
     for ($i=0; ($i < @$instr) && ($instr->[$i] !~ /nowrap/); $i++) {}  
     $nowrap = ($i == @$instr) ? "" : " nowrap";  
428    
429      my $row;      my $row;
430      foreach $row (@$tab)      foreach $row (@$tab)
431      {      {
432          push( @tab, "\t<tr>\n"          push( @tab, "\t<tr>\n"
433                    . join( "\n", map { &expand($_,$nowrap) } @$row )                    . join( "\n", map { &expand($_) } @$row )
434                    . "\n\t</tr>\n"                    . "\n\t</tr>\n"
435              );              );
436      }      }
# Line 286  Line 439 
439  }  }
440    
441  sub expand {  sub expand {
442      my($x,$nowrap) = @_;      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
443        my( $x, $tag ) = @_;
444    
445      if ($x =~ /^\@([^:]+)\:([^:]+)\:(.*)$/)      $tag = "td" unless $tag;
446        my $endtag = $tag;
447    
448        # RAE modified this so that you can pass in a reference to an array where
449        # the first element is the data to display and the second element is optional
450        # things like colspan and align. Note that in this case you need to include the td
451        # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]
452    
453        if ( ref($x) eq "ARRAY" ) { ($x, $tag) = @$x; if ($tag =~ /td/) { $endtag = "td" } }
454    
455        if ( $x =~ /^\@([^:]+)\:(.*)$/ )
456      {      {
457          return "\t\t<td$nowrap $1=\"$2\">$3</td>";          return "\t\t<$tag $1>$2</$endtag>";
458      }      }
459      else      else
460      {      {
461          return "\t\t<td$nowrap>$x</td>";          return "\t\t<$tag>$x</$endtag>";
462        }
463    }
464    
465    sub set_ec_links {
466        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
467        my($cgi,$x) = @_;
468        my($before,$match,$after);
469    
470        if ($x =~ /^(.*)(EC \d+\.\d+\.\d+\.\d+)(.*)/s)
471        {
472            $before = $1;
473            $match = $2;
474            $after = $3;
475            return &set_ec_links($cgi,$before) . &HTML::ec_link($match) . &set_ec_links($cgi,$after);
476      }      }
477        return $x;
478  }  }
479    
480  sub ec_link {  sub ec_link {
481        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
482      my($role) = @_;      my($role) = @_;
483    
484      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)
# Line 312  Line 492 
492  }  }
493    
494  sub role_link {  sub role_link {
495        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
496      my($cgi,$role) = @_;      my($cgi,$role) = @_;
497    
498      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 503 
503      return "<a href=$link>$role</a>";      return "<a href=$link>$role</a>";
504  }  }
505    
506    #
507    # Local means to eliminate the fig|org.peg from the
508    # text of the link.
509    #
510  sub fid_link {  sub fid_link {
511        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
512      my($cgi,$fid,$local,$just_url) = @_;      my($cgi,$fid,$local,$just_url) = @_;
513      my($n);      my($n);
514    
# Line 347  Line 533 
533          my $user = $cgi->param('user');          my $user = $cgi->param('user');
534          if (! $user) { $user = "" }          if (! $user) { $user = "" }
535          my $trans = $cgi->param('translate') ? "&translate=1" : "";          my $trans = $cgi->param('translate') ? "&translate=1" : "";
536          my $link = $cgi->url() . "?prot=$fid&user=$user$trans";          my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
537          $link =~ s/[a-z_A-Z]+\.cgi\?/protein.cgi?/;          my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
538            $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
539            #
540            # Elimin the p2p part if we're in that subdir. Ugh.
541            #
542            $link =~ s,p2p/protein.cgi,protein.cgi,;
543    
544          if ($just_url)          if ($just_url)
545          {          {
546              return $link;              return $link;
# Line 362  Line 554 
554  }  }
555    
556  sub family_link {  sub family_link {
557        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
558      my($family,$user) = @_;      my($family,$user) = @_;
559    
560      return $family;      return $family;
561  }  }
562    
 use URI::Escape;  
563    
564  sub get_html {  sub get_html {
565        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
566      my( $url, $type, $kv_pairs) = @_;      my( $url, $type, $kv_pairs) = @_;
567      my( $encoded, $ua, $args, @args, $out, @output, $x );      my( $encoded, $ua, $args, @args, $out, @output, $x );
568    
569      $ua = new LWP::UserAgent;      $ua = new LWP::UserAgent;
570      $ua->timeout( 900 );      $ua->timeout( 900 );
   
571      if ($type =~/post/i)      if ($type =~/post/i)
572      {      {
573          $args = [];          $args = [];
# Line 435  Line 627 
627  }  }
628    
629  sub trim_output {  sub trim_output {
630        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
631      my($out) = @_;      my($out) = @_;
632      my $i;      my $i;
633    
# Line 472  Line 665 
665  }  }
666    
667  sub set_prot_links {  sub set_prot_links {
668        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
669      my($cgi,$x) = @_;      my($cgi,$x) = @_;
670      my($before,$match,$after);      my($before,$match,$after);
671    
672      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)$/)      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)/s)
673        {
674            $before = $1;
675            $match = $2;
676            $after = $3;
677            return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after);
678        }
679        elsif ($x =~ /^(.*)\b([NXYZA]P_[0-9\.]+)\b(.*)/s)
680        {
681            $before = $1;
682            $match = $2;
683            $after = $3;
684            return &set_prot_links($cgi,$before) . &HTML::refseq_link($cgi,$match) . &set_prot_links($cgi,$after);
685        }
686        elsif ($x =~ /^(.*)(gi\|\d+)(.*)/s)
687        {
688            $before = $1;
689            $match = $2;
690            $after = $3;
691            return &set_prot_links($cgi,$before) . &HTML::gi_link($cgi,$match) . &set_prot_links($cgi,$after);
692        }
693        elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
694      {      {
695          $before = $1;          $before = $1;
696          $match = $2;          $match = $2;
697          $after = $3;          $after = $3;
698          return &set_prot_links($cgi,$before) . &HTML::fid_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);
699      }      }
700      elsif ($x =~ /^(.*)(gi\|\d+)(.*)$/)      elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)/s)
701      {      {
702          $before = $1;          $before = $1;
703          $match = $2;          $match = $2;
704          $after = $3;          $after = $3;
705          return &set_prot_links($cgi,$before) . &HTML::gi_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);
706      }      }
707      elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)$/)      elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)/s)
708      {      {
709          $before = $1;          $before = $1;
710          $match = $2;          $match = $2;
711          $after = $3;          $after = $3;
712          return &set_prot_links($cgi,$before) . &HTML::sp_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);
713      }      }
714      elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)$/)      elsif ($x =~ /^(.*)(kegg\|[a-z]{2,4}:[a-zA-Z_0-9]+)(.*)/s)
715      {      {
716          $before = $1;          $before = $1;
717          $match = $2;          $match = $2;
718          $after = $3;          $after = $3;
719          return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";          return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after);
720      }      }
721      return $x;      return $x;
722  }  }
723    
724    sub refseq_link {
725        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
726        my($cgi,$id) = @_;
727    
728        if ($id =~ /^[NXYZA]P_/)
729        {
730            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id>$id</a>";
731        }
732    }
733    
734  sub gi_link {  sub gi_link {
735        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
736      my($cgi,$gi) = @_;      my($cgi,$gi) = @_;
737    
738      if ($gi =~ /^gi\|(\d+)$/)      if ($gi =~ /^gi\|(\d+)$/)
# Line 516  Line 742 
742      return $gi;      return $gi;
743  }  }
744    
745    sub uni_link {
746        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
747        my($cgi,$uni) = @_;
748    
749        if ($uni =~ /^uni\|(\S+)$/)
750        {
751            return "<a href=http://www.pir.uniprot.org/cgi-bin/upEntry?id=$1>$uni</a>";
752        }
753        return $uni;
754    }
755    
756  sub sp_link {  sub sp_link {
757        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
758      my($cgi,$sp) = @_;      my($cgi,$sp) = @_;
759    
760      if ($sp =~ /^sp\|(\S+)$/)      if ($sp =~ /^sp\|(\S+)$/)
# Line 527  Line 765 
765  }  }
766    
767  sub pir_link {  sub pir_link {
768        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
769      my($cgi,$pir) = @_;      my($cgi,$pir) = @_;
770    
771      if ($pir =~ /^pirnr\|(NF\d+)$/)      if ($pir =~ /^pirnr\|(NF\d+)$/)
# Line 536  Line 775 
775      return $pir;      return $pir;
776  }  }
777    
778    sub kegg_link {
779        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
780        my($cgi,$kegg) = @_;
781    
782        if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)
783        {
784            return "<a href=http://www.genome.ad.jp/dbget-bin/www_bget?$1+$2>$kegg</a>";
785        }
786        return $kegg;
787    }
788    
789    sub set_map_links {
790        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
791        my($cgi,$x) = @_;
792        my($before,$match,$after);
793    
794        my $org = ($cgi->param('org') || $cgi->param('genome') || "");
795    
796        if ($x =~ /^(.*)(MAP\d+)(.*)/s)
797        {
798            $before = $1;
799            $match = $2;
800            $after = $3;
801            return &set_map_links($cgi,$before) . &map_link($cgi,$match,$org) . &set_map_links($cgi,$after);
802        }
803        return $x;
804    }
805    
806    sub map_link {
807        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
808        my($cgi,$map,$org) = @_;
809    
810        $user = $cgi->param('user');
811        $user = $user ? $user : "";
812        $org = $org ? $org : "";
813        my $url = "$FIG_Config::cgi_url/show_kegg_map.cgi?user=$user&map=$map&org=$org";
814        my $link = "<a href=\"$url\">$map</a>";
815        return $link;
816    }
817    
818    sub javascript {
819        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
820            #### MODIFIED BY RAE TO ADD JAVA SUPPORT FOR CHECK ALL/UNCHECK ALL
821            # This routine takes three arguments, $html, $form, and $button
822            # $html is the ref to the array with the html in it
823            # $form is the name of the form. This must be added whenever start_form is called
824            # by including a -name entry. This is only used for the javascript
825            # $button is the name of the button that should be checked/unchecked.
826            #
827            # At the moment this add's four buttons:
828            # Check all, check's all
829            # Check first half will check the first 50% of the entries
830            # Check second half will check the second 50% of the entries
831            # Uncheck all will remove the checks.
832    
833            # Note that the other change is I added a -name=>'fig_checked' to the start_form
834            # field. The name is needed for the java script.
835            #
836    
837              $java_script=<<EOF;
838      <SCRIPT LANGUAGE="JavaScript">
839      <!-- Begin
840      function checkAll(field)
841      {
842       for (i = 0; i < field.length; i++)
843       field[i].checked = true ;
844      }
845    
846      function checkFirst(field)
847      {
848       for (i = 0; i < field.length/2; i++)
849       field[i].checked = true;
850      }
851    
852      function checkSecond(field)
853      {
854       for (i=Math.round(field.length/2); i < field.length; i++)
855       field[i].checked = true ;
856      }
857    
858      function uncheckAll(field)
859      {
860       for (i = 0; i < field.length; i++)
861       field[i].checked = false ;
862      }
863      //  End -->
864      </script>
865    EOF
866            return $java_script;
867    }
868    
869    sub java_buttons {
870        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
871      ## ADDED BY RAE
872      # Provides code to include check all/first half/second half/none for javascrspt
873      # this takes two variables - the form name provided in start_form with the
874      # -name => field and the checkbox name
875      my ($form, $button)=@_;
876    
877      $java_script="<input type=\"button\" name=\"CheckAll\" value=\"Check All\"\nonClick=\"checkAll(document.$form.$button)\">\n";
878      $java_script.="<input type=\"button\" name=\"CheckFirst\" value=\"Check First Half\"\nonClick=\"checkFirst(document.$form.$button)\">\n";
879      $java_script.="<input type=\"button\" name=\"CheckSecond\" value=\"Check Second Half\"\nonClick=\"checkSecond(document.$form.$button)\">\n";
880      $java_script.="<input type=\"button\" name=\"UnCheckAll\" value=\"Uncheck All\"\nonClick=\"uncheckAll(document.$form.$button)\">\n";
881    
882      return $java_script;
883    }
884    
885    sub sub_link {
886        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
887        my($cgi,$sub) = @_;
888        my($sub_link);
889    
890        my $user = $cgi->param('user');
891        if ($user)
892        {
893            my $esc_sub = uri_escape( $sub );
894            $sub_link = "<a href=./subsys.cgi?ssa_name=$esc_sub&request=show_ssa&user=$user>$sub</a>";
895        }
896        else
897        {
898            $sub_link = $sub;
899        }
900        return $sub_link;
901    }
902    
903  1  1

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3