[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.101, Mon Sep 25 19:34:14 2006 UTC revision 1.122, Wed Apr 2 21:23:07 2008 UTC
# Line 28  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!  #use raelib; # now used for the excel function, that should eventually end up in here. Way too experimental!
34  my $raelib;  my $raelib;
# Line 57  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 164  Line 165 
165      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
166      my($cgi,$html,$no_home, $alt_header, $css, $javasrc, $cookie, $options) = @_;      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 181  Line 182 
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";      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 205  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 253  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 299  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 329  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 342  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 352  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 361  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 391  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 440  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 450  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 467  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 481  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 500  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 515  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  }  }
# Line 539  Line 548 
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 808  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 841  Line 865 
865          my $new_framework = $cgi->param('new_framework') ? 1 : 0;          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          my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";          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)          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             $link = "$top/feature.cgi?feature=$fid&user=$user$sprout";             $link = "$top/feature.cgi?feature=$fid&user=$user$sprout$virt";
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 865  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\&new_framework=$new_framework";              $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 887  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 996  Line 1048 
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 =~ /^\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 1022  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 =~ /^(.*)(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)      elsif ($x =~ /^(.*)(tigr\|\w+)(.*)/s)
1188      {      {
1189          $before = $1;          $before = $1;
# Line 1029  Line 1191 
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 =~ /^(.*)(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)      elsif ($x =~ /^(.*)\b(eric\|\S+)\b(.*)/s)
1202      {      {
1203          $before = $1;          $before = $1;
# Line 1240  Line 1409 
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\" target=_blank>$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\|(\S+)$/)      elsif ($tigr =~ /^tigr(cmr)?\|(\S+)$/)
1413      {      {
1414          return "<a href=\"http://www.tigr.org/tigr-scripts/CMR2/GenePage.spl?locus=$1\" target=_blank>$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 1350  Line 1519 
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 1532  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      my $esc_sub = uri_escape( $sub );      my($mapID, @reaction_list) = @_;
1773      $sub =~ s/\_/ /g;      if($mapID =~ /\d+/)
     if ($user)  
1774      {      {
1775          $sub_link = "<a href=./subsys.cgi?ssa_name=$esc_sub&request=show_ssa&user=$user>$sub</a>";          my $reactions = join "+", @reaction_list;
1776            if ($reactions ne "")
1777            {
1778                $reactions = "+".$reactions;
1779            }
1780    
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 = "<a href=\"display_subsys.cgi?ssa_name=$esc_sub&request=show_ssa&sort=by_phylo\">$sub</a>";          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+$2\" 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  }  }

Legend:
Removed from v.1.101  
changed lines
  Added in v.1.122

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3