# # Copyright (c) 2003-2006 University of Chicago and Fellowship # for Interpretations of Genomes. All Rights Reserved. # # This file is part of the SEED Toolkit. # # The SEED Toolkit is free software. You can redistribute # it and/or modify it under the terms of the SEED Toolkit # Public License. # # You should have received a copy of the SEED Toolkit Public License # along with this program; if not write to the University of Chicago # at info@ci.uchicago.edu or the Fellowship for Interpretation of # Genomes at veronika@thefig.info or download a copy from # http://www.theseed.org/LICENSE.TXT. # package HTML; use strict; 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; #use raelib; # now used for the excel function, that should eventually end up in here. Way too experimental! my $raelib; my $top_link_cache; sub new { my($class) = @_; my $self = {}; return bless $self, $class; } sub top_link { # # Determine if this is a toplevel cgi or one in one of the subdirs (currently # just /p2p). # 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 ) = @_; local $/ = "\n"; 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); # 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') { $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; } sub show_page { #warn "SHOWPAGE: cgi=", Dumper(@_); shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$html,$no_home, $alt_header, $css, $javasrc, $cookie, $options) = @_; my $i; my $top = top_link(); # 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 # $options is a reference to a hash of options that you can pass around the pages # # Find the HTML header # my $tail_name = $options->{tail_name} ? $options->{tail_name} : "html.tail"; 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,%$options); } # 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'} = "Html/css/default.css"; } if (!$css->{"Sans Serif"}) { $css->{'Sans Serif'} = "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, "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 $_; } } =head1 make_table The main method to convert an array into a table. The col_hdrs are set to the headers, the $tab is an array of arrays. The first is the rows, and the second is the columns. The title is the title of the table. The options define the settings for the table such as border, width, and class for css formatting. If the option "excelfile" is set to a filename that will be created in FIG_Config::temp, and the link included that allows the user to download the file as an excel file. =cut 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; my $class = defined $options{class} ? "class=\"$options{class}\"" : 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"); # excelfile should be appropriate for a filename (no spaces/special characters) if (defined $options{"excelfile"}) { if (! defined($raelib)) { require raelib; $raelib = new raelib; } push @tab, $raelib->tab2excel($col_hdrs,$tab,$title,\%options,$options{"excelfile"})} return join("",@tab); } sub abstract_coupling_table { my($cgi,$prot,$coupling) = @_; my %fc; my $col_hdrs = ["coupled to","Score","Type of Coupling", "Type-specific Data"]; my $tab = []; my %by_peg; foreach my $x (@$coupling) { my($peg2,$psc,$type,$extra) = @$x; if (($type !~ /^[ID]FC$/) || (! $fc{$peg2})) { if ($type =~ /^[ID]FC$/) { $fc{$peg2} = 1; } $by_peg{$peg2} += $psc; } } foreach my $x (sort { ($by_peg{$b->[0]} <=> $by_peg{$a->[0]}) or ($a->[0] cmp $b->[0]) or ($b->[1] <=> $a->[1]) or ($a->[2] cmp $b->[2]) } @$coupling) { my($peg2,$psc,$type,$extra) = @$x; push(@$tab,[&fid_link($cgi,$peg2,1),$psc,$type,&set_prot_links($cgi,join(", ",@$extra))]); } my $help = "for help"; # my @html = &make_table($col_hdrs,$tab,"Abstract Coupling Data for $prot"); # push(@html,"
\n",$cgi->h3($help),"
"); # return @html; return &make_table($col_hdrs,$tab,"Abstract Coupling Data for $prot [$help]"); } 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"; } =head2 fid_link Get a link to a fid. use: my $html=&HTML::fid_link($cgi, $fid, Local, Just_URL, Full_Path); Local is a boolean means to eliminate the fig|org.peg from the text of the link. Just_URL will only return the URL and not the HTML code. The default is to return the full code. Full_Path is a boolean that will get the full path to the URL not just a relative path. This is required in pages where the base href changes (e.g. if an image is imported like on the metabolic pages). =cut sub fid_link { shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$fid,$local,$just_url,$fullpath) = @_; my $err=join(" ", $cgi,$fid,$local,$just_url,$fullpath); print STDERR "Creating link : $err\n"; my($n); my $top = top_link(); if ($fullpath) {$top=$FIG_Config::cgi_url} print STDERR "Top is $top because full path is $fullpath\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; my $new_framework = $cgi->param('new_framework') ? 1 : 0; #added to format prophage and path island links to feature.cgi my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : ""; if ($1 ne "peg" && ! $sprout) { my $user = $cgi->param('user'); if (! $user) { $user = "" } $link = "$top/feature.cgi?feature=$fid&user=$user$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 = "$top/protein.cgi?prot=$fid&user=$user$trans$sprout\&new_framework=$new_framework"; $link =~ s/[a-z_A-Z0-9]+\.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; } if ($type =~/get/i) { @args = (); foreach $x (@$kv_pairs) { push( @args, "$x->[0]=" . uri_escape($x->[1]) ); } if (@args > 0) { $url .= "?" . join("&",@args); } my $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. my $i; 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, $j); 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) { # # Hm. We would have tried using the options here: # my $tail_name = $options{tail_name} ? $options{tail_name} : "html.tail"; # but they're not passed in. So use the default html.tail. # my $html_tail_file = "./Html/html.tail"; 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][PM]_[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\|\w+)(.*)/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 =~ /^(.*)\b(eric\|\S+)\b(.*)/s) { $before = $1; $match = $2; $after = $3; return &set_prot_links($cgi,$before) . &HTML::eric_link($cgi,$match) . &set_prot_links($cgi,$after); } elsif ($x =~ /^(.*)\b(bhb\|.*?)\b(.*)/s) { $before = $1; $match = $2; $after = $3; return &set_prot_links($cgi,$before) . &HTML::bhb_link($cgi,$match) . &set_prot_links($cgi,$after); } elsif ($x =~ /^(.*)\b(apidb\|[0-9\.a-z_]+)\b(.*)/s) { $before = $1; $match = $2; $after = $3; return &set_prot_links($cgi,$before) . &HTML::apidb_link($cgi,$match) . &set_prot_links($cgi,$after); } elsif ($x =~ /^(.*)\b(patric\|.*?)\b(.*)/s) { $before = $1; $match = $2; $after = $3; return &set_prot_links($cgi,$before) . &HTML::patric_link($cgi,$match) . &set_prot_links($cgi,$after); } elsif ($x =~ /^(.*)\b(vbrc\|.*?)\b(.*)/s) { $before = $1; $match = $2; $after = $3; return &set_prot_links($cgi,$before) . &HTML::vbrc_link($cgi,$match) . &set_prot_links($cgi,$after); } elsif ($x =~ /^(.*)\b(vectorbase\|.*?)\b(.*)/s) { $before = $1; $match = $2; $after = $3; return &set_prot_links($cgi,$before) . &HTML::vectorbase_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); } elsif ($x =~ /^(.*)(Ensembl[a-zA-Z]+:[a-zA-Z_0-9\.]+)(.*)/s) { $before = $1; $match = $2; $after = $3; return &set_prot_links($cgi,$before) . &HTML::ensembl_link($cgi,$match) . &set_prot_links($cgi,$after); } elsif ($x =~ /^(.*)(EntrezGene:[a-zA-Z_0-9\.]+)(.*)/s) { $before = $1; $match = $2; $after = $3; return &set_prot_links($cgi,$before) . &HTML::entrezgene_link($cgi,$match) . &set_prot_links($cgi,$after); } elsif ($x =~ /^(.*)(MIM:[a-zA-Z_0-9\.]+)(.*)/s) { $before = $1; $match = $2; $after = $3; return &set_prot_links($cgi,$before) . &HTML::mim_link($cgi,$match) . &set_prot_links($cgi,$after); } elsif ($x =~ /^(.*)(HGNC:[a-zA-Z_0-9\.]+)(.*)/s) { $before = $1; $match = $2; $after = $3; return &set_prot_links($cgi,$before) . &HTML::hgnc_link($cgi,$match) . &set_prot_links($cgi,$after); } elsif ($x =~ /^(.*)(UniGene:[a-zA-Z_0-9\.]+)(.*)/s) { $before = $1; $match = $2; $after = $3; return &set_prot_links($cgi,$before) . &HTML::unigene_link($cgi,$match) . &set_prot_links($cgi,$after); } # IPI stopped working. turn off for now. # elsif ($x =~ /^(.*)(IPI:[a-zA-Z_0-9\.]+)(.*)/s) # { # $before = $1; # $match = $2; # $after = $3; # return &set_prot_links($cgi,$before) . &HTML::ipi_link($cgi,$match) . &set_prot_links($cgi,$after); # } elsif ($x =~ /^(.*)(WP:[a-zA-Z_0-9\.]+)(.*)/s) { #wormbase $before = $1; $match = $2; $after = $3; return &set_prot_links($cgi,$before) . &HTML::wp_link($cgi,$match) . &set_prot_links($cgi,$after); } elsif ($x =~ /^(.*)(FB:[a-zA-Z_0-9\.]+)(.*)/s) { #flybase $before = $1; $match = $2; $after = $3; return &set_prot_links($cgi,$before) . &HTML::fb_link($cgi,$match) . &set_prot_links($cgi,$after); } elsif ($x =~ /^(.*)(FlyBaseORFNames:[a-zA-Z_0-9\.]+)(.*)/s) { #flybase $before = $1; $match = $2; $after = $3; return &set_prot_links($cgi,$before) . &HTML::fborf_link($cgi,$match) . &set_prot_links($cgi,$after); } elsif ($x =~ /^(.*)(SGD_LOCUS:[a-zA-Z_0-9\.]+)(.*)/s) { #flybase $before = $1; $match = $2; $after = $3; return &set_prot_links($cgi,$before) . &HTML::sgd_link($cgi,$match) . &set_prot_links($cgi,$after); } elsif ($x =~ /^(.*)(tr\|[a-zA-Z0-9]+)(.*)/s) { $before = $1; $match = $2; $after = $3; return &set_prot_links($cgi,$before) . &HTML::trembl_link($cgi,$match) . &set_prot_links($cgi,$after); } return $x; } sub trembl_link { shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$id) = @_; if ($id =~ /^tr\|(.*)/) { return "$id"; } else { return "invalid call to trembl link"; } } sub refseq_link { shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$id) = @_; if ($id =~ /^[NXYZA]P_/) { return "$id"; } elsif ($id =~ /^[NXYZA]M_/) { 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\|(NT|ntbp|ntbpA|BA|BMAA|BXB|GBA)(\w+)$/) { my $id=$1.$2; return "$tigr (Pathema)"; } elsif ($tigr =~ /^tigr\|(\S+)$/) { return "$tigr"; } return $tigr; } sub eric_link { shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$eric) = @_; if ($eric =~ /^eric\|(\S+)/) { return "$eric"; } return $eric; } sub bhb_link { shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$bhb) = @_; return "$bhb"; } sub apidb_link { shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$api) = @_; if ($api =~ /apidb\|(.*?)\.(.*)$/) { return "$api"; } return $api; } sub patric_link { shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$patric) = @_; if ($patric =~ /patric\|(.*)/) { return "$patric"; } return $patric; } sub vbrc_link { shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$vbrc) = @_; if ($vbrc =~ /vbrc\|(.*)/) { return "$vbrc"; } return $vbrc; } sub vectorbase_link { shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$vec) = @_; return "$vec"; } sub uni_link { shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$uni) = @_; if ($uni =~ /^uni\|(\S+)$/) { #return "$uni"; 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 ensembl_link { shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$ensembl) = @_; if ($ensembl =~ /^(\S+):(\S+)$/) { my $what=$1; my $key=$2; my $idx="All"; if ($what eq "EnsemblGene") { $idx = "Gene" } if ($what eq "EnsemblTranscript") { $idx = "All" } if ($what eq "EnsemblProtein") { $idx = "All" } #I really want to get right to the transcript and peptide pages, but #can't see how to do that without knowing the org name too, which #I don't know at this point. (ensembl org name, not real org name) return "$ensembl"; } return $ensembl; } sub entrezgene_link { shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$entrezgene) = @_; if ($entrezgene =~ /^EntrezGene:(\S+)$/) { return "$entrezgene"; } return $entrezgene; } sub mim_link { shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$mim) = @_; if ($mim =~ /^MIM:(\S+)$/) { return "$mim"; } return $mim; } sub hgnc_link { shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$hgnc) = @_; if ($hgnc =~ /^HGNC:(\S+)$/) { return "$hgnc"; } return $hgnc; } sub unigene_link { shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$unigene) = @_; if ($unigene =~ /^UniGene:(\S+)$/) { return "$unigene"; } return $unigene; } sub ipi_link { shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$ipi) = @_; if ($ipi =~ /^IPI:(\S+)$/) { return "$ipi"; } return $ipi; } sub wp_link { shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$wp) = @_; #wormbase if ($wp =~ /^WP:(\S+)$/) { return "$wp"; } return $wp; } sub fb_link { shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$fb) = @_; #flybase if ($fb =~ /^FB:(\S+)$/) { return "$fb"; } return $fb; } sub fborf_link { shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$fb) = @_; #flybase if ($fb =~ /^FlyBaseORFNames:(\S+)$/) { return "$fb"; } return $fb; } sub sgd_link { shift if UNIVERSAL::isa($_[0],__PACKAGE__); my($cgi,$sgd) = @_; #yeast if ($sgd =~ /^SGD_LOCUS:(\S+)$/) { return "$sgd"; } return $sgd; } 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) = @_; my $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)=@_; my $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'); my $esc_sub = uri_escape( $sub ); $sub =~ s/\_/ /g; if ($user) { $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 my $peg_set (@$peg_sets) { for ($i=0; ($i < @$peg_set); $i++) { my $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"}) { my $type = $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;