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

View of /FigKernelPackages/SeedHTML.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (download) (as text) (annotate)
Sun Dec 13 01:17:19 2009 UTC (10 years, 5 months ago) by overbeek
Branch: MAIN
Changes since 1.1: +1 -3 lines
minimal HTML support

package SeedHTML;

########################### HTML Utilities ###########################


=head1 make_table

The main method to convert an array into a table.

The col_hdrs are set to the <th> 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. 

=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}\"" : "";
    my $class = defined $options{class} ? "class=\"$options{class}\"" : "";
    push( @tab, "\n<table $border $width $class>\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 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;
    Trace("Setting top link.") if T(3);
    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 <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")
    #     $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
    #
    Trace("Reading tail.") if T(3);
    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";
    }
    Trace("Extracting user name and header data.") if T(3);
    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
    #my $hdr_thing = $cgi->header(-cookie=>$cookie);
    my $hdr_thing = $cgi->header();
    Trace("Printing HTML header: $hdr_thing.") if T(3);
    print $hdr_thing;
    Trace("Header printed.") if T(3);
    #
    #  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;
    Trace("Processing special cases.") if T(3);
    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 )
    {
        Trace("Sanity checks in progress.") if T(3);
        if ( $html_line >= 0 )
        {
            if ( ( $head_line >= 0 ) && ( $html_line > $head_line ) )
            {
                Trace("<HTML> tag follows <HEAD> tag.") if T(1);
            }
            if ( ( $head_end_line >= 0 ) && ( $html_line > $head_end_line ) )
            {
                Trace("<HTML> tag follows </HEAD> tag.") if T(1);
            }
        }
        if ( $head_line >= 0 )
        {
            if ( ( $head_end_line >= 0 ) && ( $head_line > $head_end_line ) )
            {
                Trace("<HEAD> tag follows </HEAD> tag.") if T(1);
            }
        }
    }
    Trace("Sanity checks complete.") if T(3);
    #
    #  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;
        Trace("Splicing body line at $body_line.") if T(3);
        splice( @$html, $body_line, 0, "<BODY>\n" );
    }

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

    if (@html_hdr)
    {
        Trace("Splicing SEED page header after $body_line.") if T(3);
        splice( @$html, $body_line + 1, 0, @html_hdr );
    }

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

    if ( $head_end_line < 0 )
    {
        $head_end_line = $body_line;
        Trace("Splicing header terminater at $body_line.") if T(3);
        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'>
    Trace("Formatting CSS.") if T(3);
    # 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 = "<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";
    }

    $csstext   .= "<link rel='alternate'  title='SEED RSS feeds' href='Html/rss/SEED.rss' type='application/rss+xml'>\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.
    Trace("Formatting javascript.") if T(3);
    # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts
    push @$javasrc, "$FIG_Config::cgi_url/Html/css/FIG.js";
    foreach my $script (@$javasrc) {
        $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";
    }

    Trace("Re-splicing the header terminator at $head_end_line.") if T(3);
    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;
        #
        # RDO 2005-1006. Remove this so proxying works better.
        #
#        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;
        Trace("Splicing the HTML tag at $html_line.") if T(3);
        splice( @$html, $html_line, 0, "<HTML>\n" );
    }

    #
    #  <HEAD> goes after <HTML>
    #

    if ( $head_line < 0 )
    {
        $head_line = $html_line + 1;
        Trace("Splicing the HEAD tag at $head_line.") if T(3);
        splice( @$html, $head_line, 0, "<HEAD>\n" );
    }

    #
    #  Place FIG search link at bottom of page
    #
    Trace("Placing FIG search link.") if T(3);
    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).
    #
    Trace("Placing site tail.") if T(3);
    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 = ();
    Trace("Processing closing tags.") if T(3);
    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 )
    {
        Trace("Splicing tail.") if T(3);
        splice( @$html, $i, 0, @tail, @tags );
    }
    elsif ( @tags )
    {
        Trace("Splicing tags.") if T(3);
        splice( @$html, $i, 0, @tags );
    }

    Trace("Printing the HTML array.") if T(3);
    # 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)
    {
        my $line = $_;
        if (T(4)) {
            my $escapedLine = Tracer::Clean($line);
            Trace("Printing:\n$escapedLine") if T(4);
        }
        print $line;
    }

}

1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3