[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.67, Wed Oct 12 21:53:22 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        # for my $k (sort keys %ENV) { warn "$k = $ENV{$k}\n"; }
40    
41        #
42        # Determine if this is a toplevel cgi or one in one of the subdirs (currently
43        # just /p2p).
44        #
45    
46        my @parts = split(/\//, $ENV{SCRIPT_NAME});
47        my $top;
48        if ($parts[-2] eq 'FIG')
49        {
50            $top = '.';
51    #       warn "toplevel @parts\n";
52        }
53        elsif ($parts[-3] eq 'FIG')
54        {
55            $top = '..';
56    #       warn "subdir @parts\n";
57        }
58        else
59        {
60            $top = $FIG_Config::cgi_base;
61    #       warn "other @parts\n";
62        }
63    
64        $options{no_fig_search} or push( @html_hdr, "<br><a href=\"$top/index.cgi?user=$user\">FIG search</a>\n" );
65    
66        if (@html_hdr)
67        {
68            my $insert_stuff;
69    
70            if (not $options{no_release_info})
71            {
72                my @ver = &FIG::file_head("$FIG_Config::fig_disk/CURRENT_RELEASE", 1);
73                my $ver = $ver[0];
74                chomp $ver;
75                if ($ver =~ /^cvs\.(\d+)$/)
76                {
77                    my $d = asctime(localtime($1));
78                    chomp($d);
79                    $ver .=  " ($d)";
80                }
81                my $host = &FIG::get_local_hostname();
82                $insert_stuff = "SEED version <b>$ver</b> on $host";
83            }
84    
85            if ($additional_insert)
86            {
87                $insert_stuff .= "<br>" . $additional_insert;
88            }
89    
90            for $_ (@html_hdr)
91            {
92                s,(href|img\s+src)="/FIG/,\1="$top/,g;
93                s,(\?user\=)\",$1$user",;
94                if ($_ eq "<!-- HEADER_INSERT -->\n")
95                {
96                    $_ = $insert_stuff;
97                }
98            }
99        }
100    
101        return @html_hdr;
102    }
103    
104  sub show_page {  sub show_page {
105      my($cgi,$html,$no_home) = @_;      #warn "SHOWPAGE: cgi=", Dumper(@_);
106        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
107        my($cgi,$html,$no_home, $alt_header, $css, $javasrc, $cookie) = @_;
108      my $i;      my $i;
109    
110        # ARGUMENTS:
111        #     $cgi is the CGI method
112        #     $html is an array with all the html in it. It is just joined by "\n" (and not <br> or <p>
113        #     $no_home eliminates ONLY the bottom FIG search link in a page
114        #     $alt_header is a reference to an array for an alternate header banner that you can replace the standard one with
115        #     $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
116        #               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
117        #               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
118        #     $javasrc is a reference to an array of URLs to javascripts to be included (e.g. "/FIG/Html/css/styleswitcher.js")
119        #     $cookie is the name and value of the cookie to set. Note that you should probably use raelib->cookie to get/set your cookies
120      #      #
121      # Find the HTML header      # Find the HTML header
122      #      #
123    
124      my $html_hdr_file = "./Html/html.hdr";      my $html_tail_file = "./Html/$tail_name";
125      if (! -f $html_hdr_file)      if (! -f $html_tail_file)
126      {      {
127          $html_hdr_file = "$FIG_Config::fig/CGI/Html/html.hdr";          $html_tail_file = "$FIG_Config::fig/CGI/Html/$tail_name";
128      }      }
129    
130      my $html_tail_file = "./Html/html.tail";      my $user = $cgi->param('user') || "";
131      if (! -f $html_tail_file)      my @html_hdr;
132        if ($alt_header && ref($alt_header) eq "ARRAY")
133      {      {
134          $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";         @html_hdr = @$alt_header;
135        }
136        else
137        {
138            @html_hdr = compute_html_header(undef,$user);
139      }      }
140    
141        # RAE: I am offloading the handling of cookies to CGI.pm since I don't know how they are set up.
142        # This modification adds the cookies if necessary
143    
144      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
145        # to add cookies back in replace these two header lines with each other
146    
147        #print $cgi->header(-cookie=>$cookie);
148        print $cgi->header();
149    
150      #      #
151      #  The SEED header file goes immediately after <BODY>.  Figure out      #  The SEED header file goes immediately after <BODY>.  Figure out
# Line 46  Line 163 
163                       meta     => 1,                       meta     => 1,
164                       nextid   => 1,                       nextid   => 1,
165                       style    => 1,                       style    => 1,
166                       title    => 1                       title    => 1,
167                     );                     );
168    
169      #      #
# Line 145  Line 262 
262      #      #
263      #  <BODY> goes after last head line      #  <BODY> goes after last head line
264      #      #
265        #  RAE:
266        #  Added the javascript for the buttons immediately after body.
267        #  Note if no buttons are added we still (at the moment) add the script,
268        #  but it only adds a little text (495 characters) to the html and noone will notice!
269        #  RAE: This is now deprecated because everything is in an external file, FIG.js, included later
270    
271      if ( $body_line < 0 )      if ( $body_line < 0 )
272      {      {
# Line 156  Line 278 
278      #  Seed page header (if it exists) goes after <BODY>      #  Seed page header (if it exists) goes after <BODY>
279      #      #
280    
281      if ( -f $html_hdr_file )      if (@html_hdr)
282      {      {
283          splice( @$html, $body_line + 1, 0, `cat $html_hdr_file` );          splice( @$html, $body_line + 1, 0, @html_hdr );
284      }      }
285    
286      #      #
# Line 171  Line 293 
293          splice( @$html, $body_line, 0, "</HEAD>\n" );          splice( @$html, $body_line, 0, "</HEAD>\n" );
294      }      }
295    
296        # RAE:
297        # Add css here
298        # Note that at the moment I define these two sheets here. I think this should
299        # be moved out, but I want to try it and see what happens.  css has the format:
300        #
301        # <link rel='stylesheet' title='default' href='/css/default.css' type='text/css'>
302    
303        # convert the default key to the right case. and eliminate dups
304        foreach my $k (keys %$css) {if (lc($k) eq "default") {$css->{'Default'}=$css->{$k}}}
305    
306        if (!$css || !$css->{'Default'})
307        {
308           $css->{'Default'} = &FIG::cgi_url() . "/Html/css/default.css";
309        }
310        if (!$css->{"Sans Serif"})
311        {
312           $css->{'Sans Serif'} = &FIG::cgi_url() . "/Html/css/sanserif.css";
313        }
314    
315        my $csstext = "<link rel='stylesheet' title='default' href='".$css->{'Default'}."' type='text/css'>\n";
316        $csstext   .= "<link rel='alternate stylesheet' title='Sans Serif' href='".$css->{'Sans Serif'}."' type='text/css'>\n";
317    
318        foreach my $k (keys %$css)
319        {
320           next if (lc($k) eq "default" || lc($k) eq "sans serif");
321           $csstext .= "<link rel='alternate stylesheet' title='$k' href='".$css->{$k}."' type='text/css'>\n";
322        }
323    
324        $csstext   .= "<link rel='alternate'  title='SEED RSS feeds' href='".&FIG::cgi_url()."/Html/rss/SEED.rss' type='application/rss+xml'>\n";
325    
326        # RAE: also added support for external javascripts here.
327        # we are cluttering the HTML code with all the javascripts when they could easily be in external files
328        # this solution allows us to source other files
329    
330        # the file FIG.js contains most of the java script we use routinely. Every browser will just cache this and so
331        # it will reduce our overhead.
332    
333        # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts
334        push @$javasrc, &FIG::cgi_url() . "/Html/css/FIG.js";
335        foreach my $script (@$javasrc) {
336            $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";
337        }
338    
339    
340    
341        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.
342    
343      #      #
344      #  <BASE ...> goes before </HEAD>      #  <BASE ...> goes before </HEAD>
345      #      #
# Line 183  Line 352 
352          #  only, or every update?), I provide an alternative derivation          #  only, or every update?), I provide an alternative derivation
353          #  from $cgi_url. -- GJO          #  from $cgi_url. -- GJO
354          #          #
355            # BASE href needs to be absolute. RDO.
356          my $base_url = $FIG_Config::cgi_base;          #
357          if ( ! $base_url )                      # if cgi_base was not defined          #
358          {          $base_url = &FIG::cgi_url;
359              $base_url = $FIG_Config::cgi_url;   # get the full cgi url  #       my $base_url = $FIG_Config::cgi_base;
360              $base_url =~ s~^http://[^/]*~~;     # remove protocol and host  #       if ( ! $base_url )                      # if cgi_base was not defined
361              $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash  #       {
362          }  #           $base_url = $FIG_Config::cgi_url;   # get the full cgi url
363    #           $base_url =~ s~^http://[^/]*~~;     # remove protocol and host
364    #           $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash
365    #       }
366    
367          $base_line = $head_end_line;          $base_line = $head_end_line;
368          splice( @$html, $base_line, 0, "<BASE href=\"$base_url\">\n" );          #
369            # RDO 2005-1006. Remove this so proxying works better.
370            #
371    #        splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );
372      }      }
373    
374      #      #
# Line 228  Line 403 
403      }      }
404    
405      #      #
406        # See if we have a site-specific tail (for disclaimers, etc).
407        #
408    
409        my $site_tail = "$FIG_Config::fig_disk/config/site_tail.html";
410        my $site_fh;
411        if (open($site_fh, "<$site_tail"))
412        {
413            push(@tail, <$site_fh>);
414            close($site_fh);
415        }
416    
417        #
418      #  Figure out where to insert The SEED tail.  Before </body>,      #  Figure out where to insert The SEED tail.  Before </body>,
419      #  or before </html>, or at end of page.      #  or before </html>, or at end of page.
420      #      #
   
