[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.64, Sat Oct 8 14:14:47 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        # This modification adds the cookies if necessary
118    
119      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
120        # to add cookies back in replace these two header lines with each other
121    
122        #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      if ($x =~ /^\@([^:]+)\:([^:]+)\:(.*)$/)      # 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 =~ /^\@([^:]+)\:(.*)$/ )
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 = &FIG::cgi_url . "/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                # Elimin the p2p part if we're in that subdir. Ugh.
722                #
723                $link =~ s,p2p/protein.cgi,protein.cgi,;
724            }
725          if ($just_url)          if ($just_url)
726          {          {
727              return $link;              return $link;
# Line 362  Line 735 
735  }  }
736    
737  sub family_link {  sub family_link {
738        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
739      my($family,$user) = @_;      my($family,$user) = @_;
740    
741      return $family;      return $family;
742  }  }
743    
 use URI::Escape;  
744    
745  sub get_html {  sub get_html {
746        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
747      my( $url, $type, $kv_pairs) = @_;      my( $url, $type, $kv_pairs) = @_;
748      my( $encoded, $ua, $args, @args, $out, @output, $x );      my( $encoded, $ua, $args, @args, $out, @output, $x );
749    
750      $ua = new LWP::UserAgent;      $ua = new LWP::UserAgent;
751      $ua->timeout( 900 );      $ua->timeout( 900 );
   
752      if ($type =~/post/i)      if ($type =~/post/i)
753      {      {
754          $args = [];          $args = [];
# Line 435  Line 808 
808  }  }
809    
810  sub trim_output {  sub trim_output {
811        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
812      my($out) = @_;      my($out) = @_;
813      my $i;      my $i;
814    
# Line 472  Line 846 
846  }  }
847    
848  sub set_prot_links {  sub set_prot_links {
849        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
850      my($cgi,$x) = @_;      my($cgi,$x) = @_;
851      my($before,$match,$after);      my($before,$match,$after);
852    
853      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)$/)      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)/s)
854        {
855            $before = $1;
856            $match = $2;
857            $after = $3;
858            return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after);
859        }
860        elsif ($x =~ /^(.*)\b([NXYZA]P_[0-9\.]+)\b(.*)/s)
861        {
862            $before = $1;
863            $match = $2;
864            $after = $3;
865            return &set_prot_links($cgi,$before) . &HTML::refseq_link($cgi,$match) . &set_prot_links($cgi,$after);
866        }
867        elsif ($x =~ /^(.*)(gi\|\d+)(.*)/s)
868        {
869            $before = $1;
870            $match = $2;
871            $after = $3;
872            return &set_prot_links($cgi,$before) . &HTML::gi_link($cgi,$match) . &set_prot_links($cgi,$after);
873        }
874        elsif ($x =~ /^(.*)(tigr\|[0-9a-zA-Z]+)(.*)/s)
875        {
876            $before = $1;
877            $match = $2;
878            $after = $3;
879            return &set_prot_links($cgi,$before) . &HTML::tigr_link($cgi,$match) . &set_prot_links($cgi,$after);
880        }
881        elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/s)
882      {      {
883          $before = $1;          $before = $1;
884          $match = $2;          $match = $2;
885          $after = $3;          $after = $3;
886          return &set_prot_links($cgi,$before) . &HTML::fid_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);
887      }      }
888      elsif ($x =~ /^(.*)(gi\|\d+)(.*)$/)      elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)/s)
889      {      {
890          $before = $1;          $before = $1;
891          $match = $2;          $match = $2;
892          $after = $3;          $after = $3;
893          return &set_prot_links($cgi,$before) . &HTML::gi_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);
894      }      }
895      elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)$/)      elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)/s)
896      {      {
897          $before = $1;          $before = $1;
898          $match = $2;          $match = $2;
899          $after = $3;          $after = $3;
900          return &set_prot_links($cgi,$before) . &HTML::sp_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";          return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after);
901      }      }
902      elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)$/)      elsif ($x =~ /^(.*)(kegg\|[a-z]{2,4}:[a-zA-Z_0-9]+)(.*)/s)
903      {      {
904          $before = $1;          $before = $1;
905          $match = $2;          $match = $2;
906          $after = $3;          $after = $3;
907          return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";          return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after);
908      }      }
909      return $x;      return $x;
910  }  }
911    
912    sub refseq_link {
913        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
914        my($cgi,$id) = @_;
915    
916        if ($id =~ /^[NXYZA]P_/)
917        {
918            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id>$id</a>";
919        }
920    }
921    
922  sub gi_link {  sub gi_link {
923        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
924      my($cgi,$gi) = @_;      my($cgi,$gi) = @_;
925    
926      if ($gi =~ /^gi\|(\d+)$/)      if ($gi =~ /^gi\|(\d+)$/)
# Line 516  Line 930 
930      return $gi;      return $gi;
931  }  }
932    
933    sub tigr_link {
934        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
935        my($cgi,$tigr) = @_;
936    
937        if ($tigr =~ /^tigr\|([0-9a-zA-Z]+)$/)
938        {
939            return "<a href=\"http://pathema.tigr.org/tigr-scripts/CMR/GenePage.cgi?locus=$1\">$tigr</a>";
940        }
941        return $tigr;
942    }
943    
944    sub uni_link {
945        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
946        my($cgi,$uni) = @_;
947    
948        if ($uni =~ /^uni\|(\S+)$/)
949        {
950            return "<a href=http://www.pir.uniprot.org/cgi-bin/upEntry?id=$1>$uni</a>";
951        }
952        return $uni;
953    }
954    
955  sub sp_link {  sub sp_link {
956        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
957      my($cgi,$sp) = @_;      my($cgi,$sp) = @_;
958    
959      if ($sp =~ /^sp\|(\S+)$/)      if ($sp =~ /^sp\|(\S+)$/)
# Line 527  Line 964 
964  }  }
965    
966  sub pir_link {  sub pir_link {
967        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
968      my($cgi,$pir) = @_;      my($cgi,$pir) = @_;
969    
970      if ($pir =~ /^pirnr\|(NF\d+)$/)      if ($pir =~ /^pirnr\|(NF\d+)$/)
# Line 536  Line 974 
974      return $pir;      return $pir;
975  }  }
976    
977    sub kegg_link {
978        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
979        my($cgi,$kegg) = @_;
980    
981        if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)
982        {
983            return "<a href=http://www.genome.ad.jp/dbget-bin/www_bget?$1+$2>$kegg</a>";
984        }
985        return $kegg;
986    }
987    
988    sub set_map_links {
989        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
990        my($cgi,$x) = @_;
991        my($before,$match,$after);
992    
993        my $org = ($cgi->param('org') || $cgi->param('genome') || "");
994    
995        if ($x =~ /^(.*)(MAP\d+)(.*)/s)
996        {
997            $before = $1;
998            $match = $2;
999            $after = $3;
1000            return &set_map_links($cgi,$before) . &map_link($cgi,$match,$org) . &set_map_links($cgi,$after);
1001        }
1002        return $x;
1003    }
1004    
1005    sub map_link {
1006        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1007        my($cgi,$map,$org) = @_;
1008    
1009        $user = $cgi->param('user');
1010        $user = $user ? $user : "";
1011        $org = $org ? $org : "";
1012    
1013        my $url = "show_kegg_map.cgi?user=$user&map=$map&org=$org";
1014    #rel    my $url = &FIG::cgi_url() . "/show_kegg_map.cgi?user=$user&map=$map&org=$org";
1015        my $link = "<a href=\"$url\">$map</a>";
1016        return $link;
1017    }
1018    
1019    sub java_buttons {
1020        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1021      ## ADDED BY RAE
1022      # Provides code to include check all/first half/second half/none for javascrspt
1023      # this takes two variables - the form name provided in start_form with the
1024      # -name => field and the checkbox name
1025      my ($form, $button)=@_;
1026    
1027      $java_script="<input type=\"button\" name=\"CheckAll\" value=\"Check All\"\nonClick=\"checkAll(document.$form.$button)\">\n";
1028      $java_script.="<input type=\"button\" name=\"CheckFirst\" value=\"Check First Half\"\nonClick=\"checkFirst(document.$form.$button)\">\n";
1029      $java_script.="<input type=\"button\" name=\"CheckSecond\" value=\"Check Second Half\"\nonClick=\"checkSecond(document.$form.$button)\">\n";
1030      $java_script.="<input type=\"button\" name=\"UnCheckAll\" value=\"Uncheck All\"\nonClick=\"uncheckAll(document.$form.$button)\">\n";
1031    
1032      return $java_script;
1033    }
1034    
1035    sub sub_link {
1036        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1037        my($cgi,$sub) = @_;
1038        my($sub_link);
1039    
1040        my $user = $cgi->param('user');
1041        if ($user)
1042        {
1043            my $esc_sub = uri_escape( $sub );
1044            $sub_link = "<a href=./subsys.cgi?ssa_name=$esc_sub&request=show_ssa&user=$user>$sub</a>";
1045        }
1046        else
1047        {
1048            $sub_link = $sub;
1049        }
1050        return $sub_link;
1051    }
1052    
1053    sub reaction_link {
1054        my($reaction) = @_;
1055    
1056        if ($reaction =~ /^R\d+/)
1057        {
1058            return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?rn+$reaction\" target=reaction$$>$reaction</a>";
1059        }
1060        return $reaction;
1061    }
1062    
1063    sub html_for_assignments {
1064        my($fig,$user,$peg_sets) = @_;
1065        my $i;
1066    
1067        my @vals = ();
1068        my $set = 1;
1069        foreach $peg_set (@$peg_sets)
1070        {
1071            for ($i=0; ($i < @$peg_set); $i++)
1072            {
1073                $peg = $peg_set->[$i];
1074                push(@vals,'show=' . join("@",($set,$i+1,$peg,&FIG::abbrev($fig->org_of($peg)),"")));
1075            }
1076            $set++;
1077        }
1078    
1079        $ENV{'REQUEST_METHOD'} = 'GET';
1080        $ENV{'QUERY_STRING'} = join('&',('request=show_commentary',"uni=1","user=$user",@vals));
1081        my $out = join("",`$FIG_Config::fig/CGI/chromosomal_clusters.cgi`);
1082        $out =~ s/^.*?<form/<form/si;
1083        $out =~ s/^(.*)<table.*/$1/si;
1084        return $out;
1085    }
1086    
1087    =head1 rss_feed
1088    
1089    Add something to the RSS feed. The rss feeds are stored in the Html directory, and there are several RSS feeds:
1090            SEED.rss                - everything gets written here
1091            SEEDgenomes.rss                 - whenever a genome is added to the SEED
1092            SEEDsubsystems.rss      - whenever a subsystem is edited (or should this be added?)
1093    
1094    
1095    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.
1096    
1097    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.
1098    
1099    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.
1100    
1101    The has can have these keys:
1102    
1103    REQUIRED:
1104    title       : the title. This is usually what is seen by the user in the pull down menu
1105    description : a more complete description that is often seen is rss viewers but not always
1106    link        : link to the item that was added/edited
1107    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.
1108    
1109    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.
1110    
1111    
1112    =cut
1113    
1114    sub rss_feed {
1115     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1116     my ($files, $args)=@_;
1117     foreach my $a (keys %$args) {if ($a =~ /^-(.*)/) {my $b=$1; $args->{$b}=$args->{$a}; delete $args->{$a}}}
1118    
1119     my $filepath=$FIG_Config::fig."/CGI/Html/rss";
1120     # check for the directory and if not, make it
1121     mkdir $filepath unless (-d $filepath);
1122    
1123     # note that $info is a hash of references to hashes that are written out as headers in the file
1124     my $info=
1125     {
1126      "SEED.rss" =>
1127       {
1128            title           => "The SEED",
1129            description     => "Latest news from the SEED",
1130            link            => &FIG::cgi_url()."/Html/rss/SEED.rss",
1131       },
1132    
1133      "SEEDsubsystems.rss" =>
1134      {
1135            title           => "SEED Subsystems",
1136            description     => "Recently updated SEED subsystems",
1137            link            => &FIG::cgi_url()."/Html/rss/SEEDsubsystems.rss",
1138      },
1139    
1140      "SEEDsubsystems.rss" =>
1141      {
1142            title           => "SEED Genomes",
1143            description     => "Genomes recently added to the SEED",
1144            link            => &FIG::cgi_url()."/Html/rss/SEEDsubsystems.rss",
1145      },
1146    
1147     };
1148    
1149    
1150     # build the new xml
1151     my $xml = "\t<item>\n";
1152     foreach my $qw ("title", "description", "link") {
1153      unless ($args->{$qw}) {
1154       print STDERR "You need to include a $qw tag in your RSS description\n";
1155       return(0);
1156      }
1157      # we need to do something a bit funky with the link. We can't have ampersands in the <link> </link> in valid html
1158      # so we are going to pull out the links and uri_escape just the part after the .cgi
1159      if ($qw eq "link")
1160      {
1161       $args->{$qw} =~ /^(.*?\.cgi.)(.*)$/;
1162       print STDERR "Got ->>$1<<- and ->>$2<<-\n";
1163       $args->{$qw} = $1.uri_escape($2) if ($1 && $2);
1164      }
1165    
1166      $xml .= "\t\t<$qw>".$args->{$qw}."</$qw>\n";
1167      delete $args->{$qw};
1168     }
1169    
1170     foreach my $tag (grep {!/type/i} keys %$args)
1171     {
1172      $xml .= "\t\t<$tag>".$args->{$tag}."</$tag>\n";
1173     }
1174    
1175     $xml .= "\t</item>\n";
1176    
1177    
1178     my @files=("SEED.rss");
1179     if ($args->{"type"}) {push @files, "SEED.$type.rss"}
1180    
1181     foreach my $file ("SEED.rss", @$files)
1182     {
1183      if (-e "$filepath/$file")
1184      {
1185       my @out; # the new content of the file
1186       my $itemcount=0; # how many <item> </item>'s are we keeping
1187       my $initem; # are we in an item?
1188       open(IN, "$filepath/$file") || die "Can't open $filepath/$file";
1189       while (<IN>)
1190       {
1191        if (/\<item\>/) {
1192         push @out, $xml, unless ($itemcount);
1193         $itemcount++;
1194         $initem=1;
1195        }
1196        if (/\<\/item\>/) {$initem=0; next if ($itemcount > 9)}
1197        next if ($initem && $itemcount > 9);
1198        push @out, $_;
1199       }
1200       close IN;
1201       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1202       print OUT @out;
1203      }
1204      else
1205      {
1206       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1207       print OUT "<?xml version=\"1.0\"?>\n<rss version=\"2.0\">\n<channel>\n";
1208       if ($info->{$file})
1209       {
1210         # we're going to sanity check each of the three options we output, just to be sure
1211         foreach my $qw ("title", "description", "link")
1212         {
1213           if ($info->{$file}->{$qw})
1214           {
1215              print OUT "<$qw>", $info->{$file}->{$qw}, "</$qw>\n";
1216           } else {
1217              print STDERR "Please add a $qw for $file\n"; print OUT "<$qw>$file</$qw>\n";
1218           }
1219         }
1220       }
1221       else {
1222        print STDERR "Please define title, link, and description information for $file\n";
1223        print OUT "<title>$file</title>\n<description>An RSS feed</description>\n<link>", &FIG::cgi_url, "</link>\n";
1224       }
1225       print OUT "\n", $xml;
1226       print OUT "\n", "</channel>\n</rss>\n"
1227      }
1228     }
1229    }
1230    
1231    
1232    
1233    1;
1234    
 1  

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3