[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.52, Sat Aug 6 15:30:29 2005 UTC
# Line 1  Line 1 
1  package HTML;  package HTML;
2    
3    use Tracer;
4    use FIG;
5  use Carp;  use Carp;
6  use Data::Dumper;  use Data::Dumper;
7  use LWP::UserAgent;  use LWP::UserAgent;
8  use LWP::Simple;  use LWP::Simple;
9    use URI::Escape;  # uri_escape()
10  use URI::URL;  use URI::URL;
11  use HTTP::Request::Common;  use HTTP::Request::Common;
12    use POSIX;
13    
14    sub new
15    {
16        my($class) = @_;
17    
18        my $self = {};
19    
20        return bless $self, $class;
21    }
22    
23    sub compute_html_header
24    {
25        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
26        my($additional_insert, $user, %options ) = @_;
27    
28        my $header_name = $options{header_name} ? $options{header_name} : "html.hdr";
29        my $tail_name = $options{tail_name} ? $options{tail_name} : "html.tail";
30    
31        my $html_hdr_file = "./Html/$header_name";
32        if (! -f $html_hdr_file)
33        {
34            $html_hdr_file = "$FIG_Config::fig/CGI/Html/$header_name";
35        }
36        my @html_hdr = &FIG::file_read($html_hdr_file);
37    
38        $options{no_fig_search} or push( @html_hdr, "<br><a href=\"index.cgi?user=$user\">FIG search</a>\n" );
39    
40        if (@html_hdr)
41        {
42            my $insert_stuff;
43    
44            if (not $options{no_release_info})
45            {
46                my @ver = &FIG::file_head("$FIG_Config::fig_disk/CURRENT_RELEASE", 1);
47                my $ver = $ver[0];
48                chomp $ver;
49                if ($ver =~ /^cvs\.(\d+)$/)
50                {
51                    my $d = asctime(localtime($1));
52                    chomp($d);
53                    $ver .=  " ($d)";
54                }
55                my $host = &FIG::get_local_hostname();
56                $insert_stuff = "SEED version <b>$ver</b> on $host";
57            }
58    
59            if ($additional_insert)
60            {
61                $insert_stuff .= "<br>" . $additional_insert;
62            }
63    
64            for $_ (@html_hdr)
65            {
66                s,(href|img\s+src)="/FIG/,\1="$FIG_Config::cgi_base,g;
67                if ($_ eq "<!-- HEADER_INSERT -->\n")
68                {
69                    $_ = $insert_stuff;
70                }
71            }
72        }
73    
74        return @html_hdr;
75    }
76    
77  sub show_page {  sub show_page {
78      my($cgi,$html,$no_home) = @_;      #warn "SHOWPAGE: cgi=", Dumper(@_);
79        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
80        my($cgi,$html,$no_home, $alt_header, $css, $javasrc) = @_;
81      my $i;      my $i;
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        #  RAE: This is now deprecated because everything is in an external file, FIG.js, included later
236    
237      if ( $body_line < 0 )      if ( $body_line < 0 )
238      {      {
# Line 156  Line 244 
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::cgi_url() . "/Html/css/default.css";
275        }
276        if (!$css->{"Sans Serif"})
277        {
278           $css->{'Sans Serif'} = &FIG::cgi_url() . "/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        # the file FIG.js contains most of the java script we use routinely. Every browser will just cache this and so
295        # it will reduce our overhead.
296    
297        # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts
298        push @$javasrc, &FIG::cgi_url() . "/Html/css/FIG.js";
299        foreach my $script (@$javasrc) {
300            $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";
301        }
302    
303    
304    
305        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.
306    
307      #      #
308      #  <BASE ...> goes before </HEAD>      #  <BASE ...> goes before </HEAD>
309      #      #
# Line 183  Line 316 
316          #  only, or every update?), I provide an alternative derivation          #  only, or every update?), I provide an alternative derivation
317          #  from $cgi_url. -- GJO          #  from $cgi_url. -- GJO
318          #          #
319            # BASE href needs to be absolute. RDO.
320          my $base_url = $FIG_Config::cgi_base;          #
321          if ( ! $base_url )                      # if cgi_base was not defined          #
322          {          $base_url = &FIG::cgi_url;
323              $base_url = $FIG_Config::cgi_url;   # get the full cgi url  #       my $base_url = $FIG_Config::cgi_base;
324              $base_url =~ s~^http://[^/]*~~;     # remove protocol and host  #       if ( ! $base_url )                      # if cgi_base was not defined
325              $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash  #       {
326          }  #           $base_url = $FIG_Config::cgi_url;   # get the full cgi url
327    #           $base_url =~ s~^http://[^/]*~~;     # remove protocol and host
328    #           $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash
329    #       }
330    
331          $base_line = $head_end_line;          $base_line = $head_end_line;
332          splice( @$html, $base_line, 0, "<BASE href=\"$base_url\">\n" );          splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );
333      }      }
334    
335      #      #
# Line 228  Line 364 
364      }      }
365    
366      #      #
367        # See if we have a site-specific tail (for disclaimers, etc).
368        #
369    
370        my $site_tail = "$FIG_Config::fig_disk/config/site_tail.html";
371        my $site_fh;
372        if (open($site_fh, "<$site_tail"))
373        {
374            push(@tail, <$site_fh>);
375            close($site_fh);
376        }
377    
378        #
379      #  Figure out where to insert The SEED tail.  Before </body>,      #  Figure out where to insert The SEED tail.  Before </body>,
380      #  or before </html>, or at end of page.      #  or before </html>, or at end of page.
381      #      #
   
