[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.66, Wed Oct 12 21:03:16 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=".,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        # This modification adds the cookies if necessary
118    
119        # Note: 3/10/05 commented this line out pending the discussion of adding cookies into the seed that we are waiting to see about
120        # to add cookies back in replace these two header lines with each other
121    
122      print $cgi->header;      #print $cgi->header(-cookie=>$cookie);
123        print $cgi->header();
124    
125      #      #
126      #  The SEED header file goes immediately after <BODY>.  Figure out      #  The SEED header file goes immediately after <BODY>.  Figure out
# Line 46  Line 138 
138                       meta     => 1,                       meta     => 1,
139                       nextid   => 1,                       nextid   => 1,
140                       style    => 1,                       style    => 1,
141                       title    => 1                       title    => 1,
142                     );                     );
143    
144      #      #
# Line 145  Line 237 
237      #      #
238      #  <BODY> goes after last head line      #  <BODY> goes after last head line
239      #      #
240        #  RAE:
241        #  Added the javascript for the buttons immediately after body.
242        #  Note if no buttons are added we still (at the moment) add the script,
243        #  but it only adds a little text (495 characters) to the html and noone will notice!
244        #  RAE: This is now deprecated because everything is in an external file, FIG.js, included later
245    
246      if ( $body_line < 0 )      if ( $body_line < 0 )
247      {      {
# Line 156  Line 253 
253      #  Seed page header (if it exists) goes after <BODY>      #  Seed page header (if it exists) goes after <BODY>
254      #      #
255    
256      if ( -f $html_hdr_file )      if (@html_hdr)
257      {      {
258          splice( @$html, $body_line + 1, 0, `cat $html_hdr_file` );          splice( @$html, $body_line + 1, 0, @html_hdr );
259      }      }
260    
261      #      #
# Line 171  Line 268 
268          splice( @$html, $body_line, 0, "</HEAD>\n" );          splice( @$html, $body_line, 0, "</HEAD>\n" );
269      }      }
270    
271        # RAE:
272        # Add css here
273        # Note that at the moment I define these two sheets here. I think this should
274        # be moved out, but I want to try it and see what happens.  css has the format:
275        #
276        # <link rel='stylesheet' title='default' href='/css/default.css' type='text/css'>
277    
278        # convert the default key to the right case. and eliminate dups
279        foreach my $k (keys %$css) {if (lc($k) eq "default") {$css->{'Default'}=$css->{$k}}}
280    
281        if (!$css || !$css->{'Default'})
282        {
283           $css->{'Default'} = &FIG::cgi_url() . "/Html/css/default.css";
284        }
285        if (!$css->{"Sans Serif"})
286        {
287           $css->{'Sans Serif'} = &FIG::cgi_url() . "/Html/css/sanserif.css";
288        }
289    
290        my $csstext = "<link rel='stylesheet' title='default' href='".$css->{'Default'}."' type='text/css'>\n";
291        $csstext   .= "<link rel='alternate stylesheet' title='Sans Serif' href='".$css->{'Sans Serif'}."' type='text/css'>\n";
292    
293        foreach my $k (keys %$css)
294        {
295           next if (lc($k) eq "default" || lc($k) eq "sans serif");
296           $csstext .= "<link rel='alternate stylesheet' title='$k' href='".$css->{$k}."' type='text/css'>\n";
297        }
298    
299        $csstext   .= "<link rel='alternate'  title='SEED RSS feeds' href='".&FIG::cgi_url()."/Html/rss/SEED.rss' type='application/rss+xml'>\n";
300    
301        # RAE: also added support for external javascripts here.
302        # we are cluttering the HTML code with all the javascripts when they could easily be in external files
303        # this solution allows us to source other files
304    
305        # the file FIG.js contains most of the java script we use routinely. Every browser will just cache this and so
306        # it will reduce our overhead.
307    
308        # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts
309        push @$javasrc, &FIG::cgi_url() . "/Html/css/FIG.js";
310        foreach my $script (@$javasrc) {
311            $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";
312        }
313    
314    
315    
316        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.
317    
318      #      #
319      #  <BASE ...> goes before </HEAD>      #  <BASE ...> goes before </HEAD>
320      #      #
# Line 183  Line 327 
327          #  only, or every update?), I provide an alternative derivation          #  only, or every update?), I provide an alternative derivation
328          #  from $cgi_url. -- GJO          #  from $cgi_url. -- GJO
329          #          #
330            # BASE href needs to be absolute. RDO.
331          my $base_url = $FIG_Config::cgi_base;          #
332          if ( ! $base_url )                      # if cgi_base was not defined          #
333          {          $base_url = &FIG::cgi_url;
334              $base_url = $FIG_Config::cgi_url;   # get the full cgi url  #       my $base_url = $FIG_Config::cgi_base;
335              $base_url =~ s~^http://[^/]*~~;     # remove protocol and host  #       if ( ! $base_url )                      # if cgi_base was not defined
336              $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash  #       {
337          }  #           $base_url = $FIG_Config::cgi_url;   # get the full cgi url
338    #           $base_url =~ s~^http://[^/]*~~;     # remove protocol and host
339    #           $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash
340    #       }
341    
342          $base_line = $head_end_line;          $base_line = $head_end_line;
343          splice( @$html, $base_line, 0, "<BASE href=\"$base_url\">\n" );          #
344            # RDO 2005-1006. Remove this so proxying works better.
345            #
346    #        splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );
347      }      }
348    
349      #      #
# Line 228  Line 378 
378      }      }
379    
380      #      #
381        # See if we have a site-specific tail (for disclaimers, etc).
382        #
383    
384        my $site_tail = "$FIG_Config::fig_disk/config/site_tail.html";
385        my $site_fh;
386        if (open($site_fh, "<$site_tail"))
387        {
388            push(@tail, <$site_fh>);
389            close($site_fh);
390        }
391    
392        #
393      #  Figure out where to insert The SEED tail.  Before </body>,      #  Figure out where to insert The SEED tail.  Before </body>,
394      #  or before </html>, or at end of page.      #  or before </html>, or at end of page.
395      #      #
   
