[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.61, Mon Oct 3 20:05:34 2005 UTC
# Line 1  Line 1 
1  package HTML;  package HTML;
2    
3    use Tracer;
4    use FIG;
5  use Carp;  use Carp;
6  use Data::Dumper;  use Data::Dumper;
7  use LWP::UserAgent;  use LWP::UserAgent;
8  use LWP::Simple;  use LWP::Simple;
9    use URI::Escape;  # uri_escape()
10  use URI::URL;  use URI::URL;
11  use HTTP::Request::Common;  use HTTP::Request::Common;
12    use POSIX;
13    
14    
15    sub new
16    {
17        my($class) = @_;
18    
19        my $self = {};
20    
21        return bless $self, $class;
22    }
23    
24    sub compute_html_header
25    {
26        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
27        my($additional_insert, $user, %options ) = @_;
28    
29        my $header_name = $options{header_name} ? $options{header_name} : "html.hdr";
30        my $tail_name = $options{tail_name} ? $options{tail_name} : "html.tail";
31    
32        my $html_hdr_file = "./Html/$header_name";
33        if (! -f $html_hdr_file)
34        {
35            $html_hdr_file = "$FIG_Config::fig/CGI/Html/$header_name";
36        }
37        my @html_hdr = &FIG::file_read($html_hdr_file);
38    
39        $options{no_fig_search} or push( @html_hdr, "<br><a href=\"index.cgi?user=$user\">FIG search</a>\n" );
40    
41        if (@html_hdr)
42        {
43            my $insert_stuff;
44    
45            if (not $options{no_release_info})
46            {
47                my @ver = &FIG::file_head("$FIG_Config::fig_disk/CURRENT_RELEASE", 1);
48                my $ver = $ver[0];
49                chomp $ver;
50                if ($ver =~ /^cvs\.(\d+)$/)
51                {
52                    my $d = asctime(localtime($1));
53                    chomp($d);
54                    $ver .=  " ($d)";
55                }
56                my $host = &FIG::get_local_hostname();
57                $insert_stuff = "SEED version <b>$ver</b> on $host";
58            }
59    
60            if ($additional_insert)
61            {
62                $insert_stuff .= "<br>" . $additional_insert;
63            }
64    
65            for $_ (@html_hdr)
66            {
67                s,(href|img\s+src)="/FIG/,\1="$FIG_Config::cgi_base,g;
68                s,(\?user\=)\",$1$user",;
69                if ($_ eq "<!-- HEADER_INSERT -->\n")
70                {
71                    $_ = $insert_stuff;
72                }
73            }
74        }
75    
76        return @html_hdr;
77    }
78    
79  sub show_page {  sub show_page {
80      my($cgi,$html,$no_home) = @_;      #warn "SHOWPAGE: cgi=", Dumper(@_);
81        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
82        my($cgi,$html,$no_home, $alt_header, $css, $javasrc, $cookie) = @_;
83      my $i;      my $i;
84    
85        # ARGUMENTS:
86        #     $cgi is the CGI method
87        #     $html is an array with all the html in it. It is just joined by "\n" (and not <br> or <p>
88        #     $no_home eliminates ONLY the bottom FIG search link in a page
89        #     $alt_header is a reference to an array for an alternate header banner that you can replace the standard one with
90        #     $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
91        #               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
92        #               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
93        #     $javasrc is a reference to an array of URLs to javascripts to be included (e.g. "/FIG/Html/css/styleswitcher.js")
94        #     $cookie is the name and value of the cookie to set. Note that you should probably use raelib->cookie to get/set your cookies
95      #      #
96      # Find the HTML header      # Find the HTML header
97      #      #
98    
99      my $html_hdr_file = "./Html/html.hdr";      my $html_tail_file = "./Html/$tail_name";
100      if (! -f $html_hdr_file)      if (! -f $html_tail_file)
101      {      {
102          $html_hdr_file = "$FIG_Config::fig/CGI/Html/html.hdr";          $html_tail_file = "$FIG_Config::fig/CGI/Html/$tail_name";
103      }      }
104    
105      my $html_tail_file = "./Html/html.tail";      my $user = $cgi->param('user') || "";
106      if (! -f $html_tail_file)      my @html_hdr;
107        if ($alt_header && ref($alt_header) eq "ARRAY")
108      {      {
109          $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";         @html_hdr = @$alt_header;
110        }
111        else
112        {
113            @html_hdr = compute_html_header(undef,$user);
114      }      }
115    
116        # RAE: I am offloading the handling of cookies to CGI.pm since I don't know how they are set up.
117      print $cgi->header;      # This modification adds the cookies if necessary
118        print $cgi->header(-cookie=>$cookie);
119    
120      #      #
121      #  The SEED header file goes immediately after <BODY>.  Figure out      #  The SEED header file goes immediately after <BODY>.  Figure out
# Line 46  Line 133 
133                       meta     => 1,                       meta     => 1,
134                       nextid   => 1,                       nextid   => 1,
135                       style    => 1,                       style    => 1,
136                       title    => 1                       title    => 1,
137                     );                     );
138    
139      #      #
# Line 145  Line 232 
232      #      #
233      #  <BODY> goes after last head line      #  <BODY> goes after last head line
234      #      #
235        #  RAE:
236        #  Added the javascript for the buttons immediately after body.
237        #  Note if no buttons are added we still (at the moment) add the script,
238        #  but it only adds a little text (495 characters) to the html and noone will notice!
239        #  RAE: This is now deprecated because everything is in an external file, FIG.js, included later
240    
241      if ( $body_line < 0 )      if ( $body_line < 0 )
242      {      {
# Line 156  Line 248 
248      #  Seed page header (if it exists) goes after <BODY>      #  Seed page header (if it exists) goes after <BODY>
249      #      #
250    
251      if ( -f $html_hdr_file )      if (@html_hdr)
252      {      {
253          splice( @$html, $body_line + 1, 0, `cat $html_hdr_file` );          splice( @$html, $body_line + 1, 0, @html_hdr );
254      }      }
255    
256      #      #
# Line 171  Line 263 
263          splice( @$html, $body_line, 0, "</HEAD>\n" );          splice( @$html, $body_line, 0, "</HEAD>\n" );
264      }      }
265    
266        # RAE:
267        # Add css here
268        # Note that at the moment I define these two sheets here. I think this should
269        # be moved out, but I want to try it and see what happens.  css has the format:
270        #
271        # <link rel='stylesheet' title='default' href='/css/default.css' type='text/css'>
272    
273        # convert the default key to the right case. and eliminate dups
274        foreach my $k (keys %$css) {if (lc($k) eq "default") {$css->{'Default'}=$css->{$k}}}
275    
276        if (!$css || !$css->{'Default'})
277        {
278           $css->{'Default'} = &FIG::cgi_url() . "/Html/css/default.css";
279        }
280        if (!$css->{"Sans Serif"})
281        {
282           $css->{'Sans Serif'} = &FIG::cgi_url() . "/Html/css/sanserif.css";
283        }
284    
285        my $csstext = "<link rel='stylesheet' title='default' href='".$css->{'Default'}."' type='text/css'>\n";
286        $csstext   .= "<link rel='alternate stylesheet' title='Sans Serif' href='".$css->{'Sans Serif'}."' type='text/css'>\n";
287    
288        foreach my $k (keys %$css)
289        {
290           next if (lc($k) eq "default" || lc($k) eq "sans serif");
291           $csstext .= "<link rel='alternate stylesheet' title='$k' href='".$css->{$k}."' type='text/css'>\n";
292        }
293    
294        $csstext   .= "<link rel='alternate'  title='SEED RSS feeds' href='".&FIG::cgi_url()."/Html/rss/SEED.rss' type='application/rss+xml'>\n";
295    
296        # RAE: also added support for external javascripts here.
297        # we are cluttering the HTML code with all the javascripts when they could easily be in external files
298        # this solution allows us to source other files
299    
300        # the file FIG.js contains most of the java script we use routinely. Every browser will just cache this and so
301        # it will reduce our overhead.
302    
303        # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts
304        push @$javasrc, &FIG::cgi_url() . "/Html/css/FIG.js";
305        foreach my $script (@$javasrc) {
306            $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";
307        }
308    
309    
310    
311        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.
312    
313      #      #
314      #  <BASE ...> goes before </HEAD>      #  <BASE ...> goes before </HEAD>
315      #      #
# Line 183  Line 322 
322          #  only, or every update?), I provide an alternative derivation          #  only, or every update?), I provide an alternative derivation
323          #  from $cgi_url. -- GJO          #  from $cgi_url. -- GJO
324          #          #
325            # BASE href needs to be absolute. RDO.
326          my $base_url = $FIG_Config::cgi_base;          #
327          if ( ! $base_url )                      # if cgi_base was not defined          #
328          {          $base_url = &FIG::cgi_url;
329              $base_url = $FIG_Config::cgi_url;   # get the full cgi url  #       my $base_url = $FIG_Config::cgi_base;
330              $base_url =~ s~^http://[^/]*~~;     # remove protocol and host  #       if ( ! $base_url )                      # if cgi_base was not defined
331              $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash  #       {
332          }  #           $base_url = $FIG_Config::cgi_url;   # get the full cgi url
333    #           $base_url =~ s~^http://[^/]*~~;     # remove protocol and host
334    #           $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash
335    #       }
336    
337          $base_line = $head_end_line;          $base_line = $head_end_line;
338          splice( @$html, $base_line, 0, "<BASE href=\"$base_url\">\n" );          splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );
339      }      }
340    
341      #      #
# Line 228  Line 370 
370      }      }
371    
372      #      #
373        # See if we have a site-specific tail (for disclaimers, etc).
374        #
375    
376        my $site_tail = "$FIG_Config::fig_disk/config/site_tail.html";
377        my $site_fh;
378        if (open($site_fh, "<$site_tail"))
379        {
380            push(@tail, <$site_fh>);
381            close($site_fh);
382        }
383    
384        #
385      #  Figure out where to insert The SEED tail.  Before </body>,      #  Figure out where to insert The SEED tail.  Before </body>,
386      #  or before </html>, or at end of page.      #  or before </html>, or at end of page.
387      #      #
   