382      my @tags = ();      my @tags = ();
383        # Check for a tracing queue.
384        my $traceString = QTrace("HTML");
385        if ($traceString) {
386            push @tags, $traceString;
387        }
388      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}
389      if ($i >= @$html)        # </body> not found; look for </html>      if ($i >= @$html)        # </body> not found; look for </html>
390      {      {
# Line 255  Line 406 
406          splice( @$html, $i, 0, @tags );          splice( @$html, $i, 0, @tags );
407      }      }
408    
409      print @$html;      # RAE the chomp will return any new lines at the ends of elements in the array,
410        # and then we can join  with a "\n". This is because somethings put newlines in,
411        # and others don't. This should make nicer looking html
412        #
413        # chomp(@$html);
414        # print join "\n", @$html;
415        #
416        # Apparently the above still breaks things. This is the correct code:
417    
418        foreach $_ (@$html)
419        {
420            print $_;
421        }
422    
423  }  }
424    
425  sub make_table {  sub make_table {
426      my($col_hdrs,$tab,$title,$instr) = @_;      my($col_hdrs,$tab,$title, %options ) = @_;
427      my(@tab);      my(@tab);
428    
429      push( @tab, "\n<table border>\n",      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";
430        push( @tab, "\n<table $border>\n",
431                  "\t<caption><b>$title</b></caption>\n",                  "\t<caption><b>$title</b></caption>\n",
432                  "\t<tr>\n\t\t<th>"                  "\t<tr>\n\t\t"
433                . join( "</th>\n\t\t<th>", @$col_hdrs )                . join( "\n", map { &expand($_, "th") } @$col_hdrs )
434                . "</th>\n\t</tr>\n"                . "\n\t</tr>\n"
435          );          );
436      my($i,$nowrap);      my($i);
   
     for ($i=0; ($i < @$instr) && ($instr->[$i] !~ /nowrap/); $i++) {}  
     $nowrap = ($i == @$instr) ? "" : " nowrap";  
437    
438      my $row;      my $row;
439      foreach $row (@$tab)      foreach $row (@$tab)
440      {      {
441          push( @tab, "\t<tr>\n"          push( @tab, "\t<tr>\n"
442                    . join( "\n", map { &expand($_,$nowrap) } @$row )                    . join( "\n", map { &expand($_) } @$row )
443                    . "\n\t</tr>\n"                    . "\n\t</tr>\n"
444              );              );
445      }      }
# Line 286  Line 448 
448  }  }
449    
450  sub expand {  sub expand {
451      my($x,$nowrap) = @_;      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
452        my( $x, $tag ) = @_;
453    
454        $tag = "td" unless $tag;
455        my $endtag = $tag;
456    
457        # RAE modified this so that you can pass in a reference to an array where
458        # the first element is the data to display and the second element is optional
459        # things like colspan and align. Note that in this case you need to include the td
460        # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]
461    
462      if ($x =~ /^\@([^:]+)\:([^:]+)\:(.*)$/)      # per GJO's request modified this line so it can take any tag.
463        if ( ref($x) eq "ARRAY" ) { ($x, $tag) = @$x; $tag =~ /^(\S+)/; $endtag = $1 }
464    
465        if ( $x =~ /^\@([^:]+)\:(.*)$/ )
466      {      {
467          return "\t\t<td$nowrap $1=\"$2\">$3</td>";          return "\t\t<$tag $1>$2</$endtag>";
468      }      }
469      else      else
470      {      {
471          return "\t\t<td$nowrap>$x</td>";          return "\t\t<$tag>$x</$endtag>";
472        }
473    }
474    
475    
476    sub merge_table_rows {
477     # RAE:
478     # Experimental piece of code. We often want to have rows or columns were cells are merged. It just looks so much nicer
479     # this block should merge adjacent rows that have the same text in them.
480     # use like this:
481     #      $tab=&HTML::merge_table_rows($tab);
482     # before you do a make_table call
483    
484     my $self=shift if UNIVERSAL::isa($_[0],__PACKAGE__);
485     my ($tab)=@_;
486    
487     my $newtable;
488     my $lastrow;
489     my $rowspan;
490     my $refs;
491    
492     for (my $y=0; $y <= $#$tab; $y++) {
493     #$y is the row in the table;
494      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
495       #$x is the column in the table
496       # if the column in the row we are looking at is the same as the column in the previous row, we don't add
497       # this cell to $newtable. Instead we increment the rowspan of the previous row by one
498    
499       # handle cells that are references to arrays
500       if (ref($tab->[$y]->[$x]) eq "ARRAY") {$refs->[$y]->[$x]=$tab->[$y]->[$x]->[1]; $tab->[$y]->[$x]=$tab->[$y]->[$x]->[0]}
501    
502       # now we go back through the table looking where to draw the merge line:
503       my $lasty=$y;
504       while ($lasty >= 0 && $tab->[$y]->[$x] eq $tab->[$lasty]->[$x]) {$lasty--}
505       $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
506       if ($lasty == $y) {
507        # we always want to have something in rows that may otherwise be empty but should be there (see below)
508        unless ($tab->[$y]->[$x]) {$tab->[$y]->[$x]=" &nbsp; "}
509        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
510       }
511       else {$rowspan->[$lasty]->[$x]++}
512      }
513     }
514    
515     # now just join everything back together
516     for (my $y=0; $y <= $#$tab; $y++) {
517      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
518       if ($rowspan->[$y]->[$x]) {
519        if ($refs->[$y]->[$x]) {$refs->[$y]->[$x] .= " rowspan=". ($rowspan->[$y]->[$x]+1)}
520        else {$refs->[$y]->[$x] = "td rowspan=". ($rowspan->[$y]->[$x]+1)}
521        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
522       }
523       elsif ($newtable->[$y]->[$x] && $refs->[$y]->[$x]) {
524        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
525       }
526      }
527     }
528    
529    
530     # finally we have to remove any completely empty cells that have been added by the array mechanism
531     # (e.g. if you define $a->[2] then $a->[0] and $a->[1] are now undef).
532     # that is why in the loop above I replace empty cells with nbsp. They are now not undef!
533     # I am sure that Gary can do this in one line, but I am hacking.
534     my @trimmed;
535     foreach my $a (@$newtable) {
536      my @row;
537      foreach my $b (@$a) {
538       push @row, $b if ($b);
539      }
540      push @trimmed, \@row;
541     }
542    
543     return \@trimmed;
544    }
545    
546    
547    
548    
549    sub set_ec_links {
550        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
551        my($cgi,$x) = @_;
552        my($before,$match,$after);
553    
554        if ($x =~ /^(.*)(EC \d+\.\d+\.\d+\.\d+)(.*)/s)
555        {
556            $before = $1;
557            $match = $2;
558            $after = $3;
559            return &set_ec_links($cgi,$before) . &HTML::ec_link($match) . &set_ec_links($cgi,$after);
560      }      }
561        return $x;
562  }  }
563    
564  sub ec_link {  sub ec_link {
565        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
566      my($role) = @_;      my($role) = @_;
567    
568      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)
# Line 312  Line 576 
576  }  }
577    
578  sub role_link {  sub role_link {
579        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
580      my($cgi,$role) = @_;      my($cgi,$role) = @_;
581    
582      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 587 
587      return "<a href=$link>$role</a>";      return "<a href=$link>$role</a>";
588  }  }
589    
590    #
591    # Local means to eliminate the fig|org.peg from the
592    # text of the link.
593    #
594  sub fid_link {  sub fid_link {
595        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
596      my($cgi,$fid,$local,$just_url) = @_;      my($cgi,$fid,$local,$just_url) = @_;
597      my($n);      my($n);
598    
# Line 347  Line 617 
617          my $user = $cgi->param('user');          my $user = $cgi->param('user');
618          if (! $user) { $user = "" }          if (! $user) { $user = "" }
619          my $trans = $cgi->param('translate') ? "&translate=1" : "";          my $trans = $cgi->param('translate') ? "&translate=1" : "";
620          my $link = $cgi->url() . "?prot=$fid&user=$user$trans";          my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
621          $link =~ s/[a-z_A-Z]+\.cgi\?/protein.cgi?/;          my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
622            $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
623            #
624            # Elimin the p2p part if we're in that subdir. Ugh.
625            #
626            $link =~ s,p2p/protein.cgi,protein.cgi,;
627    
628          if ($just_url)          if ($just_url)
629          {          {
630              return $link;              return $link;
# Line 362  Line 638 
638  }  }
639    
640  sub family_link {  sub family_link {
641        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
642      my($family,$user) = @_;      my($family,$user) = @_;
643    
644      return $family;      return $family;
645  }  }
646    
 use URI::Escape;  
647    
648  sub get_html {  sub get_html {
649        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
650      my( $url, $type, $kv_pairs) = @_;      my( $url, $type, $kv_pairs) = @_;
651      my( $encoded, $ua, $args, @args, $out, @output, $x );      my( $encoded, $ua, $args, @args, $out, @output, $x );
652    
653      $ua = new LWP::UserAgent;      $ua = new LWP::UserAgent;
654      $ua->timeout( 900 );      $ua->timeout( 900 );
   
655      if ($type =~/post/i)      if ($type =~/post/i)
656      {      {
657          $args = [];          $args = [];
# Line 435  Line 711 
711  }  }
712    
713  sub trim_output {  sub trim_output {
714        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
715      my($out) = @_;      my($out) = @_;
716      my $i;      my $i;
717    
# Line 472  Line 749 
749  }  }
750    
751  sub set_prot_links {  sub set_prot_links {
752        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
753      my($cgi,$x) = @_;      my($cgi,$x) = @_;
754      my($before,$match,$after);      my($before,$match,$after);
755    
756      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)$/)      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)/s)
757        {
758            $before = $1;
759            $match = $2;
760            $after = $3;
761            return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after);
762        }
763        elsif ($x =~ /^(.*)\b([NXYZA]P_[0-9\.]+)\b(.*)/s)
764        {
765            $before = $1;
766            $match = $2;
767            $after = $3;
768            return &set_prot_links($cgi,$before) . &HTML::refseq_link($cgi,$match) . &set_prot_links($cgi,$after);
769        }
770        elsif ($x =~ /^(.*)(gi\|\d+)(.*)/s)
771        {
772            $before = $1;
773            $match = $2;
774            $after = $3;
775            return &set_prot_links($cgi,$before) . &HTML::gi_link($cgi,$match) . &set_prot_links($cgi,$after);
776        }
777        elsif ($x =~ /^(.*)(tigr\|[0-9a-zA-Z]+)(.*)/s)
778      {      {
779          $before = $1;          $before = $1;
780          $match = $2;          $match = $2;
781          $after = $3;          $after = $3;
782          return &set_prot_links($cgi,$before) . &HTML::fid_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);
783      }      }
784      elsif ($x =~ /^(.*)(gi\|\d+)(.*)$/)      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
785      {      {
786          $before = $1;          $before = $1;
787          $match = $2;          $match = $2;
788          $after = $3;          $after = $3;
789          return &set_prot_links($cgi,$before) . &HTML::gi_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);
790      }      }
791      elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)$/)      elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)/s)
792      {      {
793          $before = $1;          $before = $1;
794          $match = $2;          $match = $2;
795          $after = $3;          $after = $3;
796          return &set_prot_links($cgi,$before) . &HTML::sp_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);
797      }      }
798      elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)$/)      elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)/s)
799      {      {
800          $before = $1;          $before = $1;
801          $match = $2;          $match = $2;
802          $after = $3;          $after = $3;
803          return &set_prot_links($cgi,$before) . &HTML::pir_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);
804        }
805        elsif ($x =~ /^(.*)(kegg\|[a-z]{2,4}:[a-zA-Z_0-9]+)(.*)/s)
806        {
807            $before = $1;
808            $match = $2;
809            $after = $3;
810            return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after);
811      }      }
812      return $x;      return $x;
813  }  }
814    
815    sub refseq_link {
816        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
817        my($cgi,$id) = @_;
818    
819        if ($id =~ /^[NXYZA]P_/)
820        {
821            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id>$id</a>";
822        }
823    }
824    
825  sub gi_link {  sub gi_link {
826        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
827      my($cgi,$gi) = @_;      my($cgi,$gi) = @_;
828    
829      if ($gi =~ /^gi\|(\d+)$/)      if ($gi =~ /^gi\|(\d+)$/)
# Line 516  Line 833 
833      return $gi;      return $gi;
834  }  }
835    
836    sub tigr_link {
837        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
838        my($cgi,$tigr) = @_;
839    
840        if ($tigr =~ /^tigr\|([0-9a-zA-Z]+)$/)
841        {
842            return "<a href=\"http://pathema.tigr.org/tigr-scripts/CMR/GenePage.cgi?locus=$1\">$tigr</a>";
843        }
844        return $tigr;
845    }
846    
847    sub uni_link {
848        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
849        my($cgi,$uni) = @_;
850    
851        if ($uni =~ /^uni\|(\S+)$/)
852        {
853            return "<a href=http://www.pir.uniprot.org/cgi-bin/upEntry?id=$1>$uni</a>";
854        }
855        return $uni;
856    }
857    
858  sub sp_link {  sub sp_link {
859        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
860      my($cgi,$sp) = @_;      my($cgi,$sp) = @_;
861    
862      if ($sp =~ /^sp\|(\S+)$/)      if ($sp =~ /^sp\|(\S+)$/)
# Line 527  Line 867 
867  }  }
868    
869  sub pir_link {  sub pir_link {
870        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
871      my($cgi,$pir) = @_;      my($cgi,$pir) = @_;
872    
873      if ($pir =~ /^pirnr\|(NF\d+)$/)      if ($pir =~ /^pirnr\|(NF\d+)$/)
# Line 536  Line 877 
877      return $pir;      return $pir;
878  }  }
879    
880    sub kegg_link {
881        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
882        my($cgi,$kegg) = @_;
883    
884        if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)
885        {
886            return "<a href=http://www.genome.ad.jp/dbget-bin/www_bget?$1+$2>$kegg</a>";
887        }
888        return $kegg;
889    }
890    
891    sub set_map_links {
892        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
893        my($cgi,$x) = @_;
894        my($before,$match,$after);
895    
896        my $org = ($cgi->param('org') || $cgi->param('genome') || "");
897    
898        if ($x =~ /^(.*)(MAP\d+)(.*)/s)
899        {
900            $before = $1;
901            $match = $2;
902            $after = $3;
903            return &set_map_links($cgi,$before) . &map_link($cgi,$match,$org) . &set_map_links($cgi,$after);
904        }
905        return $x;
906    }
907    
908    sub map_link {
909        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
910        my($cgi,$map,$org) = @_;
911    
912        $user = $cgi->param('user');
913        $user = $user ? $user : "";
914        $org = $org ? $org : "";
915    
916        my $url = &FIG::cgi_url() . "/show_kegg_map.cgi?user=$user&map=$map&org=$org";
917        my $link = "<a href=\"$url\">$map</a>";
918        return $link;
919    }
920    
921    sub java_buttons {
922        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
923      ## ADDED BY RAE
924      # Provides code to include check all/first half/second half/none for javascrspt
925      # this takes two variables - the form name provided in start_form with the
926      # -name => field and the checkbox name
927      my ($form, $button)=@_;
928    
929      $java_script="<input type=\"button\" name=\"CheckAll\" value=\"Check All\"\nonClick=\"checkAll(document.$form.$button)\">\n";
930      $java_script.="<input type=\"button\" name=\"CheckFirst\" value=\"Check First Half\"\nonClick=\"checkFirst(document.$form.$button)\">\n";
931      $java_script.="<input type=\"button\" name=\"CheckSecond\" value=\"Check Second Half\"\nonClick=\"checkSecond(document.$form.$button)\">\n";
932      $java_script.="<input type=\"button\" name=\"UnCheckAll\" value=\"Uncheck All\"\nonClick=\"uncheckAll(document.$form.$button)\">\n";
933    
934      return $java_script;
935    }
936    
937    sub sub_link {
938        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
939        my($cgi,$sub) = @_;
940        my($sub_link);
941    
942        my $user = $cgi->param('user');
943        if ($user)
944        {
945            my $esc_sub = uri_escape( $sub );
946            $sub_link = "<a href=./subsys.cgi?ssa_name=$esc_sub&request=show_ssa&user=$user>$sub</a>";
947        }
948        else
949        {
950            $sub_link = $sub;
951        }
952        return $sub_link;
953    }
954    
955    sub reaction_link {
956        my($reaction) = @_;
957    
958        if ($reaction =~ /^R\d+/)
959        {
960            return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?rn+$reaction\" target=reaction$$>$reaction</a>";
961        }
962        return $reaction;
963    }
964    
965  1  1

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3