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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3