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

View of /FigKernelPackages/HTML.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.52 - (download) (as text) (annotate)
Sat Aug 6 15:30:29 2005 UTC (14 years, 6 months ago) by redwards
Branch: MAIN
Changes since 1.51: +1 -1 lines
New interface for subsys.cgi, but it is commented out at the moment

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, "<br><a href=\"index.cgi?user=$user\">FIG search</a>\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 <b>$ver</b> on $host";
        }
        
        if ($additional_insert)
        {
            $insert_stuff .= "<br>" . $additional_insert;
        }
        
        for $_ (@html_hdr)
        {
            s,(href|img\s+src)="/FIG/,\1="$FIG_Config::cgi_base,g;
            if ($_ eq "<!-- HEADER_INSERT -->\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) = @_;
    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 <br> or <p>
    #     $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")
    #
    # 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);
    }


    print $cgi->header;

    #
    #  The SEED header file goes immediately after <BODY>.  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] =~ /\<html[^0-9a-z]/i ) { $html_line = $i }
        if ( $html->[$i] =~ /\<head[^0-9a-z]/i ) { $head_line = $i }
        if ( $html->[$i] =~ /\<base[^0-9a-z]/i ) { $base_line = $i }
        if ( $html->[$i] =~ /\<\/head\>/i )      { $head_end_line = $i }

        #  The content goes after this line:

        if ( $html->[$i] =~ /\<body[^0-9a-z]/i )
        {
            $body_line = $i;
            $last;
        }

        #  Now the general case.
        #  Analyze all the html tags on the line:

        foreach ( $html->[$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 "<HTML> tag follows <HEAD> tag\n";
            }
            if ( ( $head_end_line >= 0 ) && ( $html_line > $head_end_line ) )
            {
                print STDERR "<HTML> tag follows </HEAD> tag\n";
            }
        }
        if ( $head_line >= 0 )
        {
            if ( ( $head_end_line >= 0 ) && ( $head_line > $head_end_line ) )
            {
                print STDERR "<HEAD> tag follows </HEAD> tag\n";
            }
        }
    }

    #
    #  Okay.  Let's put in the html header file, and missing tags:
    #
    #  <BODY> 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, "<BODY>\n" );
    }

    #
    #  Seed page header (if it exists) goes after <BODY>
    #

    if (@html_hdr)
    {
        splice( @$html, $body_line + 1, 0, @html_hdr );
    }

    #
    #  </HEAD> goes before <BODY>
    #

    if ( $head_end_line < 0 )
    {
        $head_end_line = $body_line;
        splice( @$html, $body_line, 0, "</HEAD>\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:
    #
    # <link rel='stylesheet' title='default' href='/css/default.css' type='text/css'>

    # 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 = "<link rel='stylesheet' title='default' href='".$css->{'Default'}."' type='text/css'>\n";
    $csstext   .= "<link rel='alternate stylesheet' title='Sans Serif' href='".$css->{'Sans Serif'}."' type='text/css'>\n";
    
    foreach my $k (keys %$css)
    {
       next if (lc($k) eq "default" || lc($k) eq "sans serif");
       $csstext .= "<link rel='alternate stylesheet' title='$k' href='".$css->{$k}."' type='text/css'>\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 .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";
    }


    
    splice( @$html, $head_end_line, 1, "$csstext</HEAD>\n" );  # note here I am replacing the </head> line. Could be bad...? But it doesn't increment everything else.

    #
    #  <BASE ...> goes before </HEAD>
    #

    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;
        splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );
    }

    #
    #  <HTML> goes at the top of the output
    #

    if ( $html_line < 0 )
    {
        $html_line = 0;
        splice( @$html, $html_line, 0, "<HTML>\n" );
    }

    #
    #  <HEAD> goes after <HTML>
    #

    if ( $head_line < 0 )
    {
        $head_line = $html_line + 1;
        splice( @$html, $head_line, 0, "<HEAD>\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, "<hr><a href=\"index.cgi?user=$user\">FIG search</a>\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 </body>,
    #  or before </html>, 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)        # </body> not found; look for </html>
    {
        push @tags, "\n</BODY>\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)    # </html> not found; add it
        {
            push @tags, "</HTML>\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";
    push( @tab, "\n<table $border>\n",
                "\t<caption><b>$title</b></caption>\n",
                "\t<tr>\n\t\t"
              . join( "\n", map { &expand($_, "th") } @$col_hdrs ) 
              . "\n\t</tr>\n"
        );
    my($i);

    my $row;
    foreach $row (@$tab)
    {
        push( @tab, "\t<tr>\n"
                  . join( "\n", map { &expand($_) } @$row )
                  . "\n\t</tr>\n"
            );
    }
    push(@tab,"</table>\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</$endtag>";
    }
    else
    {
        return "\t\t<$tag>$x</$endtag>";
    }
}


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)=@_;
 
 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++) {
   #$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]=" &nbsp; "}
    $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 "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?ec:$1\">$role</a>";
    }
    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 "<a href=$link>$role</a>";
}

