--- HTML.pm 2004/03/21 02:20:55 1.6 +++ HTML.pm 2005/10/14 14:00:40 1.68 @@ -1,35 +1,187 @@ package HTML; +use Tracer; +use FIG; use Carp; use Data::Dumper; use LWP::UserAgent; use LWP::Simple; +use URI::Escape; # uri_escape() use URI::URL; use HTTP::Request::Common; +use POSIX; -sub show_page { - my($cgi,$html,$no_home) = @_; - my $i; +my $top_link_cache; + + +sub new +{ + my($class) = @_; + + my $self = {}; + + return bless $self, $class; +} + +sub top_link +{ + # - # Find the HTML header + # Determine if this is a toplevel cgi or one in one of the subdirs (currently + # just /p2p). # - my $html_hdr_file = "./Html/html.hdr"; + return $top_link_cache if ($top_link_cache); + + my @parts = split(/\//, $ENV{SCRIPT_NAME}); + my $top; + if ($parts[-2] eq 'FIG') + { + $top = '.'; +# warn "toplevel @parts\n"; + } + elsif ($parts[-3] eq 'FIG') + { + $top = '..'; +# warn "subdir @parts\n"; + } + else + { + $top = $FIG_Config::cgi_base; +# warn "other @parts\n"; + } + + $top_link_cache = $top; + return $top; +} + +sub compute_html_header +{ + shift if UNIVERSAL::isa($_[0],__PACKAGE__); + my($additional_insert, $user, %options ) = @_; + + my $header_name = $options{header_name} ? $options{header_name} : "html.hdr"; + my $tail_name = $options{tail_name} ? $options{tail_name} : "html.tail"; + + my $html_hdr_file = "./Html/$header_name"; if (! -f $html_hdr_file) { - $html_hdr_file = "$FIG_Config::fig/CGI/Html/html.hdr"; + $html_hdr_file = "$FIG_Config::fig/CGI/Html/$header_name"; } + my @html_hdr = &FIG::file_read($html_hdr_file); - my $html_tail_file = "./Html/html.tail"; - if (! -f $html_tail_file) + # for my $k (sort keys %ENV) { warn "$k = $ENV{$k}\n"; } + + # + # Determine if this is a toplevel cgi or one in one of the subdirs (currently + # just /p2p). + # + + my @parts = split(/\//, $ENV{SCRIPT_NAME}); + my $top; + if ($parts[-2] eq 'FIG') { - $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail"; + $top = '.'; +# warn "toplevel @parts\n"; + } + elsif ($parts[-3] eq 'FIG') + { + $top = '..'; +# warn "subdir @parts\n"; + } + else + { + $top = $FIG_Config::cgi_base; +# warn "other @parts\n"; + } + + $options{no_fig_search} or push( @html_hdr, "
FIG search\n" ); + + if (@html_hdr) + { + my $insert_stuff; + + if (not $options{no_release_info}) + { + my @ver = &FIG::file_head("$FIG_Config::fig_disk/CURRENT_RELEASE", 1); + my $ver = $ver[0]; + chomp $ver; + if ($ver =~ /^cvs\.(\d+)$/) + { + my $d = asctime(localtime($1)); + chomp($d); + $ver .= " ($d)"; + } + my $host = &FIG::get_local_hostname(); + $insert_stuff = "SEED version $ver on $host"; + } + + if ($additional_insert) + { + $insert_stuff .= "
" . $additional_insert; + } + + for $_ (@html_hdr) + { + s,(href|img\s+src)="/FIG/,\1="$top/,g; + s,(\?user\=)\",$1$user",; + if ($_ eq "\n") + { + $_ = $insert_stuff; + } + } } + return @html_hdr; +} - print $cgi->header; +sub show_page { + #warn "SHOWPAGE: cgi=", Dumper(@_); + shift if UNIVERSAL::isa($_[0],__PACKAGE__); + my($cgi,$html,$no_home, $alt_header, $css, $javasrc, $cookie) = @_; + my $i; + # ARGUMENTS: + # $cgi is the CGI method + # $html is an array with all the html in it. It is just joined by "\n" (and not
or

+ # $no_home eliminates ONLY the bottom FIG search link in a page + # $alt_header is a reference to an array for an alternate header banner that you can replace the standard one with + # $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 + # 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 + # 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 + # $javasrc is a reference to an array of URLs to javascripts to be included (e.g. "/FIG/Html/css/styleswitcher.js") + # $cookie is the name and value of the cookie to set. Note that you should probably use raelib->cookie to get/set your cookies + # + # Find the HTML header + # + + my $html_tail_file = "./Html/$tail_name"; + if (! -f $html_tail_file) + { + $html_tail_file = "$FIG_Config::fig/CGI/Html/$tail_name"; + } + + my $user = $cgi->param('user') || ""; + my @html_hdr; + if ($alt_header && ref($alt_header) eq "ARRAY") + { + @html_hdr = @$alt_header; + } + else + { + @html_hdr = compute_html_header(undef,$user); + } + + # RAE: I am offloading the handling of cookies to CGI.pm since I don't know how they are set up. + # This modification adds the cookies if necessary + + # Note: 3/10/05 commented this line out pending the discussion of adding cookies into the seed that we are waiting to see about + # to add cookies back in replace these two header lines with each other + + #print $cgi->header(-cookie=>$cookie); + print $cgi->header(); + # # The SEED header file goes immediately after . Figure out # what parts of the HTML document skeleton are there, and fill in @@ -46,7 +198,7 @@ meta => 1, nextid => 1, style => 1, - title => 1 + title => 1, ); # @@ -77,67 +229,67 @@ for ( $i = 0; $i < @$html; $i++ ) { - # Some special cases: - - if ( $html->[$i] =~ /\[$i] =~ /\[$i] =~ /\[$i] =~ /\<\/head\>/i ) { $head_end_line = $i } - - # The content goes after this line: - - if ( $html->[$i] =~ /\[$i] =~ /\<\/?([0-9a-z]+)/ig ) - { - # At first body tag, we stop the search and put the text - # after the last line with a head tag: - - if ( $body_tag{ lc $_ } ) - { - $done = 1; - last; - } - - # If this is a head tag, then move the marker forward - - elsif ( $head_tag{ lc $_ } ) - { - $last_head_line = $i; - } - } - last if $done; # When done, break loop to avoid increment + if ( $html->[$i] =~ /\[$i] =~ /\[$i] =~ /\[$i] =~ /\<\/head\>/i ) { $head_end_line = $i } + + # The content goes after this line: + + if ( $html->[$i] =~ /\[$i] =~ /\<\/?([0-9a-z]+)/ig ) + { + # At first body tag, we stop the search and put the text + # after the last line with a head tag: + + if ( $body_tag{ lc $_ } ) + { + $done = 1; + last; + } + + # If this is a head tag, then move the marker forward + + elsif ( $head_tag{ lc $_ } ) + { + $last_head_line = $i; + } + } + last if $done; # When done, break loop to avoid increment } # Some sanity checks on structure: if ( 1 ) { - if ( $html_line >= 0 ) - { - if ( ( $head_line >= 0 ) && ( $html_line > $head_line ) ) - { - print STDERR " tag follows tag\n"; - } - if ( ( $head_end_line >= 0 ) && ( $html_line > $head_end_line ) ) - { - print STDERR " tag follows tag\n"; - } - } - if ( $head_line >= 0 ) - { - if ( ( $head_end_line >= 0 ) && ( $head_line > $head_end_line ) ) - { - print STDERR " tag follows tag\n"; - } - } + if ( $html_line >= 0 ) + { + if ( ( $head_line >= 0 ) && ( $html_line > $head_line ) ) + { + print STDERR " tag follows tag\n"; + } + if ( ( $head_end_line >= 0 ) && ( $html_line > $head_end_line ) ) + { + print STDERR " tag follows tag\n"; + } + } + if ( $head_line >= 0 ) + { + if ( ( $head_end_line >= 0 ) && ( $head_line > $head_end_line ) ) + { + print STDERR " tag follows tag\n"; + } + } } # @@ -145,20 +297,25 @@ # # goes after last head line # + # RAE: + # Added the javascript for the buttons immediately after body. + # Note if no buttons are added we still (at the moment) add the script, + # but it only adds a little text (495 characters) to the html and noone will notice! + # RAE: This is now deprecated because everything is in an external file, FIG.js, included later if ( $body_line < 0 ) { - $body_line = $last_head_line + 1; - splice( @$html, $body_line, 0, "\n" ); + $body_line = $last_head_line + 1; + splice( @$html, $body_line, 0, "\n" ); } # # Seed page header (if it exists) goes after # - if ( -f $html_hdr_file ) + if (@html_hdr) { - splice( @$html, $body_line + 1, 0, `cat $html_hdr_file` ); + splice( @$html, $body_line + 1, 0, @html_hdr ); } # @@ -167,33 +324,86 @@ if ( $head_end_line < 0 ) { - $head_end_line = $body_line; - splice( @$html, $body_line, 0, "\n" ); + $head_end_line = $body_line; + splice( @$html, $body_line, 0, "\n" ); } + # RAE: + # Add css here + # Note that at the moment I define these two sheets here. I think this should + # be moved out, but I want to try it and see what happens. css has the format: + # + # + + # convert the default key to the right case. and eliminate dups + foreach my $k (keys %$css) {if (lc($k) eq "default") {$css->{'Default'}=$css->{$k}}} + + if (!$css || !$css->{'Default'}) + { + $css->{'Default'} = &FIG::cgi_url() . "/Html/css/default.css"; + } + if (!$css->{"Sans Serif"}) + { + $css->{'Sans Serif'} = &FIG::cgi_url() . "/Html/css/sanserif.css"; + } + + my $csstext = "\n"; + $csstext .= "\n"; + + foreach my $k (keys %$css) + { + next if (lc($k) eq "default" || lc($k) eq "sans serif"); + $csstext .= "\n"; + } + + $csstext .= "\n"; + + # RAE: also added support for external javascripts here. + # we are cluttering the HTML code with all the javascripts when they could easily be in external files + # this solution allows us to source other files + + # the file FIG.js contains most of the java script we use routinely. Every browser will just cache this and so + # it will reduce our overhead. + + # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts + push @$javasrc, &FIG::cgi_url() . "/Html/css/FIG.js"; + foreach my $script (@$javasrc) { + $csstext .= "\n"; + } + + + + splice( @$html, $head_end_line, 1, "$csstext\n" ); # note here I am replacing the line. Could be bad...? But it doesn't increment everything else. + # # goes before # if ( $base_line < 0 ) { + # + # Use a relative base address for pages. Also, because I am + # worried about when FIG_config.pm gets updated (clean installs + # only, or every update?), I provide an alternative derivation + # from $cgi_url. -- GJO + # + # BASE href needs to be absolute. RDO. + # + # + $base_url = &FIG::cgi_url; +# my $base_url = $FIG_Config::cgi_base; +# if ( ! $base_url ) # if cgi_base was not defined +# { +# $base_url = $FIG_Config::cgi_url; # get the full cgi url +# $base_url =~ s~^http://[^/]*~~; # remove protocol and host +# $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash +# } + + $base_line = $head_end_line; # - # Use a relative base address for pages. Also, because I am - # worried about when FIG_config.pm gets updated (clean installs - # only, or every update?), I provide an alternative derivation - # from $cgi_url. -- GJO + # RDO 2005-1006. Remove this so proxying works better. # - - my $base_url = $FIG_Config::cgi_base; - if ( ! $base_url ) # if cgi_base was not defined - { - $base_url = $FIG_Config::cgi_url; # get the full cgi url - $base_url =~ s~^http://[^/]*~~; # remove protocol and host - $base_url =~ m~/$~ || $base_url =~ s~$~/~; # check trailing slash - } - - $base_line = $head_end_line; - splice( @$html, $base_line, 0, "\n" ); +# splice( @$html, $base_line, 0, "\n" ); } # @@ -202,8 +412,8 @@ if ( $html_line < 0 ) { - $html_line = 0; - splice( @$html, $html_line, 0, "\n" ); + $html_line = 0; + splice( @$html, $html_line, 0, "\n" ); } # @@ -212,8 +422,8 @@ if ( $head_line < 0 ) { - $head_line = $html_line + 1; - splice( @$html, $head_line, 0, "\n" ); + $head_line = $html_line + 1; + splice( @$html, $head_line, 0, "\n" ); } # @@ -223,95 +433,284 @@ my @tail = -f $html_tail_file ? `cat $html_tail_file` : (); if (! $no_home) { - my $user = $cgi->param('user') || ""; - push( @tail, "


FIG search\n" ); + my $user = $cgi->param('user') || ""; + push( @tail, "
FIG search\n" ); + } + + # + # See if we have a site-specific tail (for disclaimers, etc). + # + + my $site_tail = "$FIG_Config::fig_disk/config/site_tail.html"; + my $site_fh; + if (open($site_fh, "<$site_tail")) + { + push(@tail, <$site_fh>); + close($site_fh); } # # Figure out where to insert The SEED tail. Before , # or before , or at end of page. # - my @tags = (); - + # Check for a tracing queue. + my $traceString = QTrace("HTML"); + if ($traceString) { + push @tags, $traceString; + } for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {} if ($i >= @$html) # not found; look for { - push @tags, "\n\n"; - # Even if tag is not found, index points to correct place for splice - for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/html\>/i); $i++) {} - if ($i >= @$html) # not found; add it - { - push @tags, "\n"; - } + push @tags, "\n\n"; + # Even if tag is not found, index points to correct place for splice + for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/html\>/i); $i++) {} + if ($i >= @$html) # not found; add it + { + push @tags, "\n"; + } } if ( @tail ) { - splice( @$html, $i, 0, @tail, @tags ); + splice( @$html, $i, 0, @tail, @tags ); } elsif ( @tags ) { - splice( @$html, $i, 0, @tags ); + splice( @$html, $i, 0, @tags ); } - print @$html; + # RAE the chomp will return any new lines at the ends of elements in the array, + # and then we can join with a "\n". This is because somethings put newlines in, + # and others don't. This should make nicer looking html + # + # chomp(@$html); + # print join "\n", @$html; + # + # Apparently the above still breaks things. This is the correct code: + + foreach $_ (@$html) + { + print $_; + } + } sub make_table { - my($col_hdrs,$tab,$title,$instr) = @_; + my($col_hdrs,$tab,$title, %options ) = @_; my(@tab); - push( @tab, "\n\n", + my $border = defined $options{border} ? "border=\"$options{border}\"" : "border"; + my $width = defined $options{width} ? "width=\"$options{width}\"" : undef; + push( @tab, "\n
\n", "\t\n", - "\t\n\t\t\n\t\t\n\t\n" + "\t\n\t\t" + . join( "\n", map { &expand($_, "th") } @$col_hdrs ) + . "\n\t\n" ); - my($i,$nowrap); - - for ($i=0; ($i < @$instr) && ($instr->[$i] !~ /nowrap/); $i++) {} - $nowrap = ($i == @$instr) ? "" : " nowrap"; + my($i); my $row; foreach $row (@$tab) { - push( @tab, "\t\n" - . join( "\n", map { &expand($_,$nowrap) } @$row ) - . "\n\t\n" - ); + push( @tab, "\t\n" + . join( "\n", map { &expand($_) } @$row ) + . "\n\t\n" + ); } push(@tab,"
$title
" - . join( "", @$col_hdrs ) - . "
\n"); return join("",@tab); } sub expand { - my($x,$nowrap) = @_; + shift if UNIVERSAL::isa($_[0],__PACKAGE__); + my( $x, $tag ) = @_; + + $tag = "td" unless $tag; + my $endtag = $tag; + + # RAE modified this so that you can pass in a reference to an array where + # the first element is the data to display and the second element is optional + # things like colspan and align. Note that in this case you need to include the td + # use something like ["some data to appear", "td colspan=4 bgcolor=gray"] - if ($x =~ /^\@([^:]+)\:([^:]+)\:(.*)$/) + # per GJO's request modified this line so it can take any tag. + if ( ref($x) eq "ARRAY" ) { ($x, $tag) = @$x; $tag =~ /^(\S+)/; $endtag = $1 } + + if ( $x =~ /^\@([^:]+)\:(.*)$/ ) { - return "\t\t$3"; + return "\t\t<$tag $1>$2"; } else { - return "\t\t$x"; + return "\t\t<$tag>$x"; + } +} + + +=head2 merge_table_rows() + +Merge table rows together. This will merge a table so that adjacent cells with the same content will only be shown once. + +Something like this: + + ----------------------- + | 1 | a | + ----------------------- + | 1 | b | + ----------------------- + | 2 | c | + ----------------------- + | 3 | d | + ----------------------- + | 4 | d | + ----------------------- + | 5 | d | + ----------------------- + +Will become: + + ----------------------- + | | a | + | 1 |----------- + | | b | + ----------------------- + | 2 | c | + ----------------------- + | 3 | | + ------------ | + | 4 | 5 | + ------------ | + | 5 | | + ----------------------- + + +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. + + $tab=&HTML::merge_table_rows($tab); + + or + + $skip=(1=>1, 3=>1, 5=>1); + $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 + + +=cut + + + + +sub merge_table_rows { + # RAE: + # Experimental piece of code. We often want to have rows or columns were cells are merged. It just looks so much nicer + # this block should merge adjacent rows that have the same text in them. + # use like this: + # $tab=&HTML::merge_table_rows($tab); + # before you do a make_table call + + my $self=shift if UNIVERSAL::isa($_[0],__PACKAGE__); + my ($tab, $skip)=@_; + + my $newtable; + my $lastrow; + my $rowspan; + my $refs; + + for (my $y=0; $y <= $#$tab; $y++) { + #$y is the row in the table; + for (my $x=0; $x <= $#{$tab->[$y]}; $x++) { + # this is the user definable columns not to merge + if ($skip->{$x}) + { + $newtable->[$y]->[$x] = $tab->[$y]->[$x]; + next; + } + + #$x is the column in the table + # if the column in the row we are looking at is the same as the column in the previous row, we don't add + # this cell to $newtable. Instead we increment the rowspan of the previous row by one + + # handle cells that are references to arrays + if (ref($tab->[$y]->[$x]) eq "ARRAY") {$refs->[$y]->[$x]=$tab->[$y]->[$x]->[1]; $tab->[$y]->[$x]=$tab->[$y]->[$x]->[0]} + + # now we go back through the table looking where to draw the merge line: + my $lasty=$y; + while ($lasty >= 0 && $tab->[$y]->[$x] eq $tab->[$lasty]->[$x]) {$lasty--} + $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 + if ($lasty == $y) { + # we always want to have something in rows that may otherwise be empty but should be there (see below) + unless ($tab->[$y]->[$x]) {$tab->[$y]->[$x]="   "} + $newtable->[$y]->[$x] = $tab->[$y]->[$x]; + } + else {$rowspan->[$lasty]->[$x]++} + } + } + + # now just join everything back together + for (my $y=0; $y <= $#$tab; $y++) { + for (my $x=0; $x <= $#{$tab->[$y]}; $x++) { + if ($rowspan->[$y]->[$x]) { + if ($refs->[$y]->[$x]) {$refs->[$y]->[$x] .= " rowspan=". ($rowspan->[$y]->[$x]+1)} + else {$refs->[$y]->[$x] = "td rowspan=". ($rowspan->[$y]->[$x]+1)} + $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]]; + } + elsif ($newtable->[$y]->[$x] && $refs->[$y]->[$x]) { + $newtable->[$y]->[$x]=[$newtable->[$y]->[$x], $refs->[$y]->[$x]]; + } + } + } + + + # finally we have to remove any completely empty cells that have been added by the array mechanism + # (e.g. if you define $a->[2] then $a->[0] and $a->[1] are now undef). + # that is why in the loop above I replace empty cells with nbsp. They are now not undef! + # I am sure that Gary can do this in one line, but I am hacking. + my @trimmed; + foreach my $a (@$newtable) { + my @row; + foreach my $b (@$a) { + push @row, $b if ($b); + } + push @trimmed, \@row; + } + + return \@trimmed; +} + + + + +sub set_ec_links { + shift if UNIVERSAL::isa($_[0],__PACKAGE__); + my($cgi,$x) = @_; + my($before,$match,$after); + + if ($x =~ /^(.*)(EC \d+\.\d+\.\d+\.\d+)(.*)/s) + { + $before = $1; + $match = $2; + $after = $3; + return &set_ec_links($cgi,$before) . &HTML::ec_link($match) . &set_ec_links($cgi,$after); } + return $x; } sub ec_link { + shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($role) = @_; if ($role =~ /(\d+\.\d+\.\d+\.\d+)/) { - return "$role"; + return "$role"; } else { - return $role; + return $role; } } sub role_link { + shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$role) = @_; my $roleR = ($role =~ /^(\d+\.\d+\.\d+\.\d+)\s+-\s+/) ? $1 : $role; @@ -322,33 +721,65 @@ return "$role"; } +# +# Local means to eliminate the fig|org.peg from the +# text of the link. +# sub fid_link { + shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$fid,$local,$just_url) = @_; my($n); + my $top = top_link(); + if ($fid =~ /^fig\|\d+\.\d+\.([a-z]+)\.(\d+)/) { - if ($local) - { - if ($1 eq "peg") - { - $n = $2; - } - else - { - $n = "$1.$2"; - } - } + if ($local) + { + if ($1 eq "peg") + { + $n = $2; + } + else + { + $n = "$1.$2"; + } + } + else + { + $n = $fid; + } + + my $link; + #added to format prophage and path island links to feature.cgi + if ($1 ne "peg") + { + my $user = $cgi->param('user'); + if (! $user) { $user = "" } + my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : ""; + $link = "$top/feature.cgi?feature=$fid&user=$user$trans$sprout"; + $link =~ s/[a-z_A-Z0-9]+\.cgi\?/feature.cgi?/; + } else - { - $n = $fid; + { + my $user = $cgi->param('user'); + if (! $user) { $user = "" } + my $trans = $cgi->param('translate') ? "&translate=1" : ""; + my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : ""; +###a + +### This used to be +### my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout"; +### +### The cost became prohibitive in the subsystem spreadsheets. Hence, we cache the value +### +### RAO + + #if (! $cgi_url) { $cgi_url = &FIG::cgi_url } + #$link = $cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout"; + $link = "$top/protein.cgi?prot=$fid&user=$user$trans$sprout"; + $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/; } - if ($1 ne "peg") { return $n } - my $user = $cgi->param('user'); - if (! $user) { $user = "" } - my $trans = $cgi->param('translate') ? "&translate=1" : ""; - my $link = $cgi->url() . "?prot=$fid&user=$user$trans"; - $link =~ s/[a-z_A-Z]+\.cgi\?/protein.cgi?/; if ($just_url) { return $link; @@ -362,54 +793,54 @@ } sub family_link { + shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($family,$user) = @_; return $family; } -use URI::Escape; sub get_html { + shift if UNIVERSAL::isa($_[0],__PACKAGE__); my( $url, $type, $kv_pairs) = @_; my( $encoded, $ua, $args, @args, $out, @output, $x ); $ua = new LWP::UserAgent; $ua->timeout( 900 ); - if ($type =~/post/i) { - $args = []; - foreach $x (@$kv_pairs) - { - push(@$args, ( $x->[0], $x->[1]) ); - } - my $request = POST $url, $args; - my $response = $ua->request($request); - $out = $response->content; + $args = []; + foreach $x (@$kv_pairs) + { + push(@$args, ( $x->[0], $x->[1]) ); + } + my $request = POST $url, $args; + my $response = $ua->request($request); + $out = $response->content; } else { - @args = (); - foreach $x (@$kv_pairs) - { - push( @args, "$x->[0]=" . uri_escape($x->[1]) ); - } - - if (@args > 0) - { - $url .= "?" . join("&",@args); - } - $request = new HTTP::Request('GET', $url); - my $response = $ua->request($request); - - if ($response->is_success) - { - $out = $response->content; - } - else - { - $out = "

Error: " . $response->code . "

" . $response->message; - } + @args = (); + foreach $x (@$kv_pairs) + { + push( @args, "$x->[0]=" . uri_escape($x->[1]) ); + } + + if (@args > 0) + { + $url .= "?" . join("&",@args); + } + $request = new HTTP::Request('GET', $url); + my $response = $ua->request($request); + + if ($response->is_success) + { + $out = $response->content; + } + else + { + $out = "

Error: " . $response->code . "

" . $response->message; + } } # set up a document with proper eol characters @output = split(/[\012\015]+/,$out); @@ -421,20 +852,21 @@ for ($i=0; ($i < @output) && ($output[$i] !~ /^\s*\/i); $i++) {} if ($i == @output) { - $i = -1; + $i = -1; } splice(@output,$i+1,0,"\n"); return @output; } sub trim_output { + shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($out) = @_; my $i; @@ -444,97 +876,422 @@ for ($i=0; ($i < @$out) && ($out->[$i] !~ /\/i); $i++) {} if ($i == @$out) { - for ($i=0; ($i < @$out) && ($out->[$i] !~ /\/i); $i++) {} - if ($i == @$out) - { - $i = -1; - } + for ($i=0; ($i < @$out) && ($out->[$i] !~ /\/i); $i++) {} + if ($i == @$out) + { + $i = -1; + } } for ($j=$i+1; ($j < @$out) && ($out->[$j] !~ /^\$/); $j++) {} if ($j < @$out) { - splice(@$out,$i+1,($j-$i)); + splice(@$out,$i+1,($j-$i)); } for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<\/body\>/i); $i++) {} if ($i == @$out) { - for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<\/html\>/i); $i++) {} + for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<\/html\>/i); $i++) {} } for ($j=$i-1; ($j > 0) && ($out->[$j] !~ /FIG search/); $j--) {} if ($j > 0) { - my @tmp = `cat $html_tail_file`; - my $n = @tmp; - splice(@$out,$j-$n,$n+1); + my @tmp = `cat $html_tail_file`; + my $n = @tmp; + splice(@$out,$j-$n,$n+1); } } sub set_prot_links { + shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$x) = @_; my($before,$match,$after); - if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)$/) + if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)/s) { - $before = $1; - $match = $2; - $after = $3; - return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n"; + $before = $1; + $match = $2; + $after = $3; + return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after); } - elsif ($x =~ /^(.*)(gi\|\d+)(.*)$/) + elsif ($x =~ /^(.*)\b([NXYZA]P_[0-9\.]+)\b(.*)/s) { - $before = $1; - $match = $2; - $after = $3; - return &set_prot_links($cgi,$before) . &HTML::gi_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n"; + $before = $1; + $match = $2; + $after = $3; + return &set_prot_links($cgi,$before) . &HTML::refseq_link($cgi,$match) . &set_prot_links($cgi,$after); } - elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)$/) + elsif ($x =~ /^(.*)(gi\|\d+)(.*)/s) { - $before = $1; - $match = $2; - $after = $3; - return &set_prot_links($cgi,$before) . &HTML::sp_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n"; + $before = $1; + $match = $2; + $after = $3; + return &set_prot_links($cgi,$before) . &HTML::gi_link($cgi,$match) . &set_prot_links($cgi,$after); } - elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)$/) + elsif ($x =~ /^(.*)(tigr\|[0-9a-zA-Z]+)(.*)/s) { - $before = $1; - $match = $2; - $after = $3; - return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n"; + $before = $1; + $match = $2; + $after = $3; + return &set_prot_links($cgi,$before) . &HTML::tigr_link($cgi,$match) . &set_prot_links($cgi,$after); + } + elsif ($x =~ /^(.*)(uni\|[A-Z0-9]{6})(.*)/s) + { + $before = $1; + $match = $2; + $after = $3; + return &set_prot_links($cgi,$before) . &HTML::uni_link($cgi,$match) . &set_prot_links($cgi,$after); + } + elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)/s) + { + $before = $1; + $match = $2; + $after = $3; + return &set_prot_links($cgi,$before) . &HTML::sp_link($cgi,$match) . &set_prot_links($cgi,$after); + } + elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)/s) + { + $before = $1; + $match = $2; + $after = $3; + return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after); + } + elsif ($x =~ /^(.*)(kegg\|[a-z]{2,4}:[a-zA-Z_0-9]+)(.*)/s) + { + $before = $1; + $match = $2; + $after = $3; + return &set_prot_links($cgi,$before) . &HTML::kegg_link($cgi,$match) . &set_prot_links($cgi,$after); } return $x; } +sub refseq_link { + shift if UNIVERSAL::isa($_[0],__PACKAGE__); + my($cgi,$id) = @_; + + if ($id =~ /^[NXYZA]P_/) + { + return "$id"; + } +} + sub gi_link { + shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$gi) = @_; if ($gi =~ /^gi\|(\d+)$/) { - return "$gi"; + return "$gi"; } return $gi; } +sub tigr_link { + shift if UNIVERSAL::isa($_[0],__PACKAGE__); + my($cgi,$tigr) = @_; + + if ($tigr =~ /^tigr\|([0-9a-zA-Z]+)$/) + { + return "$tigr"; + } + return $tigr; +} + +sub uni_link { + shift if UNIVERSAL::isa($_[0],__PACKAGE__); + my($cgi,$uni) = @_; + + if ($uni =~ /^uni\|(\S+)$/) + { + return "$uni"; + } + return $uni; +} + sub sp_link { + shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$sp) = @_; if ($sp =~ /^sp\|(\S+)$/) { - return "$sp"; + return "$sp"; } return $sp; } sub pir_link { + shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$pir) = @_; if ($pir =~ /^pirnr\|(NF\d+)$/) { - return "$pir"; + return "$pir"; } return $pir; } +sub kegg_link { + shift if UNIVERSAL::isa($_[0],__PACKAGE__); + my($cgi,$kegg) = @_; + + if ($kegg =~ /^kegg\|([^:]+):(\S+)$/) + { + return "$kegg"; + } + return $kegg; +} + +sub set_map_links { + shift if UNIVERSAL::isa($_[0],__PACKAGE__); + my($cgi,$x) = @_; + my($before,$match,$after); + + my $org = ($cgi->param('org') || $cgi->param('genome') || ""); + + if ($x =~ /^(.*)(MAP\d+)(.*)/s) + { + $before = $1; + $match = $2; + $after = $3; + return &set_map_links($cgi,$before) . &map_link($cgi,$match,$org) . &set_map_links($cgi,$after); + } + return $x; +} + +sub map_link { + shift if UNIVERSAL::isa($_[0],__PACKAGE__); + my($cgi,$map,$org) = @_; + + $user = $cgi->param('user'); + $user = $user ? $user : ""; + $org = $org ? $org : ""; + + my $url = "show_kegg_map.cgi?user=$user&map=$map&org=$org"; +#rel my $url = &FIG::cgi_url() . "/show_kegg_map.cgi?user=$user&map=$map&org=$org"; + my $link = "$map"; + return $link; +} + +sub java_buttons { + shift if UNIVERSAL::isa($_[0],__PACKAGE__); + ## ADDED BY RAE + # Provides code to include check all/first half/second half/none for javascrspt + # this takes two variables - the form name provided in start_form with the + # -name => field and the checkbox name + my ($form, $button)=@_; + + $java_script="\n"; + $java_script.="\n"; + $java_script.="\n"; + $java_script.="\n"; + + return $java_script; +} + +sub sub_link { + shift if UNIVERSAL::isa($_[0],__PACKAGE__); + my($cgi,$sub) = @_; + my($sub_link); + + my $user = $cgi->param('user'); + if ($user) + { + my $esc_sub = uri_escape( $sub ); + $sub_link = "$sub"; + } + else + { + $sub_link = $sub; + } + return $sub_link; +} + +sub reaction_link { + my($reaction) = @_; + + if ($reaction =~ /^R\d+/) + { + return "$reaction"; + } + return $reaction; +} + +sub html_for_assignments { + my($fig,$user,$peg_sets) = @_; + my $i; + + my @vals = (); + my $set = 1; + foreach $peg_set (@$peg_sets) + { + for ($i=0; ($i < @$peg_set); $i++) + { + $peg = $peg_set->[$i]; + push(@vals,'show=' . join("@",($set,$i+1,$peg,&FIG::abbrev($fig->org_of($peg)),""))); + } + $set++; + } + + $ENV{'REQUEST_METHOD'} = 'GET'; + $ENV{'QUERY_STRING'} = join('&',('request=show_commentary',"uni=1","user=$user",@vals)); + my $out = join("",`$FIG_Config::fig/CGI/chromosomal_clusters.cgi`); + $out =~ s/^.*?
tag. Note that there is also an initial title/description/link set that describes the file. + + +=cut + +sub rss_feed { + shift if UNIVERSAL::isa($_[0],__PACKAGE__); + my ($files, $args)=@_; + + # how many entries to store in the file + my $max_entries=50; + + foreach my $a (keys %$args) {if ($a =~ /^-(.*)/) {my $b=$1; $args->{$b}=$args->{$a}; delete $args->{$a}}} + + my $filepath=$FIG_Config::fig."/CGI/Html/rss"; + # check for the directory and if not, make it + mkdir $filepath unless (-d $filepath); + + # note that $info is a hash of references to hashes that are written out as headers in the file + my $info= + { + "SEED.rss" => + { + title => "The SEED", + description => "Latest news from the SEED", + link => "Html/rss/SEED.rss", + }, + + "SEEDsubsystems.rss" => + { + title => "SEED Subsystems", + description => "Recently updated SEED subsystems", + link => "Html/rss/SEEDsubsystems.rss", + }, + + "SEEDsubsystems.rss" => + { + title => "SEED Genomes", + description => "Genomes recently added to the SEED", + link => &FIG::cgi_url()."/Html/rss/SEEDsubsystems.rss", + }, + + }; + + + # build the new xml + my $xml = "\t\n"; + foreach my $qw ("title", "description", "link") { + unless ($args->{$qw}) { + print STDERR "You need to include a $qw tag in your RSS description\n"; + return(0); + } + # we need to do something a bit funky with the link. We can't have ampersands in the in valid html + # so we are going to pull out the links and uri_escape just the part after the .cgi + if ($qw eq "link") + { + $args->{$qw} =~ /^(.*?\.cgi.)(.*)$/; + $args->{$qw} = $1.uri_escape($2) if ($1 && $2); + } + + $xml .= "\t\t<$qw>".$args->{$qw}."\n"; + delete $args->{$qw}; + } + + foreach my $tag (grep {!/type/i} keys %$args) + { + $xml .= "\t\t<$tag>".$args->{$tag}."\n"; + } + + $xml .= "\t\n"; + + + my @files=("SEED.rss"); + if ($args->{"type"}) {push @files, "SEED.$type.rss"} + + foreach my $file ("SEED.rss", @$files) + { + if (-e "$filepath/$file") + { + my @out; # the new content of the file + my $itemcount=0; # how many 's are we keeping + my $initem; # are we in an item? + open(IN, "$filepath/$file") || die "Can't open $filepath/$file"; + while () + { + if (/\/) { + push @out, $xml, unless ($itemcount); + $itemcount++; + $initem=1; + } + if (/\<\/item\>/) {$initem=0; next if ($itemcount > $max_entries)} + next if ($initem && $itemcount > $max_entries); + push @out, $_; + } + close IN; + open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing"; + print OUT @out; + } + else + { + open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing"; + print OUT "\n\n\n"; + if ($info->{$file}) + { + # we're going to sanity check each of the three options we output, just to be sure + foreach my $qw ("title", "description", "link") + { + if ($info->{$file}->{$qw}) + { + print OUT "<$qw>", $info->{$file}->{$qw}, "\n"; + } else { + print STDERR "Please add a $qw for $file\n"; print OUT "<$qw>$file\n"; + } + } + } + else { + print STDERR "Please define title, link, and description information for $file\n"; + print OUT "$file\nAn RSS feed\n", &FIG::cgi_url, "\n"; + } + print OUT "\n", $xml; + print OUT "\n", "\n\n" + } + } +} + + + +1; -1