396      my @tags = ();      my @tags = ();
397        # Check for a tracing queue.
398        my $traceString = QTrace("HTML");
399        if ($traceString) {
400            push @tags, $traceString;
401        }
402      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}
403      if ($i >= @$html)        # </body> not found; look for </html>      if ($i >= @$html)        # </body> not found; look for </html>
404      {      {
# Line 255  Line 420 
420          splice( @$html, $i, 0, @tags );          splice( @$html, $i, 0, @tags );
421      }      }
422    
423      print @$html;      # RAE the chomp will return any new lines at the ends of elements in the array,
424        # and then we can join  with a "\n". This is because somethings put newlines in,
425        # and others don't. This should make nicer looking html
426        #
427        # chomp(@$html);
428        # print join "\n", @$html;
429        #
430        # Apparently the above still breaks things. This is the correct code:
431    
432        foreach $_ (@$html)
433        {
434            print $_;
435        }
436    
437  }  }
438    
439  sub make_table {  sub make_table {
440      my($col_hdrs,$tab,$title,$instr) = @_;      my($col_hdrs,$tab,$title, %options ) = @_;
441      my(@tab);      my(@tab);
442    
443      push( @tab, "\n<table border>\n",      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";
444        my $width = defined $options{width} ? "width=\"$options{width}\"" : undef;
445        push( @tab, "\n<table $border $width>\n",
446                  "\t<caption><b>$title</b></caption>\n",                  "\t<caption><b>$title</b></caption>\n",
447                  "\t<tr>\n\t\t<th>"                  "\t<tr>\n\t\t"
448                . join( "</th>\n\t\t<th>", @$col_hdrs )                . join( "\n", map { &expand($_, "th") } @$col_hdrs )
449                . "</th>\n\t</tr>\n"                . "\n\t</tr>\n"
450          );          );
451      my($i,$nowrap);      my($i);
   
     for ($i=0; ($i < @$instr) && ($instr->[$i] !~ /nowrap/); $i++) {}  
     $nowrap = ($i == @$instr) ? "" : " nowrap";  
452    
453      my $row;      my $row;
454      foreach $row (@$tab)      foreach $row (@$tab)
455      {      {
456          push( @tab, "\t<tr>\n"          push( @tab, "\t<tr>\n"
457                    . join( "\n", map { &expand($_,$nowrap) } @$row )                    . join( "\n", map { &expand($_) } @$row )
458                    . "\n\t</tr>\n"                    . "\n\t</tr>\n"
459              );              );
460      }      }
# Line 286  Line 463 
463  }  }
464    
465  sub expand {  sub expand {
466      my($x,$nowrap) = @_;      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
467        my( $x, $tag ) = @_;
468    
469        $tag = "td" unless $tag;
470        my $endtag = $tag;
471    
472        # RAE modified this so that you can pass in a reference to an array where
473        # the first element is the data to display and the second element is optional
474        # things like colspan and align. Note that in this case you need to include the td
475        # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]
476    
477        # per GJO's request modified this line so it can take any tag.
478        if ( ref($x) eq "ARRAY" ) { ($x, $tag) = @$x; $tag =~ /^(\S+)/; $endtag = $1 }
479    
480      if ($x =~ /^\@([^:]+)\:([^:]+)\:(.*)$/)      if ( $x =~ /^\@([^:]+)\:(.*)$/ )
481      {      {
482          return "\t\t<td$nowrap $1=\"$2\">$3</td>";          return "\t\t<$tag $1>$2</$endtag>";
483      }      }
484      else      else
485      {      {
486          return "\t\t<td$nowrap>$x</td>";          return "\t\t<$tag>$x</$endtag>";
487        }
488    }
489    
490    
491    =head2 merge_table_rows()
492    
493    Merge table rows together. This will merge a table so that adjacent cells with the same content will only be shown once.
494    
495    Something like this:
496    
497        -----------------------
498        |    1     |    a     |
499        -----------------------
500        |    1     |    b     |
501        -----------------------
502        |    2     |    c     |
503        -----------------------
504        |    3     |    d     |
505        -----------------------
506        |    4     |    d     |
507        -----------------------
508        |    5     |    d     |
509        -----------------------
510    
511    Will become:
512    
513        -----------------------
514        |          |    a     |
515        |    1     |-----------
516        |          |    b     |
517        -----------------------
518        |    2     |    c     |
519        -----------------------
520        |    3     |          |
521        ------------          |
522        |    4     |    5     |
523        ------------          |
524        |    5     |          |
525        -----------------------
526    
527    
528    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.
529    
530     $tab=&HTML::merge_table_rows($tab);
531    
532     or
533    
534     $skip=(1=>1, 3=>1, 5=>1);
535     $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
536    
537    
538    =cut
539    
540    
541    
542    
543    sub merge_table_rows {
544     # RAE:
545     # Experimental piece of code. We often want to have rows or columns were cells are merged. It just looks so much nicer
546     # this block should merge adjacent rows that have the same text in them.
547     # use like this:
548     #      $tab=&HTML::merge_table_rows($tab);
549     # before you do a make_table call
550    
551     my $self=shift if UNIVERSAL::isa($_[0],__PACKAGE__);
552     my ($tab, $skip)=@_;
553    
554     my $newtable;
555     my $lastrow;
556     my $rowspan;
557     my $refs;
558    
559     for (my $y=0; $y <= $#$tab; $y++) {
560     #$y is the row in the table;
561      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
562       # this is the user definable columns not to merge
563       if ($skip->{$x})
564       {
565        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
566        next;
567       }
568    
569       #$x is the column in the table
570       # if the column in the row we are looking at is the same as the column in the previous row, we don't add
571       # this cell to $newtable. Instead we increment the rowspan of the previous row by one
572    
573       # handle cells that are references to arrays
574       if (ref($tab->[$y]->[$x]) eq "ARRAY") {$refs->[$y]->[$x]=$tab->[$y]->[$x]->[1]; $tab->[$y]->[$x]=$tab->[$y]->[$x]->[0]}
575    
576       # now we go back through the table looking where to draw the merge line:
577       my $lasty=$y;
578       while ($lasty >= 0 && $tab->[$y]->[$x] eq $tab->[$lasty]->[$x]) {$lasty--}
579       $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
580       if ($lasty == $y) {
581        # we always want to have something in rows that may otherwise be empty but should be there (see below)
582        unless ($tab->[$y]->[$x]) {$tab->[$y]->[$x]=" &nbsp; "}
583        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
584       }
585       else {$rowspan->[$lasty]->[$x]++}
586      }
587     }
588    
589     # now just join everything back together
590     for (my $y=0; $y <= $#$tab; $y++) {
591      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
592       if ($rowspan->[$y]->[$x]) {
593        if ($refs->[$y]->[$x]) {$refs->[$y]->[$x] .= " rowspan=". ($rowspan->[$y]->[$x]+1)}
594        else {$refs->[$y]->[$x] = "td rowspan=". ($rowspan->[$y]->[$x]+1)}
595        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
596       }
597       elsif ($newtable->[$y]->[$x] && $refs->[$y]->[$x]) {
598        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
599       }
600      }
601     }
602    
603    
604     # finally we have to remove any completely empty cells that have been added by the array mechanism
605     # (e.g. if you define $a->[2] then $a->[0] and $a->[1] are now undef).
606     # that is why in the loop above I replace empty cells with nbsp. They are now not undef!
607     # I am sure that Gary can do this in one line, but I am hacking.
608     my @trimmed;
609     foreach my $a (@$newtable) {
610      my @row;
611      foreach my $b (@$a) {
612       push @row, $b if ($b);
613      }
614      push @trimmed, \@row;
615     }
616    
617     return \@trimmed;
618    }
619    
620    
621    
622    
623    sub set_ec_links {
624        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
625        my($cgi,$x) = @_;
626        my($before,$match,$after);
627    
628        if ($x =~ /^(.*)(EC \d+\.\d+\.\d+\.\d+)(.*)/s)
629        {
630            $before = $1;
631            $match = $2;
632            $after = $3;
633            return &set_ec_links($cgi,$before) . &HTML::ec_link($match) . &set_ec_links($cgi,$after);
634      }      }
635        return $x;
636  }  }
637    
638  sub ec_link {  sub ec_link {
639        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
640      my($role) = @_;      my($role) = @_;
641    
642      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)
# Line 312  Line 650 
650  }  }
651    
652  sub role_link {  sub role_link {
653        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
654      my($cgi,$role) = @_;      my($cgi,$role) = @_;
655    
656      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 661 
661      return "<a href=$link>$role</a>";      return "<a href=$link>$role</a>";
662  }  }
663    
664    #
665    # Local means to eliminate the fig|org.peg from the
666    # text of the link.
667    #
668  sub fid_link {  sub fid_link {
669        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
670      my($cgi,$fid,$local,$just_url) = @_;      my($cgi,$fid,$local,$just_url) = @_;
671      my($n);      my($n);
672    
# Line 343  Line 687 
687          {          {
688              $n = $fid;              $n = $fid;
689          }          }
690          if ($1 ne "peg") { return $n }  
691            my $link;
692            #added to format prophage and path island links to feature.cgi
693            if ($1 ne "peg")
694            {
695               my $user = $cgi->param('user');
696               if (! $user) { $user = "" }
697               my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
698               $link = "feature.cgi?feature=$fid&user=$user$trans$sprout";
699               $link =~ s/[a-z_A-Z0-9]+\.cgi\?/feature.cgi?/;
700            }
701            else
702            {
703          my $user = $cgi->param('user');          my $user = $cgi->param('user');
704          if (! $user) { $user = "" }          if (! $user) { $user = "" }
705          my $trans = $cgi->param('translate') ? "&translate=1" : "";          my $trans = $cgi->param('translate') ? "&translate=1" : "";
706          my $link = $cgi->url() . "?prot=$fid&user=$user$trans";              my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
707          $link =~ s/[a-z_A-Z]+\.cgi\?/protein.cgi?/;  ###a
708    
709    ### This used to be
710    ###     my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
711    ###
712    ### The cost became prohibitive in the subsystem spreadsheets.  Hence, we cache the value
713    ###
714    ### RAO
715    
716                #if (! $cgi_url) { $cgi_url = &FIG::cgi_url }
717                #$link = $cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
718                $link = "protein.cgi?prot=$fid&user=$user$trans$sprout";
719                $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
720            }
721          if ($just_url)          if ($just_url)
722          {          {
723              return $link;              return $link;
# Line 362  Line 731 
731  }  }
732    
733  sub family_link {  sub family_link {
734        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
735      my($family,$user) = @_;      my($family,$user) = @_;
736    
737      return $family;      return $family;
738  }  }
739    
 use URI::Escape;  
740    
741  sub get_html {  sub get_html {
742        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
743      my( $url, $type, $kv_pairs) = @_;      my( $url, $type, $kv_pairs) = @_;
744      my( $encoded, $ua, $args, @args, $out, @output, $x );      my( $encoded, $ua, $args, @args, $out, @output, $x );
745    
746      $ua = new LWP::UserAgent;      $ua = new LWP::UserAgent;
747      $ua->timeout( 900 );      $ua->timeout( 900 );
   
748      if ($type =~/post/i)      if ($type =~/post/i)
749      {      {
750          $args = [];          $args = [];
# Line 435  Line 804 
804  }  }
805    
806  sub trim_output {  sub trim_output {
807        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
808      my($out) = @_;      my($out) = @_;
809      my $i;      my $i;
810    
# Line 472  Line 842 
842  }  }
843    
844  sub set_prot_links {  sub set_prot_links {
845        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
846      my($cgi,$x) = @_;      my($cgi,$x) = @_;
847      my($before,$match,$after);      my($before,$match,$after);
848    
849      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)$/)      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)/s)
850        {
851            $before = $1;
852            $match = $2;
853            $after = $3;
854            return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after);
855        }
856        elsif ($x =~ /^(.*)\b([NXYZA]P_[0-9\.]+)\b(.*)/s)
857        {
858            $before = $1;
859            $match = $2;
860            $after = $3;
861            return &set_prot_links($cgi,$before) . &HTML::refseq_link($cgi,$match) . &set_prot_links($cgi,$after);
862        }
863        elsif ($x =~ /^(.*)(gi\|\d+)(.*)/s)
864      {      {
865          $before = $1;          $before = $1;
866          $match = $2;          $match = $2;
867          $after = $3;          $after = $3;
868          return &set_prot_links($cgi,$before) . &HTML::fid_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);
869      }      }
870      elsif ($x =~ /^(.*)(gi\|\d+)(.*)$/)      elsif ($x =~ /^(.*)(tigr\|[0-9a-zA-Z]+)(.*)/s)
871      {      {
872          $before = $1;          $before = $1;
873          $match = $2;          $match = $2;
874          $after = $3;          $after = $3;
875          return &set_prot_links($cgi,$before) . &HTML::gi_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);
876      }      }
877      elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)$/)      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
878      {      {
879          $before = $1;          $before = $1;
880          $match = $2;          $match = $2;
881          $after = $3;          $after = $3;
882          return &set_prot_links($cgi,$before) . &HTML::sp_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";          return &set_prot_links($cgi,$before) . &HTML::uni_link($cgi,$match) . &set_prot_links($cgi,$after);
883      }      }
884      elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)$/)      elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)/s)
885      {      {
886          $before = $1;          $before = $1;
887          $match = $2;          $match = $2;
888          $after = $3;          $after = $3;
889          return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";          return &set_prot_links($cgi,$before) . &HTML::sp_link($cgi,$match) . &set_prot_links($cgi,$after);
890        }
891        elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)/s)
892        {
893            $before = $1;
894            $match = $2;
895            $after = $3;
896            return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after);
897        }
898        elsif ($x =~ /^(.*)(kegg\|[a-z]{2,4}:[a-zA-Z_0-9]+)(.*)/s)
899        {
900            $before = $1;
901            $match = $2;
902            $after = $3;
903            return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after);
904      }      }
905      return $x;      return $x;
906  }  }
907    
908    sub refseq_link {
909        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
910        my($cgi,$id) = @_;
911    
912        if ($id =~ /^[NXYZA]P_/)
913        {
914            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id>$id</a>";
915        }
916    }
917    
918  sub gi_link {  sub gi_link {
919        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
920      my($cgi,$gi) = @_;      my($cgi,$gi) = @_;
921    
922      if ($gi =~ /^gi\|(\d+)$/)      if ($gi =~ /^gi\|(\d+)$/)
# Line 516  Line 926 
926      return $gi;      return $gi;
927  }  }
928    
929    sub tigr_link {
930        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
931        my($cgi,$tigr) = @_;
932    
933        if ($tigr =~ /^tigr\|([0-9a-zA-Z]+)$/)
934        {
935            return "<a href=\"http://pathema.tigr.org/tigr-scripts/CMR/GenePage.cgi?locus=$1\">$tigr</a>";
936        }
937        return $tigr;
938    }
939    
940    sub uni_link {
941        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
942        my($cgi,$uni) = @_;
943    
944        if ($uni =~ /^uni\|(\S+)$/)
945        {
946            return "<a href=http://www.pir.uniprot.org/cgi-bin/upEntry?id=$1>$uni</a>";
947        }
948        return $uni;
949    }
950    
951  sub sp_link {  sub sp_link {
952        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
953      my($cgi,$sp) = @_;      my($cgi,$sp) = @_;
954    
955      if ($sp =~ /^sp\|(\S+)$/)      if ($sp =~ /^sp\|(\S+)$/)
# Line 527  Line 960 
960  }  }
961    
962  sub pir_link {  sub pir_link {
963        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
964      my($cgi,$pir) = @_;      my($cgi,$pir) = @_;
965    
966      if ($pir =~ /^pirnr\|(NF\d+)$/)      if ($pir =~ /^pirnr\|(NF\d+)$/)
# Line 536  Line 970 
970      return $pir;      return $pir;
971  }  }
972    
973    sub kegg_link {
974        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
975        my($cgi,$kegg) = @_;
976    
977        if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)
978        {
979            return "<a href=http://www.genome.ad.jp/dbget-bin/www_bget?$1+$2>$kegg</a>";
980        }
981        return $kegg;
982    }
983    
984    sub set_map_links {
985        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
986        my($cgi,$x) = @_;
987        my($before,$match,$after);
988    
989        my $org = ($cgi->param('org') || $cgi->param('genome') || "");
990    
991        if ($x =~ /^(.*)(MAP\d+)(.*)/s)
992        {
993            $before = $1;
994            $match = $2;
995            $after = $3;
996            return &set_map_links($cgi,$before) . &map_link($cgi,$match,$org) . &set_map_links($cgi,$after);
997        }
998        return $x;
999    }
1000    
1001    sub map_link {
1002        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1003        my($cgi,$map,$org) = @_;
1004    
1005        $user = $cgi->param('user');
1006        $user = $user ? $user : "";
1007        $org = $org ? $org : "";
1008    
1009        my $url = "show_kegg_map.cgi?user=$user&map=$map&org=$org";
1010    #rel    my $url = &FIG::cgi_url() . "/show_kegg_map.cgi?user=$user&map=$map&org=$org";
1011        my $link = "<a href=\"$url\">$map</a>";
1012        return $link;
1013    }
1014    
1015    sub java_buttons {
1016        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1017      ## ADDED BY RAE
1018      # Provides code to include check all/first half/second half/none for javascrspt
1019      # this takes two variables - the form name provided in start_form with the
1020      # -name => field and the checkbox name
1021      my ($form, $button)=@_;
1022    
1023      $java_script="<input type=\"button\" name=\"CheckAll\" value=\"Check All\"\nonClick=\"checkAll(document.$form.$button)\">\n";
1024      $java_script.="<input type=\"button\" name=\"CheckFirst\" value=\"Check First Half\"\nonClick=\"checkFirst(document.$form.$button)\">\n";
1025      $java_script.="<input type=\"button\" name=\"CheckSecond\" value=\"Check Second Half\"\nonClick=\"checkSecond(document.$form.$button)\">\n";
1026      $java_script.="<input type=\"button\" name=\"UnCheckAll\" value=\"Uncheck All\"\nonClick=\"uncheckAll(document.$form.$button)\">\n";
1027    
1028      return $java_script;
1029    }
1030    
1031    sub sub_link {
1032        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1033        my($cgi,$sub) = @_;
1034        my($sub_link);
1035    
1036        my $user = $cgi->param('user');
1037        if ($user)
1038        {
1039            my $esc_sub = uri_escape( $sub );
1040            $sub_link = "<a href=./subsys.cgi?ssa_name=$esc_sub&request=show_ssa&user=$user>$sub</a>";
1041        }
1042        else
1043        {
1044            $sub_link = $sub;
1045        }
1046        return $sub_link;
1047    }
1048    
1049    sub reaction_link {
1050        my($reaction) = @_;
1051    
1052        if ($reaction =~ /^R\d+/)
1053        {
1054            return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?rn+$reaction\" target=reaction$$>$reaction</a>";
1055        }
1056        return $reaction;
1057    }
1058    
1059    sub html_for_assignments {
1060        my($fig,$user,$peg_sets) = @_;
1061        my $i;
1062    
1063        my @vals = ();
1064        my $set = 1;
1065        foreach $peg_set (@$peg_sets)
1066        {
1067            for ($i=0; ($i < @$peg_set); $i++)
1068            {
1069                $peg = $peg_set->[$i];
1070                push(@vals,'show=' . join("@",($set,$i+1,$peg,&FIG::abbrev($fig->org_of($peg)),"")));
1071            }
1072            $set++;
1073        }
1074    
1075        $ENV{'REQUEST_METHOD'} = 'GET';
1076        $ENV{'QUERY_STRING'} = join('&',('request=show_commentary',"uni=1","user=$user",@vals));
1077        my $out = join("",`$FIG_Config::fig/CGI/chromosomal_clusters.cgi`);
1078        $out =~ s/^.*?<form/<form/si;
1079        $out =~ s/^(.*)<table.*/$1/si;
1080        return $out;
1081    }
1082    
1083    =head1 rss_feed
1084    
1085    Add something to the RSS feed. The rss feeds are stored in the Html directory, and there are several RSS feeds:
1086            SEED.rss                - everything gets written here
1087            SEEDgenomes.rss                 - whenever a genome is added to the SEED
1088            SEEDsubsystems.rss      - whenever a subsystem is edited (or should this be added?)
1089    
1090    
1091    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.
1092    
1093    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.
1094    
1095    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.
1096    
1097    The has can have these keys:
1098    
1099    REQUIRED:
1100    title       : the title. This is usually what is seen by the user in the pull down menu
1101    description : a more complete description that is often seen is rss viewers but not always
1102    link        : link to the item that was added/edited
1103    All other keys are treated as optional RSS arguments and written to the file.
1104    
1105    At most, $max_entries recent entries are stored in the rss file, and this is currently 50.
1106    
1107    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.
1108    
1109    
1110    =cut
1111    
1112    sub rss_feed {
1113     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1114     my ($files, $args)=@_;
1115    
1116     # how many entries to store in the file
1117     my $max_entries=50;
1118    
1119     foreach my $a (keys %$args) {if ($a =~ /^-(.*)/) {my $b=$1; $args->{$b}=$args->{$a}; delete $args->{$a}}}
1120    
1121     my $filepath=$FIG_Config::fig."/CGI/Html/rss";
1122     # check for the directory and if not, make it
1123     mkdir $filepath unless (-d $filepath);
1124    
1125     # note that $info is a hash of references to hashes that are written out as headers in the file
1126     my $info=
1127     {
1128      "SEED.rss" =>
1129       {
1130            title           => "The SEED",
1131            description     => "Latest news from the SEED",
1132            link            => "Html/rss/SEED.rss",
1133       },
1134    
1135      "SEEDsubsystems.rss" =>
1136      {
1137            title           => "SEED Subsystems",
1138            description     => "Recently updated SEED subsystems",
1139            link            => "Html/rss/SEEDsubsystems.rss",
1140      },
1141    
1142      "SEEDsubsystems.rss" =>
1143      {
1144            title           => "SEED Genomes",
1145            description     => "Genomes recently added to the SEED",
1146            link            => &FIG::cgi_url()."/Html/rss/SEEDsubsystems.rss",
1147      },
1148    
1149     };
1150    
1151    
1152     # build the new xml
1153     my $xml = "\t<item>\n";
1154     foreach my $qw ("title", "description", "link") {
1155      unless ($args->{$qw}) {
1156       print STDERR "You need to include a $qw tag in your RSS description\n";
1157       return(0);
1158      }
1159      # we need to do something a bit funky with the link. We can't have ampersands in the <link> </link> in valid html
1160      # so we are going to pull out the links and uri_escape just the part after the .cgi
1161      if ($qw eq "link")
1162      {
1163       $args->{$qw} =~ /^(.*?\.cgi.)(.*)$/;
1164       $args->{$qw} = $1.uri_escape($2) if ($1 && $2);
1165      }
1166    
1167      $xml .= "\t\t<$qw>".$args->{$qw}."</$qw>\n";
1168      delete $args->{$qw};
1169     }
1170    
1171     foreach my $tag (grep {!/type/i} keys %$args)
1172     {
1173      $xml .= "\t\t<$tag>".$args->{$tag}."</$tag>\n";
1174     }
1175    
1176     $xml .= "\t</item>\n";
1177    
1178    
1179     my @files=("SEED.rss");
1180     if ($args->{"type"}) {push @files, "SEED.$type.rss"}
1181    
1182     foreach my $file ("SEED.rss", @$files)
1183     {
1184      if (-e "$filepath/$file")
1185      {
1186       my @out; # the new content of the file
1187       my $itemcount=0; # how many <item> </item>'s are we keeping
1188       my $initem; # are we in an item?
1189       open(IN, "$filepath/$file") || die "Can't open $filepath/$file";
1190       while (<IN>)
1191       {
1192        if (/\<item\>/) {
1193         push @out, $xml, unless ($itemcount);
1194         $itemcount++;
1195         $initem=1;
1196        }
1197        if (/\<\/item\>/) {$initem=0; next if ($itemcount > $max_entries)}
1198        next if ($initem && $itemcount > $max_entries);
1199        push @out, $_;
1200       }
1201       close IN;
1202       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1203       print OUT @out;
1204      }
1205      else
1206      {
1207       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1208       print OUT "<?xml version=\"1.0\"?>\n<rss version=\"2.0\">\n<channel>\n";
1209       if ($info->{$file})
1210       {
1211         # we're going to sanity check each of the three options we output, just to be sure
1212         foreach my $qw ("title", "description", "link")
1213         {
1214           if ($info->{$file}->{$qw})
1215           {
1216              print OUT "<$qw>", $info->{$file}->{$qw}, "</$qw>\n";
1217           } else {
1218              print STDERR "Please add a $qw for $file\n"; print OUT "<$qw>$file</$qw>\n";
1219           }
1220         }
1221       }
1222       else {
1223        print STDERR "Please define title, link, and description information for $file\n";
1224        print OUT "<title>$file</title>\n<description>An RSS feed</description>\n<link>", &FIG::cgi_url, "</link>\n";
1225       }
1226       print OUT "\n", $xml;
1227       print OUT "\n", "</channel>\n</rss>\n"
1228      }
1229     }
1230    }
1231    
1232    
1233    
1234    1;
1235    
 1  

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3