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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3