[Bio] / FigKernelPackages / HTML.pm Repository:
ViewVC logotype

Diff of /FigKernelPackages/HTML.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3