[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.17, Mon Jun 28 19:37:31 2004 UTC revision 1.101, Mon Sep 25 19:34:14 2006 UTC
# Line 1  Line 1 
1    #
2    # Copyright (c) 2003-2006 University of Chicago and Fellowship
3    # for Interpretations of Genomes. All Rights Reserved.
4    #
5    # This file is part of the SEED Toolkit.
6    #
7    # The SEED Toolkit is free software. You can redistribute
8    # it and/or modify it under the terms of the SEED Toolkit
9    # Public License.
10    #
11    # You should have received a copy of the SEED Toolkit Public License
12    # along with this program; if not write to the University of Chicago
13    # at info@ci.uchicago.edu or the Fellowship for Interpretation of
14    # Genomes at veronika@thefig.info or download a copy from
15    # http://www.theseed.org/LICENSE.TXT.
16    #
17    
18  package HTML;  package HTML;
19    
20    use strict;
21    use Tracer;
22    use FIG;
23  use Carp;  use Carp;
24  use Data::Dumper;  use Data::Dumper;
25  use LWP::UserAgent;  use LWP::UserAgent;
26  use LWP::Simple;  use LWP::Simple;
27    use URI::Escape;  # uri_escape()
28  use URI::URL;  use URI::URL;
29  use HTTP::Request::Common;  use HTTP::Request::Common;
30  use POSIX;  use POSIX;
31    
32  sub show_page {  #use raelib; # now used for the excel function, that should eventually end up in here. Way too experimental!
33      my($cgi,$html,$no_home) = @_;  my $raelib;
34      my $i;  
35    
36    my $top_link_cache;
37    
38    
39    sub new
40    {
41        my($class) = @_;
42    
43        my $self = {};
44    
45        return bless $self, $class;
46    }
47    
48    sub top_link
49    {
50    
51      #      #
52      # Find the HTML header      # Determine if this is a toplevel cgi or one in one of the subdirs (currently
53        # just /p2p).
54      #      #
55    
56      my $html_hdr_file = "./Html/html.hdr";      return $top_link_cache if ($top_link_cache);
57    
58        my @parts = split(/\//, $ENV{SCRIPT_NAME});
59        my $top;
60        if ($parts[-2] eq 'FIG')
61        {
62            $top = '.';
63    #       warn "toplevel @parts\n";
64        }
65        elsif ($parts[-3] eq 'FIG')
66        {
67            $top = '..';
68    #       warn "subdir @parts\n";
69        }
70        else
71        {
72            $top = $FIG_Config::cgi_base;
73    #       warn "other @parts\n";
74        }
75    
76        $top_link_cache = $top;
77        return $top;
78    }
79    
80    sub compute_html_header
81    {
82        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
83        my($additional_insert, $user, %options ) = @_;
84    
85        local $/ = "\n";
86    
87        my $header_name = $options{header_name} ? $options{header_name} : "html.hdr";
88        my $tail_name = $options{tail_name} ? $options{tail_name} : "html.tail";
89    
90        my $html_hdr_file = "./Html/$header_name";
91      if (! -f $html_hdr_file)      if (! -f $html_hdr_file)
92      {      {
93          $html_hdr_file = "$FIG_Config::fig/CGI/Html/html.hdr";          $html_hdr_file = "$FIG_Config::fig/CGI/Html/$header_name";
94      }      }
95        my @html_hdr = &FIG::file_read($html_hdr_file);
96    
97      my $html_tail_file = "./Html/html.tail";      # for my $k (sort keys %ENV) { warn "$k = $ENV{$k}\n"; }
98      if (! -f $html_tail_file)  
99        #
100        # Determine if this is a toplevel cgi or one in one of the subdirs (currently
101        # just /p2p).
102        #
103    
104        my @parts = split(/\//, $ENV{SCRIPT_NAME});
105        my $top;
106        if ($parts[-2] eq 'FIG')
107      {      {
108          $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";          $top = '.';
109    #       warn "toplevel @parts\n";
110        }
111        elsif ($parts[-3] eq 'FIG')
112        {
113            $top = '..';
114    #       warn "subdir @parts\n";
115        }
116        else
117        {
118            $top = $FIG_Config::cgi_base;
119    #       warn "other @parts\n";
120      }      }
121    
122      my @html_hdr = &FIG::file_read($html_hdr_file);      $options{no_fig_search} or push( @html_hdr, "<br><a href=\"$top/index.cgi?user=$user\">FIG search</a>\n" );
123    
124      if (@html_hdr)      if (@html_hdr)
125      {      {
126          my $insert_stuff;          my $insert_stuff;
127    
128            if (not $options{no_release_info})
129            {
130          my @ver = &FIG::file_head("$FIG_Config::fig_disk/CURRENT_RELEASE", 1);          my @ver = &FIG::file_head("$FIG_Config::fig_disk/CURRENT_RELEASE", 1);
131          my $ver = $ver[0];          my $ver = $ver[0];
132          chomp $ver;          chomp $ver;
# Line 43  Line 138 
138          }          }
139          my $host = &FIG::get_local_hostname();          my $host = &FIG::get_local_hostname();
140          $insert_stuff = "SEED version <b>$ver</b> on $host";          $insert_stuff = "SEED version <b>$ver</b> on $host";
141            }
142    
143            if ($additional_insert)
144            {
145                $insert_stuff .= "<br>" . $additional_insert;
146            }
147    
148          for $_ (@html_hdr)          for $_ (@html_hdr)
149          {          {
150              s,(href|img\s+src)="/FIG/,\1="$FIG_Config::cgi_base,g;              s,(href|img\s+src)="/FIG/,$1="$top/,g;
151                    s,(\?user\=)\",$1$user",;
152              if ($_ eq "<!-- HEADER_INSERT -->\n")              if ($_ eq "<!-- HEADER_INSERT -->\n")
153              {              {
154                  $_ = $insert_stuff;                  $_ = $insert_stuff;
# Line 54  Line 156 
156          }          }
157      }      }
158    
159        return @html_hdr;
160    }
161    
162    sub show_page {
163        #warn "SHOWPAGE: cgi=", Dumper(@_);
164        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
165        my($cgi,$html,$no_home, $alt_header, $css, $javasrc, $cookie, $options) = @_;
166        my $i;
167    
168        my $top = top_link();
169    
170        # ARGUMENTS:
171        #     $cgi is the CGI method
172        #     $html is an array with all the html in it. It is just joined by "\n" (and not <br> or <p>
173        #     $no_home eliminates ONLY the bottom FIG search link in a page
174        #     $alt_header is a reference to an array for an alternate header banner that you can replace the standard one with
175        #     $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
176        #               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
177        #               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
178        #     $javasrc is a reference to an array of URLs to javascripts to be included (e.g. "FIG/Html/css/styleswitcher.js")
179        #     $cookie is the name and value of the cookie to set. Note that you should probably use raelib->cookie to get/set your cookies
180        #     $options is a reference to a hash of options that you can pass around the pages
181        #
182        # Find the HTML header
183        #
184    
185        my $tail_name = $options->{tail_name} ? $options->{tail_name} : "html.tail";
186        my $html_tail_file = "./Html/$tail_name";
187        if (! -f $html_tail_file)
188        {
189            $html_tail_file = "$FIG_Config::fig/CGI/Html/$tail_name";
190        }
191    
192        my $user = $cgi->param('user') || "";
193        my @html_hdr;
194        if ($alt_header && ref($alt_header) eq "ARRAY")
195        {
196           @html_hdr = @$alt_header;
197        }
198        else
199        {
200            @html_hdr = compute_html_header(undef,$user,%$options);
201        }
202    
203        # RAE: I am offloading the handling of cookies to CGI.pm since I don't know how they are set up.
204        # This modification adds the cookies if necessary
205    
206        # Note: 3/10/05 commented this line out pending the discussion of adding cookies into the seed that we are waiting to see about
207        # to add cookies back in replace these two header lines with each other
208    
209      print $cgi->header;      #print $cgi->header(-cookie=>$cookie);
210        print $cgi->header();
211    
212      #      #
213      #  The SEED header file goes immediately after <BODY>.  Figure out      #  The SEED header file goes immediately after <BODY>.  Figure out
# Line 73  Line 225 
225                       meta     => 1,                       meta     => 1,
226                       nextid   => 1,                       nextid   => 1,
227                       style    => 1,                       style    => 1,
228                       title    => 1                       title    => 1,
229                     );                     );
230    
231      #      #
# Line 116  Line 268 
268          if ( $html->[$i] =~ /\<body[^0-9a-z]/i )          if ( $html->[$i] =~ /\<body[^0-9a-z]/i )
269          {          {
270              $body_line = $i;              $body_line = $i;
271              $last;              last;
272          }          }
273    
274          #  Now the general case.          #  Now the general case.
# Line 172  Line 324 
324      #      #
325      #  <BODY> goes after last head line      #  <BODY> goes after last head line
326      #      #
327        #  RAE:
328        #  Added the javascript for the buttons immediately after body.
329        #  Note if no buttons are added we still (at the moment) add the script,
330        #  but it only adds a little text (495 characters) to the html and noone will notice!
331        #  RAE: This is now deprecated because everything is in an external file, FIG.js, included later
332    
333      if ( $body_line < 0 )      if ( $body_line < 0 )
334      {      {
# Line 198  Line 355 
355          splice( @$html, $body_line, 0, "</HEAD>\n" );          splice( @$html, $body_line, 0, "</HEAD>\n" );
356      }      }
357    
358        # RAE:
359        # Add css here
360        # Note that at the moment I define these two sheets here. I think this should
361        # be moved out, but I want to try it and see what happens.  css has the format:
362        #
363        # <link rel='stylesheet' title='default' href='/css/default.css' type='text/css'>
364    
365        # convert the default key to the right case. and eliminate dups
366        foreach my $k (keys %$css) {if (lc($k) eq "default") {$css->{'Default'}=$css->{$k}}}
367    
368        if (!$css || !$css->{'Default'})
369        {
370           $css->{'Default'} = "Html/css/default.css";
371        }
372        if (!$css->{"Sans Serif"})
373        {
374           $css->{'Sans Serif'} = "Html/css/sanserif.css";
375        }
376    
377        my $csstext = "<link rel='stylesheet' title='default' href='".$css->{'Default'}."' type='text/css'>\n";
378        $csstext   .= "<link rel='alternate stylesheet' title='Sans Serif' href='".$css->{'Sans Serif'}."' type='text/css'>\n";
379    
380        foreach my $k (keys %$css)
381        {
382           next if (lc($k) eq "default" || lc($k) eq "sans serif");
383           $csstext .= "<link rel='alternate stylesheet' title='$k' href='".$css->{$k}."' type='text/css'>\n";
384        }
385    
386        $csstext   .= "<link rel='alternate'  title='SEED RSS feeds' href='Html/rss/SEED.rss' type='application/rss+xml'>\n";
387    
388        # RAE: also added support for external javascripts here.
389        # we are cluttering the HTML code with all the javascripts when they could easily be in external files
390        # this solution allows us to source other files
391    
392        # the file FIG.js contains most of the java script we use routinely. Every browser will just cache this and so
393        # it will reduce our overhead.
394    
395        # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts
396        push @$javasrc, "Html/css/FIG.js";
397        foreach my $script (@$javasrc) {
398            $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";
399        }
400    
401    
402    
403        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.
404    
405      #      #
406      #  <BASE ...> goes before </HEAD>      #  <BASE ...> goes before </HEAD>
407      #      #
# Line 213  Line 417 
417          # BASE href needs to be absolute. RDO.          # BASE href needs to be absolute. RDO.
418          #          #
419          #          #
420          $base_url = &FIG::cgi_url;  #        $base_url = &FIG::cgi_url;
421  #       my $base_url = $FIG_Config::cgi_base;  #       my $base_url = $FIG_Config::cgi_base;
422  #       if ( ! $base_url )                      # if cgi_base was not defined  #       if ( ! $base_url )                      # if cgi_base was not defined
423  #       {  #       {
# Line 223  Line 427 
427  #       }  #       }
428    
429          $base_line = $head_end_line;          $base_line = $head_end_line;
430          splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );          #
431            # RDO 2005-1006. Remove this so proxying works better.
432            #
433    #        splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );
434      }      }
435    
436      #      #
# Line 258  Line 465 
465      }      }
466    
467      #      #
468        # See if we have a site-specific tail (for disclaimers, etc).
469        #
470    
471        my $site_tail = "$FIG_Config::fig_disk/config/site_tail.html";
472        my $site_fh;
473        if (open($site_fh, "<$site_tail"))
474        {
475            push(@tail, <$site_fh>);
476            close($site_fh);
477        }
478    
479        #
480      #  Figure out where to insert The SEED tail.  Before </body>,      #  Figure out where to insert The SEED tail.  Before </body>,
481      #  or before </html>, or at end of page.      #  or before </html>, or at end of page.
482      #      #
   