#
# 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;
        }
        if ($1 ne "peg") { return $n }
        my $user = $cgi->param('user');
        if (! $user) { $user = "" }
        my $trans = $cgi->param('translate') ? "&translate=1" : "";
        my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
        my $link = &FIG::cgi_url . "/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 "<a href=$link>$n</a>";
        }
    }
    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 = "<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 {
    shift if UNIVERSAL::isa($_[0],__PACKAGE__);
    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 {
    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 "<a href=http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=$id>$id</a>";
    }
}

sub gi_link {
    shift if UNIVERSAL::isa($_[0],__PACKAGE__);
    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 tigr_link {
    shift if UNIVERSAL::isa($_[0],__PACKAGE__);
    my($cgi,$tigr) = @_;

    if ($tigr =~ /^tigr\|([0-9a-zA-Z]+)$/)
    {
        return "<a href=\"http://pathema.tigr.org/tigr-scripts/CMR/GenePage.cgi?locus=$1\">$tigr</a>";
    }
    return $tigr;
}

sub uni_link {
    shift if UNIVERSAL::isa($_[0],__PACKAGE__);
    my($cgi,$uni) = @_;

    if ($uni =~ /^uni\|(\S+)$/)
    {
        return "<a href=http://www.pir.uniprot.org/cgi-bin/upEntry?id=$1>$uni</a>";
    }
    return $uni;
}

sub sp_link {
    shift if UNIVERSAL::isa($_[0],__PACKAGE__);
    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 {
    shift if UNIVERSAL::isa($_[0],__PACKAGE__);
    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;
}

sub kegg_link {
    shift if UNIVERSAL::isa($_[0],__PACKAGE__);
    my($cgi,$kegg) = @_;

    if ($kegg =~ /^kegg\|([^:]+):(\S+)$/)
    {
        return "<a href=http://www.genome.ad.jp/dbget-bin/www_bget?$1+$2>$kegg</a>";
    }
    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 = &FIG::cgi_url() . "/show_kegg_map.cgi?user=$user&map=$map&org=$org";
    my $link = "<a href=\"$url\">$map</a>";
    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="<input type=\"button\" name=\"CheckAll\" value=\"Check All\"\nonClick=\"checkAll(document.$form.$button)\">\n";
  $java_script.="<input type=\"button\" name=\"CheckFirst\" value=\"Check First Half\"\nonClick=\"checkFirst(document.$form.$button)\">\n";
  $java_script.="<input type=\"button\" name=\"CheckSecond\" value=\"Check Second Half\"\nonClick=\"checkSecond(document.$form.$button)\">\n";
  $java_script.="<input type=\"button\" name=\"UnCheckAll\" value=\"Uncheck All\"\nonClick=\"uncheckAll(document.$form.$button)\">\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 = "<a href=./subsys.cgi?ssa_name=$esc_sub&request=show_ssa&user=$user>$sub</a>";
    }
    else
    {
        $sub_link = $sub;
    }
    return $sub_link;
}

sub reaction_link {
    my($reaction) = @_;

    if ($reaction =~ /^R\d+/)
    {
	return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?rn+$reaction\" target=reaction$$>$reaction</a>";
    }
    return $reaction;
}

1

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3