[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.63, Tue Oct 4 02:30:28 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" );          splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );
344      }      }
345    
346      #      #
# Line 228  Line 375 
375      }      }
376    
377      #      #
378        # See if we have a site-specific tail (for disclaimers, etc).
379        #
380    
381        my $site_tail = "$FIG_Config::fig_disk/config/site_tail.html";
382        my $site_fh;
383        if (open($site_fh, "<$site_tail"))
384        {
385            push(@tail, <$site_fh>);
386            close($site_fh);
387        }
388    
389        #
390      #  Figure out where to insert The SEED tail.  Before </body>,      #  Figure out where to insert The SEED tail.  Before </body>,
391      #  or before </html>, or at end of page.      #  or before </html>, or at end of page.
392      #      #
   
393      my @tags = ();      my @tags = ();
394        # Check for a tracing queue.
395        my $traceString = QTrace("HTML");
396        if ($traceString) {
397            push @tags, $traceString;
398        }
399      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}
400      if ($i >= @$html)        # </body> not found; look for </html>      if ($i >= @$html)        # </body> not found; look for </html>
401      {      {
# Line 255  Line 417 
417          splice( @$html, $i, 0, @tags );          splice( @$html, $i, 0, @tags );
418      }      }
419    
420      print @$html;      # RAE the chomp will return any new lines at the ends of elements in the array,
421        # and then we can join  with a "\n". This is because somethings put newlines in,
422        # and others don't. This should make nicer looking html
423        #
424        # chomp(@$html);
425        # print join "\n", @$html;
426        #
427        # Apparently the above still breaks things. This is the correct code:
428    
429        foreach $_ (@$html)
430        {
431            print $_;
432        }
433    
434  }  }
435    
436  sub make_table {  sub make_table {
437      my($col_hdrs,$tab,$title,$instr) = @_;      my($col_hdrs,$tab,$title, %options ) = @_;
438      my(@tab);      my(@tab);
439    
440      push( @tab, "\n<table border>\n",      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";
441        my $width = defined $options{width} ? "width=\"$options{width}\"" : undef;
442        push( @tab, "\n<table $border $width>\n",
443                  "\t<caption><b>$title</b></caption>\n",                  "\t<caption><b>$title</b></caption>\n",
444                  "\t<tr>\n\t\t<th>"                  "\t<tr>\n\t\t"
445                . join( "</th>\n\t\t<th>", @$col_hdrs )                . join( "\n", map { &expand($_, "th") } @$col_hdrs )
446                . "</th>\n\t</tr>\n"                . "\n\t</tr>\n"
447          );          );
448      my($i,$nowrap);      my($i);
   
     for ($i=0; ($i < @$instr) && ($instr->[$i] !~ /nowrap/); $i++) {}  
     $nowrap = ($i == @$instr) ? "" : " nowrap";  
449    
450      my $row;      my $row;
451      foreach $row (@$tab)      foreach $row (@$tab)
452      {      {
453          push( @tab, "\t<tr>\n"          push( @tab, "\t<tr>\n"
454                    . join( "\n", map { &expand($_,$nowrap) } @$row )                    . join( "\n", map { &expand($_) } @$row )
455                    . "\n\t</tr>\n"                    . "\n\t</tr>\n"
456              );              );
457      }      }
# Line 286  Line 460 
460  }  }
461    
462  sub expand {  sub expand {
463      my($x,$nowrap) = @_;      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
464        my( $x, $tag ) = @_;
465    
466        $tag = "td" unless $tag;
467        my $endtag = $tag;
468    
469        # RAE modified this so that you can pass in a reference to an array where
470        # the first element is the data to display and the second element is optional
471        # things like colspan and align. Note that in this case you need to include the td
472        # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]
473    
474      if ($x =~ /^\@([^:]+)\:([^:]+)\:(.*)$/)      # per GJO's request modified this line so it can take any tag.
475        if ( ref($x) eq "ARRAY" ) { ($x, $tag) = @$x; $tag =~ /^(\S+)/; $endtag = $1 }
476    
477        if ( $x =~ /^\@([^:]+)\:(.*)$/ )
478      {      {
479          return "\t\t<td$nowrap $1=\"$2\">$3</td>";          return "\t\t<$tag $1>$2</$endtag>";
480      }      }
481      else      else
482      {      {
483          return "\t\t<td$nowrap>$x</td>";          return "\t\t<$tag>$x</$endtag>";
484        }
485    }
486    
487    
488    =head2 merge_table_rows()
489    
490    Merge table rows together. This will merge a table so that adjacent cells with the same content will only be shown once.
491    
492    Something like this:
493    
494        -----------------------
495        |    1     |    a     |
496        -----------------------
497        |    1     |    b     |
498        -----------------------
499        |    2     |    c     |
500        -----------------------
501        |    3     |    d     |
502        -----------------------
503        |    4     |    d     |
504        -----------------------
505        |    5     |    d     |
506        -----------------------
507    
508    Will become:
509    
510        -----------------------
511        |          |    a     |
512        |    1     |-----------
513        |          |    b     |
514        -----------------------
515        |    2     |    c     |
516        -----------------------
517        |    3     |          |
518        ------------          |
519        |    4     |    5     |
520        ------------          |
521        |    5     |          |
522        -----------------------
523    
524    
525    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.
526    
527     $tab=&HTML::merge_table_rows($tab);
528    
529     or
530    
531     $skip=(1=>1, 3=>1, 5=>1);
532     $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
533    
534    
535    =cut
536    
537    
538    
539    
540    sub merge_table_rows {
541     # RAE:
542     # Experimental piece of code. We often want to have rows or columns were cells are merged. It just looks so much nicer
543     # this block should merge adjacent rows that have the same text in them.
544     # use like this:
545     #      $tab=&HTML::merge_table_rows($tab);
546     # before you do a make_table call
547    
548     my $self=shift if UNIVERSAL::isa($_[0],__PACKAGE__);
549     my ($tab, $skip)=@_;
550    
551     my $newtable;
552     my $lastrow;
553     my $rowspan;
554     my $refs;
555    
556     for (my $y=0; $y <= $#$tab; $y++) {
557     #$y is the row in the table;
558      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
559       # this is the user definable columns not to merge
560       if ($skip->{$x})
561       {
562        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
563        next;
564       }
565    
566       #$x is the column in the table
567       # if the column in the row we are looking at is the same as the column in the previous row, we don't add
568       # this cell to $newtable. Instead we increment the rowspan of the previous row by one
569    
570       # handle cells that are references to arrays
571       if (ref($tab->[$y]->[$x]) eq "ARRAY") {$refs->[$y]->[$x]=$tab->[$y]->[$x]->[1]; $tab->[$y]->[$x]=$tab->[$y]->[$x]->[0]}
572    
573       # now we go back through the table looking where to draw the merge line:
574       my $lasty=$y;
575       while ($lasty >= 0 && $tab->[$y]->[$x] eq $tab->[$lasty]->[$x]) {$lasty--}
576       $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
577       if ($lasty == $y) {
578        # we always want to have something in rows that may otherwise be empty but should be there (see below)
579        unless ($tab->[$y]->[$x]) {$tab->[$y]->[$x]=" &nbsp; "}
580        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
581       }
582       else {$rowspan->[$lasty]->[$x]++}
583      }
584     }
585    
586     # now just join everything back together
587     for (my $y=0; $y <= $#$tab; $y++) {
588      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
589       if ($rowspan->[$y]->[$x]) {
590        if ($refs->[$y]->[$x]) {$refs->[$y]->[$x] .= " rowspan=". ($rowspan->[$y]->[$x]+1)}
591        else {$refs->[$y]->[$x] = "td rowspan=". ($rowspan->[$y]->[$x]+1)}
592        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
593       }
594       elsif ($newtable->[$y]->[$x] && $refs->[$y]->[$x]) {
595        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
596       }
597      }
598     }
599    
600    
601     # finally we have to remove any completely empty cells that have been added by the array mechanism
602     # (e.g. if you define $a->[2] then $a->[0] and $a->[1] are now undef).
603     # that is why in the loop above I replace empty cells with nbsp. They are now not undef!
604     # I am sure that Gary can do this in one line, but I am hacking.
605     my @trimmed;
606     foreach my $a (@$newtable) {
607      my @row;
608      foreach my $b (@$a) {
609       push @row, $b if ($b);
610      }
611      push @trimmed, \@row;
612     }
613    
614     return \@trimmed;
615    }
616    
617    
618    
619    
620    sub set_ec_links {
621        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
622        my($cgi,$x) = @_;
623        my($before,$match,$after);
624    
625        if ($x =~ /^(.*)(EC \d+\.\d+\.\d+\.\d+)(.*)/s)
626        {
627            $before = $1;
628            $match = $2;
629            $after = $3;
630            return &set_ec_links($cgi,$before) . &HTML::ec_link($match) . &set_ec_links($cgi,$after);
631      }      }
632        return $x;
633  }  }
634    
635  sub ec_link {  sub ec_link {
636        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
637      my($role) = @_;      my($role) = @_;
638    
639      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)
# Line 312  Line 647 
647  }  }
648    
649  sub role_link {  sub role_link {
650        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
651      my($cgi,$role) = @_;      my($cgi,$role) = @_;
652    
653      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 658 
658      return "<a href=$link>$role</a>";      return "<a href=$link>$role</a>";
659  }  }
660    
661    #
662    # Local means to eliminate the fig|org.peg from the
663    # text of the link.
664    #
665  sub fid_link {  sub fid_link {
666        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
667      my($cgi,$fid,$local,$just_url) = @_;      my($cgi,$fid,$local,$just_url) = @_;
668      my($n);      my($n);
669    
# Line 343  Line 684 
684          {          {
685              $n = $fid;              $n = $fid;
686          }          }
687          if ($1 ne "peg") { return $n }  
688            my $link;
689            #added to format prophage and path island links to feature.cgi
690            if ($1 ne "peg")
691            {
692               my $user = $cgi->param('user');
693               if (! $user) { $user = "" }
694               my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
695               $link = &FIG::cgi_url . "/feature.cgi?feature=$fid&user=$user$trans$sprout";
696               $link =~ s/[a-z_A-Z0-9]+\.cgi\?/feature.cgi?/;
697            }
698            else
699            {
700          my $user = $cgi->param('user');          my $user = $cgi->param('user');
701          if (! $user) { $user = "" }          if (! $user) { $user = "" }
702          my $trans = $cgi->param('translate') ? "&translate=1" : "";          my $trans = $cgi->param('translate') ? "&translate=1" : "";
703          my $link = $cgi->url() . "?prot=$fid&user=$user$trans";              my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
704          $link =~ s/[a-z_A-Z]+\.cgi\?/protein.cgi?/;  ###a
705    
706    ### This used to be
707    ###     my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
708    ###
709    ### The cost became prohibitive in the subsystem spreadsheets.  Hence, we cache the value
710    ###
711    ### RAO
712    
713                if (! $cgi_url) { $cgi_url = &FIG::cgi_url }
714                $link = $cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
715                $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
716                #
717                # Elimin the p2p part if we're in that subdir. Ugh.
718                #
719                $link =~ s,p2p/protein.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;
866            $match = $2;
867            $after = $3;
868            return &set_prot_links($cgi,$before) . &HTML::gi_link($cgi,$match) . &set_prot_links($cgi,$after);
869        }
870        elsif ($x =~ /^(.*)(tigr\|[0-9a-zA-Z]+)(.*)/s)
871        {
872            $before = $1;
873            $match = $2;
874            $after = $3;
875            return &set_prot_links($cgi,$before) . &HTML::tigr_link($cgi,$match) . &set_prot_links($cgi,$after);
876        }
877        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::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);
883      }      }
884      elsif ($x =~ /^(.*)(gi\|\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::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);
890      }      }
891      elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)$/)      elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)/s)
892      {      {
893          $before = $1;          $before = $1;
894          $match = $2;          $match = $2;
895          $after = $3;          $after = $3;
896          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);
897      }      }
898      elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)$/)      elsif ($x =~ /^(.*)(kegg\|[a-z]{2,4}:[a-zA-Z_0-9]+)(.*)/s)
899      {      {
900          $before = $1;          $before = $1;
901          $match = $2;          $match = $2;
902          $after = $3;          $after = $3;
903          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);
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 = &FIG::cgi_url() . "/show_kegg_map.cgi?user=$user&map=$map&org=$org";
1010        my $link = "<a href=\"$url\">$map</a>";
1011        return $link;
1012    }
1013    
1014    sub java_buttons {
1015        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1016      ## ADDED BY RAE
1017      # Provides code to include check all/first half/second half/none for javascrspt
1018      # this takes two variables - the form name provided in start_form with the
1019      # -name => field and the checkbox name
1020      my ($form, $button)=@_;
1021    
1022      $java_script="<input type=\"button\" name=\"CheckAll\" value=\"Check All\"\nonClick=\"checkAll(document.$form.$button)\">\n";
1023      $java_script.="<input type=\"button\" name=\"CheckFirst\" value=\"Check First Half\"\nonClick=\"checkFirst(document.$form.$button)\">\n";
1024      $java_script.="<input type=\"button\" name=\"CheckSecond\" value=\"Check Second Half\"\nonClick=\"checkSecond(document.$form.$button)\">\n";
1025      $java_script.="<input type=\"button\" name=\"UnCheckAll\" value=\"Uncheck All\"\nonClick=\"uncheckAll(document.$form.$button)\">\n";
1026    
1027      return $java_script;
1028    }
1029    
1030    sub sub_link {
1031        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1032        my($cgi,$sub) = @_;
1033        my($sub_link);
1034    
1035        my $user = $cgi->param('user');
1036        if ($user)
1037        {
1038            my $esc_sub = uri_escape( $sub );
1039            $sub_link = "<a href=./subsys.cgi?ssa_name=$esc_sub&request=show_ssa&user=$user>$sub</a>";
1040        }
1041        else
1042        {
1043            $sub_link = $sub;
1044        }
1045        return $sub_link;
1046    }
1047    
1048    sub reaction_link {
1049        my($reaction) = @_;
1050    
1051        if ($reaction =~ /^R\d+/)
1052        {
1053            return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?rn+$reaction\" target=reaction$$>$reaction</a>";
1054        }
1055        return $reaction;
1056    }
1057    
1058    sub html_for_assignments {
1059        my($fig,$user,$peg_sets) = @_;
1060        my $i;
1061    
1062        my @vals = ();
1063        my $set = 1;
1064        foreach $peg_set (@$peg_sets)
1065        {
1066            for ($i=0; ($i < @$peg_set); $i++)
1067            {
1068                $peg = $peg_set->[$i];
1069                push(@vals,'show=' . join("@",($set,$i+1,$peg,&FIG::abbrev($fig->org_of($peg)),"")));
1070            }
1071            $set++;
1072        }
1073    
1074        $ENV{'REQUEST_METHOD'} = 'GET';
1075        $ENV{'QUERY_STRING'} = join('&',('request=show_commentary',"uni=1","user=$user",@vals));
1076        my $out = join("",`$FIG_Config::fig/CGI/chromosomal_clusters.cgi`);
1077        $out =~ s/^.*?<form/<form/si;
1078        $out =~ s/^(.*)<table.*/$1/si;
1079        return $out;
1080    }
1081    
1082    =head1 rss_feed
1083    
1084    Add something to the RSS feed. The rss feeds are stored in the Html directory, and there are several RSS feeds:
1085            SEED.rss                - everything gets written here
1086            SEEDgenomes.rss                 - whenever a genome is added to the SEED
1087            SEEDsubsystems.rss      - whenever a subsystem is edited (or should this be added?)
1088    
1089    
1090    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.
1091    
1092    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.
1093    
1094    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.
1095    
1096    The has can have these keys:
1097    
1098    REQUIRED:
1099    title       : the title. This is usually what is seen by the user in the pull down menu
1100    description : a more complete description that is often seen is rss viewers but not always
1101    link        : link to the item that was added/edited
1102    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.
1103    
1104    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.
1105    
1106    
1107    =cut
1108    
1109    sub rss_feed {
1110     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1111     my ($files, $args)=@_;
1112     foreach my $a (keys %$args) {if ($a =~ /^-(.*)/) {my $b=$1; $args->{$b}=$args->{$a}; delete $args->{$a}}}
1113    
1114     my $filepath=$FIG_Config::fig."/CGI/Html/rss";
1115     # check for the directory and if not, make it
1116     mkdir $filepath unless (-d $filepath);
1117    
1118     # note that $info is a hash of references to hashes that are written out as headers in the file
1119     my $info=
1120     {
1121      "SEED.rss" =>
1122       {
1123            title           => "The SEED",
1124            description     => "Latest news from the SEED",
1125            link            => &FIG::cgi_url()."/Html/rss/SEED.rss",
1126       },
1127    
1128      "SEEDsubsystems.rss" =>
1129      {
1130            title           => "SEED Subsystems",
1131            description     => "Recently updated SEED subsystems",
1132            link            => &FIG::cgi_url()."/Html/rss/SEEDsubsystems.rss",
1133      },
1134    
1135      "SEEDsubsystems.rss" =>
1136      {
1137            title           => "SEED Genomes",
1138            description     => "Genomes recently added to the SEED",
1139            link            => &FIG::cgi_url()."/Html/rss/SEEDsubsystems.rss",
1140      },
1141    
1142     };
1143    
1144    
1145     # build the new xml
1146     my $xml = "\t<item>\n";
1147     foreach my $qw ("title", "description", "link") {
1148      unless ($args->{$qw}) {
1149       print STDERR "You need to include a $qw tag in your RSS description\n";
1150       return(0);
1151      }
1152      # we need to do something a bit funky with the link. We can't have ampersands in the <link> </link> in valid html
1153      # so we are going to pull out the links and uri_escape just the part after the .cgi
1154      if ($qw eq "link")
1155      {
1156       $args->{$qw} =~ /^(.*?\.cgi.)(.*)$/;
1157       print STDERR "Got ->>$1<<- and ->>$2<<-\n";
1158       $args->{$qw} = $1.uri_escape($2) if ($1 && $2);
1159      }
1160    
1161      $xml .= "\t\t<$qw>".$args->{$qw}."</$qw>\n";
1162      delete $args->{$qw};
1163     }
1164    
1165     foreach my $tag (grep {!/type/i} keys %$args)
1166     {
1167      $xml .= "\t\t<$tag>".$args->{$tag}."</$tag>\n";
1168     }
1169    
1170     $xml .= "\t</item>\n";
1171    
1172    
1173     my @files=("SEED.rss");
1174     if ($args->{"type"}) {push @files, "SEED.$type.rss"}
1175    
1176     foreach my $file ("SEED.rss", @$files)
1177     {
1178      if (-e "$filepath/$file")
1179      {
1180       my @out; # the new content of the file
1181       my $itemcount=0; # how many <item> </item>'s are we keeping
1182       my $initem; # are we in an item?
1183       open(IN, "$filepath/$file") || die "Can't open $filepath/$file";
1184       while (<IN>)
1185       {
1186        if (/\<item\>/) {
1187         push @out, $xml, unless ($itemcount);
1188         $itemcount++;
1189         $initem=1;
1190        }
1191        if (/\<\/item\>/) {$initem=0; next if ($itemcount > 9)}
1192        next if ($initem && $itemcount > 9);
1193        push @out, $_;
1194       }
1195       close IN;
1196       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1197       print OUT @out;
1198      }
1199      else
1200      {
1201       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1202       print OUT "<?xml version=\"1.0\"?>\n<rss version=\"2.0\">\n<channel>\n";
1203       if ($info->{$file})
1204       {
1205         # we're going to sanity check each of the three options we output, just to be sure
1206         foreach my $qw ("title", "description", "link")
1207         {
1208           if ($info->{$file}->{$qw})
1209           {
1210              print OUT "<$qw>", $info->{$file}->{$qw}, "</$qw>\n";
1211           } else {
1212              print STDERR "Please add a $qw for $file\n"; print OUT "<$qw>$file</$qw>\n";
1213           }
1214         }
1215       }
1216       else {
1217        print STDERR "Please define title, link, and description information for $file\n";
1218        print OUT "<title>$file</title>\n<description>An RSS feed</description>\n<link>", &FIG::cgi_url, "</link>\n";
1219       }
1220       print OUT "\n", $xml;
1221       print OUT "\n", "</channel>\n</rss>\n"
1222      }
1223     }
1224    }
1225    
1226    
1227    
1228    1;
1229    
 1  

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3