483      my @tags = ();      my @tags = ();
484        # Check for a tracing queue.
485        my $traceString = QTrace("HTML");
486        if ($traceString) {
487            push @tags, $traceString;
488        }
489      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}
490      if ($i >= @$html)        # </body> not found; look for </html>      if ($i >= @$html)        # </body> not found; look for </html>
491      {      {
# Line 285  Line 507 
507          splice( @$html, $i, 0, @tags );          splice( @$html, $i, 0, @tags );
508      }      }
509    
510      print @$html;      # RAE the chomp will return any new lines at the ends of elements in the array,
511        # and then we can join  with a "\n". This is because somethings put newlines in,
512        # and others don't. This should make nicer looking html
513        #
514        # chomp(@$html);
515        # print join "\n", @$html;
516        #
517        # Apparently the above still breaks things. This is the correct code:
518    
519        foreach $_ (@$html)
520        {
521            print $_;
522  }  }
523    
524    }
525    
526    
527    =head1 make_table
528    
529    The main method to convert an array into a table.
530    
531    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.
532    
533    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.
534    
535    =cut
536    
537  sub make_table {  sub make_table {
538      my($col_hdrs,$tab,$title, %options ) = @_;      my($col_hdrs,$tab,$title, %options ) = @_;
539      my(@tab);      my(@tab);
540    
541      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";
542      push( @tab, "\n<table $border>\n",      my $width = defined $options{width} ? "width=\"$options{width}\"" : undef;
543        my $class = defined $options{class} ? "class=\"$options{class}\"" : undef;
544        push( @tab, "\n<table $border $width $class>\n",
545                  "\t<caption><b>$title</b></caption>\n",                  "\t<caption><b>$title</b></caption>\n",
546                  "\t<tr>\n\t\t<th>"                  "\t<tr>\n\t\t"
547                . join( "</th>\n\t\t<th>", @$col_hdrs )                . join( "\n", map { &expand($_, "th") } @$col_hdrs )
548                . "</th>\n\t</tr>\n"                . "\n\t</tr>\n"
549          );          );
550      my($i);      my($i);
551    
# Line 310  Line 558 
558              );              );
559      }      }
560      push(@tab,"</table>\n");      push(@tab,"</table>\n");
561    
562        # excelfile should be appropriate for a filename (no spaces/special characters)
563        if (defined $options{"excelfile"}) {
564            if (! defined($raelib)) {
565                require raelib;
566                $raelib = new raelib;
567            }
568            push @tab, $raelib->tab2excel($col_hdrs,$tab,$title,\%options,$options{"excelfile"})}
569    
570      return join("",@tab);      return join("",@tab);
571  }  }
572    
573    sub abstract_coupling_table {
574        my($cgi,$prot,$coupling) = @_;
575        my %fc;
576    
577        my $col_hdrs = ["coupled to","Score","Type of Coupling", "Type-specific Data"];
578        my $tab = [];
579        my %by_peg;
580        foreach my $x (@$coupling)
581        {
582            my($peg2,$psc,$type,$extra) = @$x;
583            if (($type !~ /^[ID]FC$/) || (! $fc{$peg2}))
584            {
585                if ($type =~  /^[ID]FC$/)
586                {
587                    $fc{$peg2} = 1;
588                }
589    
590                $by_peg{$peg2} += $psc;
591            }
592        }
593    
594        foreach my $x (sort { ($by_peg{$b->[0]} <=> $by_peg{$a->[0]})
595                              or ($a->[0] cmp $b->[0])
596                              or ($b->[1] <=> $a->[1])
597                              or ($a->[2] cmp $b->[2]) } @$coupling)
598        {
599            my($peg2,$psc,$type,$extra) = @$x;
600            push(@$tab,[&fid_link($cgi,$peg2,1),$psc,$type,&set_prot_links($cgi,join(", ",@$extra))]);
601        }
602    
603    
604         my $help = "<a href=\"Html/abstract_coupling.html\" target=\"SEED_or_SPROUT_help\">for help</a>";
605    #    my @html = &make_table($col_hdrs,$tab,"Abstract Coupling Data for $prot");
606    #    push(@html,"<hr>\n",$cgi->h3($help),"<br>");
607    #    return @html;
608    
609        return &make_table($col_hdrs,$tab,"Abstract Coupling Data for $prot [$help]");
610    }
611    
612  sub expand {  sub expand {
613      my($x) = @_;      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
614        my( $x, $tag ) = @_;
615    
616        $tag = "td" unless $tag;
617        my $endtag = $tag;
618    
619        # RAE modified this so that you can pass in a reference to an array where
620        # the first element is the data to display and the second element is optional
621        # things like colspan and align. Note that in this case you need to include the td
622        # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]
623    
624        # per GJO's request modified this line so it can take any tag.
625        if ( ref($x) eq "ARRAY" ) { ($x, $tag) = @$x; $tag =~ /^(\S+)/; $endtag = $1 }
626    
627      if ($x =~ /^\@([^:]+)\:(.*)$/)      if ($x =~ /^\@([^:]+)\:(.*)$/)
628      {      {
629          return "\t\t<td $1>$2</td>";          return "\t\t<$tag $1>$2</$endtag>";
630      }      }
631      else      else
632      {      {
633          return "\t\t<td>$x</td>";          return "\t\t<$tag>$x</$endtag>";
634      }      }
635  }  }
636    
637    
638    =head2 merge_table_rows()
639    
640    Merge table rows together. This will merge a table so that adjacent cells with the same content will only be shown once.
641    
642    Something like this:
643    
644        -----------------------
645        |    1     |    a     |
646        -----------------------
647        |    1     |    b     |
648        -----------------------
649        |    2     |    c     |
650        -----------------------
651        |    3     |    d     |
652        -----------------------
653        |    4     |    d     |
654        -----------------------
655        |    5     |    d     |
656        -----------------------
657    
658    Will become:
659    
660        -----------------------
661        |          |    a     |
662        |    1     |-----------
663        |          |    b     |
664        -----------------------
665        |    2     |    c     |
666        -----------------------
667        |    3     |          |
668        ------------          |
669        |    4     |    5     |
670        ------------          |
671        |    5     |          |
672        -----------------------
673    
674    
675    The method takes two arguments. The reference to the array that is the table ($tab). This is the standard table that is created for HTML.pm to draw, and a reference to a hash of columns that you don't want to merge together. The reference to the hash is optional, and if not included, everything will be merged.
676    
677     $tab=&HTML::merge_table_rows($tab);
678    
679     or
680    
681     $skip=(1=>1, 3=>1, 5=>1);
682     $tab=&HTML::merge_table_rows($tab, $skip);  # will merge all columns except 1, 3 and 5. Note the first column in the table is #0
683    
684    
685    =cut
686    
687    
688    
689    
690    sub merge_table_rows {
691     # RAE:
692     # Experimental piece of code. We often want to have rows or columns were cells are merged. It just looks so much nicer
693     # this block should merge adjacent rows that have the same text in them.
694     # use like this:
695     #      $tab=&HTML::merge_table_rows($tab);
696     # before you do a make_table call
697    
698     my $self=shift if UNIVERSAL::isa($_[0],__PACKAGE__);
699     my ($tab, $skip)=@_;
700    
701     my $newtable;
702     my $lastrow;
703     my $rowspan;
704     my $refs;
705    
706     for (my $y=0; $y <= $#$tab; $y++) {
707     #$y is the row in the table;
708      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
709       # this is the user definable columns not to merge
710       if ($skip->{$x})
711       {
712        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
713        next;
714       }
715    
716       #$x is the column in the table
717       # if the column in the row we are looking at is the same as the column in the previous row, we don't add
718       # this cell to $newtable. Instead we increment the rowspan of the previous row by one
719    
720       # handle cells that are references to arrays
721       if (ref($tab->[$y]->[$x]) eq "ARRAY") {$refs->[$y]->[$x]=$tab->[$y]->[$x]->[1]; $tab->[$y]->[$x]=$tab->[$y]->[$x]->[0]}
722    
723       # now we go back through the table looking where to draw the merge line:
724       my $lasty=$y;
725       while ($lasty >= 0 && $tab->[$y]->[$x] eq $tab->[$lasty]->[$x]) {$lasty--}
726       $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
727       if ($lasty == $y) {
728        # we always want to have something in rows that may otherwise be empty but should be there (see below)
729        unless ($tab->[$y]->[$x]) {$tab->[$y]->[$x]=" &nbsp; "}
730        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
731       }
732       else {$rowspan->[$lasty]->[$x]++}
733      }
734     }
735    
736     # now just join everything back together
737     for (my $y=0; $y <= $#$tab; $y++) {
738      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
739       if ($rowspan->[$y]->[$x]) {
740        if ($refs->[$y]->[$x]) {$refs->[$y]->[$x] .= " rowspan=". ($rowspan->[$y]->[$x]+1)}
741        else {$refs->[$y]->[$x] = "td rowspan=". ($rowspan->[$y]->[$x]+1)}
742        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
743       }
744       elsif ($newtable->[$y]->[$x] && $refs->[$y]->[$x]) {
745        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
746       }
747      }
748     }
749    
750    
751     # finally we have to remove any completely empty cells that have been added by the array mechanism
752     # (e.g. if you define $a->[2] then $a->[0] and $a->[1] are now undef).
753     # that is why in the loop above I replace empty cells with nbsp. They are now not undef!
754     # I am sure that Gary can do this in one line, but I am hacking.
755     my @trimmed;
756     foreach my $a (@$newtable) {
757      my @row;
758      foreach my $b (@$a) {
759       push @row, $b if ($b);
760      }
761      push @trimmed, \@row;
762     }
763    
764     return \@trimmed;
765    }
766    
767    
768    
769    
770  sub set_ec_links {  sub set_ec_links {
771        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
772      my($cgi,$x) = @_;      my($cgi,$x) = @_;
773      my($before,$match,$after);      my($before,$match,$after);
774    
# Line 341  Line 783 
783  }  }
784    
785  sub ec_link {  sub ec_link {
786        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
787      my($role) = @_;      my($role) = @_;
788    
789      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)
# Line 354  Line 797 
797  }  }
798    
799  sub role_link {  sub role_link {
800        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
801      my($cgi,$role) = @_;      my($cgi,$role) = @_;
802    
803      my $roleR = ($role =~ /^(\d+\.\d+\.\d+\.\d+)\s+-\s+/) ? $1 : $role;      my $roleR = ($role =~ /^(\d+\.\d+\.\d+\.\d+)\s+-\s+/) ? $1 : $role;
# Line 369  Line 813 
813  # text of the link.  # text of the link.
814  #  #
815  sub fid_link {  sub fid_link {
816        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
817      my($cgi,$fid,$local,$just_url) = @_;      my($cgi,$fid,$local,$just_url) = @_;
818      my($n);      my($n);
819    
820        my $top = top_link();
821    
822      if ($fid =~ /^fig\|\d+\.\d+\.([a-z]+)\.(\d+)/)      if ($fid =~ /^fig\|\d+\.\d+\.([a-z]+)\.(\d+)/)
823      {      {
824          if ($local)          if ($local)
# Line 389  Line 836 
836          {          {
837              $n = $fid;              $n = $fid;
838          }          }
839          if ($1 ne "peg") { return $n }  
840            my $link;
841            my $new_framework = $cgi->param('new_framework') ? 1 : 0;
842            #added to format prophage and path island links to feature.cgi
843            my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
844            if ($1 ne "peg" && ! $sprout)
845            {
846               my $user = $cgi->param('user');
847               if (! $user) { $user = "" }
848               $link = "$top/feature.cgi?feature=$fid&user=$user$sprout";
849               $link =~ s/[a-z_A-Z0-9]+\.cgi\?/feature.cgi?/;
850            }
851            else
852            {
853          my $user = $cgi->param('user');          my $user = $cgi->param('user');
854          if (! $user) { $user = "" }          if (! $user) { $user = "" }
855          my $trans = $cgi->param('translate') ? "&translate=1" : "";          my $trans = $cgi->param('translate') ? "&translate=1" : "";
856          my $link = $cgi->url() . "?prot=$fid&user=$user$trans";              my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
857          $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;  ###a
         #  
         # Elimin the p2p part if we're in that subdir. Ugh.  
         #  
         $link =~ s,p2p/protein.cgi,protein.cgi,;  
858    
859    ### This used to be
860    ###     my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
861    ###
862    ### The cost became prohibitive in the subsystem spreadsheets.  Hence, we cache the value
863    ###
864    ### RAO
865    
866                #if (! $cgi_url) { $cgi_url = &FIG::cgi_url }
867                #$link = $cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
868                $link = "$top/protein.cgi?prot=$fid&user=$user$trans$sprout\&new_framework=$new_framework";
869                $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
870            }
871          if ($just_url)          if ($just_url)
872          {          {
873              return $link;              return $link;
874          }          }
875          else          else
876          {          {
877              return "<a href=$link>$n</a>";              return "<a href='$link'>$n</a>";
878          }          }
879      }      }
880      return $fid;      return $fid;
881  }  }
882    
883  sub family_link {  sub family_link {
884        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
885      my($family,$user) = @_;      my($family,$user) = @_;
886    
887      return $family;      return $family;
888  }  }
889    
 use URI::Escape;  
890    
891  sub get_html {  sub get_html {
892        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
893      my( $url, $type, $kv_pairs) = @_;      my( $url, $type, $kv_pairs) = @_;
894      my( $encoded, $ua, $args, @args, $out, @output, $x );      my( $encoded, $ua, $args, @args, $out, @output, $x );
895    
896      $ua = new LWP::UserAgent;      $ua = new LWP::UserAgent;
897      $ua->timeout( 900 );      $ua->timeout( 900 );
   
898      if ($type =~/post/i)      if ($type =~/post/i)
899      {      {
900          $args = [];          $args = [];
# Line 438  Line 906 
906          my $response = $ua->request($request);          my $response = $ua->request($request);
907          $out = $response->content;          $out = $response->content;
908      }      }
909      else  
910        if ($type =~/get/i)
911      {      {
912          @args = ();          @args = ();
913          foreach $x (@$kv_pairs)          foreach $x (@$kv_pairs)
# Line 450  Line 919 
919          {          {
920              $url .= "?" . join("&",@args);              $url .= "?" . join("&",@args);
921          }          }
922          $request = new HTTP::Request('GET', $url);          my $request = new HTTP::Request('GET', $url);
923          my $response = $ua->request($request);          my $response = $ua->request($request);
924    
925          if ($response->is_success)          if ($response->is_success)
# Line 468  Line 937 
937    
938  #   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
939  #   properly.  Remove the header.  #   properly.  Remove the header.
940        my $i;
941      for ($i=0; ($i < @output) && ($output[$i] !~ /^\s*\</); $i++) {}      for ($i=0; ($i < @output) && ($output[$i] !~ /^\s*\</); $i++) {}
942      if ($i < @output)      if ($i < @output) {
     {  
   
943          splice(@output,0,$i);          splice(@output,0,$i);
944      }      }
945    
# Line 486  Line 953 
953  }  }
954    
955  sub trim_output {  sub trim_output {
956        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
957      my($out) = @_;      my($out) = @_;
958      my $i;      my ($i, $j);
959    
960      for ($i=0; ($i < @$out) && ($out->[$i] !~ /^\</); $i++) {}      for ($i=0; ($i < @$out) && ($out->[$i] !~ /^\</); $i++) {}
961      splice(@$out,0,$i);      splice(@$out,0,$i);
# Line 516  Line 984 
984      for ($j=$i-1; ($j > 0) && ($out->[$j] !~ /FIG search/); $j--) {}      for ($j=$i-1; ($j > 0) && ($out->[$j] !~ /FIG search/); $j--) {}
985      if ($j > 0)      if ($j > 0)
986      {      {
987            #
988            # Hm. We would have tried using the options here:
989            # my $tail_name = $options{tail_name} ? $options{tail_name} : "html.tail";
990            # but they're not passed in. So use the default html.tail.
991            #
992            my $html_tail_file = "./Html/html.tail";
993          my @tmp = `cat $html_tail_file`;          my @tmp = `cat $html_tail_file`;
994          my $n = @tmp;          my $n = @tmp;
995          splice(@$out,$j-$n,$n+1);          splice(@$out,$j-$n,$n+1);
# Line 523  Line 997 
997  }  }
998    
999  sub set_prot_links {  sub set_prot_links {
1000        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1001      my($cgi,$x) = @_;      my($cgi,$x) = @_;
1002      my($before,$match,$after);      my($before,$match,$after);
1003    
# Line 533  Line 1008 
1008          $after = $3;          $after = $3;
1009          return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after);          return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after);
1010      }      }
1011        elsif ($x =~ /^(.*)\b([NXYZA][PM]_[0-9\.]+)\b(.*)/s)
1012        {
1013            $before = $1;
1014            $match = $2;
1015            $after = $3;
1016            return &set_prot_links($cgi,$before) . &HTML::refseq_link($cgi,$match) . &set_prot_links($cgi,$after);
1017        }
1018      elsif ($x =~ /^(.*)(gi\|\d+)(.*)/s)      elsif ($x =~ /^(.*)(gi\|\d+)(.*)/s)
1019      {      {
1020          $before = $1;          $before = $1;
# Line 540  Line 1022 
1022          $after = $3;          $after = $3;
1023          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);
1024      }      }
1025        elsif ($x =~ /^(.*)(tigr\|\w+)(.*)/s)
1026        {
1027            $before = $1;
1028            $match = $2;
1029            $after = $3;
1030            return &set_prot_links($cgi,$before) . &HTML::tigr_link($cgi,$match) . &set_prot_links($cgi,$after);
1031        }
1032        elsif ($x =~ /^(.*)\b(eric\|\S+)\b(.*)/s)
1033        {
1034            $before = $1;
1035            $match = $2;
1036            $after = $3;
1037            return &set_prot_links($cgi,$before) . &HTML::eric_link($cgi,$match) . &set_prot_links($cgi,$after);
1038        }
1039    
1040        elsif ($x =~ /^(.*)\b(bhb\|.*?)\b(.*)/s)
1041        {
1042            $before = $1;
1043            $match = $2;
1044            $after = $3;
1045            return &set_prot_links($cgi,$before) . &HTML::bhb_link($cgi,$match) . &set_prot_links($cgi,$after);
1046        }
1047    
1048        elsif ($x =~ /^(.*)\b(apidb\|[0-9\.a-z_]+)\b(.*)/s)
1049        {
1050            $before = $1;
1051            $match = $2;
1052            $after = $3;
1053            return &set_prot_links($cgi,$before) . &HTML::apidb_link($cgi,$match) . &set_prot_links($cgi,$after);
1054        }
1055    
1056        elsif ($x =~ /^(.*)\b(patric\|.*?)\b(.*)/s)
1057        {
1058            $before = $1;
1059            $match = $2;
1060            $after = $3;
1061            return &set_prot_links($cgi,$before) . &HTML::patric_link($cgi,$match) . &set_prot_links($cgi,$after);
1062        }
1063    
1064        elsif ($x =~ /^(.*)\b(vbrc\|.*?)\b(.*)/s)
1065        {
1066            $before = $1;
1067            $match = $2;
1068            $after = $3;
1069            return &set_prot_links($cgi,$before) . &HTML::vbrc_link($cgi,$match) . &set_prot_links($cgi,$after);
1070        }
1071    
1072        elsif ($x =~ /^(.*)\b(vectorbase\|.*?)\b(.*)/s)
1073        {
1074            $before = $1;
1075            $match = $2;
1076            $after = $3;
1077            return &set_prot_links($cgi,$before) . &HTML::vectorbase_link($cgi,$match) . &set_prot_links($cgi,$after);
1078        }
1079      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
1080      {      {
1081          $before = $1;          $before = $1;
# Line 568  Line 1104 
1104          $after = $3;          $after = $3;
1105          return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after);          return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after);
1106      }      }
1107        elsif ($x =~ /^(.*)(Ensembl[a-zA-Z]+:[a-zA-Z_0-9\.]+)(.*)/s)
1108        {
1109            $before = $1;
1110            $match = $2;
1111            $after = $3;
1112            return &set_prot_links($cgi,$before) . &HTML::ensembl_link($cgi,$match) . &set_prot_links($cgi,$after);
1113        }
1114        elsif ($x =~ /^(.*)(EntrezGene:[a-zA-Z_0-9\.]+)(.*)/s)
1115        {
1116            $before = $1;
1117            $match = $2;
1118            $after = $3;
1119            return &set_prot_links($cgi,$before) . &HTML::entrezgene_link($cgi,$match) . &set_prot_links($cgi,$after);
1120        }
1121        elsif ($x =~ /^(.*)(MIM:[a-zA-Z_0-9\.]+)(.*)/s)
1122        {
1123            $before = $1;
1124            $match = $2;
1125            $after = $3;
1126            return &set_prot_links($cgi,$before) . &HTML::mim_link($cgi,$match) . &set_prot_links($cgi,$after);
1127        }
1128        elsif ($x =~ /^(.*)(HGNC:[a-zA-Z_0-9\.]+)(.*)/s)
1129        {
1130            $before = $1;
1131            $match = $2;
1132            $after = $3;
1133            return &set_prot_links($cgi,$before) . &HTML::hgnc_link($cgi,$match) . &set_prot_links($cgi,$after);
1134        }
1135        elsif ($x =~ /^(.*)(UniGene:[a-zA-Z_0-9\.]+)(.*)/s)
1136        {
1137            $before = $1;
1138            $match = $2;
1139            $after = $3;
1140            return &set_prot_links($cgi,$before) . &HTML::unigene_link($cgi,$match) . &set_prot_links($cgi,$after);
1141        }
1142    # IPI stopped working. turn off for now.
1143    #    elsif ($x =~ /^(.*)(IPI:[a-zA-Z_0-9\.]+)(.*)/s)
1144    #    {
1145    #        $before = $1;
1146    #        $match = $2;
1147    #        $after = $3;
1148    #        return &set_prot_links($cgi,$before) . &HTML::ipi_link($cgi,$match) . &set_prot_links($cgi,$after);
1149    #    }
1150        elsif ($x =~ /^(.*)(WP:[a-zA-Z_0-9\.]+)(.*)/s)
1151        {
1152            #wormbase
1153    
1154            $before = $1;
1155            $match = $2;
1156            $after = $3;
1157            return &set_prot_links($cgi,$before) . &HTML::wp_link($cgi,$match) . &set_prot_links($cgi,$after);
1158        }
1159        elsif ($x =~ /^(.*)(FB:[a-zA-Z_0-9\.]+)(.*)/s)
1160        {
1161            #flybase
1162    
1163            $before = $1;
1164            $match = $2;
1165            $after = $3;
1166            return &set_prot_links($cgi,$before) . &HTML::fb_link($cgi,$match) . &set_prot_links($cgi,$after);
1167        }
1168        elsif ($x =~ /^(.*)(FlyBaseORFNames:[a-zA-Z_0-9\.]+)(.*)/s)
1169        {
1170            #flybase
1171    
1172            $before = $1;
1173            $match = $2;
1174            $after = $3;
1175            return &set_prot_links($cgi,$before) . &HTML::fborf_link($cgi,$match) . &set_prot_links($cgi,$after);
1176        }
1177        elsif ($x =~ /^(.*)(SGD_LOCUS:[a-zA-Z_0-9\.]+)(.*)/s)
1178        {
1179            #flybase
1180    
1181            $before = $1;
1182            $match = $2;
1183            $after = $3;
1184            return &set_prot_links($cgi,$before) . &HTML::sgd_link($cgi,$match) . &set_prot_links($cgi,$after);
1185        }
1186        elsif ($x =~ /^(.*)(tr\|[a-zA-Z0-9]+)(.*)/s)
1187        {
1188    
1189          $before = $1;
1190          $match = $2;
1191          $after = $3;
1192    
1193          return &set_prot_links($cgi,$before) .  &HTML::trembl_link($cgi,$match) . &set_prot_links($cgi,$after);
1194        }
1195      return $x;      return $x;
1196  }  }
1197    
1198    sub trembl_link {
1199        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1200        my($cgi,$id) = @_;
1201    
1202        if ($id =~ /^tr\|(.*)/) {
1203          return "<a href='http://ca.expasy.org/uniprot/$1' target=_blank>$id</a>";
1204        } else {
1205          return "invalid call to trembl link";
1206        }
1207    }
1208    
1209    sub refseq_link {
1210        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1211        my($cgi,$id) = @_;
1212    
1213        if ($id =~ /^[NXYZA]P_/)
1214        {
1215            return "<a href='http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id' target=_blank>$id</a>";
1216        }
1217        elsif ($id =~ /^[NXYZA]M_/)
1218        {
1219            return "<a href='http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=nuccore&cmd=search&term=$id' target=_blank>$id</a>";
1220        }
1221    }
1222    
1223  sub gi_link {  sub gi_link {
1224        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1225      my($cgi,$gi) = @_;      my($cgi,$gi) = @_;
1226    
1227      if ($gi =~ /^gi\|(\d+)$/)      if ($gi =~ /^gi\|(\d+)$/)
1228      {      {
1229          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>";
1230      }      }
1231      return $gi;      return $gi;
1232  }  }
1233    
1234    sub tigr_link {
1235        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1236        my($cgi,$tigr) = @_;
1237    
1238        if ($tigr =~ /^tigr\|(NT|ntbp|ntbpA|BA|BMAA|BXB|GBA)(\w+)$/)
1239        {
1240            my $id=$1.$2;
1241            return "<a href=\"http://pathema.tigr.org/tigr-scripts/pathema/shared/GenePage.cgi?locus=$id\" target=_blank>$tigr</a> (Pathema)";
1242        }
1243        elsif ($tigr =~ /^tigr\|(\S+)$/)
1244        {
1245            return "<a href=\"http://www.tigr.org/tigr-scripts/CMR2/GenePage.spl?locus=$1\" target=_blank>$tigr</a>";
1246        }
1247        return $tigr;
1248    }
1249    
1250    sub eric_link {
1251        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1252        my($cgi,$eric) = @_;
1253    
1254        if ($eric =~ /^eric\|(\S+)/)
1255        {
1256            return "<a href=\"https://asap.ahabs.wisc.edu/asap/feature_info.php?FeatureID=$1\" target=_blank>$eric</a>";
1257        }
1258        return $eric;
1259    }
1260    
1261    sub bhb_link {
1262        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1263        my($cgi,$bhb) = @_;
1264    
1265        return "<a href=\"http://www.biohealthbase.org\" target=_blank>$bhb</a>";
1266    }
1267    
1268    sub apidb_link {
1269        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1270        my($cgi,$api) = @_;
1271    
1272        if ($api =~ /apidb\|(.*?)\.(.*)$/)
1273        {
1274            return "<a href=\"http://www.apidb.org/cgi-bin/redirect.cgi?taxon_id=$1&source_id=$2\" target=_blank>$api</a>";
1275        }
1276        return $api;
1277    }
1278    
1279    sub patric_link {
1280        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1281        my($cgi,$patric) = @_;
1282    
1283        if ($patric =~ /patric\|(.*)/)
1284        {
1285            return "<a href=\"https://patric.vbi.vt.edu/software/curationTool/gep/pgiCuration.php?locus_name=$1\" target=_blank>$patric</a>";
1286        }
1287        return $patric;
1288    }
1289    
1290    sub vbrc_link {
1291        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1292        my($cgi,$vbrc) = @_;
1293    
1294        if ($vbrc =~ /vbrc\|(.*)/)
1295        {
1296            return "<a href=\"http://www.biovirus.org/gene_detail.asp?name=$1\" target=_blank>$vbrc</a>";
1297        }
1298        return $vbrc;
1299    }
1300    
1301    sub vectorbase_link {
1302        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1303        my($cgi,$vec) = @_;
1304        return "<a href=\"http://www.vectorbase.org\" target=_blank>$vec</a>";
1305    }
1306    
1307    
1308  sub uni_link {  sub uni_link {
1309        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1310      my($cgi,$uni) = @_;      my($cgi,$uni) = @_;
1311    
1312      if ($uni =~ /^uni\|(\S+)$/)      if ($uni =~ /^uni\|(\S+)$/)
1313      {      {
1314          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>";
1315            return "<a href='http://www.ebi.uniprot.org/uniprot-srv/uniProtView.do?proteinAc=$1' target=_blank>$uni</a>";
1316      }      }
1317      return $uni;      return $uni;
1318  }  }
1319    
1320  sub sp_link {  sub sp_link {
1321        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1322      my($cgi,$sp) = @_;      my($cgi,$sp) = @_;
1323    
1324      if ($sp =~ /^sp\|(\S+)$/)      if ($sp =~ /^sp\|(\S+)$/)
1325      {      {
1326          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>";
1327      }      }
1328      return $sp;      return $sp;
1329  }  }
1330    
1331  sub pir_link {  sub pir_link {
1332        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1333      my($cgi,$pir) = @_;      my($cgi,$pir) = @_;
1334    
1335      if ($pir =~ /^pirnr\|(NF\d+)$/)      if ($pir =~ /^pirnr\|(NF\d+)$/)
1336      {      {
1337          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>";
1338      }      }
1339      return $pir;      return $pir;
1340  }  }
1341    
1342  sub kegg_link {  sub kegg_link {
1343        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1344      my($cgi,$kegg) = @_;      my($cgi,$kegg) = @_;
1345    
1346      if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)      if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)
1347      {      {
1348          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>";
1349      }      }
1350      return $kegg;      return $kegg;
1351  }  }
1352    
1353    sub ensembl_link {
1354        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1355        my($cgi,$ensembl) = @_;
1356    
1357        if ($ensembl =~ /^(\S+):(\S+)$/)
1358        {
1359            my $what=$1;
1360            my $key=$2;
1361            my $idx="All";
1362            if ($what eq "EnsemblGene") { $idx = "Gene" }
1363            if ($what eq "EnsemblTranscript") { $idx = "All" }
1364            if ($what eq "EnsemblProtein") { $idx = "All" }
1365    
1366            #I really want to get right to the transcript and peptide pages, but
1367            #can't see how to do that without knowing the org name too, which
1368            #I don't know at this point. (ensembl org name, not real org name)
1369    
1370            return "<a href='http://www.ensembl.org/Homo_sapiens/searchview?species=all&idx=$idx&q=$key' target=_blank>$ensembl</a>";
1371        }
1372        return $ensembl;
1373    }
1374    
1375    sub entrezgene_link {
1376        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1377        my($cgi,$entrezgene) = @_;
1378    
1379        if ($entrezgene =~ /^EntrezGene:(\S+)$/)
1380        {
1381            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>";
1382        }
1383        return $entrezgene;
1384    }
1385    
1386    sub mim_link {
1387        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1388        my($cgi,$mim) = @_;
1389    
1390        if ($mim =~ /^MIM:(\S+)$/)
1391        {
1392            return "<a href='http://www3.ncbi.nlm.nih.gov/entrez/dispomim.cgi?id=$1' target=_blank>$mim</a>";
1393        }
1394        return $mim;
1395    }
1396    
1397    sub hgnc_link {
1398        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1399        my($cgi,$hgnc) = @_;
1400    
1401        if ($hgnc =~ /^HGNC:(\S+)$/)
1402        {
1403            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>";
1404        }
1405    
1406        return $hgnc;
1407    }
1408    
1409    sub unigene_link {
1410        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1411        my($cgi,$unigene) = @_;
1412    
1413        if ($unigene =~ /^UniGene:(\S+)$/)
1414        {
1415            return "<a href='http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=unigene&cmd=search&term=$1' target=_blank>$unigene</a>";
1416        }
1417        return $unigene;
1418    }
1419    
1420    sub ipi_link {
1421        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1422        my($cgi,$ipi) = @_;
1423    
1424        if ($ipi =~ /^IPI:(\S+)$/)
1425        {
1426            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>";
1427        }
1428        return $ipi;
1429    }
1430    
1431    sub wp_link {
1432        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1433        my($cgi,$wp) = @_;
1434    
1435        #wormbase
1436    
1437        if ($wp =~ /^WP:(\S+)$/)
1438        {
1439            return "<a href='http://www.wormbase.org/db/searches/basic?class=Any&query=$1&Search=Search' target=_blank>$wp</a>";
1440        }
1441        return $wp;
1442    }
1443    
1444    sub fb_link {
1445        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1446        my($cgi,$fb) = @_;
1447    
1448        #flybase
1449    
1450        if ($fb =~ /^FB:(\S+)$/)
1451        {
1452            return "<a href='http://flybase.bio.indiana.edu/.bin/fbidq.html?$1' target=_blank>$fb</a>";
1453        }
1454        return $fb;
1455    }
1456    
1457    sub fborf_link {
1458        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1459        my($cgi,$fb) = @_;
1460    
1461        #flybase
1462    
1463        if ($fb =~ /^FlyBaseORFNames:(\S+)$/)
1464        {
1465            return "<a href='http://flybase.bio.indiana.edu/.bin/fbidq.html?$1' target=_blank>$fb</a>";
1466        }
1467        return $fb;
1468    }
1469    
1470    sub sgd_link {
1471        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1472        my($cgi,$sgd) = @_;
1473    
1474        #yeast
1475    
1476        if ($sgd =~ /^SGD_LOCUS:(\S+)$/)
1477        {
1478            return "<a href='http://db.yeastgenome.org/cgi-bin/locus.pl?locus=$1' target=_blank>$sgd</a>";
1479        }
1480        return $sgd;
1481    }
1482    
1483    
1484    
1485    
1486  sub set_map_links {  sub set_map_links {
1487        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1488      my($cgi,$x) = @_;      my($cgi,$x) = @_;
1489      my($before,$match,$after);      my($before,$match,$after);
1490    
# Line 637  Line 1500 
1500      return $x;      return $x;
1501  }  }
1502    
1503    
1504    
1505  sub map_link {  sub map_link {
1506        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1507      my($cgi,$map,$org) = @_;      my($cgi,$map,$org) = @_;
1508    
1509      $user = $cgi->param('user');      my $user = $cgi->param('user');
1510      $user = $user ? $user : "";      $user = $user ? $user : "";
1511      $org = $org ? $org : "";      $org = $org ? $org : "";
1512      my $url = "$FIG_Config::cgi_url/show_kegg_map.cgi?user=$user&map=$map&org=$org";  
1513        my $url = "show_kegg_map.cgi?user=$user&map=$map&org=$org";
1514    #rel    my $url = &FIG::cgi_url() . "/show_kegg_map.cgi?user=$user&map=$map&org=$org";
1515      my $link = "<a href=\"$url\">$map</a>";      my $link = "<a href=\"$url\">$map</a>";
1516      return $link;      return $link;
1517  }  }
1518    
1519  1  sub java_buttons {
1520        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1521      ## ADDED BY RAE
1522      # Provides code to include check all/first half/second half/none for javascrspt
1523      # this takes two variables - the form name provided in start_form with the
1524      # -name => field and the checkbox name
1525      my ($form, $button)=@_;
1526    
1527      my $java_script="<input type=\"button\" name=\"CheckAll\" value=\"Check All\"\nonClick=\"checkAll(document.$form.$button)\">\n";
1528      $java_script.="<input type=\"button\" name=\"CheckFirst\" value=\"Check First Half\"\nonClick=\"checkFirst(document.$form.$button)\">\n";
1529      $java_script.="<input type=\"button\" name=\"CheckSecond\" value=\"Check Second Half\"\nonClick=\"checkSecond(document.$form.$button)\">\n";
1530      $java_script.="<input type=\"button\" name=\"UnCheckAll\" value=\"Uncheck All\"\nonClick=\"uncheckAll(document.$form.$button)\">\n";
1531    
1532      return $java_script;
1533    }
1534    
1535    sub sub_link {
1536        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1537        my($cgi,$sub) = @_;
1538        my($sub_link);
1539    
1540        my $user = $cgi->param('user');
1541        my $esc_sub = uri_escape( $sub );
1542        $sub =~ s/\_/ /g;
1543        if ($user)
1544        {
1545            $sub_link = "<a href=./subsys.cgi?ssa_name=$esc_sub&request=show_ssa&user=$user>$sub</a>";
1546        }
1547        else
1548        {
1549            $sub_link = "<a href=\"display_subsys.cgi?ssa_name=$esc_sub&request=show_ssa&sort=by_phylo\">$sub</a>";
1550        }
1551        return $sub_link;
1552    }
1553    
1554    sub reaction_link {
1555        my($reaction) = @_;
1556        if ($reaction =~ /^(\*)?(R\d+)/)
1557        {
1558            return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?rn+$2\" target=reaction$$>$reaction</a>";
1559        }
1560        return $reaction;
1561    }
1562    
1563    
1564    sub html_for_assignments {
1565        my($fig,$user,$peg_sets) = @_;
1566        my $i;
1567    
1568        my @vals = ();
1569        my $set = 1;
1570        foreach my $peg_set (@$peg_sets)
1571        {
1572            for ($i=0; ($i < @$peg_set); $i++)
1573            {
1574                my $peg = $peg_set->[$i];
1575                push(@vals,'show=' . join("@",($set,$i+1,$peg,&FIG::abbrev($fig->org_of($peg)),"")));
1576            }
1577            $set++;
1578        }
1579    
1580        $ENV{'REQUEST_METHOD'} = 'GET';
1581        $ENV{'QUERY_STRING'} = join('&',('request=show_commentary',"uni=1","user=$user",@vals));
1582        my $out = join("",`$FIG_Config::fig/CGI/chromosomal_clusters.cgi`);
1583        $out =~ s/^.*?<form/<form/si;
1584        $out =~ s/^(.*)<table.*/$1/si;
1585        return $out;
1586    }
1587    
1588    =head1 rss_feed
1589    
1590    Add something to the RSS feed. The rss feeds are stored in the Html directory, and there are several RSS feeds:
1591            SEED.rss                - everything gets written here
1592            SEEDgenomes.rss                 - whenever a genome is added to the SEED
1593            SEEDsubsystems.rss      - whenever a subsystem is edited (or should this be added?)
1594    
1595    
1596    RSS feeds must contain a title, description, and link. The title is what is seen e.g. from the firefox or safari pull down menu. The description is seen from within an rss aggregator, and may be displayed on web pages and so on.
1597    
1598    The method takes a reference to an array containing the file names for the RSS feeds to add your item to, and a hash of items for the xml. Only title, description, and link are required tags in the XML.
1599    
1600    The file names are the full name of the file, eg SEEDsubsystems.rss, SEEDgenomes.rss. Be aware that this is a file name, though, so don't uses special characters. The path will be added.
1601    
1602    The has can have these keys:
1603    
1604    REQUIRED:
1605    title       : the title. This is usually what is seen by the user in the pull down menu
1606    description : a more complete description that is often seen is rss viewers but not always
1607    link        : link to the item that was added/edited
1608    All other keys are treated as optional RSS arguments and written to the file.
1609    
1610    At most, $max_entries recent entries are stored in the rss file, and this is currently 50.
1611    
1612    RSS files are quite simple, and contain some standard header information, and then individual items surrounded by an <item> </item> tag. Note that there is also an initial title/description/link set that describes the file.
1613    
1614    
1615    =cut
1616    
1617    sub rss_feed {
1618     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1619     my ($files, $args)=@_;
1620    
1621     # how many entries to store in the file
1622     my $max_entries=50;
1623    
1624     foreach my $a (keys %$args) {if ($a =~ /^-(.*)/) {my $b=$1; $args->{$b}=$args->{$a}; delete $args->{$a}}}
1625    
1626     my $filepath=$FIG_Config::fig."/CGI/Html/rss";
1627     # check for the directory and if not, make it
1628     mkdir $filepath unless (-d $filepath);
1629    
1630     # note that $info is a hash of references to hashes that are written out as headers in the file
1631     my $info=
1632     {
1633      "SEED.rss" =>
1634       {
1635            title           => "The SEED",
1636            description     => "Latest news from the SEED",
1637            link            => "Html/rss/SEED.rss",
1638       },
1639    
1640      "SEEDsubsystems.rss" =>
1641      {
1642            title           => "SEED Subsystems",
1643            description     => "Recently updated SEED subsystems",
1644            link            => "Html/rss/SEEDsubsystems.rss",
1645      },
1646    
1647      "SEEDsubsystems.rss" =>
1648      {
1649            title           => "SEED Genomes",
1650            description     => "Genomes recently added to the SEED",
1651            link            => &FIG::cgi_url()."/Html/rss/SEEDsubsystems.rss",
1652      },
1653    
1654     };
1655    
1656    
1657     # build the new xml
1658     my $xml = "\t<item>\n";
1659     foreach my $qw ("title", "description", "link") {
1660      unless ($args->{$qw}) {
1661       print STDERR "You need to include a $qw tag in your RSS description\n";
1662       return(0);
1663      }
1664      # we need to do something a bit funky with the link. We can't have ampersands in the <link> </link> in valid html
1665      # so we are going to pull out the links and uri_escape just the part after the .cgi
1666      if ($qw eq "link")
1667      {
1668       $args->{$qw} =~ /^(.*?\.cgi.)(.*)$/;
1669       $args->{$qw} = $1.uri_escape($2) if ($1 && $2);
1670      }
1671    
1672      $xml .= "\t\t<$qw>".$args->{$qw}."</$qw>\n";
1673      delete $args->{$qw};
1674     }
1675    
1676     foreach my $tag (grep {!/type/i} keys %$args)
1677     {
1678      $xml .= "\t\t<$tag>".$args->{$tag}."</$tag>\n";
1679     }
1680    
1681     $xml .= "\t</item>\n";
1682    
1683    
1684     my @files=("SEED.rss");
1685     if ($args->{"type"}) {
1686        my $type = $args->{type};
1687        push @files, "SEED.$type.rss"
1688    }
1689    
1690     foreach my $file ("SEED.rss", @$files)
1691     {
1692      if (-e "$filepath/$file")
1693      {
1694       my @out; # the new content of the file
1695       my $itemcount=0; # how many <item> </item>'s are we keeping
1696       my $initem; # are we in an item?
1697       open(IN, "$filepath/$file") || die "Can't open $filepath/$file";
1698       while (<IN>)
1699       {
1700        if (/\<item\>/) {
1701         push @out, $xml, unless ($itemcount);
1702         $itemcount++;
1703         $initem=1;
1704        }
1705        if (/\<\/item\>/) {$initem=0; next if ($itemcount > $max_entries)}
1706        next if ($initem && $itemcount > $max_entries);
1707        push @out, $_;
1708       }
1709       close IN;
1710       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1711       print OUT @out;
1712      }
1713      else
1714      {
1715       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1716       print OUT "<?xml version=\"1.0\"?>\n<rss version=\"2.0\">\n<channel>\n";
1717       if ($info->{$file})
1718       {
1719         # we're going to sanity check each of the three options we output, just to be sure
1720         foreach my $qw ("title", "description", "link")
1721         {
1722           if ($info->{$file}->{$qw})
1723           {
1724              print OUT "<$qw>", $info->{$file}->{$qw}, "</$qw>\n";
1725           } else {
1726              print STDERR "Please add a $qw for $file\n"; print OUT "<$qw>$file</$qw>\n";
1727           }
1728         }
1729       }
1730       else {
1731        print STDERR "Please define title, link, and description information for $file\n";
1732        print OUT "<title>$file</title>\n<description>An RSS feed</description>\n<link>", &FIG::cgi_url, "</link>\n";
1733       }
1734       print OUT "\n", $xml;
1735       print OUT "\n", "</channel>\n</rss>\n"
1736      }
1737     }
1738    }
1739    
1740    
1741    
1742    1;
1743    

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3