388      my @tags = ();      my @tags = ();
389        # Check for a tracing queue.
390        my $traceString = QTrace("HTML");
391        if ($traceString) {
392            push @tags, $traceString;
393        }
394      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}
395      if ($i >= @$html)        # </body> not found; look for </html>      if ($i >= @$html)        # </body> not found; look for </html>
396      {      {
# Line 255  Line 412 
412          splice( @$html, $i, 0, @tags );          splice( @$html, $i, 0, @tags );
413      }      }
414    
415      print @$html;      # RAE the chomp will return any new lines at the ends of elements in the array,
416        # and then we can join  with a "\n". This is because somethings put newlines in,
417        # and others don't. This should make nicer looking html
418        #
419        # chomp(@$html);
420        # print join "\n", @$html;
421        #
422        # Apparently the above still breaks things. This is the correct code:
423    
424        foreach $_ (@$html)
425        {
426            print $_;
427        }
428    
429  }  }
430    
431  sub make_table {  sub make_table {
432      my($col_hdrs,$tab,$title,$instr) = @_;      my($col_hdrs,$tab,$title, %options ) = @_;
433      my(@tab);      my(@tab);
434    
435      push( @tab, "\n<table border>\n",      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";
436        my $width = defined $options{width} ? "width=\"$options{width}\"" : undef;
437        push( @tab, "\n<table $border $width>\n",
438                  "\t<caption><b>$title</b></caption>\n",                  "\t<caption><b>$title</b></caption>\n",
439                  "\t<tr>\n\t\t<th>"                  "\t<tr>\n\t\t"
440                . join( "</th>\n\t\t<th>", @$col_hdrs )                . join( "\n", map { &expand($_, "th") } @$col_hdrs )
441                . "</th>\n\t</tr>\n"                . "\n\t</tr>\n"
442          );          );
443      my($i,$nowrap);      my($i);
   
     for ($i=0; ($i < @$instr) && ($instr->[$i] !~ /nowrap/); $i++) {}  
     $nowrap = ($i == @$instr) ? "" : " nowrap";  
444    
445      my $row;      my $row;
446      foreach $row (@$tab)      foreach $row (@$tab)
447      {      {
448          push( @tab, "\t<tr>\n"          push( @tab, "\t<tr>\n"
449                    . join( "\n", map { &expand($_,$nowrap) } @$row )                    . join( "\n", map { &expand($_) } @$row )
450                    . "\n\t</tr>\n"                    . "\n\t</tr>\n"
451              );              );
452      }      }
# Line 286  Line 455 
455  }  }
456    
457  sub expand {  sub expand {
458      my($x,$nowrap) = @_;      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
459        my( $x, $tag ) = @_;
460    
461        $tag = "td" unless $tag;
462        my $endtag = $tag;
463    
464        # RAE modified this so that you can pass in a reference to an array where
465        # the first element is the data to display and the second element is optional
466        # things like colspan and align. Note that in this case you need to include the td
467        # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]
468    
469      if ($x =~ /^\@([^:]+)\:([^:]+)\:(.*)$/)      # per GJO's request modified this line so it can take any tag.
470        if ( ref($x) eq "ARRAY" ) { ($x, $tag) = @$x; $tag =~ /^(\S+)/; $endtag = $1 }
471    
472        if ( $x =~ /^\@([^:]+)\:(.*)$/ )
473      {      {
474          return "\t\t<td$nowrap $1=\"$2\">$3</td>";          return "\t\t<$tag $1>$2</$endtag>";
475      }      }
476      else      else
477      {      {
478          return "\t\t<td$nowrap>$x</td>";          return "\t\t<$tag>$x</$endtag>";
479        }
480      }      }
481    
482    
483    sub merge_table_rows {
484     # RAE:
485     # Experimental piece of code. We often want to have rows or columns were cells are merged. It just looks so much nicer
486     # this block should merge adjacent rows that have the same text in them.
487     # use like this:
488     #      $tab=&HTML::merge_table_rows($tab);
489     # before you do a make_table call
490    
491     my $self=shift if UNIVERSAL::isa($_[0],__PACKAGE__);
492     my ($tab)=@_;
493    
494     my $newtable;
495     my $lastrow;
496     my $rowspan;
497     my $refs;
498    
499     for (my $y=0; $y <= $#$tab; $y++) {
500     #$y is the row in the table;
501      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
502       #$x is the column in the table
503       # if the column in the row we are looking at is the same as the column in the previous row, we don't add
504       # this cell to $newtable. Instead we increment the rowspan of the previous row by one
505    
506       # handle cells that are references to arrays
507       if (ref($tab->[$y]->[$x]) eq "ARRAY") {$refs->[$y]->[$x]=$tab->[$y]->[$x]->[1]; $tab->[$y]->[$x]=$tab->[$y]->[$x]->[0]}
508    
509       # now we go back through the table looking where to draw the merge line:
510       my $lasty=$y;
511       while ($lasty >= 0 && $tab->[$y]->[$x] eq $tab->[$lasty]->[$x]) {$lasty--}
512       $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
513       if ($lasty == $y) {
514        # we always want to have something in rows that may otherwise be empty but should be there (see below)
515        unless ($tab->[$y]->[$x]) {$tab->[$y]->[$x]=" &nbsp; "}
516        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
517       }
518       else {$rowspan->[$lasty]->[$x]++}
519      }
520     }
521    
522     # now just join everything back together
523     for (my $y=0; $y <= $#$tab; $y++) {
524      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
525       if ($rowspan->[$y]->[$x]) {
526        if ($refs->[$y]->[$x]) {$refs->[$y]->[$x] .= " rowspan=". ($rowspan->[$y]->[$x]+1)}
527        else {$refs->[$y]->[$x] = "td rowspan=". ($rowspan->[$y]->[$x]+1)}
528        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
529       }
530       elsif ($newtable->[$y]->[$x] && $refs->[$y]->[$x]) {
531        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
532       }
533      }
534     }
535    
536    
537     # finally we have to remove any completely empty cells that have been added by the array mechanism
538     # (e.g. if you define $a->[2] then $a->[0] and $a->[1] are now undef).
539     # that is why in the loop above I replace empty cells with nbsp. They are now not undef!
540     # I am sure that Gary can do this in one line, but I am hacking.
541     my @trimmed;
542     foreach my $a (@$newtable) {
543      my @row;
544      foreach my $b (@$a) {
545       push @row, $b if ($b);
546      }
547      push @trimmed, \@row;
548     }
549    
550     return \@trimmed;
551    }
552    
553    
554    
555    
556    sub set_ec_links {
557        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
558        my($cgi,$x) = @_;
559        my($before,$match,$after);
560    
561        if ($x =~ /^(.*)(EC \d+\.\d+\.\d+\.\d+)(.*)/s)
562        {
563            $before = $1;
564            $match = $2;
565            $after = $3;
566            return &set_ec_links($cgi,$before) . &HTML::ec_link($match) . &set_ec_links($cgi,$after);
567        }
568        return $x;
569  }  }
570    
571  sub ec_link {  sub ec_link {
572        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
573      my($role) = @_;      my($role) = @_;
574    
575      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)
# Line 312  Line 583 
583  }  }
584    
585  sub role_link {  sub role_link {
586        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
587      my($cgi,$role) = @_;      my($cgi,$role) = @_;
588    
589      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 594 
594      return "<a href=$link>$role</a>";      return "<a href=$link>$role</a>";
595  }  }
596    
597    #
598    # Local means to eliminate the fig|org.peg from the
599    # text of the link.
600    #
601  sub fid_link {  sub fid_link {
602        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
603      my($cgi,$fid,$local,$just_url) = @_;      my($cgi,$fid,$local,$just_url) = @_;
604      my($n);      my($n);
605    
# Line 343  Line 620 
620          {          {
621              $n = $fid;              $n = $fid;
622          }          }
623          if ($1 ne "peg") { return $n }  
624            my $link;
625            #added to format prophage and path island links to feature.cgi
626            if ($1 ne "peg")
627            {
628               my $user = $cgi->param('user');
629               if (! $user) { $user = "" }
630               my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
631               $link = &FIG::cgi_url . "/feature.cgi?feature=$fid&user=$user$trans$sprout";
632               $link =~ s/[a-z_A-Z0-9]+\.cgi\?/feature.cgi?/;
633            }
634            else
635            {
636          my $user = $cgi->param('user');          my $user = $cgi->param('user');
637          if (! $user) { $user = "" }          if (! $user) { $user = "" }
638          my $trans = $cgi->param('translate') ? "&translate=1" : "";          my $trans = $cgi->param('translate') ? "&translate=1" : "";
639          my $link = $cgi->url() . "?prot=$fid&user=$user$trans";              my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
640          $link =~ s/[a-z_A-Z]+\.cgi\?/protein.cgi?/;  ###a
641    
642    ### This used to be
643    ###     my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
644    ###
645    ### The cost became prohibitive in the subsystem spreadsheets.  Hence, we cache the value
646    ###
647    ### RAO
648    
649                if (! $cgi_url) { $cgi_url = &FIG::cgi_url }
650                $link = $cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
651                $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
652                #
653                # Elimin the p2p part if we're in that subdir. Ugh.
654                #
655                $link =~ s,p2p/protein.cgi,protein.cgi,;
656            }
657          if ($just_url)          if ($just_url)
658          {          {
659              return $link;              return $link;
# Line 362  Line 667 
667  }  }
668    
669  sub family_link {  sub family_link {
670        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
671      my($family,$user) = @_;      my($family,$user) = @_;
672    
673      return $family;      return $family;
674  }  }
675    
 use URI::Escape;  
676    
677  sub get_html {  sub get_html {
678        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
679      my( $url, $type, $kv_pairs) = @_;      my( $url, $type, $kv_pairs) = @_;
680      my( $encoded, $ua, $args, @args, $out, @output, $x );      my( $encoded, $ua, $args, @args, $out, @output, $x );
681    
682      $ua = new LWP::UserAgent;      $ua = new LWP::UserAgent;
683      $ua->timeout( 900 );      $ua->timeout( 900 );
   
684      if ($type =~/post/i)      if ($type =~/post/i)
685      {      {
686          $args = [];          $args = [];
# Line 435  Line 740 
740  }  }
741    
742  sub trim_output {  sub trim_output {
743        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
744      my($out) = @_;      my($out) = @_;
745      my $i;      my $i;
746    
# Line 472  Line 778 
778  }  }
779    
780  sub set_prot_links {  sub set_prot_links {
781        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
782      my($cgi,$x) = @_;      my($cgi,$x) = @_;
783      my($before,$match,$after);      my($before,$match,$after);
784    
785      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)$/)      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)/s)
786      {      {
787          $before = $1;          $before = $1;
788          $match = $2;          $match = $2;
789          $after = $3;          $after = $3;
790          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);
791      }      }
792      elsif ($x =~ /^(.*)(gi\|\d+)(.*)$/)      elsif ($x =~ /^(.*)\b([NXYZA]P_[0-9\.]+)\b(.*)/s)
793      {      {
794          $before = $1;          $before = $1;
795          $match = $2;          $match = $2;
796          $after = $3;          $after = $3;
797          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);
798      }      }
799      elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)$/)      elsif ($x =~ /^(.*)(gi\|\d+)(.*)/s)
800      {      {
801          $before = $1;          $before = $1;
802          $match = $2;          $match = $2;
803          $after = $3;          $after = $3;
804          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);
805      }      }
806      elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)$/)      elsif ($x =~ /^(.*)(tigr\|[0-9a-zA-Z]+)(.*)/s)
807      {      {
808          $before = $1;          $before = $1;
809          $match = $2;          $match = $2;
810          $after = $3;          $after = $3;
811          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);
812        }
813        elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
814        {
815            $before = $1;
816            $match = $2;
817            $after = $3;
818            return &set_prot_links($cgi,$before) . &HTML::uni_link($cgi,$match) . &set_prot_links($cgi,$after);
819        }
820        elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)/s)
821        {
822            $before = $1;
823            $match = $2;
824            $after = $3;
825            return &set_prot_links($cgi,$before) . &HTML::sp_link($cgi,$match) . &set_prot_links($cgi,$after);
826        }
827        elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)/s)
828        {
829            $before = $1;
830            $match = $2;
831            $after = $3;
832            return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after);
833        }
834        elsif ($x =~ /^(.*)(kegg\|[a-z]{2,4}:[a-zA-Z_0-9]+)(.*)/s)
835        {
836            $before = $1;
837            $match = $2;
838            $after = $3;
839            return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after);
840      }      }
841      return $x;      return $x;
842  }  }
843    
844    sub refseq_link {
845        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
846        my($cgi,$id) = @_;
847    
848        if ($id =~ /^[NXYZA]P_/)
849        {
850            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id>$id</a>";
851        }
852    }
853    
854  sub gi_link {  sub gi_link {
855        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
856      my($cgi,$gi) = @_;      my($cgi,$gi) = @_;
857    
858      if ($gi =~ /^gi\|(\d+)$/)      if ($gi =~ /^gi\|(\d+)$/)
# Line 516  Line 862 
862      return $gi;      return $gi;
863  }  }
864    
865    sub tigr_link {
866        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
867        my($cgi,$tigr) = @_;
868    
869        if ($tigr =~ /^tigr\|([0-9a-zA-Z]+)$/)
870        {
871            return "<a href=\"http://pathema.tigr.org/tigr-scripts/CMR/GenePage.cgi?locus=$1\">$tigr</a>";
872        }
873        return $tigr;
874    }
875    
876    sub uni_link {
877        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
878        my($cgi,$uni) = @_;
879    
880        if ($uni =~ /^uni\|(\S+)$/)
881        {
882            return "<a href=http://www.pir.uniprot.org/cgi-bin/upEntry?id=$1>$uni</a>";
883        }
884        return $uni;
885    }
886    
887  sub sp_link {  sub sp_link {
888        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
889      my($cgi,$sp) = @_;      my($cgi,$sp) = @_;
890    
891      if ($sp =~ /^sp\|(\S+)$/)      if ($sp =~ /^sp\|(\S+)$/)
# Line 527  Line 896 
896  }  }
897    
898  sub pir_link {  sub pir_link {
899        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
900      my($cgi,$pir) = @_;      my($cgi,$pir) = @_;
901    
902      if ($pir =~ /^pirnr\|(NF\d+)$/)      if ($pir =~ /^pirnr\|(NF\d+)$/)
# Line 536  Line 906 
906      return $pir;      return $pir;
907  }  }
908    
909    sub kegg_link {
910        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
911        my($cgi,$kegg) = @_;
912    
913        if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)
914        {
915            return "<a href=http://www.genome.ad.jp/dbget-bin/www_bget?$1+$2>$kegg</a>";
916        }
917        return $kegg;
918    }
919    
920    sub set_map_links {
921        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
922        my($cgi,$x) = @_;
923        my($before,$match,$after);
924    
925        my $org = ($cgi->param('org') || $cgi->param('genome') || "");
926    
927        if ($x =~ /^(.*)(MAP\d+)(.*)/s)
928        {
929            $before = $1;
930            $match = $2;
931            $after = $3;
932            return &set_map_links($cgi,$before) . &map_link($cgi,$match,$org) . &set_map_links($cgi,$after);
933        }
934        return $x;
935    }
936    
937    sub map_link {
938        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
939        my($cgi,$map,$org) = @_;
940    
941        $user = $cgi->param('user');
942        $user = $user ? $user : "";
943        $org = $org ? $org : "";
944    
945        my $url = &FIG::cgi_url() . "/show_kegg_map.cgi?user=$user&map=$map&org=$org";
946        my $link = "<a href=\"$url\">$map</a>";
947        return $link;
948    }
949    
950    sub java_buttons {
951        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
952      ## ADDED BY RAE
953      # Provides code to include check all/first half/second half/none for javascrspt
954      # this takes two variables - the form name provided in start_form with the
955      # -name => field and the checkbox name
956      my ($form, $button)=@_;
957    
958      $java_script="<input type=\"button\" name=\"CheckAll\" value=\"Check All\"\nonClick=\"checkAll(document.$form.$button)\">\n";
959      $java_script.="<input type=\"button\" name=\"CheckFirst\" value=\"Check First Half\"\nonClick=\"checkFirst(document.$form.$button)\">\n";
960      $java_script.="<input type=\"button\" name=\"CheckSecond\" value=\"Check Second Half\"\nonClick=\"checkSecond(document.$form.$button)\">\n";
961      $java_script.="<input type=\"button\" name=\"UnCheckAll\" value=\"Uncheck All\"\nonClick=\"uncheckAll(document.$form.$button)\">\n";
962    
963      return $java_script;
964    }
965    
966    sub sub_link {
967        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
968        my($cgi,$sub) = @_;
969        my($sub_link);
970    
971        my $user = $cgi->param('user');
972        if ($user)
973        {
974            my $esc_sub = uri_escape( $sub );
975            $sub_link = "<a href=./subsys.cgi?ssa_name=$esc_sub&request=show_ssa&user=$user>$sub</a>";
976        }
977        else
978        {
979            $sub_link = $sub;
980        }
981        return $sub_link;
982    }
983    
984    sub reaction_link {
985        my($reaction) = @_;
986    
987        if ($reaction =~ /^R\d+/)
988        {
989            return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?rn+$reaction\" target=reaction$$>$reaction</a>";
990        }
991        return $reaction;
992    }
993    
994    sub html_for_assignments {
995        my($fig,$user,$peg_sets) = @_;
996        my $i;
997    
998        my @vals = ();
999        my $set = 1;
1000        foreach $peg_set (@$peg_sets)
1001        {
1002            for ($i=0; ($i < @$peg_set); $i++)
1003            {
1004                $peg = $peg_set->[$i];
1005                push(@vals,'show=' . join("@",($set,$i+1,$peg,&FIG::abbrev($fig->org_of($peg)),"")));
1006            }
1007            $set++;
1008        }
1009    
1010        $ENV{'REQUEST_METHOD'} = 'GET';
1011        $ENV{'QUERY_STRING'} = join('&',('request=show_commentary',"uni=1","user=$user",@vals));
1012        my $out = join("",`$FIG_Config::fig/CGI/chromosomal_clusters.cgi`);
1013        $out =~ s/^.*?<form/<form/si;
1014        $out =~ s/^(.*)<table.*/$1/si;
1015        return $out;
1016    }
1017    
1018    =head1 rss_feed
1019    
1020    Add something to the RSS feed. The rss feeds are stored in the Html directory, and there are several RSS feeds:
1021            SEED.rss                - everything gets written here
1022            SEEDgenomes.rss                 - whenever a genome is added to the SEED
1023            SEEDsubsystems.rss      - whenever a subsystem is edited (or should this be added?)
1024    
1025    
1026    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.
1027    
1028    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.
1029    
1030    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.
1031    
1032    The has can have these keys:
1033    
1034    REQUIRED:
1035    title       : the title. This is usually what is seen by the user in the pull down menu
1036    description : a more complete description that is often seen is rss viewers but not always
1037    link        : link to the item that was added/edited
1038    All other keys are treated as optional RSS arguments and written to the file. At most, 10 recent entries are stored in the rss file.
1039    
1040    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.
1041    
1042    
1043    =cut
1044    
1045    sub rss_feed {
1046     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1047     my ($files, $args)=@_;
1048     foreach my $a (keys %$args) {if ($a =~ /^-(.*)/) {my $b=$1; $args->{$b}=$args->{$a}; delete $args->{$a}}}
1049    
1050     my $filepath=$FIG_Config::fig."/CGI/Html/rss";
1051     # check for the directory and if not, make it
1052     mkdir $filepath unless (-d $filepath);
1053    
1054     # note that $info is a hash of references to hashes that are written out as headers in the file
1055     my $info=
1056     {
1057      "SEED.rss" =>
1058       {
1059            title           => "The SEED",
1060            description     => "Latest news from the SEED",
1061            link            => &FIG::cgi_url()."/Html/rss/SEED.rss",
1062       },
1063    
1064      "SEEDsubsystems.rss" =>
1065      {
1066            title           => "SEED Subsystems",
1067            description     => "Recently updated SEED subsystems",
1068            link            => &FIG::cgi_url()."/Html/rss/SEEDsubsystems.rss",
1069      },
1070    
1071      "SEEDsubsystems.rss" =>
1072      {
1073            title           => "SEED Genomes",
1074            description     => "Genomes recently added to the SEED",
1075            link            => &FIG::cgi_url()."/Html/rss/SEEDsubsystems.rss",
1076      },
1077    
1078     };
1079    
1080    
1081     # build the new xml
1082     my $xml = "\t<item>\n";
1083     foreach my $qw ("title", "description", "link") {
1084      unless ($args->{$qw}) {
1085       print STDERR "You need to include a $qw tag in your RSS description\n";
1086       return(0);
1087      }
1088      # we need to do something a bit funky with the link. We can't have ampersands in the <link> </link> in valid html
1089      # so we are going to pull out the links and uri_escape just the part after the .cgi
1090      if ($qw eq "link")
1091      {
1092       $args->{$qw} =~ /^(.*?\.cgi.)(.*)$/;
1093       print STDERR "Got ->>$1<<- and ->>$2<<-\n";
1094       $args->{$qw} = $1.uri_escape($2) if ($1 && $2);
1095      }
1096    
1097      $xml .= "\t\t<$qw>".$args->{$qw}."</$qw>\n";
1098      delete $args->{$qw};
1099     }
1100    
1101     foreach my $tag (grep {!/type/i} keys %$args)
1102     {
1103      $xml .= "\t\t<$tag>".$args->{$tag}."</$tag>\n";
1104     }
1105    
1106     $xml .= "\t</item>\n";
1107    
1108    
1109     my @files=("SEED.rss");
1110     if ($args->{"type"}) {push @files, "SEED.$type.rss"}
1111    
1112     foreach my $file ("SEED.rss", @$files)
1113     {
1114      if (-e "$filepath/$file")
1115      {
1116       my @out; # the new content of the file
1117       my $itemcount=0; # how many <item> </item>'s are we keeping
1118       my $initem; # are we in an item?
1119       open(IN, "$filepath/$file") || die "Can't open $filepath/$file";
1120       while (<IN>)
1121       {
1122        if (/\<item\>/) {
1123         push @out, $xml, unless ($itemcount);
1124         $itemcount++;
1125         $initem=1;
1126        }
1127        if (/\<\/item\>/) {$initem=0; next if ($itemcount > 9)}
1128        next if ($initem && $itemcount > 9);
1129        push @out, $_;
1130       }
1131       close IN;
1132       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1133       print OUT @out;
1134      }
1135      else
1136      {
1137       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1138       print OUT "<?xml version=\"1.0\"?>\n<rss version=\"2.0\">\n<channel>\n";
1139       if ($info->{$file})
1140       {
1141         # we're going to sanity check each of the three options we output, just to be sure
1142         foreach my $qw ("title", "description", "link")
1143         {
1144           if ($info->{$file}->{$qw})
1145           {
1146              print OUT "<$qw>", $info->{$file}->{$qw}, "</$qw>\n";
1147           } else {
1148              print STDERR "Please add a $qw for $file\n"; print OUT "<$qw>$file</$qw>\n";
1149           }
1150         }
1151       }
1152       else {
1153        print STDERR "Please define title, link, and description information for $file\n";
1154        print OUT "<title>$file</title>\n<description>An RSS feed</description>\n<link>", &FIG::cgi_url, "</link>\n";
1155       }
1156       print OUT "\n", $xml;
1157       print OUT "\n", "</channel>\n</rss>\n"
1158      }
1159     }
1160    }
1161    
1162    
1163    
1164    1;
1165    
 1  

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3