421      my @tags = ();      my @tags = ();
422        # Check for a tracing queue.
423        my $traceString = QTrace("HTML");
424        if ($traceString) {
425            push @tags, $traceString;
426        }
427      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}
428      if ($i >= @$html)        # </body> not found; look for </html>      if ($i >= @$html)        # </body> not found; look for </html>
429      {      {
# Line 255  Line 445 
445          splice( @$html, $i, 0, @tags );          splice( @$html, $i, 0, @tags );
446      }      }
447    
448      print @$html;      # RAE the chomp will return any new lines at the ends of elements in the array,
449        # and then we can join  with a "\n". This is because somethings put newlines in,
450        # and others don't. This should make nicer looking html
451        #
452        # chomp(@$html);
453        # print join "\n", @$html;
454        #
455        # Apparently the above still breaks things. This is the correct code:
456    
457        foreach $_ (@$html)
458        {
459            print $_;
460        }
461    
462  }  }
463    
464  sub make_table {  sub make_table {
465      my($col_hdrs,$tab,$title,$instr) = @_;      my($col_hdrs,$tab,$title, %options ) = @_;
466      my(@tab);      my(@tab);
467    
468      push( @tab, "\n<table border>\n",      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";
469        my $width = defined $options{width} ? "width=\"$options{width}\"" : undef;
470        push( @tab, "\n<table $border $width>\n",
471                  "\t<caption><b>$title</b></caption>\n",                  "\t<caption><b>$title</b></caption>\n",
472                  "\t<tr>\n\t\t<th>"                  "\t<tr>\n\t\t"
473                . join( "</th>\n\t\t<th>", @$col_hdrs )                . join( "\n", map { &expand($_, "th") } @$col_hdrs )
474                . "</th>\n\t</tr>\n"                . "\n\t</tr>\n"
475          );          );
476      my($i,$nowrap);      my($i);
   
     for ($i=0; ($i < @$instr) && ($instr->[$i] !~ /nowrap/); $i++) {}  
     $nowrap = ($i == @$instr) ? "" : " nowrap";  
477    
478      my $row;      my $row;
479      foreach $row (@$tab)      foreach $row (@$tab)
480      {      {
481          push( @tab, "\t<tr>\n"          push( @tab, "\t<tr>\n"
482                    . join( "\n", map { &expand($_,$nowrap) } @$row )                    . join( "\n", map { &expand($_) } @$row )
483                    . "\n\t</tr>\n"                    . "\n\t</tr>\n"
484              );              );
485      }      }
# Line 286  Line 488 
488  }  }
489    
490  sub expand {  sub expand {
491      my($x,$nowrap) = @_;      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
492        my( $x, $tag ) = @_;
493    
494        $tag = "td" unless $tag;
495        my $endtag = $tag;
496    
497        # RAE modified this so that you can pass in a reference to an array where
498        # the first element is the data to display and the second element is optional
499        # things like colspan and align. Note that in this case you need to include the td
500        # use something like ["some data to appear", "td colspan=4 bgcolor=gray"]
501    
502      if ($x =~ /^\@([^:]+)\:([^:]+)\:(.*)$/)      # per GJO's request modified this line so it can take any tag.
503        if ( ref($x) eq "ARRAY" ) { ($x, $tag) = @$x; $tag =~ /^(\S+)/; $endtag = $1 }
504    
505        if ( $x =~ /^\@([^:]+)\:(.*)$/ )
506      {      {
507          return "\t\t<td$nowrap $1=\"$2\">$3</td>";          return "\t\t<$tag $1>$2</$endtag>";
508      }      }
509      else      else
510      {      {
511          return "\t\t<td$nowrap>$x</td>";          return "\t\t<$tag>$x</$endtag>";
512      }      }
513  }  }
514    
515    
516    =head2 merge_table_rows()
517    
518    Merge table rows together. This will merge a table so that adjacent cells with the same content will only be shown once.
519    
520    Something like this:
521    
522        -----------------------
523        |    1     |    a     |
524        -----------------------
525        |    1     |    b     |
526        -----------------------
527        |    2     |    c     |
528        -----------------------
529        |    3     |    d     |
530        -----------------------
531        |    4     |    d     |
532        -----------------------
533        |    5     |    d     |
534        -----------------------
535    
536    Will become:
537    
538        -----------------------
539        |          |    a     |
540        |    1     |-----------
541        |          |    b     |
542        -----------------------
543        |    2     |    c     |
544        -----------------------
545        |    3     |          |
546        ------------          |
547        |    4     |    5     |
548        ------------          |
549        |    5     |          |
550        -----------------------
551    
552    
553    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.
554    
555     $tab=&HTML::merge_table_rows($tab);
556    
557     or
558    
559     $skip=(1=>1, 3=>1, 5=>1);
560     $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
561    
562    
563    =cut
564    
565    
566    
567    
568    sub merge_table_rows {
569     # RAE:
570     # Experimental piece of code. We often want to have rows or columns were cells are merged. It just looks so much nicer
571     # this block should merge adjacent rows that have the same text in them.
572     # use like this:
573     #      $tab=&HTML::merge_table_rows($tab);
574     # before you do a make_table call
575    
576     my $self=shift if UNIVERSAL::isa($_[0],__PACKAGE__);
577     my ($tab, $skip)=@_;
578    
579     my $newtable;
580     my $lastrow;
581     my $rowspan;
582     my $refs;
583    
584     for (my $y=0; $y <= $#$tab; $y++) {
585     #$y is the row in the table;
586      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
587       # this is the user definable columns not to merge
588       if ($skip->{$x})
589       {
590        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
591        next;
592       }
593    
594       #$x is the column in the table
595       # if the column in the row we are looking at is the same as the column in the previous row, we don't add
596       # this cell to $newtable. Instead we increment the rowspan of the previous row by one
597    
598       # handle cells that are references to arrays
599       if (ref($tab->[$y]->[$x]) eq "ARRAY") {$refs->[$y]->[$x]=$tab->[$y]->[$x]->[1]; $tab->[$y]->[$x]=$tab->[$y]->[$x]->[0]}
600    
601       # now we go back through the table looking where to draw the merge line:
602       my $lasty=$y;
603       while ($lasty >= 0 && $tab->[$y]->[$x] eq $tab->[$lasty]->[$x]) {$lasty--}
604       $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
605       if ($lasty == $y) {
606        # we always want to have something in rows that may otherwise be empty but should be there (see below)
607        unless ($tab->[$y]->[$x]) {$tab->[$y]->[$x]=" &nbsp; "}
608        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
609       }
610       else {$rowspan->[$lasty]->[$x]++}
611      }
612     }
613    
614     # now just join everything back together
615     for (my $y=0; $y <= $#$tab; $y++) {
616      for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
617       if ($rowspan->[$y]->[$x]) {
618        if ($refs->[$y]->[$x]) {$refs->[$y]->[$x] .= " rowspan=". ($rowspan->[$y]->[$x]+1)}
619        else {$refs->[$y]->[$x] = "td rowspan=". ($rowspan->[$y]->[$x]+1)}
620        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
621       }
622       elsif ($newtable->[$y]->[$x] && $refs->[$y]->[$x]) {
623        $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]];
624       }
625      }
626     }
627    
628    
629     # finally we have to remove any completely empty cells that have been added by the array mechanism
630     # (e.g. if you define $a->[2] then $a->[0] and $a->[1] are now undef).
631     # that is why in the loop above I replace empty cells with nbsp. They are now not undef!
632     # I am sure that Gary can do this in one line, but I am hacking.
633     my @trimmed;
634     foreach my $a (@$newtable) {
635      my @row;
636      foreach my $b (@$a) {
637       push @row, $b if ($b);
638      }
639      push @trimmed, \@row;
640     }
641    
642     return \@trimmed;
643    }
644    
645    
646    
647    
648    sub set_ec_links {
649        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
650        my($cgi,$x) = @_;
651        my($before,$match,$after);
652    
653        if ($x =~ /^(.*)(EC \d+\.\d+\.\d+\.\d+)(.*)/s)
654        {
655            $before = $1;
656            $match = $2;
657            $after = $3;
658            return &set_ec_links($cgi,$before) . &HTML::ec_link($match) . &set_ec_links($cgi,$after);
659        }
660        return $x;
661    }
662    
663  sub ec_link {  sub ec_link {
664        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
665      my($role) = @_;      my($role) = @_;
666    
667      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)      if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)
# Line 312  Line 675 
675  }  }
676    
677  sub role_link {  sub role_link {
678        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
679      my($cgi,$role) = @_;      my($cgi,$role) = @_;
680    
681      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 686 
686      return "<a href=$link>$role</a>";      return "<a href=$link>$role</a>";
687  }  }
688    
689    #
690    # Local means to eliminate the fig|org.peg from the
691    # text of the link.
692    #
693  sub fid_link {  sub fid_link {
694        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
695      my($cgi,$fid,$local,$just_url) = @_;      my($cgi,$fid,$local,$just_url) = @_;
696      my($n);      my($n);
697    
# Line 343  Line 712 
712          {          {
713              $n = $fid;              $n = $fid;
714          }          }
715          if ($1 ne "peg") { return $n }  
716            my $link;
717            #added to format prophage and path island links to feature.cgi
718            if ($1 ne "peg")
719            {
720               my $user = $cgi->param('user');
721               if (! $user) { $user = "" }
722               my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
723               $link = "feature.cgi?feature=$fid&user=$user$trans$sprout";
724               $link =~ s/[a-z_A-Z0-9]+\.cgi\?/feature.cgi?/;
725            }
726            else
727            {
728          my $user = $cgi->param('user');          my $user = $cgi->param('user');
729          if (! $user) { $user = "" }          if (! $user) { $user = "" }
730          my $trans = $cgi->param('translate') ? "&translate=1" : "";          my $trans = $cgi->param('translate') ? "&translate=1" : "";
731          my $link = $cgi->url() . "?prot=$fid&user=$user$trans";              my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
732          $link =~ s/[a-z_A-Z]+\.cgi\?/protein.cgi?/;  ###a
733    
734    ### This used to be
735    ###     my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
736    ###
737    ### The cost became prohibitive in the subsystem spreadsheets.  Hence, we cache the value
738    ###
739    ### RAO
740    
741                #if (! $cgi_url) { $cgi_url = &FIG::cgi_url }
742                #$link = $cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
743                $link = "protein.cgi?prot=$fid&user=$user$trans$sprout";
744                $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
745            }
746          if ($just_url)          if ($just_url)
747          {          {
748              return $link;              return $link;
# Line 362  Line 756 
756  }  }
757    
758  sub family_link {  sub family_link {
759        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
760      my($family,$user) = @_;      my($family,$user) = @_;
761    
762      return $family;      return $family;
763  }  }
764    
 use URI::Escape;  
765    
766  sub get_html {  sub get_html {
767        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
768      my( $url, $type, $kv_pairs) = @_;      my( $url, $type, $kv_pairs) = @_;
769      my( $encoded, $ua, $args, @args, $out, @output, $x );      my( $encoded, $ua, $args, @args, $out, @output, $x );
770    
771      $ua = new LWP::UserAgent;      $ua = new LWP::UserAgent;
772      $ua->timeout( 900 );      $ua->timeout( 900 );
   
773      if ($type =~/post/i)      if ($type =~/post/i)
774      {      {
775          $args = [];          $args = [];
# Line 435  Line 829 
829  }  }
830    
831  sub trim_output {  sub trim_output {
832        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
833      my($out) = @_;      my($out) = @_;
834      my $i;      my $i;
835    
# Line 472  Line 867 
867  }  }
868    
869  sub set_prot_links {  sub set_prot_links {
870        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
871      my($cgi,$x) = @_;      my($cgi,$x) = @_;
872      my($before,$match,$after);      my($before,$match,$after);
873    
874      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)$/)      if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)/s)
875        {
876            $before = $1;
877            $match = $2;
878            $after = $3;
879            return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after);
880        }
881        elsif ($x =~ /^(.*)\b([NXYZA]P_[0-9\.]+)\b(.*)/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::refseq_link($cgi,$match) . &set_prot_links($cgi,$after);
887      }      }
888      elsif ($x =~ /^(.*)(gi\|\d+)(.*)$/)      elsif ($x =~ /^(.*)(gi\|\d+)(.*)/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::gi_link($cgi,$match) . &set_prot_links($cgi,$after);
894      }      }
895      elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)$/)      elsif ($x =~ /^(.*)(tigr\|[0-9a-zA-Z]+)(.*)/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::tigr_link($cgi,$match) . &set_prot_links($cgi,$after);
901      }      }
902      elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)$/)      elsif ($x =~  /^(.*)(uni\|[A-Z0-9]{6})(.*)/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::uni_link($cgi,$match) . &set_prot_links($cgi,$after);
908        }
909        elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)/s)
910        {
911            $before = $1;
912            $match = $2;
913            $after = $3;
914            return &set_prot_links($cgi,$before) . &HTML::sp_link($cgi,$match) . &set_prot_links($cgi,$after);
915        }
916        elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)/s)
917        {
918            $before = $1;
919            $match = $2;
920            $after = $3;
921            return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after);
922        }
923        elsif ($x =~ /^(.*)(kegg\|[a-z]{2,4}:[a-zA-Z_0-9]+)(.*)/s)
924        {
925            $before = $1;
926            $match = $2;
927            $after = $3;
928            return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after);
929      }      }
930      return $x;      return $x;
931  }  }
932    
933    sub refseq_link {
934        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
935        my($cgi,$id) = @_;
936    
937        if ($id =~ /^[NXYZA]P_/)
938        {
939            return "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id>$id</a>";
940        }
941    }
942    
943  sub gi_link {  sub gi_link {
944        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
945      my($cgi,$gi) = @_;      my($cgi,$gi) = @_;
946    
947      if ($gi =~ /^gi\|(\d+)$/)      if ($gi =~ /^gi\|(\d+)$/)
# Line 516  Line 951 
951      return $gi;      return $gi;
952  }  }
953    
954    sub tigr_link {
955        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
956        my($cgi,$tigr) = @_;
957    
958        if ($tigr =~ /^tigr\|([0-9a-zA-Z]+)$/)
959        {
960            return "<a href=\"http://pathema.tigr.org/tigr-scripts/CMR/GenePage.cgi?locus=$1\">$tigr</a>";
961        }
962        return $tigr;
963    }
964    
965    sub uni_link {
966        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
967        my($cgi,$uni) = @_;
968    
969        if ($uni =~ /^uni\|(\S+)$/)
970        {
971            return "<a href=http://www.pir.uniprot.org/cgi-bin/upEntry?id=$1>$uni</a>";
972        }
973        return $uni;
974    }
975    
976  sub sp_link {  sub sp_link {
977        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
978      my($cgi,$sp) = @_;      my($cgi,$sp) = @_;
979    
980      if ($sp =~ /^sp\|(\S+)$/)      if ($sp =~ /^sp\|(\S+)$/)
# Line 527  Line 985 
985  }  }
986    
987  sub pir_link {  sub pir_link {
988        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
989      my($cgi,$pir) = @_;      my($cgi,$pir) = @_;
990    
991      if ($pir =~ /^pirnr\|(NF\d+)$/)      if ($pir =~ /^pirnr\|(NF\d+)$/)
# Line 536  Line 995 
995      return $pir;      return $pir;
996  }  }
997    
998    sub kegg_link {
999        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1000        my($cgi,$kegg) = @_;
1001    
1002        if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)
1003        {
1004            return "<a href=http://www.genome.ad.jp/dbget-bin/www_bget?$1+$2>$kegg</a>";
1005        }
1006        return $kegg;
1007    }
1008    
1009    sub set_map_links {
1010        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1011        my($cgi,$x) = @_;
1012        my($before,$match,$after);
1013    
1014        my $org = ($cgi->param('org') || $cgi->param('genome') || "");
1015    
1016        if ($x =~ /^(.*)(MAP\d+)(.*)/s)
1017        {
1018            $before = $1;
1019            $match = $2;
1020            $after = $3;
1021            return &set_map_links($cgi,$before) . &map_link($cgi,$match,$org) . &set_map_links($cgi,$after);
1022        }
1023        return $x;
1024    }
1025    
1026    sub map_link {
1027        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1028        my($cgi,$map,$org) = @_;
1029    
1030        $user = $cgi->param('user');
1031        $user = $user ? $user : "";
1032        $org = $org ? $org : "";
1033    
1034        my $url = "show_kegg_map.cgi?user=$user&map=$map&org=$org";
1035    #rel    my $url = &FIG::cgi_url() . "/show_kegg_map.cgi?user=$user&map=$map&org=$org";
1036        my $link = "<a href=\"$url\">$map</a>";
1037        return $link;
1038    }
1039    
1040    sub java_buttons {
1041        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1042      ## ADDED BY RAE
1043      # Provides code to include check all/first half/second half/none for javascrspt
1044      # this takes two variables - the form name provided in start_form with the
1045      # -name => field and the checkbox name
1046      my ($form, $button)=@_;
1047    
1048      $java_script="<input type=\"button\" name=\"CheckAll\" value=\"Check All\"\nonClick=\"checkAll(document.$form.$button)\">\n";
1049      $java_script.="<input type=\"button\" name=\"CheckFirst\" value=\"Check First Half\"\nonClick=\"checkFirst(document.$form.$button)\">\n";
1050      $java_script.="<input type=\"button\" name=\"CheckSecond\" value=\"Check Second Half\"\nonClick=\"checkSecond(document.$form.$button)\">\n";
1051      $java_script.="<input type=\"button\" name=\"UnCheckAll\" value=\"Uncheck All\"\nonClick=\"uncheckAll(document.$form.$button)\">\n";
1052    
1053      return $java_script;
1054    }
1055    
1056    sub sub_link {
1057        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1058        my($cgi,$sub) = @_;
1059        my($sub_link);
1060    
1061        my $user = $cgi->param('user');
1062        if ($user)
1063        {
1064            my $esc_sub = uri_escape( $sub );
1065            $sub_link = "<a href=./subsys.cgi?ssa_name=$esc_sub&request=show_ssa&user=$user>$sub</a>";
1066        }
1067        else
1068        {
1069            $sub_link = $sub;
1070        }
1071        return $sub_link;
1072    }
1073    
1074    sub reaction_link {
1075        my($reaction) = @_;
1076    
1077        if ($reaction =~ /^R\d+/)
1078        {
1079            return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?rn+$reaction\" target=reaction$$>$reaction</a>";
1080        }
1081        return $reaction;
1082    }
1083    
1084    sub html_for_assignments {
1085        my($fig,$user,$peg_sets) = @_;
1086        my $i;
1087    
1088        my @vals = ();
1089        my $set = 1;
1090        foreach $peg_set (@$peg_sets)
1091        {
1092            for ($i=0; ($i < @$peg_set); $i++)
1093            {
1094                $peg = $peg_set->[$i];
1095                push(@vals,'show=' . join("@",($set,$i+1,$peg,&FIG::abbrev($fig->org_of($peg)),"")));
1096            }
1097            $set++;
1098        }
1099    
1100        $ENV{'REQUEST_METHOD'} = 'GET';
1101        $ENV{'QUERY_STRING'} = join('&',('request=show_commentary',"uni=1","user=$user",@vals));
1102        my $out = join("",`$FIG_Config::fig/CGI/chromosomal_clusters.cgi`);
1103        $out =~ s/^.*?<form/<form/si;
1104        $out =~ s/^(.*)<table.*/$1/si;
1105        return $out;
1106    }
1107    
1108    =head1 rss_feed
1109    
1110    Add something to the RSS feed. The rss feeds are stored in the Html directory, and there are several RSS feeds:
1111            SEED.rss                - everything gets written here
1112            SEEDgenomes.rss                 - whenever a genome is added to the SEED
1113            SEEDsubsystems.rss      - whenever a subsystem is edited (or should this be added?)
1114    
1115    
1116    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.
1117    
1118    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.
1119    
1120    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.
1121    
1122    The has can have these keys:
1123    
1124    REQUIRED:
1125    title       : the title. This is usually what is seen by the user in the pull down menu
1126    description : a more complete description that is often seen is rss viewers but not always
1127    link        : link to the item that was added/edited
1128    All other keys are treated as optional RSS arguments and written to the file.
1129    
1130    At most, $max_entries recent entries are stored in the rss file, and this is currently 50.
1131    
1132    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.
1133    
1134    
1135    =cut
1136    
1137    sub rss_feed {
1138     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1139     my ($files, $args)=@_;
1140    
1141     # how many entries to store in the file
1142     my $max_entries=50;
1143    
1144     foreach my $a (keys %$args) {if ($a =~ /^-(.*)/) {my $b=$1; $args->{$b}=$args->{$a}; delete $args->{$a}}}
1145    
1146     my $filepath=$FIG_Config::fig."/CGI/Html/rss";
1147     # check for the directory and if not, make it
1148     mkdir $filepath unless (-d $filepath);
1149    
1150     # note that $info is a hash of references to hashes that are written out as headers in the file
1151     my $info=
1152     {
1153      "SEED.rss" =>
1154       {
1155            title           => "The SEED",
1156            description     => "Latest news from the SEED",
1157            link            => "Html/rss/SEED.rss",
1158       },
1159    
1160      "SEEDsubsystems.rss" =>
1161      {
1162            title           => "SEED Subsystems",
1163            description     => "Recently updated SEED subsystems",
1164            link            => "Html/rss/SEEDsubsystems.rss",
1165      },
1166    
1167      "SEEDsubsystems.rss" =>
1168      {
1169            title           => "SEED Genomes",
1170            description     => "Genomes recently added to the SEED",
1171            link            => &FIG::cgi_url()."/Html/rss/SEEDsubsystems.rss",
1172      },
1173    
1174     };
1175    
1176    
1177     # build the new xml
1178     my $xml = "\t<item>\n";
1179     foreach my $qw ("title", "description", "link") {
1180      unless ($args->{$qw}) {
1181       print STDERR "You need to include a $qw tag in your RSS description\n";
1182       return(0);
1183      }
1184      # we need to do something a bit funky with the link. We can't have ampersands in the <link> </link> in valid html
1185      # so we are going to pull out the links and uri_escape just the part after the .cgi
1186      if ($qw eq "link")
1187      {
1188       $args->{$qw} =~ /^(.*?\.cgi.)(.*)$/;
1189       $args->{$qw} = $1.uri_escape($2) if ($1 && $2);
1190      }
1191    
1192      $xml .= "\t\t<$qw>".$args->{$qw}."</$qw>\n";
1193      delete $args->{$qw};
1194     }
1195    
1196     foreach my $tag (grep {!/type/i} keys %$args)
1197     {
1198      $xml .= "\t\t<$tag>".$args->{$tag}."</$tag>\n";
1199     }
1200    
1201     $xml .= "\t</item>\n";
1202    
1203    
1204     my @files=("SEED.rss");
1205     if ($args->{"type"}) {push @files, "SEED.$type.rss"}
1206    
1207     foreach my $file ("SEED.rss", @$files)
1208     {
1209      if (-e "$filepath/$file")
1210      {
1211       my @out; # the new content of the file
1212       my $itemcount=0; # how many <item> </item>'s are we keeping
1213       my $initem; # are we in an item?
1214       open(IN, "$filepath/$file") || die "Can't open $filepath/$file";
1215       while (<IN>)
1216       {
1217        if (/\<item\>/) {
1218         push @out, $xml, unless ($itemcount);
1219         $itemcount++;
1220         $initem=1;
1221        }
1222        if (/\<\/item\>/) {$initem=0; next if ($itemcount > $max_entries)}
1223        next if ($initem && $itemcount > $max_entries);
1224        push @out, $_;
1225       }
1226       close IN;
1227       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1228       print OUT @out;
1229      }
1230      else
1231      {
1232       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1233       print OUT "<?xml version=\"1.0\"?>\n<rss version=\"2.0\">\n<channel>\n";
1234       if ($info->{$file})
1235       {
1236         # we're going to sanity check each of the three options we output, just to be sure
1237         foreach my $qw ("title", "description", "link")
1238         {
1239           if ($info->{$file}->{$qw})
1240           {
1241              print OUT "<$qw>", $info->{$file}->{$qw}, "</$qw>\n";
1242           } else {
1243              print STDERR "Please add a $qw for $file\n"; print OUT "<$qw>$file</$qw>\n";
1244           }
1245         }
1246       }
1247       else {
1248        print STDERR "Please define title, link, and description information for $file\n";
1249        print OUT "<title>$file</title>\n<description>An RSS feed</description>\n<link>", &FIG::cgi_url, "</link>\n";
1250       }
1251       print OUT "\n", $xml;
1252       print OUT "\n", "</channel>\n</rss>\n"
1253      }
1254     }
1255    }
1256    
1257    
1258    
1259    1;
1260    
 1  

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3