[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.88, Fri Feb 3 18:42:27 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 =~ /^(.*)(UniGene:[a-zA-Z_0-9\.]+)(.*)/s)
1098        {
1099            $before = $1;
1100            $match = $2;
1101            $after = $3;
1102            return &set_prot_links($cgi,$before) . &HTML::unigene_link($cgi,$match) . &set_prot_links($cgi,$after);
1103        }
1104        elsif ($x =~ /^(.*)(IPI:[a-zA-Z_0-9\.]+)(.*)/s)
1105        {
1106            $before = $1;
1107            $match = $2;
1108            $after = $3;
1109            return &set_prot_links($cgi,$before) . &HTML::ipi_link($cgi,$match) . &set_prot_links($cgi,$after);
1110        }
1111        elsif ($x =~ /^(.*)(WP:[a-zA-Z_0-9\.]+)(.*)/s)
1112        {
1113            #wormbase
1114    
1115            $before = $1;
1116            $match = $2;
1117            $after = $3;
1118            return &set_prot_links($cgi,$before) . &HTML::wp_link($cgi,$match) . &set_prot_links($cgi,$after);
1119        }
1120        elsif ($x =~ /^(.*)(FB:[a-zA-Z_0-9\.]+)(.*)/s)
1121        {
1122            #flybase
1123    
1124            $before = $1;
1125            $match = $2;
1126            $after = $3;
1127            return &set_prot_links($cgi,$before) . &HTML::fb_link($cgi,$match) . &set_prot_links($cgi,$after);
1128        }
1129        elsif ($x =~ /^(.*)(FlyBaseORFNames:[a-zA-Z_0-9\.]+)(.*)/s)
1130        {
1131            #flybase
1132    
1133            $before = $1;
1134            $match = $2;
1135            $after = $3;
1136            return &set_prot_links($cgi,$before) . &HTML::fborf_link($cgi,$match) . &set_prot_links($cgi,$after);
1137        }
1138        elsif ($x =~ /^(.*)(SGD_LOCUS:[a-zA-Z_0-9\.]+)(.*)/s)
1139        {
1140            #flybase
1141    
1142            $before = $1;
1143            $match = $2;
1144            $after = $3;
1145            return &set_prot_links($cgi,$before) . &HTML::sgd_link($cgi,$match) . &set_prot_links($cgi,$after);
1146        }
1147        return $x;
1148    }
1149    
1150    sub refseq_link {
1151        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1152        my($cgi,$id) = @_;
1153    
1154        if ($id =~ /^[NXYZA]P_/)
1155        {
1156            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id>$id</a>";
1157        }
1158        elsif ($id =~ /^[NXYZA]M_/)
1159        {
1160            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=nuccore&cmd=search&term=$id>$id</a>";
1161        }
1162    }
1163    
1164    sub gi_link {
1165        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1166        my($cgi,$gi) = @_;
1167    
1168        if ($gi =~ /^gi\|(\d+)$/)
1169        {
1170            return "<a href=http://www.ncbi.nlm.nih.gov:80/entrez/query.fcgi?cmd=Retrieve&db=Protein&list_uids=$1&dopt=GenPept>$gi</a>";
1171        }
1172        return $gi;
1173    }
1174    
1175    sub tigr_link {
1176        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1177        my($cgi,$tigr) = @_;
1178    
1179        if ($tigr =~ /^tigr\|(NT|ntbp|ntbpA|BA|BMAA|BXB|GBA)(\w+)$/)
1180        {
1181            my $id=$1.$2;
1182            return "<a href=\"http://pathema.tigr.org/tigr-scripts/pathema/shared/GenePage.cgi?locus=$id\">$tigr</a> (Pathema)";
1183        }
1184        elsif ($tigr =~ /^tigr\|(\S+)$/)
1185        {
1186            return "<a href=\"http://www.tigr.org/tigr-scripts/CMR2/GenePage.spl?locus=$1\">$tigr</a>";
1187        }
1188        return $tigr;
1189    }
1190    
1191    sub eric_link {
1192        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1193        my($cgi,$eric) = @_;
1194    
1195        if ($eric =~ /^eric\|(\S+)/)
1196        {
1197            return "<a href=\"https://asap.ahabs.wisc.edu/asap/feature_info.php?FeatureID=$1\">$eric</a>";
1198        }
1199        return $eric;
1200    }
1201    
1202    sub bhb_link {
1203        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1204        my($cgi,$bhb) = @_;
1205    
1206        return "<a href=\"http://www.biohealthbase.org\">$bhb</a>";
1207    }
1208    
1209    sub apidb_link {
1210        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1211        my($cgi,$api) = @_;
1212    
1213        if ($api =~ /apidb\|(.*?)\.(.*)$/)
1214        {
1215            return "<a href=\"http://www.apidb.org/cgi-bin/redirect.cgi?taxon_id=$1&source_id=$2\">$api</a>";
1216        }
1217        return $api;
1218    }
1219    
1220    sub patric_link {
1221        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1222        my($cgi,$patric) = @_;
1223    
1224        if ($patric =~ /patric\|(.*)/)
1225        {
1226            return "<a href=\"https://patric.vbi.vt.edu/software/curationTool/gep/pgiCuration.php?locus_name=$1\">$patric</a>";
1227        }
1228        return $patric;
1229    }
1230    
1231    sub vbrc_link {
1232        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1233        my($cgi,$vbrc) = @_;
1234    
1235        if ($vbrc =~ /vbrc\|(.*)/)
1236        {
1237            return "<a href=\"http://www.biovirus.org/gene_detail.asp?name=$1\">$vbrc</a>";
1238        }
1239        return $vbrc;
1240    }
1241    
1242    sub vectorbase_link {
1243        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1244        my($cgi,$vec) = @_;
1245        return "<a href=\"http://www.vectorbase.org\">$vec</a>";
1246    }
1247    
1248    
1249    sub uni_link {
1250        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1251        my($cgi,$uni) = @_;
1252    
1253        if ($uni =~ /^uni\|(\S+)$/)
1254        {
1255            return "<a href=http://www.pir.uniprot.org/cgi-bin/upEntry?id=$1>$uni</a>";
1256        }
1257        return $uni;
1258    }
1259    
1260    sub sp_link {
1261        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1262        my($cgi,$sp) = @_;
1263    
1264        if ($sp =~ /^sp\|(\S+)$/)
1265        {
1266            return "<a href=http://us.expasy.org/cgi-bin/get-sprot-entry?$1>$sp</a>";
1267        }
1268        return $sp;
1269    }
1270    
1271    sub pir_link {
1272        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1273        my($cgi,$pir) = @_;
1274    
1275        if ($pir =~ /^pirnr\|(NF\d+)$/)
1276        {
1277            return "<a href=http://pir.georgetown.edu/cgi-bin/nfEntry.pl?id=$1>$pir</a>";
1278        }
1279        return $pir;
1280    }
1281    
1282    sub kegg_link {
1283        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1284        my($cgi,$kegg) = @_;
1285    
1286        if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)
1287        {
1288            return "<a href=http://www.genome.ad.jp/dbget-bin/www_bget?$1+$2>$kegg</a>";
1289        }
1290        return $kegg;
1291    }
1292    
1293    sub ensembl_link {
1294        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1295        my($cgi,$ensembl) = @_;
1296    
1297        if ($ensembl =~ /^(\S+):(\S+)$/)
1298        {
1299            my $what=$1;
1300            my $key=$2;
1301            my $idx="all";
1302            if ($what eq "EnsemblGene") { $idx = "Gene" }
1303            if ($what eq "EnsemblTranscript") { $idx = "all" }
1304            if ($what eq "EnsemblProtein") { $idx = "all" }
1305    
1306            #I really want to get right to the transcript and peptide pages, but
1307            #can't see how to do that without knowing the org name too, which
1308            #I don't know at this point. (ensembl org name, not real org name)
1309    
1310            return "<a href=http://www.ensembl.org/Homo_sapiens/textview?species=all&idx=$idx&q=$key>$ensembl</a>";
1311        }
1312        return $ensembl;
1313    }
1314    
1315    sub entrezgene_link {
1316        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1317        my($cgi,$entrezgene) = @_;
1318    
1319        if ($entrezgene =~ /^EntrezGene:(\S+)$/)
1320        {
1321            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=gene&cmd=Retrieve&dopt=full_report&list_uids=$1>$entrezgene</a>";
1322        }
1323        return $entrezgene;
1324    }
1325    
1326    sub mim_link {
1327        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1328        my($cgi,$mim) = @_;
1329    
1330        if ($mim =~ /^MIM:(\S+)$/)
1331        {
1332            return "<a href=http://www3.ncbi.nlm.nih.gov/entrez/dispomim.cgi?id=$1>$mim</a>";
1333        }
1334        return $mim;
1335    }
1336    
1337    sub unigene_link {
1338        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1339        my($cgi,$unigene) = @_;
1340    
1341        if ($unigene =~ /^UniGene:(\S+)$/)
1342        {
1343            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=unigene&cmd=search&term=$1>$unigene</a>";
1344        }
1345        return $unigene;
1346    }
1347    
1348    sub ipi_link {
1349        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1350        my($cgi,$ipi) = @_;
1351    
1352        if ($ipi =~ /^IPI:(\S+)$/)
1353        {
1354            return "<a href=http://srs.ebi.ac.uk/srsbin/cgi-bin/wgetz?-id+AEoS1R8Jnn+-e+[IPI:\'$1\']+-qnum+1+-enum+1>$ipi</a>";
1355        }
1356        return $ipi;
1357    }
1358    
1359    sub wp_link {
1360        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1361        my($cgi,$wp) = @_;
1362    
1363        #wormbase
1364    
1365        if ($wp =~ /^WP:(\S+)$/)
1366        {
1367            return "<a href=http://www.wormbase.org/db/searches/basic?class=Any&query=$1&Search=Search>$wp</a>";
1368        }
1369        return $wp;
1370    }
1371    
1372    sub fb_link {
1373        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1374        my($cgi,$fb) = @_;
1375    
1376        #flybase
1377    
1378        if ($fb =~ /^FB:(\S+)$/)
1379        {
1380            return "<a href=http://flybase.bio.indiana.edu/.bin/fbidq.html?$1>$fb</a>";
1381        }
1382        return $fb;
1383    }
1384    
1385    sub fborf_link {
1386        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1387        my($cgi,$fb) = @_;
1388    
1389        #flybase
1390    
1391        if ($fb =~ /^FlyBaseORFNames:(\S+)$/)
1392        {
1393            return "<a href=http://flybase.bio.indiana.edu/.bin/fbidq.html?$1>$fb</a>";
1394        }
1395        return $fb;
1396    }
1397    
1398    sub sgd_link {
1399        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1400        my($cgi,$sgd) = @_;
1401    
1402        #yeast
1403    
1404        if ($sgd =~ /^SGD_LOCUS:(\S+)$/)
1405        {
1406            return "<a href=http://db.yeastgenome.org/cgi-bin/locus.pl?locus=$1>$sgd</a>";
1407        }
1408        return $sgd;
1409    }
1410    
1411    
1412    
1413    
1414    sub set_map_links {
1415        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1416        my($cgi,$x) = @_;
1417        my($before,$match,$after);
1418    
1419        my $org = ($cgi->param('org') || $cgi->param('genome') || "");
1420    
1421        if ($x =~ /^(.*)(MAP\d+)(.*)/s)
1422        {
1423            $before = $1;
1424            $match = $2;
1425            $after = $3;
1426            return &set_map_links($cgi,$before) . &map_link($cgi,$match,$org) . &set_map_links($cgi,$after);
1427        }
1428        return $x;
1429    }
1430    
1431    
1432    
1433    sub map_link {
1434        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1435        my($cgi,$map,$org) = @_;
1436    
1437        $user = $cgi->param('user');
1438        $user = $user ? $user : "";
1439        $org = $org ? $org : "";
1440    
1441        my $url = "show_kegg_map.cgi?user=$user&map=$map&org=$org";
1442    #rel    my $url = &FIG::cgi_url() . "/show_kegg_map.cgi?user=$user&map=$map&org=$org";
1443        my $link = "<a href=\"$url\">$map</a>";
1444        return $link;
1445    }
1446    
1447    sub java_buttons {
1448        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1449      ## ADDED BY RAE
1450      # Provides code to include check all/first half/second half/none for javascrspt
1451      # this takes two variables - the form name provided in start_form with the
1452      # -name => field and the checkbox name
1453      my ($form, $button)=@_;
1454    
1455      $java_script="<input type=\"button\" name=\"CheckAll\" value=\"Check All\"\nonClick=\"checkAll(document.$form.$button)\">\n";
1456      $java_script.="<input type=\"button\" name=\"CheckFirst\" value=\"Check First Half\"\nonClick=\"checkFirst(document.$form.$button)\">\n";
1457      $java_script.="<input type=\"button\" name=\"CheckSecond\" value=\"Check Second Half\"\nonClick=\"checkSecond(document.$form.$button)\">\n";
1458      $java_script.="<input type=\"button\" name=\"UnCheckAll\" value=\"Uncheck All\"\nonClick=\"uncheckAll(document.$form.$button)\">\n";
1459    
1460      return $java_script;
1461    }
1462    
1463    sub sub_link {
1464        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1465        my($cgi,$sub) = @_;
1466        my($sub_link);
1467    
1468        my $user = $cgi->param('user');
1469        my $esc_sub = uri_escape( $sub );
1470        $sub =~ s/\_/ /g;
1471        if ($user)
1472        {
1473            $sub_link = "<a href=./subsys.cgi?ssa_name=$esc_sub&request=show_ssa&user=$user>$sub</a>";
1474        }
1475        else
1476        {
1477            $sub_link = "<a href=\"display_subsys.cgi?ssa_name=$esc_sub&request=show_ssa&sort=by_phylo\">$sub</a>";
1478        }
1479        return $sub_link;
1480    }
1481    
1482    sub reaction_link {
1483        my($reaction) = @_;
1484    
1485        if ($reaction =~ /^R\d+/)
1486        {
1487            return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?rn+$reaction\" target=reaction$$>$reaction</a>";
1488        }
1489        return $reaction;
1490    }
1491    
1492    sub html_for_assignments {
1493        my($fig,$user,$peg_sets) = @_;
1494        my $i;
1495    
1496        my @vals = ();
1497        my $set = 1;
1498        foreach $peg_set (@$peg_sets)
1499        {
1500            for ($i=0; ($i < @$peg_set); $i++)
1501            {
1502                $peg = $peg_set->[$i];
1503                push(@vals,'show=' . join("@",($set,$i+1,$peg,&FIG::abbrev($fig->org_of($peg)),"")));
1504            }
1505            $set++;
1506        }
1507    
1508        $ENV{'REQUEST_METHOD'} = 'GET';
1509        $ENV{'QUERY_STRING'} = join('&',('request=show_commentary',"uni=1","user=$user",@vals));
1510        my $out = join("",`$FIG_Config::fig/CGI/chromosomal_clusters.cgi`);
1511        $out =~ s/^.*?<form/<form/si;
1512        $out =~ s/^(.*)<table.*/$1/si;
1513        return $out;
1514    }
1515    
1516    =head1 rss_feed
1517    
1518    Add something to the RSS feed. The rss feeds are stored in the Html directory, and there are several RSS feeds:
1519            SEED.rss                - everything gets written here
1520            SEEDgenomes.rss                 - whenever a genome is added to the SEED
1521            SEEDsubsystems.rss      - whenever a subsystem is edited (or should this be added?)
1522    
1523    
1524    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.
1525    
1526    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.
1527    
1528    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.
1529    
1530    The has can have these keys:
1531    
1532    REQUIRED:
1533    title       : the title. This is usually what is seen by the user in the pull down menu
1534    description : a more complete description that is often seen is rss viewers but not always
1535    link        : link to the item that was added/edited
1536    All other keys are treated as optional RSS arguments and written to the file.
1537    
1538    At most, $max_entries recent entries are stored in the rss file, and this is currently 50.
1539    
1540    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.
1541    
1542    
1543    =cut
1544    
1545    sub rss_feed {
1546     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1547     my ($files, $args)=@_;
1548    
1549     # how many entries to store in the file
1550     my $max_entries=50;
1551    
1552     foreach my $a (keys %$args) {if ($a =~ /^-(.*)/) {my $b=$1; $args->{$b}=$args->{$a}; delete $args->{$a}}}
1553    
1554     my $filepath=$FIG_Config::fig."/CGI/Html/rss";
1555     # check for the directory and if not, make it
1556     mkdir $filepath unless (-d $filepath);
1557    
1558     # note that $info is a hash of references to hashes that are written out as headers in the file
1559     my $info=
1560     {
1561      "SEED.rss" =>
1562       {
1563            title           => "The SEED",
1564            description     => "Latest news from the SEED",
1565            link            => "Html/rss/SEED.rss",
1566       },
1567    
1568      "SEEDsubsystems.rss" =>
1569      {
1570            title           => "SEED Subsystems",
1571            description     => "Recently updated SEED subsystems",
1572            link            => "Html/rss/SEEDsubsystems.rss",
1573      },
1574    
1575      "SEEDsubsystems.rss" =>
1576      {
1577            title           => "SEED Genomes",
1578            description     => "Genomes recently added to the SEED",
1579            link            => &FIG::cgi_url()."/Html/rss/SEEDsubsystems.rss",
1580      },
1581    
1582     };
1583    
1584    
1585     # build the new xml
1586     my $xml = "\t<item>\n";
1587     foreach my $qw ("title", "description", "link") {
1588      unless ($args->{$qw}) {
1589       print STDERR "You need to include a $qw tag in your RSS description\n";
1590       return(0);
1591      }
1592      # we need to do something a bit funky with the link. We can't have ampersands in the <link> </link> in valid html
1593      # so we are going to pull out the links and uri_escape just the part after the .cgi
1594      if ($qw eq "link")
1595      {
1596       $args->{$qw} =~ /^(.*?\.cgi.)(.*)$/;
1597       $args->{$qw} = $1.uri_escape($2) if ($1 && $2);
1598      }
1599    
1600      $xml .= "\t\t<$qw>".$args->{$qw}."</$qw>\n";
1601      delete $args->{$qw};
1602     }
1603    
1604     foreach my $tag (grep {!/type/i} keys %$args)
1605     {
1606      $xml .= "\t\t<$tag>".$args->{$tag}."</$tag>\n";
1607     }
1608    
1609     $xml .= "\t</item>\n";
1610    
1611    
1612     my @files=("SEED.rss");
1613     if ($args->{"type"}) {push @files, "SEED.$type.rss"}
1614    
1615     foreach my $file ("SEED.rss", @$files)
1616     {
1617      if (-e "$filepath/$file")
1618      {
1619       my @out; # the new content of the file
1620       my $itemcount=0; # how many <item> </item>'s are we keeping
1621       my $initem; # are we in an item?
1622       open(IN, "$filepath/$file") || die "Can't open $filepath/$file";
1623       while (<IN>)
1624       {
1625        if (/\<item\>/) {
1626         push @out, $xml, unless ($itemcount);
1627         $itemcount++;
1628         $initem=1;
1629        }
1630        if (/\<\/item\>/) {$initem=0; next if ($itemcount > $max_entries)}
1631        next if ($initem && $itemcount > $max_entries);
1632        push @out, $_;
1633       }
1634       close IN;
1635       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1636       print OUT @out;
1637      }
1638      else
1639      {
1640       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1641       print OUT "<?xml version=\"1.0\"?>\n<rss version=\"2.0\">\n<channel>\n";
1642       if ($info->{$file})
1643       {
1644         # we're going to sanity check each of the three options we output, just to be sure
1645         foreach my $qw ("title", "description", "link")
1646         {
1647           if ($info->{$file}->{$qw})
1648           {
1649              print OUT "<$qw>", $info->{$file}->{$qw}, "</$qw>\n";
1650           } else {
1651              print STDERR "Please add a $qw for $file\n"; print OUT "<$qw>$file</$qw>\n";
1652           }
1653         }
1654       }
1655       else {
1656        print STDERR "Please define title, link, and description information for $file\n";
1657        print OUT "<title>$file</title>\n<description>An RSS feed</description>\n<link>", &FIG::cgi_url, "</link>\n";
1658       }
1659       print OUT "\n", $xml;
1660       print OUT "\n", "</channel>\n</rss>\n"
1661      }
1662     }
1663    }
1664    
1665    
1666    
1667    1;
1668    
 1  

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3