[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.48, Fri Jul 22 21:39:19 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        # ARGUMENTS:
83        #     $cgi is the CGI method
84        #     $html is an array with all the html in it. It is just joined by "\n" (and not <br> or <p>
85        #     $no_home eliminates ONLY the bottom FIG search link in a page
86        #     $alt_header is a reference to an array for an alternate header banner that you can replace the standard one with
87        #     $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
88        #               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
89        #               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
90        #     $javasrc is a reference to an array of URLs to javascripts to be included (e.g. "/FIG/Html/css/styleswitcher.js")
91      #      #
92      # Find the HTML header      # Find the HTML header
93      #      #
94    
95      my $html_hdr_file = "./Html/html.hdr";      my $html_tail_file = "./Html/$tail_name";
96      if (! -f $html_hdr_file)      if (! -f $html_tail_file)
97      {      {
98          $html_hdr_file = "$FIG_Config::fig/CGI/Html/html.hdr";          $html_tail_file = "$FIG_Config::fig/CGI/Html/$tail_name";
99      }      }
100    
101      my $html_tail_file = "./Html/html.tail";      my $user = $cgi->param('user') || "";
102      if (! -f $html_tail_file)      my @html_hdr;
103        if ($alt_header && ref($alt_header) eq "ARRAY")
104      {      {
105          $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";         @html_hdr = @$alt_header;
106        }
107        else
108        {
109            @html_hdr = compute_html_header(undef,$user);
110      }      }
111    
112    
# Line 145  Line 227 
227      #      #
228      #  <BODY> goes after last head line      #  <BODY> goes after last head line
229      #      #
230        #  RAE:
231        #  Added the javascript for the buttons immediately after body.
232        #  Note if no buttons are added we still (at the moment) add the script,
233        #  but it only adds a little text (495 characters) to the html and noone will notice!
234        #  RAE: This is now deprecated because everything is in an external file, FIG.js, included later
235    
236      if ( $body_line < 0 )      if ( $body_line < 0 )
237      {      {
# Line 156  Line 243 
243      #  Seed page header (if it exists) goes after <BODY>      #  Seed page header (if it exists) goes after <BODY>
244      #      #
245    
246      if ( -f $html_hdr_file )      if (@html_hdr)
247      {      {
248          splice( @$html, $body_line + 1, 0, `cat $html_hdr_file` );          splice( @$html, $body_line + 1, 0, @html_hdr );
249      }      }
250    
251      #      #
# Line 171  Line 258 
258          splice( @$html, $body_line, 0, "</HEAD>\n" );          splice( @$html, $body_line, 0, "</HEAD>\n" );
259      }      }
260    
261        # RAE:
262        # Add css here
263        # Note that at the moment I define these two sheets here. I think this should
264        # be moved out, but I want to try it and see what happens.  css has the format:
265        #
266        # <link rel='stylesheet' title='default' href='/css/default.css' type='text/css'>
267    
268        # convert the default key to the right case. and eliminate dups
269        foreach my $k (keys %$css) {if (lc($k) eq "default") {$css->{'Default'}=$css->{$k}}}
270    
271        if (!$css || !$css->{'Default'})
272        {
273           $css->{'Default'}=$FIG_Config::cgi_url."/Html/css/default.css";
274        }
275        if (!$css->{"Sans Serif"})
276        {
277           $css->{'Sans Serif'}=$FIG_Config::cgi_url."/Html/css/sanserif.css";
278        }
279        my $csstext = "<link rel='stylesheet' title='default' href='".$css->{'Default'}."' type='text/css'>\n";
280        $csstext   .= "<link rel='alternate stylesheet' title='Sans Serif' href='".$css->{'Sans Serif'}."' type='text/css'>\n";
281    
282        foreach my $k (keys %$css)
283        {
284           next if (lc($k) eq "default" || lc($k) eq "sans serif");
285           $csstext .= "<link rel='alternate stylesheet' title='$k' href='".$css->{$k}."' type='text/css'>\n";
286        }
287    
288    
289        # RAE: also added support for external javascripts here.
290        # we are cluttering the HTML code with all the javascripts when they could easily be in external files
291        # this solution allows us to source other files
292    
293        # the file FIG.js contains most of the java script we use routinely. Every browser will just cache this and so
294        # it will reduce our overhead.
295    
296        # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts
297        push @$javasrc, $FIG_Config::cgi_url."/Html/css/FIG.js";
298        foreach my $script (@$javasrc) {
299         $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";
300        }
301    
302    
303    
304        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.
305    
306      #      #
307      #  <BASE ...> goes before </HEAD>      #  <BASE ...> goes before </HEAD>
308      #      #
# Line 183  Line 315 
315          #  only, or every update?), I provide an alternative derivation          #  only, or every update?), I provide an alternative derivation
316          #  from $cgi_url. -- GJO          #  from $cgi_url. -- GJO
317          #          #
318            # BASE href needs to be absolute. RDO.
319          my $base_url = $FIG_Config::cgi_base;          #
320          if ( ! $base_url )                      # if cgi_base was not defined          #
321          {          $base_url = &FIG::cgi_url;
322              $base_url = $FIG_Config::cgi_url;   # get the full cgi url  #       my $base_url = $FIG_Config::cgi_base;
323              $base_url =~ s~^http://[^/]*~~;     # remove protocol and host  #       if ( ! $base_url )                      # if cgi_base was not defined
324              $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash  #       {
325          }  #           $base_url = $FIG_Config::cgi_url;   # get the full cgi url
326    #           $base_url =~ s~^http://[^/]*~~;     # remove protocol and host
327    #           $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash
328    #       }
329    
330          $base_line = $head_end_line;          $base_line = $head_end_line;
331          splice( @$html, $base_line, 0, "<BASE href=\"$base_url\">\n" );          splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );
332      }      }
333    
334      #      #
# Line 228  Line 363 
363      }      }
364    
365      #      #
366        # See if we have a site-specific tail (for disclaimers, etc).
367        #
368    
369        my $site_tail = "$FIG_Config::fig_disk/config/site_tail.html";
370        my $site_fh;
371        if (open($site_fh, "<$site_tail"))
372        {
373            push(@tail, <$site_fh>);
374            close($site_fh);
375        }
376    
377        #
378      #  Figure out where to insert The SEED tail.  Before </body>,      #  Figure out where to insert The SEED tail.  Before </body>,
379      #  or before </html>, or at end of page.      #  or before </html>, or at end of page.
380      #      #
# Line 255  Line 402 
402          splice( @$html, $i, 0, @tags );          splice( @$html, $i, 0, @tags );
403      }      }
404    
405      print @$html;      # RAE the chomp will return any new lines at the ends of elements in the array,
406        # and then we can join  with a "\n". This is because somethings put newlines in,
407        # and others don't. This should make nicer looking html
408        #
409        # chomp(@$html);
410        # print join "\n", @$html;
411        #
412        # Apparently the above still breaks things. This is the correct code:
413    
414        foreach $_ (@$html)
415        {
416            print $_;
417        }
418  }  }
419    
420  sub make_table {  sub make_table {
421      my($col_hdrs,$tab,$title,$instr) = @_;      my($col_hdrs,$tab,$title, %options ) = @_;
422      my(@tab);      my(@tab);
423    
424      push( @tab, "\n<table border>\n",      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";
425        push( @tab, "\n<table $border>\n",
426                  "\t<caption><b>$title</b></caption>\n",                  "\t<caption><b>$title</b></caption>\n",
427                  "\t<tr>\n\t\t<th>"                  "\t<tr>\n\t\t"
428                . join( "</th>\n\t\t<th>", @$col_hdrs )                . join( "\n", map { &expand($_, "th") } @$col_hdrs )
429                . "</th>\n\t</tr>\n"                . "\n\t</tr>\n"
430          );          );
431      my($i,$nowrap);      my($i);
   
     for ($i=0; ($i < @$instr) && ($instr->[$i] !~ /nowrap/); $i++) {}  
     $nowrap = ($i == @$instr) ? "" : " nowrap";  
432    
433      my $row;      my $row;
434      foreach $row (@$tab)      foreach $row (@$tab)
435      {      {
436          push( @tab, "\t<tr>\n"          push( @tab, "\t<tr>\n"
437                    . join( "\n", map { &expand($_,$nowrap) } @$row )                    . join( "\n", map { &expand($_) } @$row )
438                    . "\n\t</tr>\n"                    . "\n\t</tr>\n"
439              );              );
440      }      }
# Line 286  Line 443 
443  }  }
444    
445  sub expand {  sub expand {
446      my($x,$nowrap) = @_;      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
447        my( $x, $tag ) = @_;
448    
449      if ($x =~ /^\@([^:]+)\:([^:]+)\:(.*)$/)      $tag = "td" unless $tag;
450        my $endtag = $tag;
451    
452        # RAE modified this so that you can pass in a reference to an array where
453        # the first element is the data to display and the second element is optional
454        # things like colspan and align. Note that in this case you need to include the td
455        # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]
456    
457        # per GJO's request modified this line so it can take any tag.
458        if ( ref($x) eq "ARRAY" ) { ($x, $tag) = @$x; $tag =~ /^(\S+)/; $endtag = $1 }
459    
460        if ( $x =~ /^\@([^:]+)\:(.*)$/ )
461      {      {
462          return "\t\t<td$nowrap $1=\"$2\">$3</td>";          return "\t\t<$tag $1>$2</$endtag>";
463      }      }
464      else      else
465      {      {
466          return "\t\t<td$nowrap>$x</td>";          return "\t\t<$tag>$x</$endtag>";
467        }
468    }
469    
470    
471    sub merge_table_rows {
472     # RAE:
473     # Experimental piece of code. We often want to have rows or columns were cells are merged. It just looks so much nicer
474     # this block should merge adjacent rows that have the same text in them.
475     # use like this:
476     #      $tab=&HTML::merge_table_rows($tab);
477     # before you do a make_table call
478    
479     my $self=shift if UNIVERSAL::isa($_[0],__PACKAGE__);
480     my ($tab)=@_;
481    
482     my $newtable;
483     my $lastrow;
484     my $rowspan;
485     my $refs;
486    
487     for (my $y=0; $y <= $#$tab; $y++) {
488     #$y is the row in the table;
489      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
490       #$x is the column in the table
491       # if the column in the row we are looking at is the same as the column in the previous row, we don't add
492       # this cell to $newtable. Instead we increment the rowspan of the previous row by one
493    
494       # handle cells that are references to arrays
495       if (ref($tab->[$y]->[$x]) eq "ARRAY") {$refs->[$y]->[$x]=$tab->[$y]->[$x]->[1]; $tab->[$y]->[$x]=$tab->[$y]->[$x]->[0]}
496    
497       # now we go back through the table looking where to draw the merge line:
498       my $lasty=$y;
499       while ($tab->[$y]->[$x] eq $tab->[$lasty]->[$x]) {$lasty--}
500       $lasty++; # this is the last identical cell. If lasty==y it is the current cell, so we just save the data. Otherwise we increment the rowspan
501       if ($lasty == $y) {
502        # we always want to have something in rows that may otherwise be empty but should be there (see below)
503        unless ($tab->[$y]->[$x]) {$tab->[$y]->[$x]=" &nbsp; "}
504        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
505       }
506       else {$rowspan->[$lasty]->[$x]++}
507      }
508     }
509    
510     # now just join everything back together
511     for (my $y=0; $y <= $#$tab; $y++) {
512      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
513       if ($rowspan->[$y]->[$x]) {
514        if ($refs->[$y]->[$x]) {$refs->[$y]->[$x] .= " rowspan=". ($rowspan->[$y]->[$x]+1)}
515        else {$refs->[$y]->[$x] = "td rowspan=". ($rowspan->[$y]->[$x]+1)}
516        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
517       }
518       elsif ($newtable->[$y]->[$x] && $refs->[$y]->[$x]) {
519        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
520       }
521      }
522     }
523    
524    
525     # finally we have to remove any completely empty cells that have been added by the array mechanism
526     # (e.g. if you define $a->[2] then $a->[0] and $a->[1] are now undef).
527     # that is why in the loop above I replace empty cells with nbsp. They are now not undef!
528     # I am sure that Gary can do this in one line, but I am hacking.
529     my @trimmed;
530     foreach my $a (@$newtable) {
531      my @row;
532      foreach my $b (@$a) {
533       push @row, $b if ($b);
534      }
535      push @trimmed, \@row;
536     }
537    
538     return \@trimmed;
539    }
540    
541    
542    
543    
544    sub set_ec_links {
545        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
546        my($cgi,$x) = @_;
547        my($before,$match,$after);
548    
549        if ($x =~ /^(.*)(EC \d+\.\d+\.\d+\.\d+)(.*)/s)
550        {
551            $before = $1;
552            $match = $2;
553            $after = $3;
554            return &set_ec_links($cgi,$before) . &HTML::ec_link($match) . &set_ec_links($cgi,$after);
555      }      }
556        return $x;
557  }  }
558    
559  sub ec_link {  sub ec_link {
560        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
561      my($role) = @_;      my($role) = @_;
562    
563      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)
# Line 312  Line 571 
571  }  }
572    
573  sub role_link {  sub role_link {
574        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
575      my($cgi,$role) = @_;      my($cgi,$role) = @_;
576    
577      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 582 
582      return "<a href=$link>$role</a>";      return "<a href=$link>$role</a>";
583  }  }
584    
585    #
586    # Local means to eliminate the fig|org.peg from the
587    # text of the link.
588    #
589  sub fid_link {  sub fid_link {
590        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
591      my($cgi,$fid,$local,$just_url) = @_;      my($cgi,$fid,$local,$just_url) = @_;
592      my($n);      my($n);
593    
# Line 347  Line 612 
612          my $user = $cgi->param('user');          my $user = $cgi->param('user');
613          if (! $user) { $user = "" }          if (! $user) { $user = "" }
614          my $trans = $cgi->param('translate') ? "&translate=1" : "";          my $trans = $cgi->param('translate') ? "&translate=1" : "";
615          my $link = $cgi->url() . "?prot=$fid&user=$user$trans";          my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
616          $link =~ s/[a-z_A-Z]+\.cgi\?/protein.cgi?/;          my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
617            $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
618            #
619            # Elimin the p2p part if we're in that subdir. Ugh.
620            #
621            $link =~ s,p2p/protein.cgi,protein.cgi,;
622    
623          if ($just_url)          if ($just_url)
624          {          {
625              return $link;              return $link;
# Line 362  Line 633 
633  }  }
634    
635  sub family_link {  sub family_link {
636        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
637      my($family,$user) = @_;      my($family,$user) = @_;
638    
639      return $family;      return $family;
640  }  }
641    
 use URI::Escape;  
642    
643  sub get_html {  sub get_html {
644        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
645      my( $url, $type, $kv_pairs) = @_;      my( $url, $type, $kv_pairs) = @_;
646      my( $encoded, $ua, $args, @args, $out, @output, $x );      my( $encoded, $ua, $args, @args, $out, @output, $x );
647    
648      $ua = new LWP::UserAgent;      $ua = new LWP::UserAgent;
649      $ua->timeout( 900 );      $ua->timeout( 900 );
   
650      if ($type =~/post/i)      if ($type =~/post/i)
651      {      {
652          $args = [];          $args = [];
# Line 435  Line 706 
706  }  }
707    
708  sub trim_output {  sub trim_output {
709        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
710      my($out) = @_;      my($out) = @_;
711      my $i;      my $i;
712    
# Line 472  Line 744 
744  }  }
745    
746  sub set_prot_links {  sub set_prot_links {
747        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
748      my($cgi,$x) = @_;      my($cgi,$x) = @_;
749      my($before,$match,$after);      my($before,$match,$after);
750    
751      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)$/)      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)/s)
752        {
753            $before = $1;
754            $match = $2;
755            $after = $3;
756            return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after);
757        }
758        elsif ($x =~ /^(.*)\b([NXYZA]P_[0-9\.]+)\b(.*)/s)
759      {      {
760          $before = $1;          $before = $1;
761          $match = $2;          $match = $2;
762          $after = $3;          $after = $3;
763          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);
764      }      }
765      elsif ($x =~ /^(.*)(gi\|\d+)(.*)$/)      elsif ($x =~ /^(.*)(gi\|\d+)(.*)/s)
766      {      {
767          $before = $1;          $before = $1;
768          $match = $2;          $match = $2;
769          $after = $3;          $after = $3;
770          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);
771      }      }
772      elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)$/)      elsif ($x =~ /^(.*)(tigr\|[0-9a-zA-Z]+)(.*)/s)
773      {      {
774          $before = $1;          $before = $1;
775          $match = $2;          $match = $2;
776          $after = $3;          $after = $3;
777          return &set_prot_links($cgi,$before) . &HTML::sp_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";          return &set_prot_links($cgi,$before) . &HTML::tigr_link($cgi,$match) . &set_prot_links($cgi,$after);
778      }      }
779      elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)$/)      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
780      {      {
781          $before = $1;          $before = $1;
782          $match = $2;          $match = $2;
783          $after = $3;          $after = $3;
784          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);
785        }
786        elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)/s)
787        {
788            $before = $1;
789            $match = $2;
790            $after = $3;
791            return &set_prot_links($cgi,$before) . &HTML::sp_link($cgi,$match) . &set_prot_links($cgi,$after);
792        }
793        elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)/s)
794        {
795            $before = $1;
796            $match = $2;
797            $after = $3;
798            return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after);
799        }
800        elsif ($x =~ /^(.*)(kegg\|[a-z]{2,4}:[a-zA-Z_0-9]+)(.*)/s)
801        {
802            $before = $1;
803            $match = $2;
804            $after = $3;
805            return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after);
806      }      }
807      return $x;      return $x;
808  }  }
809    
810    sub refseq_link {
811        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
812        my($cgi,$id) = @_;
813    
814        if ($id =~ /^[NXYZA]P_/)
815        {
816            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id>$id</a>";
817        }
818    }
819    
820  sub gi_link {  sub gi_link {
821        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
822      my($cgi,$gi) = @_;      my($cgi,$gi) = @_;
823    
824      if ($gi =~ /^gi\|(\d+)$/)      if ($gi =~ /^gi\|(\d+)$/)
# Line 516  Line 828 
828      return $gi;      return $gi;
829  }  }
830    
831    sub tigr_link {
832        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
833        my($cgi,$tigr) = @_;
834    
835        if ($tigr =~ /^tigr\|([0-9a-zA-Z]+)$/)
836        {
837            return "<a href=\"http://pathema.tigr.org/tigr-scripts/CMR/GenePage.cgi?locus=$1\">$tigr</a>";
838        }
839        return $tigr;
840    }
841    
842    sub uni_link {
843        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
844        my($cgi,$uni) = @_;
845    
846        if ($uni =~ /^uni\|(\S+)$/)
847        {
848            return "<a href=http://www.pir.uniprot.org/cgi-bin/upEntry?id=$1>$uni</a>";
849        }
850        return $uni;
851    }
852    
853  sub sp_link {  sub sp_link {
854        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
855      my($cgi,$sp) = @_;      my($cgi,$sp) = @_;
856    
857      if ($sp =~ /^sp\|(\S+)$/)      if ($sp =~ /^sp\|(\S+)$/)
# Line 527  Line 862 
862  }  }
863    
864  sub pir_link {  sub pir_link {
865        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
866      my($cgi,$pir) = @_;      my($cgi,$pir) = @_;
867    
868      if ($pir =~ /^pirnr\|(NF\d+)$/)      if ($pir =~ /^pirnr\|(NF\d+)$/)
# Line 536  Line 872 
872      return $pir;      return $pir;
873  }  }
874    
875    sub kegg_link {
876        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
877        my($cgi,$kegg) = @_;
878    
879        if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)
880        {
881            return "<a href=http://www.genome.ad.jp/dbget-bin/www_bget?$1+$2>$kegg</a>";
882        }
883        return $kegg;
884    }
885    
886    sub set_map_links {
887        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
888        my($cgi,$x) = @_;
889        my($before,$match,$after);
890    
891        my $org = ($cgi->param('org') || $cgi->param('genome') || "");
892    
893        if ($x =~ /^(.*)(MAP\d+)(.*)/s)
894        {
895            $before = $1;
896            $match = $2;
897            $after = $3;
898            return &set_map_links($cgi,$before) . &map_link($cgi,$match,$org) . &set_map_links($cgi,$after);
899        }
900        return $x;
901    }
902    
903    sub map_link {
904        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
905        my($cgi,$map,$org) = @_;
906    
907        $user = $cgi->param('user');
908        $user = $user ? $user : "";
909        $org = $org ? $org : "";
910        my $url = "$FIG_Config::cgi_url/show_kegg_map.cgi?user=$user&map=$map&org=$org";
911        my $link = "<a href=\"$url\">$map</a>";
912        return $link;
913    }
914    
915    sub java_buttons {
916        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
917      ## ADDED BY RAE
918      # Provides code to include check all/first half/second half/none for javascrspt
919      # this takes two variables - the form name provided in start_form with the
920      # -name => field and the checkbox name
921      my ($form, $button)=@_;
922    
923      $java_script="<input type=\"button\" name=\"CheckAll\" value=\"Check All\"\nonClick=\"checkAll(document.$form.$button)\">\n";
924      $java_script.="<input type=\"button\" name=\"CheckFirst\" value=\"Check First Half\"\nonClick=\"checkFirst(document.$form.$button)\">\n";
925      $java_script.="<input type=\"button\" name=\"CheckSecond\" value=\"Check Second Half\"\nonClick=\"checkSecond(document.$form.$button)\">\n";
926      $java_script.="<input type=\"button\" name=\"UnCheckAll\" value=\"Uncheck All\"\nonClick=\"uncheckAll(document.$form.$button)\">\n";
927    
928      return $java_script;
929    }
930    
931    sub sub_link {
932        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
933        my($cgi,$sub) = @_;
934        my($sub_link);
935    
936        my $user = $cgi->param('user');
937        if ($user)
938        {
939            my $esc_sub = uri_escape( $sub );
940            $sub_link = "<a href=./subsys.cgi?ssa_name=$esc_sub&request=show_ssa&user=$user>$sub</a>";
941        }
942        else
943        {
944            $sub_link = $sub;
945        }
946        return $sub_link;
947    }
948    
949  1  1

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3