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 new { my($class) = @_; my $self = {}; return bless $self, $class; } 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/$header_name"; } my @html_hdr = &FIG::file_read($html_hdr_file); $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="$FIG_Config::cgi_base,g; s,(\?user\=)\",$1$user",; if ($_ eq "\n") { $_ = $insert_stuff; } } } return @html_hdr; } 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 # missing ones. # # This list should be as comprehensive as feasible: # my %head_tag = ( base => 1, basefont => 1, html => 1, isindex => 1, link => 1, meta => 1, nextid => 1, style => 1, title => 1, ); # # This list need not be comprehensive; it is just stopping conditions: # my %body_tag = ( a => 1, br => 1, center => 1, form => 1, h1 => 1, h2 => 1, h3 => 1, hr => 1, img => 1, p => 1, pre => 1, table => 1 ); my $html_line = -1; my $head_line = -1; my $base_line = -1; my $head_end_line = -1; my $body_line = -1; my $last_head_line = -1; # If no head tags are found, text goes at top. my $done = 0; 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 } # 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"; } } } # # Okay. Let's put in the html header file, and missing tags: # # 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" ); } # # Seed page header (if it exists) goes after # if (@html_hdr) { splice( @$html, $body_line + 1, 0, @html_hdr ); } # # goes before # if ( $head_end_line < 0 ) { $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; # # RDO 2005-1006. Remove this so proxying works better. # # splice( @$html, $base_line, 0, "\n" ); } # # goes at the top of the output # if ( $html_line < 0 ) { $html_line = 0; splice( @$html, $html_line, 0, "\n" ); } # # goes after # if ( $head_line < 0 ) { $head_line = $html_line + 1; splice( @$html, $head_line, 0, "\n" ); } # # Place FIG search link at bottom of page # my @tail = -f $html_tail_file ? `cat $html_tail_file` : (); if (! $no_home) { 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"; } } if ( @tail ) { splice( @$html, $i, 0, @tail, @tags ); } elsif ( @tags ) { splice( @$html, $i, 0, @tags ); } # 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, %options ) = @_; my(@tab); 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" . join( "\n", map { &expand($_, "th") } @$col_hdrs ) . "\n\t\n" ); my($i); my $row; foreach $row (@$tab) { push( @tab, "\t\n" . join( "\n", map { &expand($_) } @$row ) . "\n\t\n" ); } push(@tab,"
$title
\n"); return join("",@tab); } sub expand { 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"] # 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<$tag $1>$2"; } else { 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"; } else { 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; my $user = $cgi->param('user'); if (! $user) { $user = "" } my $link = $cgi->url() . "?role=$roleR&user=$user"; $link =~ s/[a-z]+\.cgi\?/pom.cgi?/; 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); if ($fid =~ /^fig\|\d+\.\d+\.([a-z]+)\.(\d+)/) { 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 = &FIG::cgi_url . "/feature.cgi?feature=$fid&user=$user$trans$sprout"; $link =~ s/[a-z_A-Z0-9]+\.cgi\?/feature.cgi?/; } else { 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 = "protein.cgi?prot=$fid&user=$user$trans$sprout"; $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/; # # Elimin the p2p part if we're in that subdir. Ugh. # $link =~ s,p2p/protein.cgi,protein.cgi,; } if ($just_url) { return $link; } else { return "$n"; } } return $fid; } sub family_link { shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($family,$user) = @_; return $family; } 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; } 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; } } # set up a document with proper eol characters @output = split(/[\012\015]+/,$out); foreach $out (@output) { $out .= "\n"; } # Now splice in a line of the form to cause all relative links to work # properly. Remove the header. for ($i=0; ($i < @output) && ($output[$i] !~ /^\s*\/i); $i++) {} if ($i == @output) { $i = -1; } splice(@output,$i+1,0,"\n"); return @output; } sub trim_output { shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($out) = @_; my $i; for ($i=0; ($i < @$out) && ($out->[$i] !~ /^\[$i] !~ /\/i); $i++) {} if ($i == @$out) { 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)); } for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<\/body\>/i); $i++) {} if ($i == @$out) { 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); } } sub set_prot_links { shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$x) = @_; my($before,$match,$after); 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); } elsif ($x =~ /^(.*)\b([NXYZA]P_[0-9\.]+)\b(.*)/s) { $before = $1; $match = $2; $after = $3; return &set_prot_links($cgi,$before) . &HTML::refseq_link($cgi,$match) . &set_prot_links($cgi,$after); } elsif ($x =~ /^(.*)(gi\|\d+)(.*)/s) { $before = $1; $match = $2; $after = $3; return &set_prot_links($cgi,$before) . &HTML::gi_link($cgi,$match) . &set_prot_links($cgi,$after); } elsif ($x =~ /^(.*)(tigr\|[0-9a-zA-Z]+)(.*)/s) { $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; } 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; } sub pir_link { shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$pir) = @_; if ($pir =~ /^pirnr\|(NF\d+)$/) { 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)=@_; 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 => &FIG::cgi_url()."/Html/rss/SEED.rss", }, "SEEDsubsystems.rss" => { title => "SEED Subsystems", description => "Recently updated SEED subsystems", link => &FIG::cgi_url()."/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.)(.*)$/; print STDERR "Got ->>$1<<- and ->>$2<<-\n"; $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 > 9)} next if ($initem && $itemcount > 9); 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;