HTML::SearchPage - Generic framework for building web-based search pages
Index
Code Index:
NAME
HTML::SearchPage - Generic framework for building web-based search pages
SYNOPSIS
Please refer to HTML::SearchPage::Tutorial for a tutorial on using HTML::SearchPage & HTML::SearchPage::Param.
DESCRIPTION
This module provides a generic framework for building web-based search pages.
USAGE
Please refer to HTML::SearchPage::Tutorial for a tutorial on using HTML::SearchPage & HTML::SearchPage::Param.
QUICK REFERENCE
All the parameters listed below have a get/set method. However, the set
functionality of the params in the 3rd group is not intended to be
utilized except for development.
Group 1 - Parameters required by the constructor
The following parameters are required by the constructor.
Parameter Description Format
--------- ----------- ------
db_access_params Database access parameters [$datasource, $user,
$password]
temp_dir Temporary directory to store images scalar scalar
and session files
temp_dir_eq URL-equivalent to access files in temp_dir scalar
base_sql_table Base SQL table (or table join) to build final scalar
SQL queries
base_sql_fields Fields that will be retrieved by the SQL arrayref
statement
base_output_headers Headers output in results arrayref
base_identifier Unique identifier column used by display_info scalar
method (* required only when display_info
method is used)
Group 2 - Optional parameters
The following parameters are optional.
Parameter Description Format Default
--------- ----------- ------ -------
page_title Page title scalar 'Search
Page'
header HTML header in views scalar(i) ''
footer HTML footer in views scalar(i) ''
cookie Name of cookie scalar html-searchpage
cookie_expires_in_min Expiration tim eof cookie scalar 30
(number)
css CSS for views scalar(i) ''
instructions Instructions for views scalar(i) ''
distinct Make SQL query "distinct" 0|1 0
no_reset No reset button 0|1 0
new_search Place a new search button, 0|<URL> 0
(implies no_reset)
group_by Group by statement scalar ''
(exclude
GROUP BY)
sort_fields Number of sort fields scalar 0
(number)
sort_defaults Default sort options arrayref(ii) []
method HTML form method to use GET|POST GET
action HTML URL to script scalar $ENV{SCRIPT_NAME}
page_size Number of records per scalar 50
result page (number)
show_search_url Whether to display a
self-referencing search URL 0|1 0
debug_level Level of debug information: 0|1|2(iii) 0
go_to_results If set, a click on the page 0|1 1
will take the display to the
beginning of the results
on the subsequent page
modifier The page modifier object ref undef
external_where_clauses External where clauses arrayref []
Notes:
(i) The parameter provided here can be of the following types, specified by the preceding keyword:
- FILE:<something> : Contents of file <something> is retrieved
- EXEC:<something> : <something> is executed and its STDOUT is retrieved
- GET:<something> : URL <something> is retrieved by LWP
- <something> : <something> is used as it is
(ii) Format for sort defaults:
["(asc|desc) <field>", "(asc|desc) <field>", "(asc|desc) <field>"]
(iii) Debug levels:
- 0: No debug information
- 1: Time, URL, version information of critical code components, generated SQL statements
- 2: In addition to (1), environment variables
Group 3 - Internal methods
The following parameters are set automatically but they can be
get/set after object instantiation.
Parameter Description Format
--------- ----------- ------
cgi CGI object CGI ref
cgi_params CGI params hashref
count Retrieved data count scalar
count_sql_statement Generated SQL statement for scalar
retrieving count of results
data Retrieved data arrayref (each element is
an arrayref of a row)
debug_info HTML code for retrieved debug scalar
info based on debug level
db_display Display name for the database scalar
in effect
dbh Database handle DBI ref
db_selected Database specified using the scalar
database param in the URL
formatted_data HTML code or text for of data scalar
formatted based on output
format
modifications Scheduled modifications arrayref
param_fields Stored HTML::SearchPage::Param hashref
objects
query_sql_statement Generated SQL statement for scalar
retrieving results
search_form HTML code for generated search scalar
form
session Session object CGI::Session ref
session_id Session id scalar
super_output_headers Headers and super hashref
headers
OTHER
"db_access_params" can be specified in two forms:
The following format is used when there is only one database that the page will be running on.
db_access_params => [$datasource, $username, $password];
Alternatively, a set of databases can be specified and can be addressed by "database=<alias>" URL parameter.
db_access_params => {
database => [
{
alias => $alias,
display => 'Database 1',
datasource => $datasource2,
username => $username2,
password => $password2,
},
{
alias => $alias,
display => 'Database 2',
datasource => $datasource2,
username => $username2,
password => $password2,
},
],
}
When multiple databases are provided, database selection is persistent between pages that use HTML::SearchPage. This feature requires cookies to be enabled.
AUTHOR
Payan Canaran <pcanaran@cpan.org>
BUGS
VERSION
ACKNOWLEDGEMENTS
This module has been initially written for implementing search pages for displaying maize diversity data on Panzea (www.panzea.org), the public web site of the "Molecular and Functional Diversity of the Maize Genome" project. Thanks to project members for their feedback on user features and help in testing the web displays.
COPYRIGHT & LICENSE
Copyright (c) 2005-2007 Cold Spring Harbor Laboratory
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself. See DISCLAIMER.txt for
disclaimers of warranty.
package HTML::SearchPage;
our $VERSION = '0.05';
# $Id: SearchPage.pm,v 1.24 2007/09/19 21:30:18 canaran Exp $
use warnings;
use strict;
use HTML::SearchPage::Files;
use Carp;
use CGI;
use CGI::Session;
use DBI;
use List::Util qw(first);
use LWP::Simple;
use Spreadsheet::WriteExcel;
use Tie::IxHash;
use Time::Format qw(%time);
###############
# CONSTRUCTOR #
###############
sub new {
my ($class, %raw_params) = @_;
# Remove dashes from param names
my %params = map {
my $key = $_;
my $value = $raw_params{$key};
$key =~ s/^-//;
$key => $value;
} keys %raw_params;
my $self = bless {}, $class;
eval {
# CGI obj created initially
my $cgi = CGI->new;
$self->cgi($cgi);
my $cgi_params = $self->cgi->Vars;
$self->cgi_params($cgi_params);
# Temp dir
$params{temp_dir} or croak("A temp_dir param is required!");
$self->temp_dir($params{temp_dir});
$params{temp_dir_eq} or croak("A temp_dir_eq param is required!");
$self->temp_dir_eq($params{temp_dir_eq});
# Cookie params
my $cookie =
defined $params{cookie} ? $params{cookie} : 'html-searchpage';
$self->cookie($cookie);
my $cookie_expires_in_min =
defined $params{cookie_expires_in_min}
? $params{cookie_expires_in_min}
: 30;
$self->cookie_expires_in_min($cookie_expires_in_min);
# Session id from URL/cookie
my $session_id =
$self->cgi_params->{session_id}
|| $self->cgi->cookie($self->cookie)
|| undef;
my $session_dir = $self->temp_dir . '/sessions';
my $session =
CGI::Session->new('file', $session_id, {Directory => $session_dir});
# Session id may change at this step
$self->session_id($session->id);
$self->session($session);
# Required params
$params{db_access_params} or croak("A db_access_params is required!");
$self->db_access_params($params{db_access_params});
$params{temp_dir} or croak("A temp_dir param is required!");
$self->temp_dir($params{temp_dir});
$params{temp_dir_eq} or croak("A temp_dir_eq param is required!");
$self->temp_dir_eq($params{temp_dir_eq});
$params{base_sql_table} or croak("A base_sql_table is required!");
$self->base_sql_table($params{base_sql_table});
$params{base_sql_fields} or croak("A base_sql_fields is required!");
$self->base_sql_fields($params{base_sql_fields});
$params{base_output_headers}
or croak("A base_output_headers is required!");
$self->base_output_headers($params{base_output_headers});
# Create image files
HTML::SearchPage::Files->new(temp_dir => $self->temp_dir);
# Required param for only display_info
$self->base_identifier($params{base_identifier});
# Optional params
my $page_title =
defined $params{page_title} ? $params{page_title} : 'Search Page';
$self->page_title($page_title);
$self->header($params{header});
$self->footer($params{footer});
$self->css($params{css});
$self->instructions($params{instructions});
$self->distinct($params{distinct});
$self->no_reset($params{no_reset});
$self->new_search($params{new_search});
$self->group_by($params{group_by});
$self->sort_fields($params{sort_fields});
$self->sort_defaults($params{sort_defaults});
my $method = defined $params{method} ? $params{method} : 'GET';
$self->method($method);
unless ($method eq 'GET' or $method eq 'POST') {
croak("Invalid method ($method)!");
}
my $action =
defined $params{action} ? $params{action} : $ENV{SCRIPT_NAME};
$self->action($action);
my $page_size = defined $params{page_size} ? $params{page_size} : 50;
$self->page_size($page_size);
$self->show_search_url($params{show_search_url});
$self->debug_level($params{debug_level});
my $go_to_results =
defined $params{go_to_results} ? $params{go_to_results} : 1;
$self->go_to_results($go_to_results);
$self->modifier($params{modifier});
$self->external_where_clauses($params{external_where_clauses});
# If reset, empty cgi_params
if ($self->cgi_params->{reset}) {
$self->cgi_params({});
}
# If new search, redirect
if ($self->cgi_params->{new_search}) {
my $url = "http://" . $ENV{HTTP_HOST} . $self->new_search;
print $self->cgi->redirect($url);
exit 0;
}
# Calculate super headers
$self->_calculate_super_headers();
# Validate cgi params
$self->_validate_cgi_params();
# Create db_handle from db_access_params
my $db_access_params = $self->db_access_params;
# -- Re-format if a single db is entered
if ( ref($db_access_params)
and ref($db_access_params) eq 'ARRAY') {
my ($datasource, $username, $password) = @$db_access_params;
my $db_access_params = {
database => [
{ alias => 'default',
display => 'Default Database',
datasource => $datasource,
username => $username,
password => $password,
}
]
};
}
$self->db_access_params($db_access_params);
# -- Extract params
my $database =
$self->cgi_params->{database}
|| $self->session->param('db_selected');
my @available_databases = ( ref $db_access_params->{database}
&& ref $db_access_params->{database} eq 'ARRAY')
? @{$db_access_params->{database}}
: ($db_access_params->{database});
unless (@available_databases) {
croak("No database specified!");
}
if (!$database) {
$database = $available_databases[0]->{alias};
}
my $selected_db =
first { $_->{alias} eq $database } @available_databases;
if (!defined($selected_db)) {
croak("Cannot determine database ($database)!");
}
my $dbh = DBI->connect(
$selected_db->{datasource},
$selected_db->{username}, $selected_db->{password},
{PrintError => 1, RaiseError => 1}
) || croak("Cannot connect to database!");
$self->dbh($dbh);
$self->db_selected($database);
$self->db_display($selected_db->{display});
$self->session->param('db_selected', $database);
# Adjust URL if "go_to_results"
if ($self->go_to_results) {
my $action = $self->action;
$self->action("$action#results");
}
# Create an empty param_fields container
$self->{param_fields} = {};
# Create an empty modifications container
$self->{modifications} = [];
};
$self->display_error_page($@) if $@;
return $self;
}
##################
# PUBLIC METHODS #
##################
# Function : Adds/retrieves param_field.
# Arguments : $id [$ParamField_object]
# Returns : $ParamField_object
# Notes : None specified.
sub param_field {
my ($self, $id, $value) = @_;
if (defined $value) {
croak(
"A HTML::SearchPage::Param object is needed to add param_field!")
unless ref $value eq 'HTML::SearchPage::Param';
my $max = 0;
foreach (keys %{$self->param_fields}) {
my $pf = $self->param_fields->{$_};
$max = $pf->rank if $pf->rank > $max;
}
$value->rank(++$max);
$self->param_fields->{$id} = $value;
}
croak("This param_field ($id) does not exist!")
unless exists $self->param_fields->{$id};
return $self->param_fields->{$id};
}
# Function : Adds modification.
# Arguments : $hashref
# Returns : 1
# Notes : None specified.
sub add_modification {
my ($self, %value) = @_;
croak("A modification hashref is needed!") unless %value;
push @{$self->modifications}, \%value;
return 1;
}
# Function : Performs the necessary operations and
# displays a complete search page.
# Arguments : None
# Returns : 1
# Notes : None specified.
sub display_page {
my ($self) = @_;
my $submit = $self->cgi_params->{'submit'};
eval {
$self->_generate_search_form unless $self->search_form;
$self->_generate_sql_statements
if ($submit and !$self->query_sql_statement);
$self->_get_debug_info if $self->debug_level;
$self->_retrieve_data if ($submit and !$self->data);
$self->_retrieve_count if ($submit and !(defined $self->count));
$self->_format_data if ($submit and !$self->formatted_data);
};
$self->display_error_page($@) if $@;
eval { $self->_print_page; };
$self->display_error_page($@) if $@;
return 1;
}
# Function : Generates an error page.
# Arguments : $error
# Returns : - exists with 0 -
# Notes : None specified.
sub display_error_page {
my ($self, $error) = @_;
my $cookie = $self->cookie;
my $session_id = $self->session_id;
my $cookie_expires_in_min = $self->cookie_expires_in_min;
my $cookie_obj = CGI::cookie(
-name => $cookie,
-value => $session_id,
-expires => "+${cookie_expires_in_min}m",
);
print $self->cgi->header(-cookie => $cookie_obj);
my $header = $self->_content($self->header);
my $css = $self->_content($self->css);
my $page_title =
$self->page_title ? 'Error: ' . $self->page_title : 'Error Page';
my $instructions = $self->_content($self->instructions);
my $debug_info = $self->debug_info;
my $footer = $self->_content($self->footer);
my $temp_dir_eq = $self->temp_dir_eq;
print <<HTML;
<html>
<head>
<title>$page_title</title>
<link rel="stylesheet" type="text/css" href="$temp_dir_eq/searchpage-main.css" />
$css
</head>
<body>
<table border="0" width="100%">
<tr><td colspan="2">$header</td></tr>
<tr><td colspan="2"><h1>$page_title</h1></td></tr>
<tr><td width="60%"><b>An error occured: $error</b></td><td width="40%"> </td></tr>
<tr><td colspan="2"> </td></tr>
<tr><td colspan="2" align="center">$debug_info</td></tr>
<tr><td colspan="2">$footer</td></tr>
</table>
</body>
</html>
HTML
exit 0;
}
# Function : Performs the necessary operations and displays a complete info page.
# Arguments : None
# Returns : 1
# Notes : None specified.
sub display_info {
my ($self) = @_;
# This display is *not* interactive, no search form is provided
# "submit" is assumed, no need to check for it
# We must have an identifier provided
my $identifier = $self->cgi_params->{'identifier'};
$self->display_error_page('A valid identifier is required!')
unless defined $identifier;
# Automatically set parameter field
my $base_identifier = $self->base_identifier;
$self->display_error_page('A base_identifier is not specified!')
unless defined $base_identifier;
my $pf = HTML::SearchPage::Param->new(
-sql_column => $base_identifier,
-form_name => 'identifier',
-param_type => 'text:12', # place-holder
) or $self->display_error_page($@);
$self->param_field('identifier', $pf);
# We set the "identifier_operator" to "equals" by default
$self->cgi_params->{'identifier_operator'} = '=';
# We set the "output_format" to "html" by default
$self->cgi_params->{'output_format'} = 'html';
eval {
# -> do not generate search form
$self->_generate_sql_statements if !$self->query_sql_statement;
$self->_get_debug_info if $self->debug_level;
$self->_retrieve_data if !$self->data;
$self->_retrieve_count if !(defined $self->count);
# We have to retrieve one and only one record
if ($self->count == 0) {
$self->display_error_page(
"Cannot find identifier ($identifier)!");
}
if ($self->count > 1) {
$self->display_error_page(
"Multiple records found for identifier ($identifier)!");
}
#Use different method to format data
$self->_format_vertical_data if !$self->formatted_data;
};
$self->display_error_page($@) if $@;
eval { $self->_print_page; };
$self->display_error_page($@) if $@;
return 1;
}
# Function : Retrieves values for a distinct statement.
# Arguments : $statement
# Returns : @columns
# Notes : None specified.
sub run_distinct_statement {
my ($self, $statement) = @_;
my $dbh = $self->dbh;
my $sth = $dbh->prepare($statement) or croak($dbh->errstr);
$sth->execute or croak($dbh->errstr);
my @columns;
while (my ($value) = $sth->fetchrow_array) { push @columns, $value; }
$sth->finish or croak($dbh->errstr);
return @columns;
}
# Function : URL-encodes a given string.
# Arguments : $string
# Returns : $url_encoded_string
# Notes : This is a private method.
sub url_encode {
my ($self, $string) = @_;
$string =~ s/([^A-Za-z0-9])/sprintf("%%%02X", ord($1))/seg;
return $string;
}
# Function : URL-decodes a given string.
# Arguments : $string
# Returns : $url_decoded_string
# Notes : This is a private method.
sub url_decode {
my ($self, $string) = @_;
$string =~ s/\%([A-Fa-f0-9]{2})/pack('C', hex($1))/seg if $string;
return $string;
}
###########################
# PRIVATE/UTILITY METHODS #
###########################
# Function : Parse base_output_headers for super headers,
# store in base_super_headers as an array.
# Arguments : None
# Returns : 1
# Notes : This is a private method.
sub _calculate_super_headers {
my ($self) = @_;
my $headers = $self->base_output_headers;
my %super_headers;
my $current_group = 0;
my $current_super_header = qq[];
foreach my $pos (0 .. $#{@$headers}) {
my $super_header = qq[];
$super_header = $1 if $headers->[$pos] =~ s/^([^~]*)~//;
if ($super_header && $super_header eq $current_super_header) {
push @{$super_headers{$current_group}{headers}}, $headers->[$pos];
$super_headers{$current_group}{colspan}++;
}
else {
$current_group++;
$current_super_header = $super_header;
$super_headers{$current_group}{super_header} = $super_header;
push @{$super_headers{$current_group}{headers}}, $headers->[$pos];
$super_headers{$current_group}{colspan}++;
}
}
$self->super_output_headers(\%super_headers);
return 1;
}
# Function : Validates CGI params. Checks the CGI parameters
# passed on as a hashref and croaks
# if an error is found.
# Arguments : \%cgi
# Returns : 1
# Notes : This is a private method.
sub _validate_cgi_params {
my ($self) = @_;
my $cgi_params = $self->cgi_params;
my %validated_cgi_params = %{$cgi_params};
my @fields = @{$self->base_output_headers};
my %allowed_order_by_fields;
foreach my $field (@fields) {
my ($column_name, $order_by_field) = split(':', $field);
if ($order_by_field) {
$allowed_order_by_fields{$self->url_decode($order_by_field)} = 1;
}
}
$allowed_order_by_fields{asc} = 1;
$allowed_order_by_fields{desc} = 1;
$allowed_order_by_fields{not_selected} = 1;
my %allowed_operators = (
'=' => 1,
'like_m' => 1,
'like_c' => 1,
'>' => 1,
'>=' => 1,
'<' => 1,
'<=' => 1,
'<>' => 1,
'not_like_m' => 1,
'not_like_c' => 1,
);
my %allowed_output_formats = (
'html' => 1,
'csv' => 1,
'tab' => 1,
'text' => 1,
'excel' => 1,
);
foreach my $key (keys %$cgi_params) {
unless ($cgi_params->{$key} or $cgi_params->{$key} eq '0') {
$cgi_params->{$key} = undef;
next;
}
my @value = split("\0", $cgi_params->{$key});
foreach (@value) {
$_ =~ s/^\s+//;
$_ =~ s/\s+$//;
# Check all values against this
if ($_ =~ /[^A-Za-z0-9\-\_\?\*\.\%\(\)\,\'\+\=\:\# ]/
and !$allowed_operators{$_}) {
croak("Illegal character in value ($key:$_)!");
}
# Check individual values
if ($key =~ /_operator$/) {
croak("Illegal operator ($key:$_)!")
unless $allowed_operators{$_};
}
elsif ($key eq 'order_by') {
my $lc_cgi_value = lc $_;
croak("Invalid order by column ($key:$_)!")
unless ($allowed_order_by_fields{$_}
or $allowed_order_by_fields{$lc_cgi_value});
}
elsif ($key eq 'output_format') {
croak("Invalid output format($key:$_)!")
unless $allowed_output_formats{$_};
}
}
$validated_cgi_params{$key} = @value > 1 ? \@value : $value[0];
# (Array memory location stringified if passed to $cgi_params)
}
$self->cgi_params(\%validated_cgi_params);
return 1;
}
# Function : Generates and stores the HTML code for the
# search form component.
# Arguments : None
# Returns : 1
# Notes : This is a private method.
sub _generate_search_form {
my ($self) = @_;
# Assign form information
my $dbh = $self->dbh;
my $action = $self->action;
my $method = $self->method;
my $cgi = $self->cgi_params;
my $database = $self->cgi_params->{database};
my @order_by = @{$self->cgi_params->{order_by}}
if $self->cgi_params->{order_by};
my $sort_fields = $self->sort_fields;
my @sort_defaults = @{$self->sort_defaults} if $self->sort_defaults;
my @base_output_headers = @{$self->base_output_headers};
my $reset_button =
$self->new_search
? qq[ <input type="submit" name="new_search" value="New Search"></input>]
: !$self->no_reset
? qq[ <input type="submit" name="reset" value="Reset"></input>]
: qq[];
my $db_selector = $self->_make_db_selector;
my @field_sections;
foreach my $id (
sort { $self->param_field($a)->rank <=> $self->param_field($b)->rank }
keys %{$self->param_fields}
) {
my $pf = $self->param_field($id);
my $field_section;
# Assign field information
my $label = $pf->label;
my $sql_column = $pf->sql_column;
my $form_name = $pf->form_name;
my @operator_list = @{$pf->operator_list} if $pf->operator_list;
my $operator_display = $pf->operator_display;
my $disabled = $pf->disabled;
my $operator_default = $pf->operator_default || qq[];
my $case_sensitive = $pf->case_sensitive;
my $exact = $pf->exact;
my $numerical = $pf->numerical;
my $param_type = $pf->param_type;
my @param_list = @{$pf->param_list} if $pf->param_list;
my $auto_all = $pf->auto_all;
my $auto_null = $pf->auto_null;
my $param_default = $pf->param_default || qq[];
# my %param_default;
# foreach (@param_default) {
# $param_default{$_} = 1 if $_;
# }
# Adjustments
# (i) Resolve DISTINCT statements in param_list
my @resolved_param_list;
foreach my $param_statement (@param_list) {
if ($param_statement && $param_statement =~ s/^DISTINCT://) {
my @resolved_params =
$self->run_distinct_statement($param_statement);
foreach (@resolved_params) {
next if !defined $_;
$_ = $self->url_encode($_);
push(@resolved_param_list, $_);
}
}
else { push(@resolved_param_list, $param_statement); }
}
@param_list = @resolved_param_list;
$pf->param_list(\@param_list);
# (ii) Append AUTO NULL AND ALL to param list
unshift @param_list, 'null:NULL' if $auto_null;
unshift @param_list, 'all:ALL' if $auto_all;
# Make sure param_list is populated
if ( $param_type eq 'drop_down'
or $param_type =~ /^scrolling_list:\d+$/) {
croak("Parameter field ($label) has empty param_list!")
unless @param_list;
}
# (iii) Auto-complete display names for param_list
foreach (@operator_list, @param_list) {
$_ = "$1:$1" if ($_ && $_ =~ /^([^:]+)$/);
}
# Prepare operator section
my $operator_section;
if (@operator_list > 1) {
$operator_section .= qq[<select name="${form_name}_operator">\n];
foreach (@operator_list) {
my ($operator, $display) = split(':', $_);
$operator = $self->url_decode($operator) || qq[];
$display = $self->url_decode($display) || qq[];
my $selected = qq[];
if ( defined $cgi->{$form_name}
&& defined $cgi->{"${form_name}_operator"}
&& $cgi->{"${form_name}_operator"} eq $operator) {
$selected = 'selected';
}
elsif ($operator eq $operator_default
&& !defined $cgi->{$form_name}) {
$selected = 'selected';
}
$operator_section .=
qq[<option $selected value="$operator">$display</option>\n];
}
$operator_section .= qq[</select>\n];
}
elsif (@operator_list == 1) {
my ($operator, $display) = split(':', $operator_list[0]);
$operator = $self->url_decode($operator);
$display = $self->url_decode($display);
my ($field_type, $disabled) =
$operator_display ? ('text', 'disabled') : ('hidden', qq[]);
$operator_section .=
qq[<input type="$field_type" name="${form_name}_operator" value="$operator" $disabled> </input>\n];
}
else { croak("No opearator specified (form field: $form_name)!"); }
# Prepare param section
my $param_section;
if ( $param_type eq 'drop_down'
or $param_type =~ /^scrolling_list:\d+$/) {
if ($param_type eq 'drop_down') {
$param_section .= qq[<select name="$form_name">\n];
}
elsif ($param_type =~ /^scrolling_list:(\d+)$/) {
$param_section .=
qq[<select name="$form_name" size="$1" multiple>\n];
}
my @values;
if (defined $cgi->{$form_name}) {
@values =
ref $cgi->{$form_name}
? @{$cgi->{$form_name}}
: ($cgi->{$form_name});
}
my %values = map { ($_, 1) } @values;
foreach (@param_list) {
my ($param, $display) = split(':', $_);
$param = $self->url_decode($param);
$display = $self->url_decode($display);
my $selected = ' ';
if (@values and $values{$param}) { $selected = 'selected'; }
elsif (!@values and $param_default eq $param) {
$selected = 'selected';
}
$param_section .=
qq[<option $selected value="$param">$display</option>\n];
}
$param_section .= qq[</select>\n];
}
elsif ($param_type =~ /^text:(\d+)$/) {
my $field_size = $1;
my $value = qq[];
if ($cgi->{"${form_name}"} and ($cgi->{"${form_name}"} ne 'all'))
{
$value = $cgi->{"${form_name}"};
}
elsif ($param_default && $param_default ne 'all') {
$value = $param_default;
}
my $disable_status = $disabled ? qq[disabled="1"] : qq[];
$param_section .=
qq[<input type="text" name="$form_name" value="$value" size="$field_size" maxlength="$field_size" $disable_status></input>\n];
}
else {
croak(
"Invalid param field type designation ($form_name : $param_type)!"
);
}
$field_section .=
qq[<tr><td align="left" width="50%"><b>$label</b></td><td align="left" width="25%">$operator_section</td><td align="left" width="25%">$param_section</td></tr>\n];
push @field_sections, $field_section;
}
my @order_by_sections;
my @sortable_fields = ('-- Select --:not_selected');
foreach (@base_output_headers) { push @sortable_fields, $_ if /:/; }
foreach my $i (1 .. $sort_fields) {
my $label = "Sort by (\#$i):";
# Direction
my $direction = lc(shift @order_by);
if ($direction and !($direction =~ /^asc$/ or $direction =~ /^desc$/))
{
croak("Illegal direction (order_by) param ($direction)!");
}
my $direction_default = lc(shift @sort_defaults);
if ($direction_default
and !(
$direction_default =~ /^asc$/
or $direction_default =~ /^desc$/
)
) {
croak(
"Illegal direction (sort_defaults) param ($direction_default)!"
);
}
my $direction_selected =
$direction ? $direction
: $direction_default ? $direction_default
: qq[];
my $direction_section = $self->_make_select(
'order_by', [qw(ascending:asc descending:desc)],
$direction_selected
);
# Field
my $field = shift @order_by;
my $field_default = shift @sort_defaults;
my $field_selected =
$field ? $field
: $field_default ? $field_default
: 'not_selected';
my $field_section =
$self->_make_select('order_by', \@sortable_fields, $field_selected);
# Order by
my $order_by_section =
qq[<tr><td align="left" width="50%"><b><i>$label</i></b></td><td align="left" width="25%">$direction_section</td><td align="left" width="25%">$field_section</td></tr>\n];
push @order_by_sections, $order_by_section;
}
# Render complete HTML form
my $search_form;
$search_form .= <<HTML;
<form method="$method" action="$action">
<table border="0" align="center" width="100%" cellpadding="1" cellspacing="1">
HTML
$search_form .= $db_selector;
$search_form .= join("\n", @field_sections);
$search_form .= <<HTML;
<tr>
<td align="left"> </td>
<td align="left"> </td>
<td align="left"> </td>
</tr>
HTML
$search_form .= join("\n", @order_by_sections);
$search_form .= <<HTML;
<tr>
<td align="left"><b><i>Output Format:</i></b></td>
<td align="left"> </td>
<td align="left">
<select name="output_format">
<option selected value="html">HTML</option>
<option value="excel">Excel</option>
<option value="text">text (fixed-width)</option>
<option value="csv">csv (comma-separated)</option>
<option value="tab">tsv (tab-delimited)</option>
</select>
</td>
</tr>
<tr>
<td align="left"> </td>
<td align="center" colspan="2">
<input type="submit" name="submit" value="Submit"></input>
$reset_button
</td>
</tr>
</table>
</form>
<script type="text/javascript">
<!--
document.getElementById("javascript_warning").deleteRow(0)
-->
</script>
HTML
# Store in the object
$self->search_form($search_form);
return 1;
}
# Function : Returns a select box.
# Arguments : $name, \@fields, $selected
# Returns : $html
# Notes : This is a private method.
# Members of @fields are
# in the format: "<display>:<value>"
sub _make_select {
my ($self, $name, $fields_ref, $selected) = @_;
my @fields_ref = @$fields_ref;
my $html;
$html .= qq[<select name="$name">\n];
foreach (@$fields_ref) {
my ($display, $field) = split(':', $_);
my $selected_switch = $field eq $selected ? 'selected' : qq[];
$html .=
qq[<option $selected_switch value="$field">$display</option>\n];
}
$html .= qq[</select>\n];
return $html;
}
# Function : Returns a db selection box.
# Arguments :
# Returns : $html
# Notes : This is a private method.
sub _make_db_selector {
my ($self) = @_;
my $db_access_params = $self->db_access_params;
my $database = $self->db_selected;
my @available_databases =
( ref($db_access_params->{database})
and ref($db_access_params->{database}) eq 'ARRAY')
? @{$db_access_params->{database}}
: ($db_access_params->{database});
my $html;
if (@available_databases > 1) {
my $select;
$select .=
qq[<select id="db_selector" name="database" onchange="select_db()">\n];
foreach my $available_database (@available_databases) {
my $alias = $available_database->{alias};
my $display = $available_database->{display};
my $selected_switch = $alias eq $database ? 'selected' : qq[];
$select .=
qq[<option $selected_switch value="$alias">$display</option>\n];
}
$select .= qq[</select>\n];
$html = <<HTML;
<tr>
<td align="left"><b><i>Database:</i></b></td>
<td align="left"> </td>
<td align="left">
<script type="text/javascript">
<!--
function select_db()
{
var database=document.getElementById("db_selector").value
var target_url= location.pathname + "?database=" + database
window.location=target_url
}
-->
</script>
$select
</td>
</tr>
<tr>
<td align="left" colspan="3">
<table id="javascript_warning" width="100%">
<tr>
<td>
<a style="color:red; font-style:italic">
(Javascript must be enabled for automatic refresh!)</a>
</td>
</tr>
</table>
</td>
</tr>
<tr>
<td align="left"> </td>
<td align="left"> </td>
<td align="left"> </td>
</tr>
HTML
}
else {
$html .=
qq[<input type="hidden" name="database" value="$database"/></input>\n];
}
return $html;
}
# Function : Generates and stores the relevant SQL statements
# (query and count).
# Arguments : None
# Returns : 1
# Notes : This is a private method.
sub _generate_sql_statements {
my ($self) = @_;
my $base_sql_table = $self->base_sql_table;
my $page_size = $self->page_size;
my $current_page =
$self->cgi_params->{page}
? $self->cgi_params->{page}
: 1; # Page defaults to 1
my $output_format = $self->cgi_params->{output_format};
my $group_by = $self->group_by;
my @fields = @{$self->base_sql_fields};
my $distinct = $self->distinct ? 'distinct' : qq[];
my @where_clauses;
my @order_by_clauses
; # Currently only a single sort column is supported although data is stored in a list
my $limit_clause;
# Assign CGI information and clean values
my @order_by = @{$self->cgi_params->{"order_by"}}
if $self->cgi_params->{"order_by"};
foreach my $id (sort keys %{$self->param_fields}) {
my $pf = $self->param_field($id);
# Assign field information
my $param_type = $pf->param_type;
my $sql_column = $pf->sql_column;
my $form_name = $pf->form_name;
my $case_sensitive = $pf->case_sensitive;
my $exact = $pf->exact;
my $numerical = $pf->numerical;
# Skip this ParamField if sql_column is 'INDEPENDENT'
next if $sql_column eq 'INDEPENDENT';
# Assign CGI information and clean values
my $value = $self->cgi_params->{$form_name};
my $operator = $self->cgi_params->{"${form_name}_operator"};
# Add the field to the WHERE <SOMETHING> segment if it is defined, observe additional rules
if (defined $value
and ($value or $value eq '0')
&& $param_type =~ /^scrolling_list:\d+$/) {
my @values = ref $value ? @$value : ($value);
if (($operator eq '<>' or $operator =~ /^not_/)
and $self->_ary_exists(\@values, 'all')) {
croak("Negation operators cannot be used with value ALL!");
}
unless ($self->_ary_exists(\@values, 'all')) {
my @in_where_clauses;
foreach my $value (@values) {
push @in_where_clauses,
$self->_make_where_clause($operator, $value, $pf);
}
if ($operator eq '<>' or $operator =~ /^not_/) {
push @where_clauses,
"(" . join(" AND ", @in_where_clauses) . ")";
}
else {
push @where_clauses,
"(" . join(" OR ", @in_where_clauses) . ")";
}
}
}
elsif (($operator eq '<>' or $operator =~ /^not_/)
and $value eq 'all') {
croak("Negation operators cannot be used with value ALL!");
}
elsif ( defined $value
and ($value or $value eq '0')
and $value ne 'all') {
croak("Operator is not specified for field ($form_name)!")
unless defined $operator;
push @where_clauses,
$self->_make_where_clause($operator, $value, $pf);
}
}
# Add external WHERE clause rule
my @external_where_clauses = @{$self->external_where_clauses}
if $self->external_where_clauses;
push @where_clauses, @external_where_clauses;
# Add the field to ORDER BY <SOMETHING>
while (@order_by) {
my $direction = shift @order_by;
my $field = shift @order_by;
croak("Invalid order direction ($direction)!")
unless ($direction eq 'asc' or $direction eq 'desc');
push @order_by_clauses, "$field $direction"
if ($field and $field ne 'not_selected');
}
# Add LIMIT section (for pagination)
my $limit_start = ($current_page - 1) * $page_size;
$limit_clause = "LIMIT $limit_start, $page_size";
# Generate query SQL statement
my $query_sql_statement = "SELECT $distinct " . join(", ", @fields);
$query_sql_statement .= " FROM " . $base_sql_table;
$query_sql_statement .= " WHERE " . join(" AND ", @where_clauses)
if @where_clauses;
$query_sql_statement .= " GROUP BY " . $group_by if $group_by;
$query_sql_statement .= " ORDER BY " . join(", ", @order_by_clauses)
if @order_by_clauses;
$query_sql_statement .= " " . $limit_clause if $output_format eq 'html';
# Generate count SQL statement
my $count_sql_statement = "SELECT COUNT(*) FROM (";
# Mysql 5 complains about duplicate column names in select ocunt(*)
# Added placeholder aliases
my @aliased_fields;
foreach my $i (0 .. $#fields) {
push @aliased_fields, $fields[$i] . " as alias$i";
}
$count_sql_statement .= "SELECT $distinct " . join(", ", @aliased_fields);
$count_sql_statement .= " FROM " . $base_sql_table;
$count_sql_statement .= " WHERE " . join(" AND ", @where_clauses)
if @where_clauses;
$count_sql_statement .= " GROUP BY " . $group_by if $group_by;
$count_sql_statement .= ") a";
# Store in the object
$self->query_sql_statement($query_sql_statement);
$self->count_sql_statement($count_sql_statement);
return 1;
}
# Function : Return whether the query exists in the ary
# Arguments : $aryref, $query
# Returns : undef | 1
# Notes : This is a private method.
sub _ary_exists {
my ($self, $ary, $query) = @_;
foreach (@$ary) { return 1 if $_ eq $query; }
return;
}
# Function : Generates WHERE clause for the SQL statement.
# Arguments : $operator, $value, $ParamField
# Returns : $where_clause
# Notes : This is a private method.
sub _make_where_clause {
my ($self, $operator, $value, $pf) = @_;
my $dbh = $self->dbh;
my $sql_column = $pf->sql_column;
my $case_sensitive = $pf->case_sensitive;
my $numerical = $pf->numerical;
my $where_clause;
if ($value eq 'null') {
if ( $operator eq '='
or $operator eq 'like_m'
or $operator eq 'like_c') {
$where_clause = qq[$sql_column IS NULL];
}
elsif ($operator eq '<>'
or $operator eq 'not_like_m'
or $operator eq 'not_like_c') {
$where_clause = qq[$sql_column IS NOT NULL];
}
else {
croak(
"Unable to process reserved keyword null, invalid operator ($operator)!"
);
}
}
else {
if ($operator eq 'like_c') {
$operator = 'like';
$value = qq[%$value%];
$value = $dbh->quote($value);
}
elsif ($operator eq 'like_m') {
$operator = 'like';
$value =~ s/\*/%/g;
$value =~ s/\?/_/g;
$value = $dbh->quote($value);
}
else { $value = $numerical ? qq[$value] : qq["$value"]; }
$value = qq[BINARY $value] if $case_sensitive;
$where_clause = qq[$sql_column $operator $value];
}
return $where_clause;
}
# Function : Executes the query SQL statement, retrieves and stores the raw data.
# Arguments : None
# Returns : 1
# Notes : This is a private method.
sub _retrieve_data {
my ($self) = @_;
my $dbh = $self->dbh;
my $statement = $self->query_sql_statement
|| croak("No pre-set (query) SQL statement!");
my @data;
my $sth = $dbh->prepare($statement)
|| croak("Cannot prepare statement ($statement)!");
$sth->execute() || croak("Cannot execute statement ($statement)!");
while (my @row = $sth->fetchrow_array) {
foreach (@row) {
$_ = '' unless defined $_;
}
push @data, \@row;
}
# Store in the object
$self->data(\@data);
return 1;
}
# Function : Executes the count SQL statement, retrieves
# and stores the data count.
# Arguments : None
# Returns : 1
# Notes : This is a private method.
sub _retrieve_count {
my ($self) = @_;
my $dbh = $self->dbh;
my $statement = $self->count_sql_statement
|| croak("No pre-set (count) SQL statement!");
my $sth = $dbh->prepare($statement)
|| croak("Cannot prepare statement ($statement)!");
$sth->execute() || croak("Cannot execute statement ($statement)!");
my ($count) = $sth->fetchrow_array;
# Store in the object
$self->count($count);
return 1;
}
# Function : Compiles debug info and stores in object.
# Arguments : None
# Returns : 1
# Notes : This is a private method.
sub _get_debug_info {
my ($self) = @_;
my $debug_level = $self->debug_level;
my $dbh = $self->dbh;
my $alias = $self->db_selected;
my ($database_name) = $dbh->{Name} =~ /database=([^;]+)/;
my $datasource_info = qq[alias=$alias; database_name=$database_name];
my $html;
my $debug_info = qq[];
if ($debug_level > 0) {
my $time_stamp = $time{'dd-Mon-yyyy hh:mm:ss tz'};
my $url = $ENV{HTTP_HOST} . $ENV{REQUEST_URI};
my @software;
foreach my $file (
$0, $INC{'HTML/SearchPage/Param.pm'},
$INC{'HTML/SearchPage.pm'},
) {
my ($id) = $self->_get_version_information($file);
my ($file_name) = $file =~ /([^\/]+)$/;
push(@software, "SW: $file_name", $id);
}
my $query_sql_statement = $self->query_sql_statement;
my $count_sql_statement = $self->count_sql_statement;
$debug_info .= '<p>'
. $self->_format_box(
'VERSION & PROCESSING INFORMATION',
'URL', $url,
'Time', $time_stamp,
@software,
'Datasource', $datasource_info,
'Query SQL Statement', $query_sql_statement,
'Count SQL Statement', $count_sql_statement,
);
}
if ($debug_level > 1) {
$debug_info .= '<p>' . $self->_format_box('ENVIRONMENT', %ENV);
}
# Store in the object
$self->debug_info($debug_info);
return 1;
}
# Function :
# Arguments :
# Returns :
# Notes : This is a private method.
sub _format_box {
my ($self, $title, @content) = @_;
tie my %content, 'Tie::IxHash';
%content = @content;
my $formatted_box;
$formatted_box .= qq[<table class="small_box2" border="0" width="100%">];
$formatted_box .=
qq[<tr><td align="left"colspan="2"><b><u>$title</u></b></td></tr>];
foreach my $key (keys %content) {
my $line = $content{$key} || qq[];
$line =~ s/(.{100})/ $1<br>/g if $line =~ /\S{100,}/;
$formatted_box .= qq[<tr><td><b>$key</b></td><td>$line</td></tr>];
}
$formatted_box .= qq[</table>];
return $formatted_box;
}
# Function :
# Arguments :
# Returns :
# Notes : This is a private method.
sub _get_version_information {
my ($self, $file) = @_;
open(IN, "<$file") or die("Cannot read file ($file)");
my $content;
{ local $/; $content = <IN>; }
close IN;
my ($id) = $content =~ /\n(\$Id[^\$]*\$)/;
return ($id);
}
# Function : Formats the stored data based on the selected output format.
# Arguments : None
# Returns : 1
# Notes : This is a private method.
sub _format_data {
my ($self) = @_;
# Do modifications if any
$self->_modify_data if @{$self->modifications};
# Assign form information
my $temp_dir_eq = $self->temp_dir_eq;
my $action = $self->action;
my $method = $self->method;
my $page_size = $self->page_size;
# Self-referencing URL, without explicit database
my $search_url =
$self->show_search_url ? $self->cgi->self_url . "#results" : qq[];
my $order_by = $self->cgi_params->{"order_by"};
my $order_direction = $self->cgi_params->{"order_direction"};
my $current_page =
$self->cgi_params->{page}
? $self->cgi_params->{page}
: 1; # Page defaults to 1
my $count = $self->count;
my $number_of_pages =
$count % $page_size
? int($count / $page_size) + 1
: $count / $page_size;
$current_page = 1 if $current_page < 1;
$current_page = $number_of_pages if $current_page > $number_of_pages;
my $output_format = $self->cgi_params->{output_format};
my @data = @{$self->data};
my @base_sql_fields = @{$self->base_sql_fields};
my @base_output_headers = @{$self->base_output_headers};
my $column_width_percent = int(100 / @base_output_headers);
my %super_output_headers = %{$self->super_output_headers};
my @trimmed_boh = map { /^([^:]+)/; $1; } @base_output_headers;
my $formatted_data;
if ($output_format eq 'html') {
# Prepare segment to display page navigation
my %no_page_cgi = %{$self->cgi_params};
delete $no_page_cgi{page};
my $no_page_opt = $self->_form_opt(\%no_page_cgi);
my $display_start = ($current_page - 1) * $page_size + 1;
$display_start = 0 if $count == 0;
my $display_end = $current_page * $page_size;
$display_end = $count if $display_end > $count;
$display_end = 0 if $count == 0;
my $prev_page = $current_page - 1;
$prev_page = 1 if $prev_page < 1;
my $next_page = $current_page + 1;
$next_page = $number_of_pages if $next_page > $number_of_pages;
my @page_list =
map {
$current_page eq $_
? qq[<option selected value="$_">Page $_</option>\n]
: qq[<option value="$_">Page $_</option>\n]
} (1 .. $number_of_pages);
my $page_list = join(qq[], @page_list);
my $search_url_link =
$search_url ? qq[<a href="$search_url">[Search URL]</a>] : ' ';
my $page_navigation = <<HTML;
<table border="0" width="100%" class="navigator_color">
<tr>
<td width="40%" align="left">
Record $display_start-$display_end of $count
$search_url_link
</td>
<td align="center">
<form method="$method" action="$action">
$no_page_opt
<input type="hidden" name="page" value="$prev_page"/></input>
<input type="image" src="$temp_dir_eq/left-arrow.png" alt="Previous" width="25" height="25" name="submit"></input>
</form>
</td>
<td align="center">
Page $current_page of $number_of_pages
</td>
<td align="center">
<form method="$method" action="$action">
$no_page_opt
<input type="hidden" name="page" value="$next_page"></input>
<input type="image" src="$temp_dir_eq/right-arrow.png" alt="Next" width="25" height="25" name="submit"></input>
</form>
</td>
<td width="40%" align="right">
<form method="$method" action="$action">
$no_page_opt
<select name="page">
$page_list
</select>
<input type="submit" name="submit" value="Go"></input>
</form>
</td>
</tr>
</table>
HTML
# Add navigation bar to the top
$formatted_data .=
qq[<table border="0" width="100%"><tr><td>$page_navigation</td></tr></table>\n];
# Start table
$formatted_data .=
qq[<table border="1" width="100%" class="header_color">\n];
# Add headers - 1st row
$formatted_data .= qq[<tr>\n];
foreach my $group (sort { $a <=> $b } keys %super_output_headers) {
my $super_header = $super_output_headers{$group}{super_header};
my @headers = @{$super_output_headers{$group}{headers}};
my $colspan = $super_output_headers{$group}{colspan};
if ($colspan == 1) {
my $header_piece = $self->_get_header_piece($headers[0]);
$formatted_data .=
qq[<td rowspan="2" width="$column_width_percent\%" align="center">$header_piece</td>\n];
}
else {
$formatted_data .=
qq[<td colspan="$colspan" align="center"><b>$super_header</b></td>\n];
}
}
$formatted_data .= qq[</tr>\n];
# Add headers - 2nd row
$formatted_data .= qq[<tr>\n];
foreach my $group (sort { $a <=> $b } keys %super_output_headers) {
my @headers = @{$super_output_headers{$group}{headers}};
my $colspan = $super_output_headers{$group}{colspan};
if ($colspan > 1) {
foreach (@headers) {
my $header_piece = $self->_get_header_piece($_);
$formatted_data .=
qq[<td align="center" width="$column_width_percent\%">$header_piece</td>\n];
}
}
}
$formatted_data .= qq[</tr>\n];
# Add data
my $counter = 0;
foreach my $row (@data) {
$counter++;
my $background_color =
$counter % 2 == 1
? qq[class="row_color_one"]
: qq[class="row_color_two"];
$formatted_data .= qq[<tr $background_color>\n];
foreach (@$row) {
$formatted_data .=
(defined $_ and $_ ne qq[])
? qq[<td>$_</td>]
: qq[<td> </td>];
$formatted_data .= "\n";
}
$formatted_data .= qq[</tr>];
}
# End table
$formatted_data .= qq[</table>\n];
# Add navigation bar to the bottom
$formatted_data .=
qq[<table border="0" width="100%"><tr><td>$page_navigation</td></tr></table>\n];
}
elsif ($output_format eq 'text') {
# Calculate field length for each column
my @index = @{$self->_get_column_lengths(\@trimmed_boh, @data)};
# Add headers and data
foreach my $row (\@trimmed_boh, @data) {
my @row = @$row;
foreach my $i (0 .. $#row) {
my $size = $index[$i] + 1;
$formatted_data .= sprintf("\%-${size}s", $row[$i]);
}
$formatted_data .= "\n";
}
# Add end marker
$formatted_data .= '# [END]';
}
elsif ($output_format eq 'excel') {
open my $fh, '>', \$formatted_data
or croak("Failed to open filehandle to write excel output: $!");
# Create WriteExcel object
my $workbook = Spreadsheet::WriteExcel->new($fh);
my $worksheet = $workbook->add_worksheet();
# Add header format to WriteExcel object
my $header_format = $workbook->add_format;
$header_format->set_properties(
bold => 1,
);
# Set column widths
my @index =
@{$self->_get_column_lengths(\@base_output_headers, @data)};
foreach my $i (0 .. $#index) {
$worksheet->set_column($i, $i, $index[$i]);
}
# Add headers and data
my $row_number = 0;
foreach my $row (\@trimmed_boh, @data) {
foreach my $i (0 .. $#{@$row}) {
if ($row_number == 0) {
$worksheet->write(
$row_number, $i, $row->[$i],
$header_format
);
}
else {
$worksheet->write($row_number, $i, $row->[$i]);
}
}
$row_number++;
}
$workbook->close;
}
elsif ($output_format eq 'csv') {
# Add headers and data
foreach my $row (\@trimmed_boh, @data) {
foreach (@$row) { $_ = qq["$_"]; }
$formatted_data .= join(',', @$row) . "\n";
}
# Add end marker
$formatted_data .= '# [END]';
}
elsif ($output_format eq 'tab') {
# Track tab conversion
my @tab_removed;
# Add headers and data
my $row_number = 0;
foreach my $row (\@trimmed_boh, @data) {
foreach my $i (0 .. $#{@$row}) {
if ($row->[$i] =~ s/\t/_/g) {
push @tab_removed, "Row: row_number, Column: $i";
}
}
$formatted_data .= join("\t", @$row) . "\n";
$row_number++;
}
# Record tab removals
foreach (@tab_removed) {
$formatted_data .= "# tab conveted to underscore $_\n";
}
# Add end marker
$formatted_data .= "# [END]\n";
}
# Store in the object
$self->formatted_data($formatted_data);
return 1;
}
# Function : Generates the oheader segment that contains the sort icons
# Arguments : $label (header:sql_column)
# Returns : $html_code
# Notes : This is a private method.
sub _get_header_piece {
my ($self, $label) = @_;
my $temp_dir_eq = $self->temp_dir_eq;
my ($header, $sql_column) = split(':', $label);
my $content;
my $image = $sql_column
? qq[<img src="$temp_dir_eq/sort-button.png" alt="Sortable" width="14" height="14">]
: ' ';
$content .=
qq[<table><tr><td><b>$header</b></td><td>$image</td></tr></table>];
return $content;
}
# Function : Generates the options segment of a form, given
# a hasref of cgi params
# Arguments : \%cgi
# Returns : $options_segment
# Notes : This is a private method.
sub _form_opt {
my ($self, $cgi) = @_;
my $options;
foreach my $key (keys %$cgi) {
my @values = ref $cgi->{$key} ? @{$cgi->{$key}} : ($cgi->{$key});
foreach my $value (@values) {
$value ||= qq[];
$options .=
qq[<input type="hidden" name="$key" value="$value"></input>\n];
}
}
return $options;
}
# Function : For a given arrayref of data, calculate max column lengths
# Arguments : \@data (Each member is an arrayref of column data)
# Returns : \@index (Each member is the max length of that column)
# Notes : This is a private method.
sub _get_column_lengths {
my ($self, @data) = @_;
my @index;
foreach my $row_ref (@data) {
my @row = @{$row_ref};
foreach my $i (0 .. $#row) {
if (!defined $index[$i] || length($row[$i]) > $index[$i]) {
$index[$i] = length($row[$i]);
}
}
}
return \@index;
}
# Function : Generates the HTML code for the search page
# Arguments : None
# Returns : 1
# Notes : This is a private method.
sub _print_page {
my ($self) = @_;
my $header = $self->_content($self->header);
my $css = $self->_content($self->css);
my $page_title = $self->page_title;
my $instructions = $self->_content($self->instructions);
my $search_form = $self->search_form || qq[];
my $formatted_data = $self->formatted_data || qq[];
my $debug_info = $self->debug_info || qq[];
my $footer = $self->_content($self->footer);
my $temp_dir_eq = $self->temp_dir_eq;
my $cookie = $self->cookie;
my $session_id = $self->session_id;
my $cookie_expires_in_min = $self->cookie_expires_in_min;
my $cookie_obj = CGI::cookie(
-name => $cookie,
-value => $session_id,
-expires => "+${cookie_expires_in_min}m",
);
my $output_format = $self->cgi_params->{output_format} || 'html';
my $results_anchor =
$formatted_data
? "results"
: "placeholder"; # Don't display results anchor if there
# are no results
if ($output_format eq 'html') {
print $self->cgi->header(-cookie => $cookie_obj);
print <<HTML;
<html>
<head>
<title>$page_title</title>
<link rel="stylesheet" type="text/css" href="$temp_dir_eq/searchpage-main.css" />
$css
</head>
<body>
<table border="0" width="97%" align="center">
<tr><td colspan="2" align="center">$header</td></tr>
<tr><td colspan="2" align="center"><h1>$page_title</h1></td></tr>
<tr><td width="60%" align="left">$instructions</td><td width="40%" align="center">$search_form</td></tr>
<tr><td colspan="2" align="center"><a name="$results_anchor"></a>$formatted_data</td></tr>
<tr><td colspan="2" align="center">$debug_info</td></tr>
<tr><td colspan="2" align="center">$footer</td></tr>
</table>
</body>
</html>
HTML
}
elsif ($output_format eq 'excel') {
print $self->cgi->header(
-cookie => $cookie_obj,
-type => 'application/vnd.ms-excel'
);
print $formatted_data;
}
elsif ($output_format eq 'csv') {
print $self->cgi->header(
-cookie => $cookie_obj,
-type => 'text/comma-separated-values'
);
print $formatted_data;
}
elsif ($output_format eq 'tab') {
print $self->cgi->header(
-cookie => $cookie_obj,
-type => 'text/tab-separated-values'
);
print $formatted_data;
}
elsif ($output_format eq 'text') {
print $self->cgi->header(
-cookie => $cookie_obj,
-type => 'text/plain'
);
print $formatted_data;
}
else {
print $self->cgi->header(
-cookie => $cookie_obj,
-type => 'text/plain'
);
print $formatted_data;
}
return 1;
}
# Function : Retrieves the content for the directive specified;
# supports GET (retrieval by LWP), EXEC (executes a command-line
# and captures output), FILE (retrieves a file content).
# Arguments : $directive
# Returns : $content
# Notes : This is a private method.
sub _content {
my ($self, $container) = @_;
return ' ' unless $container;
my $content = $container || qq[];
if ($container =~ s/^(FILE|EXEC|GET)://) {
my $type = $1;
if ($type eq 'GET') {
my $self_url = $self->cgi->self_url;
my ($current_url, $current_args) = split(/\?/, $self_url);
$current_args ||= qq[];
$current_url =~ s!^http://[^/]+!!;
$current_url = CGI::escape($current_url);
$current_args = CGI::escape($current_args);
$container =~ s/__CURRENT_URL__/$current_url/;
$container =~ s/__CURRENT_ARGS__/$current_args/;
$content = get($container)
or croak("Cannot get container ($container)!");
}
elsif ($type eq 'EXEC') {
open(EXEC, "$container|")
or croak("Cannot exec container ($container)! - $!");
{ local $/; $content = <EXEC>; }
close EXEC;
}
elsif ($type eq 'FILE') {
open(FILE, "<$container")
or croak("Cannot open container ($container)! - $!");
{ local $/; $content = <FILE>; }
close FILE;
}
}
return $content;
}
# Function : Modifies the data in its raw form.
# Arguments : %params
# Returns : 1
# Notes : This is a private method.
sub _modify_data {
my ($self) = @_;
my $modifier = $self->modifier
or croak("Cannot modify without a modifier object!");
foreach my $params (@{$self->modifications}) {
$params->{-page_obj} =
$self; # temporary hack to be able to modify SearchPage obj
$params->{-data} = $self->data;
$params->{-output_format} = $self->cgi_params->{output_format}
|| 'html';
$params->{-dbh} = $self->dbh;
my $action = $params->{-action}
or croak("No modifier action specified!");
delete $params->{-action};
eval { $modifier->$action(%$params); };
croak($@) if $@;
}
# Ref to data is passed on, changes are made directly.
return 1;
}
# Function : Formats the stored data based on the selected output format.
# Arguments : None
# Returns : 1
# Notes : This is a private method.
sub _format_vertical_data {
my ($self) = @_;
# Do modifications if any
$self->_modify_data if @{$self->modifications};
# Assign form information
my $action = $self->action;
my $method = $self->method;
my $output_format = $self->cgi_params->{output_format};
my @data = @{$self->data};
my @base_output_headers = @{$self->base_output_headers};
my @trimmed_boh = map { /^([^:]+)/; $1; } @base_output_headers;
# Combine @data and trimmed_boh to make data vertical
my @vertical_data;
foreach my $i (0 .. $#trimmed_boh) {
$vertical_data[$i] = [$trimmed_boh[$i], $data[0][$i]];
}
my $formatted_data;
if ($output_format eq 'html') {
# Start table
$formatted_data .=
qq[<table border="1" align="center" width="75%">\n];
# Add data
my $counter = 0;
foreach my $row (@vertical_data) {
$counter++;
my $background_color =
$counter % 2 == 1
? qq[class="row_color_one"]
: qq[class="row_color_two"];
$formatted_data .= qq[<tr $background_color>\n];
foreach my $i (0 .. $#{@$row}) {
my $value = $row->[$i];
if ($i == 0) {
$formatted_data .= $value
? qq[<td width="20%"><b>$value</b></td>]
: qq[<td> </td>];
}
else {
$formatted_data .= $value
? qq[<td width="80%">$value</td>]
: qq[<td> </td>];
}
$formatted_data .= "\n";
}
$formatted_data .= qq[</tr>];
}
# End table
$formatted_data .= qq[</table>\n];
# Add some space
$formatted_data .= qq[<p> <p> <p> \n];
}
else { croak("Unknown output_format ($output_format) to display_info!"); }
# Store in the object
$self->formatted_data($formatted_data);
return 1;
}
###################
# GET/SET METHODS #
###################
sub action {
my ($self, $value) = @_;
$self->{action} = $value if @_ > 1;
return $self->{action};
}
sub base_identifier {
my ($self, $value) = @_;
$self->{base_identifier} = $value if @_ > 1;
return $self->{base_identifier};
}
sub base_output_headers {
my ($self, $value) = @_;
$self->{base_output_headers} = $value if @_ > 1;
return $self->{base_output_headers};
}
sub base_sql_fields {
my ($self, $value) = @_;
$self->{base_sql_fields} = $value if @_ > 1;
return $self->{base_sql_fields};
}
sub base_sql_table {
my ($self, $value) = @_;
$self->{base_sql_table} = $value if @_ > 1;
return $self->{base_sql_table};
}
sub cgi {
my ($self, $value) = @_;
$self->{cgi} = $value if @_ > 1;
return $self->{cgi};
}
sub cgi_params {
my ($self, $value) = @_;
$self->{cgi_params} = $value if @_ > 1;
return $self->{cgi_params};
}
sub cookie {
my ($self, $value) = @_;
$self->{cookie} = $value if @_ > 1;
return $self->{cookie};
}
sub cookie_expires_in_min {
my ($self, $value) = @_;
$self->{cookie_expires_in_min} = $value if @_ > 1;
return $self->{cookie_expires_in_min};
}
sub count {
my ($self, $value) = @_;
$self->{count} = $value if @_ > 1;
return $self->{count};
}
sub count_sql_statement {
my ($self, $value) = @_;
$self->{count_sql_statement} = $value if @_ > 1;
return $self->{count_sql_statement};
}
sub css {
my ($self, $value) = @_;
$self->{css} = $value if @_ > 1;
return $self->{css};
}
sub data {
my ($self, $value) = @_;
$self->{data} = $value if @_ > 1;
return $self->{data};
}
sub db_access_params {
my ($self, $value) = @_;
$self->{db_access_params} = $value if @_ > 1;
return $self->{db_access_params};
}
sub db_display {
my ($self, $value) = @_;
$self->{db_display} = $value if @_ > 1;
return $self->{db_display};
}
sub dbh {
my ($self, $value) = @_;
$self->{dbh} = $value if @_ > 1;
return $self->{dbh};
}
sub db_selected {
my ($self, $value) = @_;
$self->{db_selected} = $value if @_ > 1;
return $self->{db_selected};
}
sub debug_info {
my ($self, $value) = @_;
$self->{debug_info} = $value if @_ > 1;
return $self->{debug_info};
}
sub debug_level {
my ($self, $value) = @_;
$self->{debug_level} = $value if @_ > 1;
return $self->{debug_level};
}
sub distinct {
my ($self, $value) = @_;
$self->{distinct} = $value if @_ > 1;
return $self->{distinct};
}
sub external_where_clauses {
my ($self, $value) = @_;
$self->{external_where_clauses} = $value if @_ > 1;
return $self->{external_where_clauses};
}
sub footer {
my ($self, $value) = @_;
$self->{footer} = $value if @_ > 1;
return $self->{footer};
}
sub formatted_data {
my ($self, $value) = @_;
$self->{formatted_data} = $value if @_ > 1;
return $self->{formatted_data};
}
sub go_to_results {
my ($self, $value) = @_;
$self->{go_to_results} = $value if @_ > 1;
return $self->{go_to_results};
}
sub group_by {
my ($self, $value) = @_;
$self->{group_by} = $value if @_ > 1;
return $self->{group_by};
}
sub header {
my ($self, $value) = @_;
$self->{header} = $value if @_ > 1;
return $self->{header};
}
sub instructions {
my ($self, $value) = @_;
$self->{instructions} = $value if @_ > 1;
return $self->{instructions};
}
sub method {
my ($self, $value) = @_;
$self->{method} = $value if @_ > 1;
return $self->{method};
}
sub modifications {
my ($self, $value) = @_;
$self->{modifications} = $value if @_ > 1;
return $self->{modifications};
}
sub modifier {
my ($self, $value) = @_;
$self->{modifier} = $value if @_ > 1;
return $self->{modifier};
}
sub new_search {
my ($self, $value) = @_;
$self->{new_search} = $value if @_ > 1;
return $self->{new_search};
}
sub no_reset {
my ($self, $value) = @_;
$self->{no_reset} = $value if @_ > 1;
return $self->{no_reset};
}
sub page_size {
my ($self, $value) = @_;
$self->{page_size} = $value if @_ > 1;
return $self->{page_size};
}
sub page_title {
my ($self, $value) = @_;
$self->{page_title} = $value if @_ > 1;
return $self->{page_title};
}
sub param_fields {
my ($self, $value) = @_;
$self->{param_fields} = $value if @_ > 1;
return $self->{param_fields};
}
sub query_sql_statement {
my ($self, $value) = @_;
$self->{query_sql_statement} = $value if @_ > 1;
return $self->{query_sql_statement};
}
sub search_form {
my ($self, $value) = @_;
$self->{search_form} = $value if @_ > 1;
return $self->{search_form};
}
sub session {
my ($self, $value) = @_;
$self->{session} = $value if @_ > 1;
return $self->{session};
}
sub session_id {
my ($self, $value) = @_;
$self->{session_id} = $value if @_ > 1;
return $self->{session_id};
}
sub show_search_url {
my ($self, $value) = @_;
$self->{show_search_url} = $value if @_ > 1;
return $self->{show_search_url};
}
sub sort_defaults {
my ($self, $value) = @_;
$self->{sort_defaults} = $value if @_ > 1;
return $self->{sort_defaults};
}
sub sort_fields {
my ($self, $value) = @_;
$self->{sort_fields} = $value if @_ > 1;
return $self->{sort_fields};
}
sub super_output_headers {
my ($self, $value) = @_;
$self->{super_output_headers} = $value if @_ > 1;
return $self->{super_output_headers};
}
sub temp_dir {
my ($self, $value) = @_;
$self->{temp_dir} = $value if @_ > 1;
return $self->{temp_dir};
}
sub temp_dir_eq {
my ($self, $value) = @_;
$self->{temp_dir_eq} = $value if @_ > 1;
return $self->{temp_dir_eq};
}
1;
__END__