[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.3, Fri Mar 19 18:45:37 2004 UTC revision 1.36, Tue Mar 15 21:01:14 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 = {};
17      # Find the HTML header  
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) = @_;
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    
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)
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      print "<base href=\"" . &FIG::cgi_url . "/\">\n";  
105      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<body\>/i); $i++) {}      #
106      if ($i < @$html)      #  The SEED header file goes immediately after <BODY>.  Figure out
107        #  what parts of the HTML document skeleton are there, and fill in
108        #  missing ones.
109        #
110        #  This list should be as comprehensive as feasible:
111        #
112    
113        my %head_tag = ( base     => 1,
114                         basefont => 1,
115                         html     => 1,
116                         isindex  => 1,
117                         link     => 1,
118                         meta     => 1,
119                         nextid   => 1,
120                         style    => 1,
121                         title    => 1
122                       );
123    
124        #
125        #  This list need not be comprehensive; it is just stopping conditions:
126        #
127    
128        my %body_tag = ( a      => 1,
129                         br     => 1,
130                         center => 1,
131                         form   => 1,
132                         h1     => 1,
133                         h2     => 1,
134                         h3     => 1,
135                         hr     => 1,
136                         img    => 1,
137                         p      => 1,
138                         pre    => 1,
139                         table  => 1
140                       );
141    
142        my $html_line = -1;
143        my $head_line = -1;
144        my $base_line = -1;
145        my $head_end_line = -1;
146        my $body_line = -1;
147        my $last_head_line = -1;  #  If no head tags are found, text goes at top.
148        my $done = 0;
149    
150        for ( $i = 0; $i < @$html; $i++ )
151        {
152            #  Some special cases:
153    
154            if ( $html->[$i] =~ /\<html[^0-9a-z]/i ) { $html_line = $i }
155            if ( $html->[$i] =~ /\<head[^0-9a-z]/i ) { $head_line = $i }
156            if ( $html->[$i] =~ /\<base[^0-9a-z]/i ) { $base_line = $i }
157            if ( $html->[$i] =~ /\<\/head\>/i )      { $head_end_line = $i }
158    
159            #  The content goes after this line:
160    
161            if ( $html->[$i] =~ /\<body[^0-9a-z]/i )
162      {      {
163          splice(@$html,$i+1,0,`cat $html_hdr_file`);              $body_line = $i;
164                $last;
165      }      }
166      else  
167            #  Now the general case.
168            #  Analyze all the html tags on the line:
169    
170            foreach ( $html->[$i] =~ /\<\/?([0-9a-z]+)/ig )
171      {      {
172          for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<html\>/i); $i++) {}              #  At first body tag, we stop the search and put the text
173          if ($i < @$html)              #  after the last line with a head tag:
174    
175                if ( $body_tag{ lc $_ } )
176          {          {
177              splice(@$html,$i+1,0,`cat $html_hdr_file`);                  $done = 1;
178                    last;
179          }          }
180          else  
181                #  If this is a head tag, then move the marker forward
182    
183                elsif ( $head_tag{ lc $_ } )
184          {          {
185              splice(@$html,0,0,`cat $html_hdr_file`);                  $last_head_line = $i;
186                }
187          }          }
188            last if $done;      # When done, break loop to avoid increment
189      }      }
190    
191      @tail = `cat $html_tail_file`;      #  Some sanity checks on structure:
192      if (! $no_home)  
193        if ( 1 )
194      {      {
195          my $user = $cgi->param('user');          if ( $html_line >= 0 )
196          $user = $user ? $user : "";          {
197          my $link = $cgi->url();              if ( ( $head_line >= 0 ) && ( $html_line > $head_line ) )
198          $link =~ s/[a-zA-Z_]+\.cgi$/index.cgi/;              {
199          push(@tail,"<hr><a href=\"$link?user=$user\">FIG search</a>\n");                  print STDERR "<HTML> tag follows <HEAD> tag\n";
200                }
201                if ( ( $head_end_line >= 0 ) && ( $html_line > $head_end_line ) )
202                {
203                    print STDERR "<HTML> tag follows </HEAD> tag\n";
204                }
205            }
206            if ( $head_line >= 0 )
207            {
208                if ( ( $head_end_line >= 0 ) && ( $head_line > $head_end_line ) )
209                {
210                    print STDERR "<HEAD> tag follows </HEAD> tag\n";
211                }
212            }
213      }      }
214    
215      if (@tail > 0)      #
216        #  Okay.  Let's put in the html header file, and missing tags:
217        #
218        #  <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 )
226        {
227            my $js=&javascript;
228            $body_line = $last_head_line + 1;
229            splice( @$html, $body_line, 0, "<BODY>\n$js\n" );
230        }
231    
232        #
233        #  Seed page header (if it exists) goes after <BODY>
234        #
235    
236        if (@html_hdr)
237      {      {
238          for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}          splice( @$html, $body_line + 1, 0, @html_hdr );
239          if ($i < @$html)      }
240    
241        #
242        #  </HEAD> goes before <BODY>
243        #
244    
245        if ( $head_end_line < 0 )
246          {          {
247              splice(@$html,$i,0,@tail);          $head_end_line = $body_line;
248            splice( @$html, $body_line, 0, "</HEAD>\n" );
249          }          }
250          else  
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              for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/html\>/i); $i++) {}         $css->{'Default'}="/FIG/Html/css/default.css";
263              if ($i < @$html)      }
264        if (!$css->{"Sans Serif"})
265              {              {
266                  splice(@$html,$i,0,@tail);         $css->{'Sans Serif'}="/FIG/Html/css/sanserif.css";
267              }              }
268              else      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                  push(@$html,@tail);         next if (lc($k) eq "default" || lc($k) eq "sans serif");
274           $csstext .= "<link rel='stylesheet' title='$k' href='".$css->{$k}."' type='text/css'>\n";
275              }              }
276        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.
277    
278        #
279        #  <BASE ...> goes before </HEAD>
280        #
281    
282        if ( $base_line < 0 )
283        {
284            #
285            #  Use a relative base address for pages.  Also, because I am
286            #  worried about when FIG_config.pm gets updated (clean installs
287            #  only, or every update?), I provide an alternative derivation
288            #  from $cgi_url. -- GJO
289            #
290            # BASE href needs to be absolute. RDO.
291            #
292            #
293            $base_url = &FIG::cgi_url;
294    #       my $base_url = $FIG_Config::cgi_base;
295    #       if ( ! $base_url )                      # if cgi_base was not defined
296    #       {
297    #           $base_url = $FIG_Config::cgi_url;   # get the full cgi url
298    #           $base_url =~ s~^http://[^/]*~~;     # remove protocol and host
299    #           $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash
300    #       }
301    
302            $base_line = $head_end_line;
303            splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );
304          }          }
305    
306        #
307        #  <HTML> goes at the top of the output
308        #
309    
310        if ( $html_line < 0 )
311        {
312            $html_line = 0;
313            splice( @$html, $html_line, 0, "<HTML>\n" );
314      }      }
315      print @$html;  
316        #
317        #  <HEAD> goes after <HTML>
318        #
319    
320        if ( $head_line < 0 )
321        {
322            $head_line = $html_line + 1;
323            splice( @$html, $head_line, 0, "<HEAD>\n" );
324        }
325    
326        #
327        #  Place FIG search link at bottom of page
328        #
329    
330        my @tail = -f $html_tail_file ? `cat $html_tail_file` : ();
331        if (! $no_home)
332        {
333            my $user = $cgi->param('user') || "";
334            push( @tail, "<hr><a href=\"index.cgi?user=$user\">FIG search</a>\n" );
335        }
336    
337        #
338        # See if we have a site-specific tail (for disclaimers, etc).
339        #
340    
341        my $site_tail = "$FIG_Config::fig_disk/config/site_tail.html";
342        my $site_fh;
343        if (open($site_fh, "<$site_tail"))
344        {
345            push(@tail, <$site_fh>);
346            close($site_fh);
347        }
348    
349        #
350        #  Figure out where to insert The SEED tail.  Before </body>,
351        #  or before </html>, or at end of page.
352        #
353    
354        my @tags = ();
355    
356        for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}
357        if ($i >= @$html)        # </body> not found; look for </html>
358        {
359            push @tags, "\n</BODY>\n";
360            # Even if tag is not found, index points to correct place for splice
361            for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/html\>/i); $i++) {}
362            if ($i >= @$html)    # </html> not found; add it
363            {
364                push @tags, "</HTML>\n";
365            }
366        }
367    
368        if ( @tail )
369        {
370            splice( @$html, $i, 0, @tail, @tags );
371        }
372        elsif ( @tags )
373        {
374            splice( @$html, $i, 0, @tags );
375        }
376    
377        # RAE the chomp will return any new lines at the ends of elements in the array, and then we can join  with a "\n"
378        # this is because somethings put newlines in, and others don't. This should make nicer looking html
379        chomp(@$html);
380        print join "\n", @$html;
381  }  }
382    
383  sub make_table {  sub make_table {
384      my($col_hdrs,$tab,$title,$instr) = @_;      my($col_hdrs,$tab,$title, %options ) = @_;
385      my(@tab);      my(@tab);
386    
387      push(@tab,"<table border><caption><b>$title</b></caption>\n");      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";
388      push(@tab,"<tr><th>" . join("</th><th>",@$col_hdrs) . "</th></tr>\n");      push( @tab, "\n<table $border>\n",
389      my($i,$nowrap);                  "\t<caption><b>$title</b></caption>\n",
390                    "\t<tr>\n\t\t"
391      for ($i=0; ($i < @$instr) && ($instr->[$i] !~ /nowrap/); $i++) {}                . join( "\n", map { &expand($_, "th") } @$col_hdrs )
392      $nowrap = ($i == @$instr) ? "" : " nowrap";                . "\n\t</tr>\n"
393            );
394        my($i);
395    
396      my $row;      my $row;
397      foreach $row (@$tab)      foreach $row (@$tab)
398      {      {
399          push(@tab,"<tr><td$nowrap>" . join("</td>",map { &expand($_) } @$row) . "</td></tr>\n");          push( @tab, "\t<tr>\n"
400                      . join( "\n", map { &expand($_) } @$row )
401                      . "\n\t</tr>\n"
402                );
403      }      }
404      push(@tab,"</table>\n");      push(@tab,"</table>\n");
405      return join("",@tab);      return join("",@tab);
406  }  }
407    
408  sub expand {  sub expand {
409      my($x) = @_;      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
410        my($x, $tag) = @_;
411    
412        $tag = "td" unless $tag;
413        my $endtag=$tag;
414        # RAE modified this so that you can pass in a reference to an array where the first element is the data to
415        # display and the second element is optional things like colspan and align. Note that in this case you need to include the td
416        # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]
417        if (ref($x) eq "ARRAY") {($x, $tag)=@$x; if ($tag =~ /td/) {$endtag = "td"}}
418    
419      if ($x =~ /^\@([^:]+)\:([^:]+)\:(.*)$/)      if ($x =~ /^\@([^:]+)\:(.*)$/)
420      {      {
421          return "<td$nowrap $1=\"$2\">$3";          return "\t\t<$tag $1>$2</$endtag>";
422      }      }
423      else      else
424      {      {
425          return "<td$nowrap>$x";          return "\t\t<$tag>$x</$endtag>";
426      }      }
427  }  }
428    
429    sub set_ec_links {
430        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
431        my($cgi,$x) = @_;
432        my($before,$match,$after);
433    
434        if ($x =~ /^(.*)(EC \d+\.\d+\.\d+\.\d+)(.*)/s)
435        {
436            $before = $1;
437            $match = $2;
438            $after = $3;
439            return &set_ec_links($cgi,$before) . &HTML::ec_link($match) . &set_ec_links($cgi,$after);
440        }
441        return $x;
442    }
443    
444  sub ec_link {  sub ec_link {
445        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
446      my($role) = @_;      my($role) = @_;
447    
448      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)
# Line 128  Line 456 
456  }  }
457    
458  sub role_link {  sub role_link {
459        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
460      my($cgi,$role) = @_;      my($cgi,$role) = @_;
461    
462      my $roleR = ($role =~ /^(\d+\.\d+\.\d+\.\d+)\s+-\s+/) ? $1 : $role;      my $roleR = ($role =~ /^(\d+\.\d+\.\d+\.\d+)\s+-\s+/) ? $1 : $role;
# Line 138  Line 467 
467      return "<a href=$link>$role</a>";      return "<a href=$link>$role</a>";
468  }  }
469    
470    #
471    # Local means to eliminate the fig|org.peg from the
472    # text of the link.
473    #
474  sub fid_link {  sub fid_link {
475        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
476      my($cgi,$fid,$local,$just_url) = @_;      my($cgi,$fid,$local,$just_url) = @_;
477      my($n);      my($n);
478    
# Line 163  Line 497 
497          my $user = $cgi->param('user');          my $user = $cgi->param('user');
498          if (! $user) { $user = "" }          if (! $user) { $user = "" }
499          my $trans = $cgi->param('translate') ? "&translate=1" : "";          my $trans = $cgi->param('translate') ? "&translate=1" : "";
500          my $link = $cgi->url() . "?prot=$fid&user=$user$trans";          my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
501          $link =~ s/[a-z_A-Z]+\.cgi\?/protein.cgi?/;          my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
502            $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
503            #
504            # Elimin the p2p part if we're in that subdir. Ugh.
505            #
506            $link =~ s,p2p/protein.cgi,protein.cgi,;
507    
508          if ($just_url)          if ($just_url)
509          {          {
510              return $link;              return $link;
# Line 178  Line 518 
518  }  }
519    
520  sub family_link {  sub family_link {
521        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
522      my($family,$user) = @_;      my($family,$user) = @_;
523    
524      return $family;      return $family;
# Line 186  Line 527 
527  use URI::Escape;  use URI::Escape;
528    
529  sub get_html {  sub get_html {
530        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
531      my( $url, $type, $kv_pairs) = @_;      my( $url, $type, $kv_pairs) = @_;
532      my( $encoded, $ua, $args, @args, $out, @output, $x );      my( $encoded, $ua, $args, @args, $out, @output, $x );
533    
534      $ua = new LWP::UserAgent;      $ua = new LWP::UserAgent;
535      $ua->timeout( 900 );      $ua->timeout( 900 );
   
536      if ($type =~/post/i)      if ($type =~/post/i)
537      {      {
538          $args = [];          $args = [];
# Line 251  Line 592 
592  }  }
593    
594  sub trim_output {  sub trim_output {
595        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
596      my($out) = @_;      my($out) = @_;
597      my $i;      my $i;
598    
# Line 288  Line 630 
630  }  }
631    
632  sub set_prot_links {  sub set_prot_links {
633        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
634      my($cgi,$x) = @_;      my($cgi,$x) = @_;
635      my($before,$match,$after);      my($before,$match,$after);
636    
637      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)$/)      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)/s)
638        {
639            $before = $1;
640            $match = $2;
641            $after = $3;
642            return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after);
643        }
644        elsif ($x =~ /^(.*)\b([NXYZA]P_[0-9\.]+)\b(.*)/s)
645      {      {
646          $before = $1;          $before = $1;
647          $match = $2;          $match = $2;
648          $after = $3;          $after = $3;
649          return &set_prot_links($cgi,$before) . &HTML::fid_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);
650      }      }
651      elsif ($x =~ /^(.*)(gi\|\d+)(.*)$/)      elsif ($x =~ /^(.*)(gi\|\d+)(.*)/s)
652      {      {
653          $before = $1;          $before = $1;
654          $match = $2;          $match = $2;
655          $after = $3;          $after = $3;
656          return &set_prot_links($cgi,$before) . &HTML::gi_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);
657      }      }
658      elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)$/)      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
659      {      {
660          $before = $1;          $before = $1;
661          $match = $2;          $match = $2;
662          $after = $3;          $after = $3;
663          return &set_prot_links($cgi,$before) . &HTML::sp_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);
664      }      }
665      elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)$/)      elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)/s)
666      {      {
667          $before = $1;          $before = $1;
668          $match = $2;          $match = $2;
669          $after = $3;          $after = $3;
670          return &set_prot_links($cgi,$before) . &HTML::pir_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);
671        }
672        elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)/s)
673        {
674            $before = $1;
675            $match = $2;
676            $after = $3;
677            return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after);
678        }
679        elsif ($x =~ /^(.*)(kegg\|[a-z]{2,4}:[a-zA-Z_0-9]+)(.*)/s)
680        {
681            $before = $1;
682            $match = $2;
683            $after = $3;
684            return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after);
685      }      }
686      return $x;      return $x;
687  }  }
688    
689    sub refseq_link {
690        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
691        my($cgi,$id) = @_;
692    
693        if ($id =~ /^[NXYZA]P_/)
694        {
695            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id>$id</a>";
696        }
697    }
698    
699  sub gi_link {  sub gi_link {
700        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
701      my($cgi,$gi) = @_;      my($cgi,$gi) = @_;
702    
703      if ($gi =~ /^gi\|(\d+)$/)      if ($gi =~ /^gi\|(\d+)$/)
# Line 332  Line 707 
707      return $gi;      return $gi;
708  }  }
709    
710    sub uni_link {
711        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
712        my($cgi,$uni) = @_;
713    
714        if ($uni =~ /^uni\|(\S+)$/)
715        {
716            return "<a href=http://www.pir.uniprot.org/cgi-bin/upEntry?id=$1>$uni</a>";
717        }
718        return $uni;
719    }
720    
721  sub sp_link {  sub sp_link {
722        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
723      my($cgi,$sp) = @_;      my($cgi,$sp) = @_;
724    
725      if ($sp =~ /^sp\|(\S+)$/)      if ($sp =~ /^sp\|(\S+)$/)
# Line 343  Line 730 
730  }  }
731    
732  sub pir_link {  sub pir_link {
733        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
734      my($cgi,$pir) = @_;      my($cgi,$pir) = @_;
735    
736      if ($pir =~ /^pirnr\|(NF\d+)$/)      if ($pir =~ /^pirnr\|(NF\d+)$/)
# Line 352  Line 740 
740      return $pir;      return $pir;
741  }  }
742    
743    sub kegg_link {
744        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
745        my($cgi,$kegg) = @_;
746    
747        if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)
748        {
749            return "<a href=http://www.genome.ad.jp/dbget-bin/www_bget?$1+$2>$kegg</a>";
750        }
751        return $kegg;
752    }
753    
754    sub set_map_links {
755        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
756        my($cgi,$x) = @_;
757        my($before,$match,$after);
758    
759        my $org = ($cgi->param('org') || $cgi->param('genome') || "");
760    
761        if ($x =~ /^(.*)(MAP\d+)(.*)/s)
762        {
763            $before = $1;
764            $match = $2;
765            $after = $3;
766            return &set_map_links($cgi,$before) . &map_link($cgi,$match,$org) . &set_map_links($cgi,$after);
767        }
768        return $x;
769    }
770    
771    sub map_link {
772        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
773        my($cgi,$map,$org) = @_;
774    
775        $user = $cgi->param('user');
776        $user = $user ? $user : "";
777        $org = $org ? $org : "";
778        my $url = "$FIG_Config::cgi_url/show_kegg_map.cgi?user=$user&map=$map&org=$org";
779        my $link = "<a href=\"$url\">$map</a>";
780        return $link;
781    }
782    
783    sub javascript {
784        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
785            #### MODIFIED BY RAE TO ADD JAVA SUPPORT FOR CHECK ALL/UNCHECK ALL
786            # This routine takes three arguments, $html, $form, and $button
787            # $html is the ref to the array with the html in it
788            # $form is the name of the form. This must be added whenever start_form is called
789            # by including a -name entry. This is only used for the javascript
790            # $button is the name of the button that should be checked/unchecked.
791            #
792            # At the moment this add's four buttons:
793            # Check all, check's all
794            # Check first half will check the first 50% of the entries
795            # Check second half will check the second 50% of the entries
796            # Uncheck all will remove the checks.
797    
798            # Note that the other change is I added a -name=>'fig_checked' to the start_form
799            # field. The name is needed for the java script.
800            #
801    
802              $java_script=<<EOF;
803      <SCRIPT LANGUAGE="JavaScript">
804      <!-- Begin
805      function checkAll(field)
806      {
807       for (i = 0; i < field.length; i++)
808       field[i].checked = true ;
809      }
810    
811      function checkFirst(field)
812      {
813       for (i = 0; i < field.length/2; i++)
814       field[i].checked = true;
815      }
816    
817      function checkSecond(field)
818      {
819       for (i=Math.round(field.length/2); i < field.length; i++)
820       field[i].checked = true ;
821      }
822    
823      function uncheckAll(field)
824      {
825       for (i = 0; i < field.length; i++)
826       field[i].checked = false ;
827      }
828      //  End -->
829      </script>
830    EOF
831            return $java_script;
832    }
833    
834    sub java_buttons {
835        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
836      ## ADDED BY RAE
837      # Provides code to include check all/first half/second half/none for javascrspt
838      # this takes two variables - the form name provided in start_form with the
839      # -name => field and the checkbox name
840      my ($form, $button)=@_;
841    
842      $java_script="<input type=\"button\" name=\"CheckAll\" value=\"Check All\"\nonClick=\"checkAll(document.$form.$button)\">\n";
843      $java_script.="<input type=\"button\" name=\"CheckFirst\" value=\"Check First Half\"\nonClick=\"checkFirst(document.$form.$button)\">\n";
844      $java_script.="<input type=\"button\" name=\"CheckSecond\" value=\"Check Second Half\"\nonClick=\"checkSecond(document.$form.$button)\">\n";
845      $java_script.="<input type=\"button\" name=\"UnCheckAll\" value=\"Uncheck All\"\nonClick=\"uncheckAll(document.$form.$button)\">\n";
846    
847      return $java_script;
848    }
849    
850    sub sub_link {
851        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
852        my($cgi,$sub) = @_;
853        my($sub_link);
854    
855        my $user = $cgi->param('user');
856        if ($user)
857        {
858            $sub_link = "<a href=./subsys.cgi?ssa_name=$sub&request=show_ssa&user=$user>$sub</a>";
859        }
860        else
861        {
862            $sub_link = $sub;
863        }
864        return $sub_link;
865    }
866    
867  1  1

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.36

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3