From 232701f1eb3b001e0d158f957f6d5deca5e84b33 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Andreas=20Kusalananda=20K=C3=A4h=C3=A4ri?=
<ak4@sanger.ac.uk>
Date: Thu, 3 Jul 2003 16:29:37 +0000
Subject: [PATCH] Guzzle, a stand-alone Perl-based DAS client.
---
misc-scripts/das_client/guzzle.README | 150 ++++++
misc-scripts/das_client/guzzle.pl | 740 ++++++++++++++++++++++++++
2 files changed, 890 insertions(+)
create mode 100644 misc-scripts/das_client/guzzle.README
create mode 100755 misc-scripts/das_client/guzzle.pl
diff --git a/misc-scripts/das_client/guzzle.README b/misc-scripts/das_client/guzzle.README
new file mode 100644
index 0000000000..02b087bbbe
--- /dev/null
+++ b/misc-scripts/das_client/guzzle.README
@@ -0,0 +1,150 @@
+ Guzzle
+
+ A STAND-ALONE PERL-BASED WEB DAS-CLIENT
+
+
+ Author:
+ Andreas Kähäri (EMBL-EBI/ensembl),
+ andreas.kahari@ebi.ac.uk
+
+
+
+ ABOUT
+
+ Guzzle consists of the "guzzle.pl" Perl script. It is a web based
+ client program that may be used to interface a distributed annotation
+ server (DAS). The name means "to eat or drink quickly, eagerly and
+ usually in large amounts" (Cambridge International Dictionary of
+ English). More information about DAS may be found at [1].
+
+ This particular client was developed at the EBI to be used with a
+ Dazzle server [2] or a Lightweight Distributed Annotation Server
+ (LDAS) [3] serving protein features, but there is really nothing
+ stopping it from being used as a more generic DAS client for LDAS or
+ Dazzle or any other server that serves data in a way that is
+ consistent with version 1.5 of the DAS protocol.
+
+
+ USAGE
+
+ So, what does Guzzle do then? When invoked as a CGI script by a web
+ browser, it will present a request page consisting of a number of
+ predefined DAS server sources (with the possibility of adding any
+ number of user-defined sources). Each source has a name and an URL
+ associated with it. The URL is equivalent to the DSN, the DAS Source
+ Name, of the source. In addition to this, there is also the
+ possibility to choose a colour to identify each source or to specify
+ that the colour should be taken from the DAS stylesheet of the source,
+ if it has one.
+
+ Once the DAS sources have been chosen, the ID of the sequence that
+ interests you may be entered together with an optional range. The
+ type of ID that should be used (SwissProt, Ensembl, or what have you)
+ depends entirely on the DAS sources that are being queried.
+
+ Once done, press the "GO" button.
+
+ The result page will contain a PNG image showing the tracks found in
+ the specified region on the sequence as colored boxes, followed by a
+ table containing the equivalent information. If link information was
+ retrieved from the DAS source, the table will contain the appropriate
+ links.
+
+ The descriptive labels on the features in the tracks may be turned off
+ by unchecking "Show descriptions on tracks". You are also be able
+ to sort the information in the table in various ways by using
+ the controls at the bottom of the page and clicking the "Update
+ display"-button.
+
+
+ CODE DEPENDENCIES
+
+ Although it was developed within the Ensembl project at the EBI and
+ Sanger institutes [4], the code does not depend on any pre-existing
+ Ensembl code, which hopefully makes it easy to install, to use, and to
+ modify.
+
+ The client does have dependencies on non-standard Perl modules. This
+ is a list of all modules that it depends on:
+
+ Bio::Das required
+ CGI required
+
+ Bio::Graphics required for graphics (optional)
+ Bio::SeqFeature::Generic required for graphics (optional)
+ File::Temp required for graphics (optional)
+
+ LWP::UserAgent required for faking
+ stylesheets (optional)
+
+ Data::Serializer required for being nice
+ to DAS servers (optional)
+
+ Most of these Perl modules have additional dependencies in themselves
+ (e.g. the Bio::Graphics module depends on the Perl GD module etc.),
+ but they are all available through CPAN.
+
+
+ INSTALLATION
+
+ Make sure that all dependencies are met (see above) and copy the
+ guzzle.pl script into the cgi-bin directory of a web server. Make
+ sure the script has the right permissions (executable). Configure the
+ client before running for the first time (see below).
+
+
+ CONFIGURATION
+
+ Guzzle is configured by changing the definition of a set of variables
+ in the head of the guzzle.pl script file itself. The comments in the
+ script should be descriptive enough for most configurational things.
+
+ You have the option to turn certain features on or off. These
+ features are the graphics, the "being nice to DAS servers" feature,
+ and the stylesheet feature. Turning features off removes dependencies
+ on some Perl modules.
+
+ Turning the graphics feature off will inhibit the creation of
+ temporary PNG files (which otherwise would need to be cleaned out with
+ a cron-job or something similar). There will be no graphical view of
+ the tracks on the result page.
+
+ The "being nice to DAS servers" feature is a feature that ensures that
+ the DAS servers will only be queried once. Without it, the servers
+ will be queried for features and stylesheets whenever the user presses
+ the "GO" or "Update display" buttons. With the feature, the responses
+ from the DAS servers are serialized, compressed, and stored as a
+ string in a hidden field on the result page.
+
+ Turning off the stylesheet feature will prevent the client from ever
+ asking the DAS server for stylesheet information.
+
+
+ BUGS
+
+ The DAS stylesheet support is a hack. The Bio::Das modules from CPAN
+ does not contain the implementation of the Bio::Das::Stylesheet
+ module. Rather than building the client around a version of the
+ Bio::Das modules that can only be found on a CVS server, I decided to
+ fake the stylesheet support of the client using LWP::UserAgent. This
+ hack simply picks up the *first* encountered foreground color from the
+ reply to a stylesheet request. I do not currently use glyphs or other
+ things specified in the stylesheet of a DAS source.
+
+ The generated graphics isn't beautiful.
+
+ Better suggestion for names are welcomed.
+
+
+ TO DO
+
+ Sequence ID translation and annotation mapping. Watch this space, I'm
+ working on it.
+
+
+ REFERENCES
+
+ [1] http://www.biodas/org/
+ [2] http://www.biojava.org/dazzle/
+ [3] http://www.biodas.org/servers/
+ [4] http://www.ensembl.org/
diff --git a/misc-scripts/das_client/guzzle.pl b/misc-scripts/das_client/guzzle.pl
new file mode 100755
index 0000000000..c8f4312fa4
--- /dev/null
+++ b/misc-scripts/das_client/guzzle.pl
@@ -0,0 +1,740 @@
+#!/usr/bin/perl
+
+# $Id$
+#
+# GUZZLE
+#
+# A STAND-ALONE PERL-BASED WEB DAS-CLIENT
+#
+#
+# Author: Andreas Kähäri (EMBL-EBI/ensembl),
+# andreas.kahari@ebi.ac.uk
+
+use strict;
+use warnings;
+
+# Whereever you keep non-standard modules
+use lib qw(/opt/local/libdata/perl5/i386-openbsd/5.8.0
+ /opt/local/libdata/perl5
+ /opt/local/libdata/perl5/site_perl/i386-openbsd
+ /opt/local/libdata/perl5/site_perl);
+
+use Bio::Das;
+use CGI::Pretty qw(:standard -compile);
+
+#use Data::Dumper;
+
+#---------------------------------------------------------------
+# Configurable things (change these):
+
+# $contact:
+# Who's responsible for this thing (webmaster or similar).
+#
+my $contact = 'Yours Truly<br>yt@some.place';
+
+# $htdocs:
+# Where the web server looks when someone requests the web
+# server root ('/') URL.
+#
+my $htdocs = '/var/www/htdocs';
+
+# $tmpurl:
+# The URL to the directory which hold the generated images.
+#
+my $tmpurl = '/guzzle_tmp';
+
+# $tmpdir:
+# Where the directory of $tmpurl is located on the system.
+# MAKE SURE THIS DIRECTORY EXISTS AND THAT IT IS WRITABLE AND
+# EXECUTABLE BY THE WEB SERVER USER!
+#
+my $tmpdir = $htdocs . $tmpurl;
+
+# $query_page_title and $result_page_title:
+# These holds the title stings for the two pages.
+#
+my $query_page_title = 'Guzzle query page';
+my $result_page_title = 'Guzzle result page';
+
+# @presets:
+# The DSN's to present by default on the query page. A DSN with
+# a non-zero CHECKED field will be checked (used/queried) by
+# default.
+#
+my @presets = (
+ { NAME => 'Pfam-A (test)',
+ DSN => 'http://uhuru/cgi-bin/das/pfam',
+ CHECKED => 1 },
+ { NAME => 'Sprot (test)',
+ DSN => 'http://uhuru/cgi-bin/das/sprot',
+ CHECKED => 1 } );
+
+# $nblanks:
+# The number of blank/empty fields to present on the query page
+# by default.
+#
+my $nblanks = 1;
+
+# @colours:
+# The colours that the user should be able to
+# choose from. Must be "named colors", see e.g.
+# "http://webdesign.about.com/library/bl_namedcolors.htm".
+#
+my @colours = qw( red green blue magenta cyan yellow gray black );
+
+# $stylesheet:
+# A CSS stylesheet that will be included in every generated web
+# page.
+#
+my $stylesheet = <<EOT;
+body {
+ color: #000;
+ background: #6a6;
+ margin: 5%;
+ font-family: helvetica, arial, sans-serif;
+}
+td {
+ font-size: x-small;
+}
+h1 {
+ font-family: helvetica, arial, sans-serif;
+}
+address {
+ font-family: times, serif;
+ color: #666;
+ font-size: small;
+}
+tt {
+ font-family: courier, monospace;
+}
+.thetable {
+ background: #9c9;
+}
+EOT
+
+#
+# OPTIONAL FEATURES
+#
+
+# $use_stylesheets
+# Whether to try to make use of the DAS stylesheets or not
+# (non-zero is "yes").
+#
+my $use_stylesheets = 1;
+
+# $be_nice
+# Whether to be nice to DAS servers or not.
+#
+my $be_nice = 1;
+
+# $use_graphics
+# Whether to generate and use graphics ro not.
+#
+my $use_graphics = 1;
+
+
+# No servicable parts inside...
+#---------------------------------------------------------------
+
+if ($use_stylesheets) {
+ require LWP::UserAgent;
+}
+
+if ($be_nice) {
+ require Data::Serializer;
+}
+
+if ($use_graphics) {
+ require Bio::Graphics;
+ require Bio::SeqFeature::Generic;
+
+ require File::Temp;
+ import File::Temp 'tempfile';
+}
+
+#---------------------------------------------------------------
+
+# page_start_and_head():
+# Will create the head of a HTML page with the CSS stylesheet
+# from above ($stylesheet) and a H1 header with the page title.
+#
+sub page_start_and_head
+{
+ my $cgi = shift;
+ my $title = shift;
+
+ print $cgi->header( -expires => 'now' );
+
+ print $cgi->start_html(
+ -title => $title,
+ -style => $stylesheet);
+
+ print $cgi->h1({ style => 'text-align:center' }, $title);
+}
+
+# page_foot_and_end():
+# Will put the contact address in the page footer and then
+# close/finish the page.
+#
+sub page_foot_and_end
+{
+ my $cgi = shift;
+
+ print $cgi->hr, $cgi->address($contact), $cgi->end_html;
+}
+
+#---------------------------------------------------------------
+
+# create_graphics():
+# Given the array of structures created in result_page(), will
+# create a PNG image and return its URL.
+#
+sub create_graphics
+{
+ my $table = shift; # "Table" since it's the data that goes
+ # into the table on the result page.
+
+ my $do_descr = shift; # Whether to include the descriptions
+ # on each feature in the graph or not.
+
+ my $minpos = $table->[0]{FEATURE}->start;
+ my $maxpos = $table->[0]{FEATURE}->stop;
+
+ my $full_seq;
+ my %all;
+ foreach my $table_row (@{ $table }) {
+ my $feature = $table_row->{FEATURE};
+
+ if ($minpos > $feature->start) {
+ $minpos = $feature->start;
+ }
+ if ($maxpos < $feature->stop) {
+ $maxpos = $feature->stop;
+ }
+
+ my $tag = $table_row->{COLUMNS}[0];
+ my $source = $table_row->{COLUMNS}[1];
+
+ if ($feature->group =~ /^Sequence:/) {
+ if (!defined $full_seq) {
+ $full_seq = new Bio::SeqFeature::Generic(
+ -start => $feature->start,
+ -end => $feature->end );
+ }
+ } else {
+ push(@{ $all{$source}->{$tag} },
+ new Bio::SeqFeature::Generic(
+ -start => $feature->start,
+ -end => $feature->end,
+ -primary => $feature->group,
+ -source_tag => $feature->type->label,
+ -tag => {
+ colour => $table_row->{COLOUR}
+ } ));
+ }
+ }
+
+ my $panel = new Bio::Graphics::Panel(
+ -start => $minpos,
+ -stop => $maxpos,
+ -grid => 1,
+ -key_style => 'between',
+ -pad_left => 10,
+ -pad_right => 100,
+ -pad_top => 10,
+ -pad_bottom => 10);
+
+ my $full_length = new Bio::SeqFeature::Generic(
+ -start => $minpos,
+ -end => $maxpos);
+
+ # Add a nice arrow at the top of the image.
+ $panel->add_track($full_length,
+ -glyph => 'arrow',
+ -tick => 2,
+ -fgcolor => 'black',
+ -double => 1);
+
+ # (don't show the track for the whole sequence, it's not
+ # interesting)
+ #if (defined $full_seq) {
+ #$panel->add_track($full_seq);
+ #}
+
+ # Populate the panel.
+ foreach my $source (values %all) {
+ foreach my $tag (keys %{ $source }) {
+ if (defined $do_descr) {
+ $panel->add_track($source->{$tag},
+ -key => $tag,
+ -description => sub { $_[0]->source_tag },
+ -bgcolor => $source->{$tag}[0]->_tag_value('colour'),
+ -font2color => 'black' );
+ } else {
+ $panel->add_track($source->{$tag},
+ -key => $tag,
+ -bgcolor => $source->{$tag}[0]->_tag_value('colour'));
+ }
+ }
+ }
+
+ # Get a handle of a temporary (persistent) file.
+ my ($tmpfh, $tmpname) = tempfile('pdas_XXXXX',
+ UNLINK => 0,
+ SUFFIX => '.png',
+ DIR => $tmpdir);
+
+ # Dump the image data into the file.
+ syswrite($tmpfh, $panel->png);
+
+ # Make the image file readable for web clients.
+ chmod(0644, $tmpname);
+
+ $tmpname =~ s#.*/##; # Does a 'basename' operation.
+
+ return $tmpurl . '/' . $tmpname;
+}
+
+#---------------------------------------------------------------
+
+# query_page():
+# Creates the page with the query form.
+#
+sub query_page
+{
+ my $cgi = shift;
+
+ if (defined $cgi->param('COUNT')) {
+ # We've been here before, so figure out how many blank
+ # lines we should display.
+ $nblanks = $cgi->param('COUNT') - scalar(@presets);
+ }
+
+ if (defined $cgi->param('INCR')) {
+ # User wants to insert more blank lines.
+ ++$nblanks;
+ } elsif (defined $cgi->param('DECR')) {
+ # User wants to remove blank lines.
+ --$nblanks;
+ }
+
+ $nblanks = 0 if ($nblanks < 0);
+
+ page_start_and_head($cgi, $query_page_title);
+
+ $cgi->delete_all;
+
+ print $cgi->start_form;
+
+ print $cgi->start_table({
+ -class => 'thetable',
+ -border => '0',
+ -cellpadding => '2',
+ -cellspacing => '2',
+ -align => 'center' });
+ if ($use_stylesheets) {
+ print $cgi->Tr($cgi->th( [ qw( Use Name URL Colour ),
+ '... or Stylesheet' ] ));
+ }
+
+ my $count = 0;
+ foreach my $preset (@presets) {
+ print $cgi->Tr($cgi->td( { -align => 'center' },
+ $cgi->checkbox(
+ -name => 'USE',
+ -value => $count,
+ -checked => $preset->{CHECKED},
+ -label => '')),
+ $cgi->td( [
+ $preset->{NAME},
+ $preset->{DSN},
+ $cgi->popup_menu(
+ -name => 'COLOUR',
+ -values => \@colours,
+ -default => $colours[$count % scalar @colours])
+ ]),
+ ($use_stylesheets ?
+ $cgi->td( { -align => 'center' },
+ $cgi->checkbox(
+ -name => 'STYLE',
+ -value => $count,
+ -checked => '1',
+ -label => '' )) : '' ) ); # That wasn't pretty...
+ print $cgi->hidden(
+ -name => 'NAME',
+ -value => $preset->{NAME});
+ print $cgi->hidden(
+ -name => 'DSN',
+ -value => $preset->{DSN});
+ ++$count;
+ }
+
+ for (my $i = 0; $i < $nblanks; ++$i) {
+ print $cgi->Tr($cgi->td( { -align => 'center' },
+ $cgi->checkbox(
+ -name => 'USE',
+ -value => $count,
+ -checked => '0',
+ -label => '')),
+ $cgi->td( [
+ $cgi->textfield(
+ -name => 'NAME',
+ -size => '10',
+ -default => 'Source #' . (1 + $count)),
+ $cgi->textfield(
+ -name => 'DSN',
+ -size => '50'),
+ $cgi->popup_menu(
+ -name => 'COLOUR',
+ -values => \@colours,
+ -default => $colours[$count % scalar @colours])
+ ] ),
+ ($use_stylesheets ?
+ $cgi->td( { -align => 'center' },
+ $cgi->checkbox(
+ -name => 'STYLE',
+ -value => $count,
+ -checked => '0',
+ -label => '' )) : '' ) ); # Stylish? No...
+ ++$count;
+ }
+ print $cgi->Tr($cgi->td( [ ' ', ' ',
+ $cgi->submit(
+ -name => 'INCR',
+ -value => 'More blank fields') . ' ' .
+ $cgi->submit(
+ -name => 'DECR',
+ -value => 'Fewer blank fields'), ' ',
+ ($use_stylesheets ? ' ' : '') ] ));
+
+ print $cgi->hidden(
+ -name => 'COUNT',
+ -value => $count);
+ print $cgi->hidden(
+ -name => 'DESCR',
+ -value => 1);
+
+ print $cgi->Tr($cgi->th(
+ { -colspan => '2', -align => 'right' }, 'Sequence ID'),
+ $cgi->td({ -colspan => '2' }, $cgi->textfield(
+ -name => 'ID',
+ -size => '25',
+ -default => 'FLNA_HUMAN') ),
+ ($use_stylesheets ? $cgi->td(' ') : ''));
+
+
+ print $cgi->Tr($cgi->th(
+ { -colspan => '2', -align => 'right' }, 'Range'),
+ $cgi->td($cgi->textfield(
+ -name => 'START',
+ -size => '5') . ' to ' .
+ $cgi->textfield(
+ -name => 'STOP',
+ -size => '5')),
+ $cgi->td({ -align => 'center',
+ -colspan => ($use_stylesheets ? '2' : '1') },
+ $cgi->submit( -name => 'GO', -value => ' Go ' ) ));
+
+ print $cgi->end_table, $cgi->end_form;
+
+ page_foot_and_end($cgi);
+}
+
+#---------------------------------------------------------------
+
+# result_page():
+# Queries the DAS server, generates the graphics, and creates
+# the result page.
+#
+sub result_page
+{
+ my $cgi = shift;
+
+ my $cereal;
+ if ($be_nice) {
+ # Create a serialization/deserialization object
+ # ($cereal) that we use to embed the results from the
+ # query in a variable (RESULT) in the form on the result
+ # page. This means that if the user wants to re-sort
+ # the result, we won't need to query the DAS server
+ # again.
+
+ $cereal = new Data::Serializer(
+ serializer => 'Storable',
+ compress => 1,
+ portable => 1);
+ }
+
+ page_start_and_head($cgi, $result_page_title);
+
+ my $table = [ ];
+ if (!defined $cgi->param('RESULTS') || !$be_nice) {
+ # The results are fetched from the DAS server.
+
+ my @sources;
+ foreach my $idx ($cgi->param('USE')) {
+ my %source = (
+ NAME => [ $cgi->param('NAME') ]->[$idx],
+ DSN => [ $cgi->param('DSN') ]->[$idx],
+ COLOUR => [ $cgi->param('COLOUR') ]->[$idx],
+ USESTYLE => [ $cgi->param('STYLE') ]->[$idx] );
+
+ $source{DSN} =~ s/\s//g;
+ next unless (length $source{DSN} > 0);
+
+ push(@sources, \%source);
+ }
+
+ my $start = $cgi->param('START') || undef;
+ my $stop = $cgi->param('STOP') || undef;
+ my $segment;
+
+ if (defined $start && defined $stop) {
+ $segment = $cgi->param('ID') . ':' . $start . ',' . $stop;
+ } else {
+ $segment = $cgi->param('ID');
+ }
+
+ my @query;
+ foreach my $source (@sources) {
+ push(@query, $source->{DSN} . '/features?segment=' . $segment);
+ }
+
+ my $das = new Bio::Das(15);
+
+ my @replies = $das->features(
+ -dsn => \@query,
+ -segment => $segment);
+
+ foreach my $reply (@replies) {
+ next unless ($reply->is_success && defined $reply->results);
+
+ my $source_url = $reply->dsn->base;
+ if (defined $reply->dsn->id) {
+ $source_url .= '/' . $reply->dsn->id;
+ }
+ $source_url =~ s/\/features\?.*//;
+
+ foreach my $source (@sources) {
+ next if ($source_url ne $source->{DSN});
+
+ # FIXME: This is a quick'n dirty hack to work
+ # around the non-existant Bio::Das::Stylesheet
+ # module (in the CPAN distribution of the
+ # Bio::Das modules, as of 2003-05-08). It will
+ # pick up and use the *first* FGCOLOR from the
+ # stylesheet, if one exists.
+
+ if ($use_stylesheets && defined $source->{USESTYLE}) {
+ my $ua = new LWP::UserAgent;
+ my $response = $ua->get($source_url . '/stylesheet');
+ if ($response->is_success) {
+ my $headers = $response->headers;
+ if ($headers->header('x-das-status') == 200) {
+ $response->content =~ m#<FGCOLOR>(\w+)</FGCOLOR>#;
+ $source->{COLOUR} = $1 if (defined $1);
+ }
+ }
+ }
+
+ foreach my $feature ($reply->results) {
+ my %table_row = (
+ COLUMNS => [
+ $feature->group, # Label
+ $source->{NAME}, # Source
+ $feature->type->label, # Description
+ $feature->start, # Start
+ $feature->stop ], # Stop
+ FEATURE => $feature, # Yes, this will duplicate
+ # some of the data...
+ COLOUR => $source->{COLOUR} );
+ push(@{ $table }, \%table_row);
+ }
+ last;
+ }
+ }
+ } else {
+ # The results are picked up from the encoded string,
+ # not from any DAS server. Hopefully this works
+ # everywhere...
+
+ $table = $cereal->deserialize($cgi->param('RESULTS'));
+ }
+
+ print $cgi->start_form;
+
+ my $sort1;
+ my $sort2;
+
+ if (defined $cgi->param('SORT1')) {
+ $sort1 = $cgi->param('SORT1');
+ $sort2 = $cgi->param('SORT2');
+ } else {
+ $sort1 = 1;
+ $sort2 = 3;
+ }
+
+ # Sorting. Must distinguish between the numerical and the
+ # non-numerical columns (the last few ones and the first few
+ # ones, respectively).
+
+ if ($sort1 <= 2) {
+ if ($sort2 <= 2) {
+ $table = [ sort {
+ $a->{COLUMNS}[$sort1] cmp
+ $b->{COLUMNS}[$sort1] ||
+ $a->{COLUMNS}[$sort2] cmp
+ $b->{COLUMNS}[$sort2] } @{ $table } ];
+ } else {
+ $table = [ sort {
+ $a->{COLUMNS}[$sort1] cmp
+ $b->{COLUMNS}[$sort1] ||
+ $a->{COLUMNS}[$sort2] <=>
+ $b->{COLUMNS}[$sort2] } @{ $table } ];
+ }
+ } else {
+ if ($sort2 <= 2) {
+ $table = [ sort {
+ $a->{COLUMNS}[$sort1] <=>
+ $b->{COLUMNS}[$sort1] ||
+ $a->{COLUMNS}[$sort2] cmp
+ $b->{COLUMNS}[$sort2] } @{ $table } ];
+ } else {
+ $table = [ sort {
+ $a->{COLUMNS}[$sort1] <=>
+ $b->{COLUMNS}[$sort1] ||
+ $a->{COLUMNS}[$sort2] <=>
+ $b->{COLUMNS}[$sort2] } @{ $table } ];
+ }
+ }
+
+
+ if ($be_nice) {
+ # Embed the results for fast re-sort.
+
+ $cgi->autoEscape(0);
+ print $cgi->hidden(
+ -name => 'RESULTS',
+ -value => $cereal->serialize($table));
+ $cgi->autoEscape(1);
+ } else {
+ # Save the state from the query page.
+ print $cgi->hidden(
+ -name => 'USE',
+ -value => $cgi->param('USE') );
+ print $cgi->hidden(
+ -name => 'NAME',
+ -value => $cgi->param('NAME') );
+ print $cgi->hidden(
+ -name => 'DSN',
+ -value => $cgi->param('DSN') );
+ print $cgi->hidden(
+ -name => 'COLOUR',
+ -value => $cgi->param('COLOUR') );
+ print $cgi->hidden(
+ -name => 'STYLE',
+ -value => $cgi->param('STYLE') );
+ print $cgi->hidden(
+ -name => 'START',
+ -value => $cgi->param('START') );
+ print $cgi->hidden(
+ -name => 'STOP',
+ -value => $cgi->param('STOP') );
+ print $cgi->hidden(
+ -name => 'ID',
+ -value => $cgi->param('ID') );
+ }
+
+ print $cgi->start_table({
+ -class => 'thetable',
+ -border => '0',
+ -cellpadding => '2',
+ -cellspacing => '2',
+ -align => 'center' });
+
+ if ($use_graphics) {
+ my $imgsrc = create_graphics($table, $cgi->param('DESCR'));
+
+ print $cgi->Tr($cgi->td( { -colspan => '6', -align => 'center' },
+ $cgi->img({ -src => $imgsrc, -alt => 'Result (PNG)' }),
+ $cgi->p({ -style => 'text-align:right' },
+ $cgi->checkbox(
+ -name => 'DESCR',
+ -value => 1,
+ -checked => 1,
+ -label => ' Show descriptions on tracks' ),
+ $cgi->br,
+ $cgi->submit( -name => 'GO', -value => 'Update display' )),
+ $cgi->p(' ')
+ ));
+ }
+
+ print $cgi->Tr($cgi->th( [
+ qw( Label Source Description Start Stop ) ] ));
+
+ foreach my $table_row (@{ $table }) {
+ # Don't display the full sequence reply (good/bad?)
+ next if ($table_row->{COLUMNS}[0] =~ /^Sequence:/);
+
+ # Make the first column the link.
+ $table_row->{COLUMNS}[0] = $cgi->a({
+ -href => $table_row->{FEATURE}->link },
+ $table_row->{COLUMNS}[0]);
+
+ print $cgi->Tr($cgi->td( {
+ -style => 'background:' . $table_row->{COLOUR} }, ' ' ),
+ $cgi->td($table_row->{COLUMNS}));
+ }
+
+ print $cgi->Tr($cgi->td({ -colspan => 6 }, ' ' ));
+ print $cgi->Tr($cgi->th({ -colspan => 6 }, 'Sorting' ));
+
+ $cgi->autoEscape(0);
+ print $cgi->Tr($cgi->td({ -colspan => 2, -align => 'right' },
+ 'First sort on '),
+ $cgi->td({ -colspan => 2 },
+ $cgi->radio_group(
+ -name => 'SORT1',
+ -values => [ 0, 1, 2, 3, 4 ],
+ -labels => {
+ 0 => ' Label',
+ 1 => ' Source',
+ 2 => ' Description',
+ 3 => ' Start',
+ 4 => ' Stop' },
+ -default => 1 ) ),
+ $cgi->td({
+ -rowspan => 2,
+ -colspan => 2,
+ -align => 'center',
+ -valign => 'center' },
+ $cgi->submit( -name => 'GO', -value => 'Update display' ) ));
+
+ print $cgi->Tr($cgi->td({ -colspan => 2, -align => 'right' },
+ 'Then sort on '),
+ $cgi->td({ -colspan => 2 },
+ $cgi->radio_group(
+ -name => 'SORT2',
+ -values => [ 0, 1, 2, 3, 4 ],
+ -labels => {
+ 0 => ' Label',
+ 1 => ' Source',
+ 2 => ' Description',
+ 3 => ' Start',
+ 4 => ' Stop' },
+ -default => 3 ) ));
+ $cgi->autoEscape(1);
+ print $cgi->end_table, $cgi->end_form;
+
+ page_foot_and_end($cgi);
+}
+
+#---------------------------------------------------------------
+
+my $cgi = new CGI;
+
+if (defined $cgi->param('GO')) {
+ result_page($cgi);
+} else {
+ query_page($cgi);
+}
--
GitLab