[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.81, Tue Jan 24 23:51:22 2006 UTC revision 1.121, Thu Mar 13 20:10:57 2008 UTC
# Line 17  Line 17 
17    
18  package HTML;  package HTML;
19    
20    use strict;
21  use Tracer;  use Tracer;
22  use FIG;  use FIG;
23  use Carp;  use Carp;
# Line 27  Line 28 
28  use URI::URL;  use URI::URL;
29  use HTTP::Request::Common;  use HTTP::Request::Common;
30  use POSIX;  use POSIX;
31    use CGI;
32    
33    #use raelib; # now used for the excel function, that should eventually end up in here. Way too experimental!
34    my $raelib;
35    
36    
37  my $top_link_cache;  my $top_link_cache;
# Line 53  Line 58 
58    
59      my @parts = split(/\//, $ENV{SCRIPT_NAME});      my @parts = split(/\//, $ENV{SCRIPT_NAME});
60      my $top;      my $top;
61      if ($parts[-2] eq 'FIG')      if (defined $parts[-2] && $parts[-2] eq 'FIG')
62      {      {
63          $top = '.';          $top = '.';
64  #       warn "toplevel @parts\n";  #       warn "toplevel @parts\n";
65      }      }
66      elsif ($parts[-3] eq 'FIG')      elsif (defined $parts[-3] && $parts[-3] eq 'FIG')
67      {      {
68          $top = '..';          $top = '..';
69  #       warn "subdir @parts\n";  #       warn "subdir @parts\n";
# Line 78  Line 83 
83      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
84      my($additional_insert, $user, %options ) = @_;      my($additional_insert, $user, %options ) = @_;
85    
86        local $/ = "\n";
87    
88      my $header_name = $options{header_name} ? $options{header_name} : "html.hdr";      my $header_name = $options{header_name} ? $options{header_name} : "html.hdr";
89      my $tail_name = $options{tail_name} ? $options{tail_name} : "html.tail";      my $tail_name = $options{tail_name} ? $options{tail_name} : "html.tail";
90    
# Line 156  Line 163 
163  sub show_page {  sub show_page {
164      #warn "SHOWPAGE: cgi=", Dumper(@_);      #warn "SHOWPAGE: cgi=", Dumper(@_);
165      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
166      my($cgi,$html,$no_home, $alt_header, $css, $javasrc, $cookie) = @_;      my($cgi,$html,$no_home, $alt_header, $css, $javasrc, $cookie, $options) = @_;
167      my $i;      my $i;
168        Trace("Setting top link.") if T(3);
169      my $top = top_link();      my $top = top_link();
170    
171      # ARGUMENTS:      # ARGUMENTS:
# Line 171  Line 178 
178      #               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      #               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
179      #     $javasrc is a reference to an array of URLs to javascripts to be included (e.g. "FIG/Html/css/styleswitcher.js")      #     $javasrc is a reference to an array of URLs to javascripts to be included (e.g. "FIG/Html/css/styleswitcher.js")
180      #     $cookie is the name and value of the cookie to set. Note that you should probably use raelib->cookie to get/set your cookies      #     $cookie is the name and value of the cookie to set. Note that you should probably use raelib->cookie to get/set your cookies
181        #     $options is a reference to a hash of options that you can pass around the pages
182      #      #
183      # Find the HTML header      # Find the HTML header
184      #      #
185        Trace("Reading tail.") if T(3);
186        my $tail_name = $options->{tail_name} ? $options->{tail_name} : "html.tail";
187      my $html_tail_file = "./Html/$tail_name";      my $html_tail_file = "./Html/$tail_name";
188      if (! -f $html_tail_file)      if (! -f $html_tail_file)
189      {      {
190          $html_tail_file = "$FIG_Config::fig/CGI/Html/$tail_name";          $html_tail_file = "$FIG_Config::fig/CGI/Html/$tail_name";
191      }      }
192        Trace("Extracting user name and header data.") if T(3);
193      my $user = $cgi->param('user') || "";      my $user = $cgi->param('user') || "";
194      my @html_hdr;      my @html_hdr;
195      if ($alt_header && ref($alt_header) eq "ARRAY")      if ($alt_header && ref($alt_header) eq "ARRAY")
# Line 189  Line 198 
198      }      }
199      else      else
200      {      {
201          @html_hdr = compute_html_header(undef,$user);          @html_hdr = compute_html_header(undef,$user,%$options);
202      }      }
203    
204      # RAE: I am offloading the handling of cookies to CGI.pm since I don't know how they are set up.      # RAE: I am offloading the handling of cookies to CGI.pm since I don't know how they are set up.
# Line 197  Line 206 
206    
207      # Note: 3/10/05 commented this line out pending the discussion of adding cookies into the seed that we are waiting to see about      # Note: 3/10/05 commented this line out pending the discussion of adding cookies into the seed that we are waiting to see about
208      # to add cookies back in replace these two header lines with each other      # to add cookies back in replace these two header lines with each other
209        #my $hdr_thing = $cgi->header(-cookie=>$cookie);
210      #print $cgi->header(-cookie=>$cookie);      my $hdr_thing = $cgi->header();
211      print $cgi->header();      Trace("Printing HTML header: $hdr_thing.") if T(3);
212        print $hdr_thing;
213        Trace("Header printed.") if T(3);
214      #      #
215      #  The SEED header file goes immediately after <BODY>.  Figure out      #  The SEED header file goes immediately after <BODY>.  Figure out
216      #  what parts of the HTML document skeleton are there, and fill in      #  what parts of the HTML document skeleton are there, and fill in
# Line 245  Line 255 
255      my $body_line = -1;      my $body_line = -1;
256      my $last_head_line = -1;  #  If no head tags are found, text goes at top.      my $last_head_line = -1;  #  If no head tags are found, text goes at top.
257      my $done = 0;      my $done = 0;
258        Trace("Processing special cases.") if T(3);
259      for ( $i = 0; $i < @$html; $i++ )      for ( $i = 0; $i < @$html; $i++ )
260      {      {
261          #  Some special cases:          #  Some special cases:
# Line 291  Line 301 
301    
302      if ( 1 )      if ( 1 )
303      {      {
304            Trace("Sanity checks in progress.") if T(3);
305          if ( $html_line >= 0 )          if ( $html_line >= 0 )
306          {          {
307              if ( ( $head_line >= 0 ) && ( $html_line > $head_line ) )              if ( ( $head_line >= 0 ) && ( $html_line > $head_line ) )
308              {              {
309                  print STDERR "<HTML> tag follows <HEAD> tag\n";                  Trace("<HTML> tag follows <HEAD> tag.") if T(1);
310              }              }
311              if ( ( $head_end_line >= 0 ) && ( $html_line > $head_end_line ) )              if ( ( $head_end_line >= 0 ) && ( $html_line > $head_end_line ) )
312              {              {
313                  print STDERR "<HTML> tag follows </HEAD> tag\n";                  Trace("<HTML> tag follows </HEAD> tag.") if T(1);
314              }              }
315          }          }
316          if ( $head_line >= 0 )          if ( $head_line >= 0 )
317          {          {
318              if ( ( $head_end_line >= 0 ) && ( $head_line > $head_end_line ) )              if ( ( $head_end_line >= 0 ) && ( $head_line > $head_end_line ) )
319              {              {
320                  print STDERR "<HEAD> tag follows </HEAD> tag\n";                  Trace("<HEAD> tag follows </HEAD> tag.") if T(1);
321              }              }
322          }          }
323      }      }
324        Trace("Sanity checks complete.") if T(3);
325      #      #
326      #  Okay.  Let's put in the html header file, and missing tags:      #  Okay.  Let's put in the html header file, and missing tags:
327      #      #
# Line 321  Line 332 
332      #  Note if no buttons are added we still (at the moment) add the script,      #  Note if no buttons are added we still (at the moment) add the script,
333      #  but it only adds a little text (495 characters) to the html and noone will notice!      #  but it only adds a little text (495 characters) to the html and noone will notice!
334      #  RAE: This is now deprecated because everything is in an external file, FIG.js, included later      #  RAE: This is now deprecated because everything is in an external file, FIG.js, included later
   
335      if ( $body_line < 0 )      if ( $body_line < 0 )
336      {      {
337          $body_line = $last_head_line + 1;          $body_line = $last_head_line + 1;
338            Trace("Splicing body line at $body_line.") if T(3);
339          splice( @$html, $body_line, 0, "<BODY>\n" );          splice( @$html, $body_line, 0, "<BODY>\n" );
340      }      }
341    
# Line 334  Line 345 
345    
346      if (@html_hdr)      if (@html_hdr)
347      {      {
348            Trace("Splicing SEED page header after $body_line.") if T(3);
349          splice( @$html, $body_line + 1, 0, @html_hdr );          splice( @$html, $body_line + 1, 0, @html_hdr );
350      }      }
351    
# Line 344  Line 356 
356      if ( $head_end_line < 0 )      if ( $head_end_line < 0 )
357      {      {
358          $head_end_line = $body_line;          $head_end_line = $body_line;
359            Trace("Splicing header terminater at $body_line.") if T(3);
360          splice( @$html, $body_line, 0, "</HEAD>\n" );          splice( @$html, $body_line, 0, "</HEAD>\n" );
361      }      }
362    
# Line 353  Line 366 
366      # be moved out, but I want to try it and see what happens.  css has the format:      # be moved out, but I want to try it and see what happens.  css has the format:
367      #      #
368      # <link rel='stylesheet' title='default' href='/css/default.css' type='text/css'>      # <link rel='stylesheet' title='default' href='/css/default.css' type='text/css'>
369        Trace("Formatting CSS.") if T(3);
370      # convert the default key to the right case. and eliminate dups      # convert the default key to the right case. and eliminate dups
371      foreach my $k (keys %$css) {if (lc($k) eq "default") {$css->{'Default'}=$css->{$k}}}      foreach my $k (keys %$css) {if (lc($k) eq "default") {$css->{'Default'}=$css->{$k}}}
372    
# Line 383  Line 396 
396    
397      # the file FIG.js contains most of the java script we use routinely. Every browser will just cache this and so      # the file FIG.js contains most of the java script we use routinely. Every browser will just cache this and so
398      # it will reduce our overhead.      # it will reduce our overhead.
399        Trace("Formatting javascript.") if T(3);
400      # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts      # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts
401      push @$javasrc, "Html/css/FIG.js";      push @$javasrc, "Html/css/FIG.js";
402      foreach my $script (@$javasrc) {      foreach my $script (@$javasrc) {
403          $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";          $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";
404      }      }
405    
406        Trace("Re-splicing the header terminator at $head_end_line.") if T(3);
   
407      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.      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.
408    
409      #      #
# Line 409  Line 421 
421          # BASE href needs to be absolute. RDO.          # BASE href needs to be absolute. RDO.
422          #          #
423          #          #
424          $base_url = &FIG::cgi_url;  #        $base_url = &FIG::cgi_url;
425  #       my $base_url = $FIG_Config::cgi_base;  #       my $base_url = $FIG_Config::cgi_base;
426  #       if ( ! $base_url )                      # if cgi_base was not defined  #       if ( ! $base_url )                      # if cgi_base was not defined
427  #       {  #       {
# Line 432  Line 444 
444      if ( $html_line < 0 )      if ( $html_line < 0 )
445      {      {
446          $html_line = 0;          $html_line = 0;
447            Trace("Splicing the HTML tag at $html_line.") if T(3);
448          splice( @$html, $html_line, 0, "<HTML>\n" );          splice( @$html, $html_line, 0, "<HTML>\n" );
449      }      }
450    
# Line 442  Line 455 
455      if ( $head_line < 0 )      if ( $head_line < 0 )
456      {      {
457          $head_line = $html_line + 1;          $head_line = $html_line + 1;
458            Trace("Splicing the HEAD tag at $head_line.") if T(3);
459          splice( @$html, $head_line, 0, "<HEAD>\n" );          splice( @$html, $head_line, 0, "<HEAD>\n" );
460      }      }
461    
462      #      #
463      #  Place FIG search link at bottom of page      #  Place FIG search link at bottom of page
464      #      #
465        Trace("Placing FIG search link.") if T(3);
466      my @tail = -f $html_tail_file ? `cat $html_tail_file` : ();      my @tail = -f $html_tail_file ? `cat $html_tail_file` : ();
467      if (! $no_home)      if (! $no_home)
468      {      {
# Line 459  Line 473 
473      #      #
474      # See if we have a site-specific tail (for disclaimers, etc).      # See if we have a site-specific tail (for disclaimers, etc).
475      #      #
476        Trace("Placing site tail.") if T(3);
477      my $site_tail = "$FIG_Config::fig_disk/config/site_tail.html";      my $site_tail = "$FIG_Config::fig_disk/config/site_tail.html";
478      my $site_fh;      my $site_fh;
479      if (open($site_fh, "<$site_tail"))      if (open($site_fh, "<$site_tail"))
# Line 473  Line 487 
487      #  or before </html>, or at end of page.      #  or before </html>, or at end of page.
488      #      #
489      my @tags = ();      my @tags = ();
490      # Check for a tracing queue.      Trace("Processing closing tags.") if T(3);
     my $traceString = QTrace("HTML");  
     if ($traceString) {  
         push @tags, $traceString;  
     }  
491      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}
492      if ($i >= @$html)        # </body> not found; look for </html>      if ($i >= @$html)        # </body> not found; look for </html>
493      {      {
# Line 492  Line 502 
502    
503      if ( @tail )      if ( @tail )
504      {      {
505            Trace("Splicing tail.") if T(3);
506          splice( @$html, $i, 0, @tail, @tags );          splice( @$html, $i, 0, @tail, @tags );
507      }      }
508      elsif ( @tags )      elsif ( @tags )
509      {      {
510            Trace("Splicing tags.") if T(3);
511          splice( @$html, $i, 0, @tags );          splice( @$html, $i, 0, @tags );
512      }      }
513    
514        Trace("Printing the HTML array.") if T(3);
515      # RAE the chomp will return any new lines at the ends of elements in the array,      # RAE the chomp will return any new lines at the ends of elements in the array,
516      # and then we can join  with a "\n". This is because somethings put newlines in,      # and then we can join  with a "\n". This is because somethings put newlines in,
517      # and others don't. This should make nicer looking html      # and others don't. This should make nicer looking html
# Line 507  Line 520 
520      # print join "\n", @$html;      # print join "\n", @$html;
521      #      #
522      # Apparently the above still breaks things. This is the correct code:      # Apparently the above still breaks things. This is the correct code:
   
523      foreach $_ (@$html)      foreach $_ (@$html)
524      {      {
525          print $_;          my $line = $_;
526            if (T(4)) {
527                my $escapedLine = CGI::escapeHTML($line);
528                Trace("Printing:\n$escapedLine") if T(4);
529            }
530            print $line;
531      }      }
532    
533  }  }
534    
535    
536    =head1 make_table
537    
538    The main method to convert an array into a table.
539    
540    The col_hdrs are set to the <th> headers, the $tab is an array of arrays. The first is the rows, and the second is the columns. The title is the title of the table.
541    
542    The options define the settings for the table such as border, width, and class for css formatting. If the option "excelfile" is set to a filename that will be created in FIG_Config::temp, and the link included that allows the user to download the file as an excel file.
543    
544    =cut
545    
546  sub make_table {  sub make_table {
547      my($col_hdrs,$tab,$title, %options ) = @_;      my($col_hdrs,$tab,$title, %options ) = @_;
548      my(@tab);      my(@tab);
549    
550      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";
551      my $width = defined $options{width} ? "width=\"$options{width}\"" : undef;      my $width = defined $options{width} ? "width=\"$options{width}\"" : "";
552      my $class = defined $options{class} ? "class=\"$options{class}\"" : undef;      my $class = defined $options{class} ? "class=\"$options{class}\"" : "";
553      push( @tab, "\n<table $border $width $class>\n",      push( @tab, "\n<table $border $width $class>\n",
554                  "\t<caption><b>$title</b></caption>\n",                  "\t<caption><b>$title</b></caption>\n",
555                  "\t<tr>\n\t\t"                  "\t<tr>\n\t\t"
# Line 539  Line 567 
567              );              );
568      }      }
569      push(@tab,"</table>\n");      push(@tab,"</table>\n");
570    
571        # excelfile should be appropriate for a filename (no spaces/special characters)
572        if (defined $options{"excelfile"}) {
573            if (! defined($raelib)) {
574                require raelib;
575                $raelib = new raelib;
576            }
577            push @tab, $raelib->tab2excel($col_hdrs,$tab,$title,\%options,$options{"excelfile"})}
578    
579      return join("",@tab);      return join("",@tab);
580  }  }
581    
# Line 780  Line 817 
817      return "<a href=$link>$role</a>";      return "<a href=$link>$role</a>";
818  }  }
819    
820  #  =head2 fid_link
821  # Local means to eliminate the fig|org.peg from the  
822  # text of the link.  Get a link to a fid.
823  #  
824    use: my $html=&HTML::fid_link($cgi, $fid, Local, Just_URL, Full_Path);
825    
826    Local is a boolean means to eliminate the fig|org.peg from the text of the link.
827    
828    Just_URL will only return the URL and not the HTML code. The default is to return the full code.
829    
830    Full_Path is a boolean that will get the full path to the URL not just a relative path. This is required in pages where the base href changes (e.g. if an image is imported like on the metabolic pages).
831    
832    =cut
833    
834    
835  sub fid_link {  sub fid_link {
836      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
837      my($cgi,$fid,$local,$just_url) = @_;      my($cgi,$fid,$local,$just_url,$fullpath) = @_;
838        Trace("Creating link for feature $fid.") if T(4);
839        my $err=join(" ", $cgi,$fid,$local,$just_url,$fullpath);
840    
841      my($n);      my($n);
842    
843      my $top = top_link();      my $top = top_link();
844        if ($fullpath) {$top=$FIG_Config::cgi_url}
845    
846      if ($fid =~ /^fig\|\d+\.\d+\.([a-z]+)\.(\d+)/)      if ($fid =~ /^fig\|\d+\.\d+\.([a-zA-Z]+)\.(\d+)/)
847      {      {
848          if ($local)          if ($local)
849          {          {
# Line 810  Line 862 
862          }          }
863    
864          my $link;          my $link;
865            my $new_framework = $cgi->param('new_framework') ? 1 : 0;
866          #added to format prophage and path island links to feature.cgi          #added to format prophage and path island links to feature.cgi
867          if ($1 ne "peg")          my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
868            my $virt = "&48hr_job=" . $cgi->param("48hr_job");
869            Trace("Sprout mode is \"$sprout\".") if T(4);
870            if ($1 ne "peg" && ! $sprout)
871          {          {
872               Trace("Creating feature link for $fid.") if T(4);
873             my $user = $cgi->param('user');             my $user = $cgi->param('user');
874             if (! $user) { $user = "" }             if (! $user) { $user = "" }
875             my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";             $link = "$top/feature.cgi?feature=$fid&user=$user$sprout$virt";
            $link = "$top/feature.cgi?feature=$fid&user=$user$trans$sprout";  
876             $link =~ s/[a-z_A-Z0-9]+\.cgi\?/feature.cgi?/;             $link =~ s/[a-z_A-Z0-9]+\.cgi\?/feature.cgi?/;
877          }          }
878          else          else
879          {          {
880                Trace("Creating protein link for $fid.") if T(4);
881              my $user = $cgi->param('user');              my $user = $cgi->param('user');
882              if (! $user) { $user = "" }              if (! $user) { $user = "" }
883              my $trans = $cgi->param('translate') ? "&translate=1" : "";              my $trans = $cgi->param('translate') ? "&translate=1" : "";
# Line 836  Line 893 
893    
894              #if (! $cgi_url) { $cgi_url = &FIG::cgi_url }              #if (! $cgi_url) { $cgi_url = &FIG::cgi_url }
895              #$link = $cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";              #$link = $cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
896              $link = "$top/protein.cgi?prot=$fid&user=$user$trans$sprout";              $link = "$top/protein.cgi?prot=$fid&user=$user$trans$sprout$virt\&new_framework=$new_framework";
897              $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;              $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
898          }          }
899          if ($just_url)          if ($just_url)
# Line 845  Line 902 
902          }          }
903          else          else
904          {          {
905              return "<a href=$link>$n</a>";              return "<a href='$link'>$n</a>";
906          }          }
907      }      }
908      return $fid;      return $fid;
# Line 858  Line 915 
915      return $family;      return $family;
916  }  }
917    
918    =head2 evidence_codes_explain
919    
920    Given an evidence code, returns a string that explains this eveidence code.
921    
922    =cut
923    
924    sub evidence_codes_explain {
925     my($ec)=@_;
926     return unless ($ec);
927    
928     $ec=uc($ec);
929     return "IDA: Inferred from Direct Assay" if ($ec =~ /IDA/);
930     return "IGI: Inferred from Genetic Interaction" if ($ec =~ /IGI/);
931     return "TAS: Traceable Author Statement" if ($ec =~ /TAS/);
932     return "ISU: in subsystem unique" if ($ec =~ /ISU/);
933     return "$ec: in subsystem duplicates" if ($ec =~ /IDU/);
934     return "$ec: in cluster with" if ($ec =~ /ICW/);
935     return "FF: in FIGfam" if ($ec =~ /FF/);
936     return "CWN: clustered with nonhypothetical" if ($ec =~ /CWN/);
937     return "CWH: clustered, but only with hypotheticals" if ($ec =~ /CWH/);
938     return "DLIT: literature references to this gene exist" if ($ec =~ /DLIT/);
939     return "ILIT: no references to this gene exist, but they do to other genes with the same functional role" if ($ec =~ /ILIT/);
940     return "$ec: unknown!";
941    }
942    
943  sub get_html {  sub get_html {
944      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
# Line 877  Line 958 
958          my $response = $ua->request($request);          my $response = $ua->request($request);
959          $out = $response->content;          $out = $response->content;
960      }      }
961      else  
962        if ($type =~/get/i)
963      {      {
964          @args = ();          @args = ();
965          foreach $x (@$kv_pairs)          foreach $x (@$kv_pairs)
# Line 889  Line 971 
971          {          {
972              $url .= "?" . join("&",@args);              $url .= "?" . join("&",@args);
973          }          }
974          $request = new HTTP::Request('GET', $url);          my $request = new HTTP::Request('GET', $url);
975          my $response = $ua->request($request);          my $response = $ua->request($request);
976    
977          if ($response->is_success)          if ($response->is_success)
# Line 907  Line 989 
989    
990  #   Now splice in a line of the form <base href=URL> to cause all relative links to work  #   Now splice in a line of the form <base href=URL> to cause all relative links to work
991  #   properly.  Remove the header.  #   properly.  Remove the header.
992        my $i;
993      for ($i=0; ($i < @output) && ($output[$i] !~ /^\s*\</); $i++) {}      for ($i=0; ($i < @output) && ($output[$i] !~ /^\s*\</); $i++) {}
994      if ($i < @output)      if ($i < @output) {
     {  
   
995          splice(@output,0,$i);          splice(@output,0,$i);
996      }      }
997    
# Line 927  Line 1007 
1007  sub trim_output {  sub trim_output {
1008      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1009      my($out) = @_;      my($out) = @_;
1010      my $i;      my ($i, $j);
1011    
1012      for ($i=0; ($i < @$out) && ($out->[$i] !~ /^\</); $i++) {}      for ($i=0; ($i < @$out) && ($out->[$i] !~ /^\</); $i++) {}
1013      splice(@$out,0,$i);      splice(@$out,0,$i);
# Line 956  Line 1036 
1036      for ($j=$i-1; ($j > 0) && ($out->[$j] !~ /FIG search/); $j--) {}      for ($j=$i-1; ($j > 0) && ($out->[$j] !~ /FIG search/); $j--) {}
1037      if ($j > 0)      if ($j > 0)
1038      {      {
1039            #
1040            # Hm. We would have tried using the options here:
1041            # my $tail_name = $options{tail_name} ? $options{tail_name} : "html.tail";
1042            # but they're not passed in. So use the default html.tail.
1043            #
1044            my $html_tail_file = "./Html/html.tail";
1045          my @tmp = `cat $html_tail_file`;          my @tmp = `cat $html_tail_file`;
1046          my $n = @tmp;          my $n = @tmp;
1047          splice(@$out,$j-$n,$n+1);          splice(@$out,$j-$n,$n+1);
1048      }      }
1049  }  }
1050    
1051    =head2 alias_url
1052    
1053    Returns the url that links to an external page showing information about the given alias.
1054    The type of the alias will be determined by the prefix (i.e. 'tr|' for Trembl) If the type
1055    cannot be determined, the function will return undef.
1056    
1057    use: my $html=&HTML::alias_url($alias, $type);
1058    
1059    =cut
1060    
1061    sub alias_url {
1062      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1063    
1064      my ($id, $type) = @_;
1065    
1066      if ($type eq "SEED") { # 1
1067        return "http://seed-viewer.theseed.org/linkin.cgi?id=$id";
1068      }
1069      elsif ($type eq "UniProt") {
1070        return "http://www.uniprot.org/entry/$id";
1071      }
1072      elsif ($type eq "UniProt_ac") { # 2
1073        return "http://www.uniprot.org/entry/$id";
1074      }
1075      elsif ($type eq "UniProt_id") { # 3
1076        return "http://www.uniprot.org/entry/$id";
1077      }
1078      elsif ($type eq "EntrezGene") { # 4
1079        return "http://www.ncbi.nlm.nih.gov/entrez/viewer.fcgi?db=protein&id=$id";
1080      }
1081      elsif ($type eq "RefSeq") { # 5
1082        return "http://www.ncbi.nlm.nih.gov/entrez/viewer.fcgi?db=protein&id=$id";
1083      }
1084      elsif ($type eq "GIID") { # 6
1085        return "http://www.ncbi.nlm.nih.gov/entrez/viewer.fcgi?db=protein&id=$id";
1086      }
1087      elsif ($type eq "NCBI") {
1088        return "http://www.ncbi.nlm.nih.gov/entrez/viewer.fcgi?db=protein&id=$id";
1089      }
1090      elsif ($type eq "PDB") { # 7
1091        $id =~ s/\:\w//;
1092        return "http://www.rcsb.org/pdb/explore/explore.do?structureId=$id";
1093      }
1094      elsif ($type eq "PFAM") { # 8
1095        return "http://pfam.janelia.org/family?acc=$id";
1096      }
1097      elsif ($type eq "GO") { # 9
1098        return "http://amigo.geneontology.org/cgi-bin/amigo/go.cgi?view=details&search_constraint=terms&depth=0&query=$id";
1099      }
1100      elsif ($type eq "PIRSF") { # 10
1101        return "http://pir.georgetown.edu/cgi-bin/ipcSF?id=$id";
1102      }
1103      elsif ($type eq "IPI") { # 11
1104        return "http://srs.ebi.ac.uk/srsbin/cgi-bin/wgetz?-newId+[IPI-AllText:".$id."*]+-lv+30+-view+SeqSimpleView+-page+qResult";
1105      }
1106      elsif ($type eq "UniRef_100") { # 12
1107        return "http://www.uniprot.org/entry/$id";
1108      }
1109      elsif ($type eq "UniRef_90") { # 13
1110        return "http://www.uniprot.org/entry/$id";
1111      }
1112      elsif ($type eq "UniRef_50") { # 14
1113        return "http://www.uniprot.org/entry/$id";
1114      }
1115      elsif ($type eq "UniParc") { # 15
1116        return "http://www.uniprot.org/entry/$id";
1117      }
1118      elsif ($type eq "PIR-PSD") { # 16
1119        return "http://pir.georgetown.edu/cgi-bin/pir_psd_get.pl?id=$id";
1120      }
1121      elsif ($type eq "Taxon_ID") { # 17
1122        return "http://www.ncbi.nlm.nih.gov/Taxonomy/Browser/wwwtax.cgi?id=$id";
1123      }
1124      elsif ($type eq "OMIM") { # 18
1125        return "http://www.ncbi.nlm.nih.gov/entrez/dispomim.cgi?id=$id";
1126      }
1127      elsif ($type eq "UniGene") { # 19
1128        return "http://www.ncbi.nlm.nih.gov/sites/entrez?db=unigene&cmd=search&term=$id";
1129      }
1130      elsif ($type eq "Ensemble_ID") { # 20
1131        #return "$id";
1132      }
1133      elsif ($type eq "PMID") { # 21
1134        return "http://www.ncbi.nlm.nih.gov/pubmed/$id";
1135      }
1136      elsif ($type eq "EMBL_DNA_AC") { # 22
1137        return "http://srs.ebi.ac.uk/srsbin/cgi-bin/wgetz?-e+[EMBL:".$id."]+-newId";
1138      }
1139      elsif ($type eq "EMBL_Protein_AC") { # 23
1140        $id =~ s/\.\d//;
1141        return "http://srs.ebi.ac.uk/srsbin/cgi-bin/wgetz?-e+[{EMBL}-ProteinID:".$id."]";
1142      }
1143      elsif ($type eq "CMR") { # 24
1144        if ($id =~ s/^\d+$//) {
1145          return "http://cmr.jcvi.org/cgi-bin/CMR/shared/GenePage.cgi?type=PID&acc=".$id;
1146        } else {
1147          return "http://cmr.jcvi.org/tigr-scripts/CMR/shared/GenePage.cgi?locus=".$id;
1148        }
1149      }
1150    
1151      return undef;
1152    }
1153    
1154  sub set_prot_links {  sub set_prot_links {
1155      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1156      my($cgi,$x) = @_;      my($cgi,$x) = @_;
# Line 988  Line 1177 
1177          $after = $3;          $after = $3;
1178          return &set_prot_links($cgi,$before) . &HTML::gi_link($cgi,$match) . &set_prot_links($cgi,$after);          return &set_prot_links($cgi,$before) . &HTML::gi_link($cgi,$match) . &set_prot_links($cgi,$after);
1179      }      }
1180      elsif ($x =~ /^(.*)(tigr\|[0-9a-zA-Z]+)(.*)/s)      elsif ($x =~ /^(.*)(img\|\d+)(.*)/s)
1181        {
1182            $before = $1;
1183            $match = $2;
1184            $after = $3;
1185            return &set_prot_links($cgi,$before) . &HTML::img_link($cgi,$match) . &set_prot_links($cgi,$after);
1186        }
1187        elsif ($x =~ /^(.*)(tigr\|\w+)(.*)/s)
1188      {      {
1189          $before = $1;          $before = $1;
1190          $match = $2;          $match = $2;
1191          $after = $3;          $after = $3;
1192          return &set_prot_links($cgi,$before) . &HTML::tigr_link($cgi,$match) . &set_prot_links($cgi,$after);          return &set_prot_links($cgi,$before) . &HTML::tigr_link($cgi,$match) . &set_prot_links($cgi,$after);
1193      }      }
1194      elsif ($x =~ /^(.*)\beric\|\w+\b(.*)/s)      elsif ($x =~ /^(.*)(tigrcmr\|\w+)(.*)/s)
1195        {
1196            $before = $1;
1197            $match = $2;
1198            $after = $3;
1199            return &set_prot_links($cgi,$before) . &HTML::tigr_link($cgi,$match) . &set_prot_links($cgi,$after);
1200        }
1201        elsif ($x =~ /^(.*)\b(eric\|\S+)\b(.*)/s)
1202      {      {
1203          $before = $1;          $before = $1;
1204          $match = $2;          $match = $2;
# Line 1003  Line 1206 
1206          return &set_prot_links($cgi,$before) . &HTML::eric_link($cgi,$match) . &set_prot_links($cgi,$after);          return &set_prot_links($cgi,$before) . &HTML::eric_link($cgi,$match) . &set_prot_links($cgi,$after);
1207      }      }
1208    
1209      elsif ($x =~ /^(.*)\bbhb\|.*?\b(.*)/s)      elsif ($x =~ /^(.*)\b(bhb\|.*?)\b(.*)/s)
1210      {      {
1211          $before = $1;          $before = $1;
1212          $match = $2;          $match = $2;
# Line 1011  Line 1214 
1214          return &set_prot_links($cgi,$before) . &HTML::bhb_link($cgi,$match) . &set_prot_links($cgi,$after);          return &set_prot_links($cgi,$before) . &HTML::bhb_link($cgi,$match) . &set_prot_links($cgi,$after);
1215      }      }
1216    
1217      elsif ($x =~ /^(.*)\bapidb\|.*?\..*\b(.*)/s)      elsif ($x =~ /^(.*)\b(apidb\|[0-9\.a-z_]+)\b(.*)/s)
1218      {      {
1219          $before = $1;          $before = $1;
1220          $match = $2;          $match = $2;
# Line 1019  Line 1222 
1222          return &set_prot_links($cgi,$before) . &HTML::apidb_link($cgi,$match) . &set_prot_links($cgi,$after);          return &set_prot_links($cgi,$before) . &HTML::apidb_link($cgi,$match) . &set_prot_links($cgi,$after);
1223      }      }
1224    
1225      elsif ($x =~ /^(.*)\bpatric\|.*?\b(.*)/s)      elsif ($x =~ /^(.*)\b(patric\|.*?)\b(.*)/s)
1226      {      {
1227          $before = $1;          $before = $1;
1228          $match = $2;          $match = $2;
# Line 1027  Line 1230 
1230          return &set_prot_links($cgi,$before) . &HTML::patric_link($cgi,$match) . &set_prot_links($cgi,$after);          return &set_prot_links($cgi,$before) . &HTML::patric_link($cgi,$match) . &set_prot_links($cgi,$after);
1231      }      }
1232    
1233      elsif ($x =~ /^(.*)\bvbrc\|.*?\b(.*)/s)      elsif ($x =~ /^(.*)\b(vbrc\|.*?)\b(.*)/s)
1234      {      {
1235          $before = $1;          $before = $1;
1236          $match = $2;          $match = $2;
# Line 1035  Line 1238 
1238          return &set_prot_links($cgi,$before) . &HTML::vbrc_link($cgi,$match) . &set_prot_links($cgi,$after);          return &set_prot_links($cgi,$before) . &HTML::vbrc_link($cgi,$match) . &set_prot_links($cgi,$after);
1239      }      }
1240    
1241      elsif ($x =~ /^(.*)\bvectorbase\|.*?\b(.*)/s)      elsif ($x =~ /^(.*)\b(vectorbase\|.*?)\b(.*)/s)
1242      {      {
1243          $before = $1;          $before = $1;
1244          $match = $2;          $match = $2;
# Line 1091  Line 1294 
1294          $after = $3;          $after = $3;
1295          return &set_prot_links($cgi,$before) . &HTML::mim_link($cgi,$match) . &set_prot_links($cgi,$after);          return &set_prot_links($cgi,$before) . &HTML::mim_link($cgi,$match) . &set_prot_links($cgi,$after);
1296      }      }
1297      elsif ($x =~ /^(.*)(UniGene:[a-zA-Z_0-9\.]+)(.*)/s)      elsif ($x =~ /^(.*)(HGNC:[a-zA-Z_0-9\.]+)(.*)/s)
1298      {      {
1299          $before = $1;          $before = $1;
1300          $match = $2;          $match = $2;
1301          $after = $3;          $after = $3;
1302          return &set_prot_links($cgi,$before) . &HTML::unigene_link($cgi,$match) . &set_prot_links($cgi,$after);          return &set_prot_links($cgi,$before) . &HTML::hgnc_link($cgi,$match) . &set_prot_links($cgi,$after);
1303      }      }
1304      elsif ($x =~ /^(.*)(IPI:[a-zA-Z_0-9\.]+)(.*)/s)      elsif ($x =~ /^(.*)(UniGene:[a-zA-Z_0-9\.]+)(.*)/s)
1305      {      {
1306          $before = $1;          $before = $1;
1307          $match = $2;          $match = $2;
1308          $after = $3;          $after = $3;
1309          return &set_prot_links($cgi,$before) . &HTML::ipi_link($cgi,$match) . &set_prot_links($cgi,$after);          return &set_prot_links($cgi,$before) . &HTML::unigene_link($cgi,$match) . &set_prot_links($cgi,$after);
1310      }      }
1311    # IPI stopped working. turn off for now.
1312    #    elsif ($x =~ /^(.*)(IPI:[a-zA-Z_0-9\.]+)(.*)/s)
1313    #    {
1314    #        $before = $1;
1315    #        $match = $2;
1316    #        $after = $3;
1317    #        return &set_prot_links($cgi,$before) . &HTML::ipi_link($cgi,$match) . &set_prot_links($cgi,$after);
1318    #    }
1319      elsif ($x =~ /^(.*)(WP:[a-zA-Z_0-9\.]+)(.*)/s)      elsif ($x =~ /^(.*)(WP:[a-zA-Z_0-9\.]+)(.*)/s)
1320      {      {
1321          #wormbase          #wormbase
# Line 1141  Line 1352 
1352          $after = $3;          $after = $3;
1353          return &set_prot_links($cgi,$before) . &HTML::sgd_link($cgi,$match) . &set_prot_links($cgi,$after);          return &set_prot_links($cgi,$before) . &HTML::sgd_link($cgi,$match) . &set_prot_links($cgi,$after);
1354      }      }
1355        elsif ($x =~ /^(.*)(tr\|[a-zA-Z0-9]+)(.*)/s)
1356        {
1357    
1358          $before = $1;
1359          $match = $2;
1360          $after = $3;
1361    
1362          return &set_prot_links($cgi,$before) .  &HTML::trembl_link($cgi,$match) . &set_prot_links($cgi,$after);
1363        }
1364      return $x;      return $x;
1365  }  }
1366    
1367    sub trembl_link {
1368        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1369        my($cgi,$id) = @_;
1370    
1371        if ($id =~ /^tr\|(.*)/) {
1372          return "<a href='http://ca.expasy.org/uniprot/$1' target=_blank>$id</a>";
1373        } else {
1374          return "invalid call to trembl link";
1375        }
1376    }
1377    
1378  sub refseq_link {  sub refseq_link {
1379      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1380      my($cgi,$id) = @_;      my($cgi,$id) = @_;
1381    
1382      if ($id =~ /^[NXYZA]P_/)      if ($id =~ /^[NXYZA]P_/)
1383      {      {
1384          return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id>$id</a>";          return "<a href='http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id' target=_blank>$id</a>";
1385      }      }
1386      elsif ($id =~ /^[NXYZA]M_/)      elsif ($id =~ /^[NXYZA]M_/)
1387      {      {
1388          return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=nuccore&cmd=search&term=$id>$id</a>";          return "<a href='http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=nuccore&cmd=search&term=$id' target=_blank>$id</a>";
1389      }      }
1390  }  }
1391    
# Line 1164  Line 1395 
1395    
1396      if ($gi =~ /^gi\|(\d+)$/)      if ($gi =~ /^gi\|(\d+)$/)
1397      {      {
1398          return "<a href=http://www.ncbi.nlm.nih.gov:80/entrez/query.fcgi?cmd=Retrieve&db=Protein&list_uids=$1&dopt=GenPept>$gi</a>";          return "<a href='http://www.ncbi.nlm.nih.gov:80/entrez/query.fcgi?cmd=Retrieve&db=Protein&list_uids=$1&dopt=GenPept' target=_blank>$gi</a>";
1399      }      }
1400      return $gi;      return $gi;
1401  }  }
# Line 1173  Line 1404 
1404      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1405      my($cgi,$tigr) = @_;      my($cgi,$tigr) = @_;
1406    
1407      if ($tigr =~ /^tigr\|(NT|ntbp|ntbpA|BA|BMAA|BXB|GBA)([0-9a-zA-Z]+)$/)      if ($tigr =~ /^tigr\|(NT|ntbp|ntbpA|BA|BMAA|BXB|GBA)(\w+)$/)
1408      {      {
1409          my $id=$1.$2;          my $id=$1.$2;
1410          return "<a href=\"http://pathema.tigr.org/tigr-scripts/pathema/shared/GenePage.cgi?locus=$id\">$tigr</a> (Pathema)";          return "<a href=\"http://pathema.tigr.org/tigr-scripts/pathema/shared/GenePage.cgi?locus=$id\" target=_blank>$tigr</a> (Pathema)";
1411      }      }
1412      elsif ($tigr =~ /^tigr\|([0-9a-zA-Z]+)$/)      elsif ($tigr =~ /^tigr(cmr)?\|(\S+)$/)
1413      {      {
1414          return "<a href=\"http://www.tigr.org/tigr-scripts/CMR2/GenePage.spl?locus=$1\">$?tigr</a>";          return "<a href=\"http://www.tigr.org/tigr-scripts/CMR2/GenePage.spl?locus=$2\" target=_blank>$tigr</a>";
1415      }      }
1416      return $tigr;      return $tigr;
1417  }  }
# Line 1189  Line 1420 
1420      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1421      my($cgi,$eric) = @_;      my($cgi,$eric) = @_;
1422    
1423      if ($eric =~ /^eric\|(\w+)$/)      if ($eric =~ /^eric\|(\S+)/)
1424      {      {
1425          return "<a href=\"https://asap.ahabs.wisc.edu/asap/feature_info.php?FeatureID=$1\">$eric</a>";          return "<a href=\"https://asap.ahabs.wisc.edu/asap/feature_info.php?FeatureID=$1\" target=_blank>$eric</a>";
1426      }      }
1427      return $eric;      return $eric;
1428  }  }
# Line 1200  Line 1431 
1431      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1432      my($cgi,$bhb) = @_;      my($cgi,$bhb) = @_;
1433    
1434      return "<a href=\"http://www.biohealthbase.org\">$bhb</a>";      return "<a href=\"http://www.biohealthbase.org\" target=_blank>$bhb</a>";
1435  }  }
1436    
1437  sub apidb_link {  sub apidb_link {
# Line 1209  Line 1440 
1440    
1441      if ($api =~ /apidb\|(.*?)\.(.*)$/)      if ($api =~ /apidb\|(.*?)\.(.*)$/)
1442      {      {
1443          return "<a href=\"http://www.apidb.org/cgi-bin/redirect.cgi?taxon_id=$1&source_id=$2\">$api</a>";          return "<a href=\"http://www.apidb.org/cgi-bin/redirect.cgi?taxon_id=$1&source_id=$2\" target=_blank>$api</a>";
1444      }      }
1445      return $api;      return $api;
1446  }  }
# Line 1220  Line 1451 
1451    
1452      if ($patric =~ /patric\|(.*)/)      if ($patric =~ /patric\|(.*)/)
1453      {      {
1454          return "<a href=\"https://patric.vbi.vt.edu/software/curationTool/gep/pgiCuration.php?locus_name=$1\">$patric</a>";          return "<a href=\"https://patric.vbi.vt.edu/software/curationTool/gep/pgiCuration.php?locus_name=$1\" target=_blank>$patric</a>";
1455      }      }
1456      return $patric;      return $patric;
1457  }  }
# Line 1231  Line 1462 
1462    
1463      if ($vbrc =~ /vbrc\|(.*)/)      if ($vbrc =~ /vbrc\|(.*)/)
1464      {      {
1465          return "<a href=\"http://www.biovirus.org/gene_detail.asp?name=$1\">$vbrc</a>";          return "<a href=\"http://www.biovirus.org/gene_detail.asp?name=$1\" target=_blank>$vbrc</a>";
1466      }      }
1467      return $vbrc;      return $vbrc;
1468  }  }
# Line 1239  Line 1470 
1470  sub vectorbase_link {  sub vectorbase_link {
1471      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1472      my($cgi,$vec) = @_;      my($cgi,$vec) = @_;
1473      return "<a href=\"http://www.vectorbase.org\">$vec</a>";      return "<a href=\"http://www.vectorbase.org\" target=_blank>$vec</a>";
1474  }  }
1475    
1476    
# Line 1249  Line 1480 
1480    
1481      if ($uni =~ /^uni\|(\S+)$/)      if ($uni =~ /^uni\|(\S+)$/)
1482      {      {
1483          return "<a href=http://www.pir.uniprot.org/cgi-bin/upEntry?id=$1>$uni</a>";          #return "<a href=http://www.pir.uniprot.org/cgi-bin/upEntry?id=$1>$uni</a>";
1484            return "<a href='http://www.ebi.uniprot.org/uniprot-srv/uniProtView.do?proteinAc=$1' target=_blank>$uni</a>";
1485      }      }
1486      return $uni;      return $uni;
1487  }  }
# Line 1260  Line 1492 
1492    
1493      if ($sp =~ /^sp\|(\S+)$/)      if ($sp =~ /^sp\|(\S+)$/)
1494      {      {
1495          return "<a href=http://us.expasy.org/cgi-bin/get-sprot-entry?$1>$sp</a>";          return "<a href='http://us.expasy.org/cgi-bin/get-sprot-entry?$1' target=_blank>$sp</a>";
1496      }      }
1497      return $sp;      return $sp;
1498  }  }
# Line 1271  Line 1503 
1503    
1504      if ($pir =~ /^pirnr\|(NF\d+)$/)      if ($pir =~ /^pirnr\|(NF\d+)$/)
1505      {      {
1506          return "<a href=http://pir.georgetown.edu/cgi-bin/nfEntry.pl?id=$1>$pir</a>";          return "<a href='http://pir.georgetown.edu/cgi-bin/nfEntry.pl?id=$1' target=_blank>$pir</a>";
1507      }      }
1508      return $pir;      return $pir;
1509  }  }
# Line 1282  Line 1514 
1514    
1515      if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)      if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)
1516      {      {
1517          return "<a href=http://www.genome.ad.jp/dbget-bin/www_bget?$1+$2>$kegg</a>";          return "<a href='http://www.genome.ad.jp/dbget-bin/www_bget?$1+$2' target=_blank>$kegg</a>";
1518      }      }
1519      return $kegg;      return $kegg;
1520  }  }
1521    
1522    sub img_link {
1523        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1524        my($cgi,$img) = @_;
1525    
1526        if ($img =~ /^img\|(\S+)$/)
1527        {
1528            return "<a href='http://img.jgi.doe.gov/cgi-bin/pub/main.cgi?page=geneDetail&gene_oid=$1' target=_blank>$img</a>";
1529        }
1530        return $img;
1531    }
1532    
1533  sub ensembl_link {  sub ensembl_link {
1534      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1535      my($cgi,$ensembl) = @_;      my($cgi,$ensembl) = @_;
# Line 1295  Line 1538 
1538      {      {
1539          my $what=$1;          my $what=$1;
1540          my $key=$2;          my $key=$2;
1541          my $idx="all";          my $idx="All";
1542          if ($what eq "EnsemblGene") { $idx = "Gene" }          if ($what eq "EnsemblGene") { $idx = "Gene" }
1543          if ($what eq "EnsemblTranscript") { $idx = "all" }          if ($what eq "EnsemblTranscript") { $idx = "All" }
1544          if ($what eq "EnsemblProtein") { $idx = "all" }          if ($what eq "EnsemblProtein") { $idx = "All" }
1545    
1546          #I really want to get right to the transcript and peptide pages, but          #I really want to get right to the transcript and peptide pages, but
1547          #can't see how to do that without knowing the org name too, which          #can't see how to do that without knowing the org name too, which
1548          #I don't know at this point. (ensembl org name, not real org name)          #I don't know at this point. (ensembl org name, not real org name)
1549    
1550          return "<a href=http://www.ensembl.org/Homo_sapiens/textview?species=all&idx=$idx&q=$key>$ensembl</a>";          return "<a href='http://www.ensembl.org/Homo_sapiens/searchview?species=all&idx=$idx&q=$key' target=_blank>$ensembl</a>";
1551      }      }
1552      return $ensembl;      return $ensembl;
1553  }  }
# Line 1315  Line 1558 
1558    
1559      if ($entrezgene =~ /^EntrezGene:(\S+)$/)      if ($entrezgene =~ /^EntrezGene:(\S+)$/)
1560      {      {
1561          return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=gene&cmd=Retrieve&dopt=full_report&list_uids=$1>$entrezgene</a>";          return "<a href='http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=gene&cmd=Retrieve&dopt=full_report&list_uids=$1' target=_blank>$entrezgene</a>";
1562      }      }
1563      return $entrezgene;      return $entrezgene;
1564  }  }
# Line 1326  Line 1569 
1569    
1570      if ($mim =~ /^MIM:(\S+)$/)      if ($mim =~ /^MIM:(\S+)$/)
1571      {      {
1572          return "<a href=http://www3.ncbi.nlm.nih.gov/entrez/dispomim.cgi?id=$1>$mim</a>";          return "<a href='http://www3.ncbi.nlm.nih.gov/entrez/dispomim.cgi?id=$1' target=_blank>$mim</a>";
1573      }      }
1574      return $mim;      return $mim;
1575  }  }
1576    
1577    sub hgnc_link {
1578        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1579        my($cgi,$hgnc) = @_;
1580    
1581        if ($hgnc =~ /^HGNC:(\S+)$/)
1582        {
1583            return "<a href='http://www.gene.ucl.ac.uk/cgi-bin/nomenclature/searchgenes.pl?field=symbol&anchor=equals&match=$1&symbol_search=Search&number=50&format=html&sortby=symbol' target=_blank>$hgnc</a>";
1584        }
1585    
1586        return $hgnc;
1587    }
1588    
1589  sub unigene_link {  sub unigene_link {
1590      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1591      my($cgi,$unigene) = @_;      my($cgi,$unigene) = @_;
1592    
1593      if ($unigene =~ /^UniGene:(\S+)$/)      if ($unigene =~ /^UniGene:(\S+)$/)
1594      {      {
1595          return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=unigene&cmd=search&term=$1>$unigene</a>";          return "<a href='http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=unigene&cmd=search&term=$1' target=_blank>$unigene</a>";
1596      }      }
1597      return $unigene;      return $unigene;
1598  }  }
# Line 1348  Line 1603 
1603    
1604      if ($ipi =~ /^IPI:(\S+)$/)      if ($ipi =~ /^IPI:(\S+)$/)
1605      {      {
1606          return "<a href=http://srs.ebi.ac.uk/srsbin/cgi-bin/wgetz?-id+AEoS1R8Jnn+-e+[IPI:\'$1\']+-qnum+1+-enum+1>$ipi</a>";          return "<a href='http://srs.ebi.ac.uk/srsbin/cgi-bin/wgetz?-id+AEoS1R8Jnn+-e+[IPI:\'$1\']+-qnum+1+-enum+1' target=_blank>$ipi</a>";
1607      }      }
1608      return $ipi;      return $ipi;
1609  }  }
# Line 1361  Line 1616 
1616    
1617      if ($wp =~ /^WP:(\S+)$/)      if ($wp =~ /^WP:(\S+)$/)
1618      {      {
1619          return "<a href=http://www.wormbase.org/db/searches/basic?class=Any&query=$1&Search=Search>$wp</a>";          return "<a href='http://www.wormbase.org/db/searches/basic?class=Any&query=$1&Search=Search' target=_blank>$wp</a>";
1620      }      }
1621      return $wp;      return $wp;
1622  }  }
# Line 1374  Line 1629 
1629    
1630      if ($fb =~ /^FB:(\S+)$/)      if ($fb =~ /^FB:(\S+)$/)
1631      {      {
1632          return "<a href=http://flybase.bio.indiana.edu/.bin/fbidq.html?$1>$fb</a>";          return "<a href='http://flybase.bio.indiana.edu/.bin/fbidq.html?$1' target=_blank>$fb</a>";
1633      }      }
1634      return $fb;      return $fb;
1635  }  }
# Line 1387  Line 1642 
1642    
1643      if ($fb =~ /^FlyBaseORFNames:(\S+)$/)      if ($fb =~ /^FlyBaseORFNames:(\S+)$/)
1644      {      {
1645          return "<a href=http://flybase.bio.indiana.edu/.bin/fbidq.html?$1>$fb</a>";          return "<a href='http://flybase.bio.indiana.edu/.bin/fbidq.html?$1' target=_blank>$fb</a>";
1646      }      }
1647      return $fb;      return $fb;
1648  }  }
# Line 1400  Line 1655 
1655    
1656      if ($sgd =~ /^SGD_LOCUS:(\S+)$/)      if ($sgd =~ /^SGD_LOCUS:(\S+)$/)
1657      {      {
1658          return "<a href=http://db.yeastgenome.org/cgi-bin/locus.pl?locus=$1>$sgd</a>";          return "<a href='http://db.yeastgenome.org/cgi-bin/locus.pl?locus=$1' target=_blank>$sgd</a>";
1659      }      }
1660      return $sgd;      return $sgd;
1661  }  }
# Line 1431  Line 1686 
1686      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1687      my($cgi,$map,$org) = @_;      my($cgi,$map,$org) = @_;
1688    
1689      $user = $cgi->param('user');      my $user = $cgi->param('user');
1690      $user = $user ? $user : "";      $user = $user ? $user : "";
1691      $org = $org ? $org : "";      $org = $org ? $org : "";
1692    
# Line 1449  Line 1704 
1704    # -name => field and the checkbox name    # -name => field and the checkbox name
1705    my ($form, $button)=@_;    my ($form, $button)=@_;
1706    
1707    $java_script="<input type=\"button\" name=\"CheckAll\" value=\"Check All\"\nonClick=\"checkAll(document.$form.$button)\">\n";    my $java_script="<input type=\"button\" name=\"CheckAll\" value=\"Check All\"\nonClick=\"checkAll(document.$form.$button)\">\n";
1708    $java_script.="<input type=\"button\" name=\"CheckFirst\" value=\"Check First Half\"\nonClick=\"checkFirst(document.$form.$button)\">\n";    $java_script.="<input type=\"button\" name=\"CheckFirst\" value=\"Check First Half\"\nonClick=\"checkFirst(document.$form.$button)\">\n";
1709    $java_script.="<input type=\"button\" name=\"CheckSecond\" value=\"Check Second Half\"\nonClick=\"checkSecond(document.$form.$button)\">\n";    $java_script.="<input type=\"button\" name=\"CheckSecond\" value=\"Check Second Half\"\nonClick=\"checkSecond(document.$form.$button)\">\n";
1710    $java_script.="<input type=\"button\" name=\"UnCheckAll\" value=\"Uncheck All\"\nonClick=\"uncheckAll(document.$form.$button)\">\n";    $java_script.="<input type=\"button\" name=\"UnCheckAll\" value=\"Uncheck All\"\nonClick=\"uncheckAll(document.$form.$button)\">\n";
# Line 1457  Line 1712 
1712    return $java_script;    return $java_script;
1713  }  }
1714    
1715    =head3 sub_link
1716    
1717        my $htmlText = HTML::sub_link($cgi, $sub, gid);
1718    
1719    Create a subsystem link. The link will be to the display page if there is no
1720    user or we are in SPROUT mode; otherwise it will be to the edit page.
1721    
1722    =over 4
1723    
1724    =item cgi
1725    
1726    CGI query object for the current web session. The parameters of special interest
1727    are C<SPROUT> and C<user>. If the user is non-blank and SPROUT mode is 0, then
1728    the subsystem's edit page will be shown rather than its display page.
1729    
1730    =item sub
1731    
1732    Name of the desired subsystem. It will be cleaned of underscores before the
1733    hyperlink is applied.
1734    
1735    =item gid
1736    
1737    Genome ID to be specified as the focus.
1738    
1739    =back
1740    
1741    =cut
1742    
1743  sub sub_link {  sub sub_link {
1744        # Allow call as an instance in addition to the authorized method.
1745      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1746      my($cgi,$sub) = @_;      # Get the parameters.
1747      my($sub_link);      my ($cgi, $sub, $gid) = @_;
1748        # Declare the return variable.
1749        my $retVal;
1750        # Clean the subsystem name for display purposes. This is a very
1751        # different thing from URL-escaping.
1752        my $cleaned = CGI::escapeHTML($sub);
1753        $cleaned =~ s/_/ /g;
1754        # URL-escape the subsystem name for use in the link.
1755        my $linkable = uri_escape($sub);
1756        # Determine the mode. Note we use the little OR trick to insure that
1757        # we have the correct value for plugging into the output link.
1758        my $user = $cgi->param('user') || "";
1759        my $sproutMode = $cgi->param('SPROUT') || 0;
1760        if ($user && ! $sproutMode) {
1761            # A SEED user is calling, so we go to the edit page.
1762            $retVal = "<a href=\"subsys.cgi?ssa_name=$linkable&request=show_ssa&user=$user\">$cleaned</a>";
1763        } else {
1764            # A visitor or SPROUT user is calling, so we go to the display page.
1765            $retVal = "<a href=\"display_subsys.cgi?ssa_name=$linkable;request=show_ssa;sort=by_phylo;focus=$gid;SPROUT=$sproutMode\">$cleaned</a>";
1766        }
1767        # Return the result.
1768        return $retVal;
1769    }
1770    
1771      my $user = $cgi->param('user');  sub reaction_map_link {
1772      if ($user)      my($mapID, @reaction_list) = @_;
1773        if($mapID =~ /\d+/)
1774        {
1775            my $reactions = join "+", @reaction_list;
1776            if ($reactions ne "")
1777      {      {
1778          my $esc_sub = uri_escape( $sub );              $reactions = "+".$reactions;
1779          $sub =~ s/\_/ /g;          }
1780          $sub_link = "<a href=./subsys.cgi?ssa_name=$esc_sub&request=show_ssa&user=$user>$sub</a>";  
1781            return "<a href=http://www.genome.jp/dbget-bin/show_pathway?rn$mapID$reactions>$mapID</a>";
1782      }      }
1783      else      else
1784      {      {
1785          $sub_link = $sub;          return $mapID;
1786      }      }
     return $sub_link;  
1787  }  }
1788    
1789    sub compound_link {
1790        my($compound) = @_;
1791        if($compound =~ /^C\d+/)
1792        {
1793            return "<a href=\"javascript:void(0)\"onclick=\"window.open('http://www.genome.jp/dbget-bin/www_bget?compound+$compound','$&','height=640,width=800,scrollbars=yes,toolbar=yes,status=yes,resizable=yes')\">$compound</a>";
1794        }
1795        else
1796        {
1797            return $compound;
1798        }
1799    }
1800    
1801    
1802  sub reaction_link {  sub reaction_link {
1803      my($reaction) = @_;      my($reaction) = @_;
1804        if ($reaction =~ /^(\*)?(R\d+)/)
     if ($reaction =~ /^R\d+/)  
1805      {      {
1806          return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?rn+$reaction\" target=reaction$$>$reaction</a>";          # return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?rn+$2\" target=reaction$$>$reaction</a>";
1807            return "<a href=\"javascript:void(0)\"onclick=\"window.open('http://www.genome.ad.jp/dbget-bin/www_bget?rn+$reaction','$&','height=640,width=800,scrollbars=yes,toolbar=yes,status=yes,resizable=yes')\">$reaction</a>";
1808      }      }
1809      return $reaction;      return $reaction;
1810  }  }
1811    
1812    
1813  sub html_for_assignments {  sub html_for_assignments {
1814      my($fig,$user,$peg_sets) = @_;      my($fig,$user,$peg_sets) = @_;
1815      my $i;      my $i;
1816    
1817      my @vals = ();      my @vals = ();
1818      my $set = 1;      my $set = 1;
1819      foreach $peg_set (@$peg_sets)      foreach my $peg_set (@$peg_sets)
1820      {      {
1821          for ($i=0; ($i < @$peg_set); $i++)          for ($i=0; ($i < @$peg_set); $i++)
1822          {          {
1823              $peg = $peg_set->[$i];              my $peg = $peg_set->[$i];
1824              push(@vals,'show=' . join("@",($set,$i+1,$peg,&FIG::abbrev($fig->org_of($peg)),"")));              push(@vals,'show=' . join("@",($set,$i+1,$peg,&FIG::abbrev($fig->org_of($peg)),"")));
1825          }          }
1826          $set++;          $set++;
# Line 1607  Line 1931 
1931    
1932    
1933   my @files=("SEED.rss");   my @files=("SEED.rss");
1934   if ($args->{"type"}) {push @files, "SEED.$type.rss"}   if ($args->{"type"}) {
1935        my $type = $args->{type};
1936        push @files, "SEED.$type.rss"
1937    }
1938    
1939   foreach my $file ("SEED.rss", @$files)   foreach my $file ("SEED.rss", @$files)
1940   {   {

Legend:
Removed from v.1.81  
changed lines
  Added in v.1.121

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3