[Bio] / FigKernelPackages / HTML.pm Repository:
ViewVC logotype

View of /FigKernelPackages/HTML.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (download) (as text) (annotate)
Fri Mar 19 21:58:31 2004 UTC (15 years, 11 months ago) by golsen
Branch: MAIN
Changes since 1.4: +17 -1 lines
Relative base address support and cgi_url() based on current http request

package HTML;

use Carp;
use Data::Dumper;
use LWP::UserAgent;
use LWP::Simple;
use URI::URL;
use HTTP::Request::Common;

sub show_page {
    my($cgi,$html,$no_home) = @_;
    my $i;

    #
    # Find the HTML header
    #

    my $html_hdr_file = "./Html/html.hdr";
    if (! -f $html_hdr_file)
    {
	$html_hdr_file = "$FIG_Config::fig/CGI/Html/html.hdr";
    }

    my $html_tail_file = "./Html/html.tail";
    if (! -f $html_tail_file)
    {
	$html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";
    }


    print $cgi->header;

    #
    #  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
    #
    #  print "<base href=\"" . &FIG::cgi_url . "/\">\n";
    #
    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~$~/~;  # and add trailing slash?
    } 
    print "<base href=\"$base_url\">\n";

    for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<body\>/i); $i++) {}
    if ($i < @$html)
    {
	splice(@$html,$i+1,0,`cat $html_hdr_file`);
    }
    else
    {
	for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<html\>/i); $i++) {}
	if ($i < @$html)
	{
	    splice(@$html,$i+1,0,`cat $html_hdr_file`);
	}
	else
	{
	    splice(@$html,0,0,`cat $html_hdr_file`);
	}
    }

    @tail = `cat $html_tail_file`;
    if (! $no_home)
    {
	my $user = $cgi->param('user');
	$user = $user ? $user : "";
	my $link = $cgi->url();
	$link =~ s/[a-zA-Z_]+\.cgi$/index.cgi/;
	push(@tail,"<hr><a href=\"$link?user=$user\">FIG search</a>\n");
    }

    if (@tail > 0)
    {
	for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}
	if ($i < @$html)
	{
	    splice(@$html,$i,0,@tail);
	}
	else
	{
	    for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/html\>/i); $i++) {}
	    if ($i < @$html)
	    {
		splice(@$html,$i,0,@tail);
	    }
	    else
	    {
		push(@$html,@tail);
	    }
	}
    }
    print @$html;
}

sub make_table {
    my($col_hdrs,$tab,$title,$instr) = @_;
    my(@tab);

    push(@tab,"<table border><caption><b>$title</b></caption>\n");
    push(@tab,"<tr><th>" . join("</th><th>",@$col_hdrs) . "</th></tr>\n");
    my($i,$nowrap);

    for ($i=0; ($i < @$instr) && ($instr->[$i] !~ /nowrap/); $i++) {}
    $nowrap = ($i == @$instr) ? "" : " nowrap";

    my $row;
    foreach $row (@$tab)
    {
	push(@tab,"<tr>" . join("</td>",map { &expand($_,$nowrap) } @$row) . "</td></tr>\n");
    }
    push(@tab,"</table>\n");
    return join("",@tab);
}

sub expand {
    my($x,$nowrap) = @_;

    if ($x =~ /^\@([^:]+)\:([^:]+)\:(.*)$/)
    {
	return "<td$nowrap $1=\"$2\">$3";
    }
    else
    {
	return "<td$nowrap>$x";
    }
}

sub ec_link {
    my($role) = @_;

    if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)
    {
	return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?ec:$1\">$role</a>";
    }
    else
    {
	return $role;
    }
}

sub role_link {
    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 "<a href=$link>$role</a>";
}

sub fid_link {
    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;
	}
	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;
	}
	else
	{
	    return "<a href=$link>$n</a>";
	}
    }
    return $fid;
}

sub family_link {
    my($family,$user) = @_;

    return $family;
}

use URI::Escape;

sub get_html {
    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 = "<H1>Error: " . $response->code . "</H1>" . $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 <base href=URL> to cause all relative links to work 
#   properly.  Remove the header.

    for ($i=0; ($i < @output) && ($output[$i] !~ /^\s*\</); $i++) {}
    if ($i < @output)
    {
	
	splice(@output,0,$i);
    }

    for ($i=0; ($i < @output) && ($output[$i] !~ /\<body\>/i); $i++) {}
    if ($i == @output)
    {
	$i = -1;
    }
    splice(@output,$i+1,0,"<base href=\"$url\">\n");
    return @output;
}

sub trim_output {
    my($out) = @_;
    my $i;

    for ($i=0; ($i < @$out) && ($out->[$i] !~ /^\</); $i++) {}
    splice(@$out,0,$i);

    for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<body\>/i); $i++) {}
    if ($i == @$out)
    {
	for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<html\>/i); $i++) {}
	if ($i == @$out)
	{
	    $i = -1;
	}
    }
    for ($j=$i+1; ($j < @$out) && ($out->[$j] !~ /^\<hr\>$/); $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 {
    my($cgi,$x) = @_;
    my($before,$match,$after);

    if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)$/)
    {
	$before = $1;
	$match = $2;
	$after = $3;
	return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";
    }
    elsif ($x =~ /^(.*)(gi\|\d+)(.*)$/)
    {
	$before = $1;
	$match = $2;
	$after = $3;
	return &set_prot_links($cgi,$before) . &HTML::gi_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";
    }
    elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)$/)
    {
	$before = $1;
	$match = $2;
	$after = $3;
	return &set_prot_links($cgi,$before) . &HTML::sp_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";
    }
    elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)$/)
    {
	$before = $1;
	$match = $2;
	$after = $3;
	return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";
    }
    return $x;
}

sub gi_link {
    my($cgi,$gi) = @_;

    if ($gi =~ /^gi\|(\d+)$/)
    {
	return "<a href=http://www.ncbi.nlm.nih.gov:80/entrez/query.fcgi?cmd=Retrieve&db=Protein&list_uids=$1&dopt=GenPept>$gi</a>";
    }
    return $gi;
}

sub sp_link {
    my($cgi,$sp) = @_;

    if ($sp =~ /^sp\|(\S+)$/)
    {
	return "<a href=http://us.expasy.org/cgi-bin/get-sprot-entry?$1>$sp</a>";
    }
    return $sp;
}

sub pir_link {
    my($cgi,$pir) = @_;

    if ($pir =~ /^pirnr\|(NF\d+)$/)
    {
	return "<a href=http://pir.georgetown.edu/cgi-bin/nfEntry.pl?id=$1>$pir</a>";
    }
    return $pir;
}


1

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3