894 lines
33 KiB
Perl
894 lines
33 KiB
Perl
# ==================================================================
|
|
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
|
#
|
|
# GT::SQL::Display::HTML
|
|
# Author: Scott & Alex
|
|
# $Id: HTML.pm,v 1.98 2009/03/23 22:55:53 brewt Exp $
|
|
#
|
|
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
# ==================================================================
|
|
#
|
|
# Description:
|
|
# HTML module that provides a set of method to control your
|
|
# user display in order to get rid of HTML coding inside CGI script.
|
|
#
|
|
|
|
package GT::SQL::Display::HTML;
|
|
# ===============================================================
|
|
use strict;
|
|
use vars qw/@ISA $AUTOLOAD $VERSION $ERROR_MESSAGE $ATTRIBS $DEBUG $FONT %SIZE_FORMS $INPUT_SEPARATOR/;
|
|
use GT::Base;
|
|
|
|
@ISA = qw/GT::Base/;
|
|
$FONT = 'face="Tahoma,Arial,Helvetica" size="2"';
|
|
$VERSION = sprintf "%d.%03d", q$Revision: 1.98 $ =~ /(\d+)\.(\d+)/;
|
|
$DEBUG = 0;
|
|
$ERROR_MESSAGE = 'GT::SQL';
|
|
$INPUT_SEPARATOR = "\n";
|
|
|
|
$ATTRIBS = {
|
|
db => undef,
|
|
input => undef,
|
|
mode => '',
|
|
code => {},
|
|
font => $FONT,
|
|
hide_timestamp => 0,
|
|
hide_download => 0,
|
|
file_field => 0,
|
|
file_delete => 0,
|
|
file_use_path => 0,
|
|
view_key => 0,
|
|
defaults => 0,
|
|
search_opts => 0,
|
|
values => {},
|
|
multiple => 0,
|
|
table => 'border="0" width="500"',
|
|
tr => '',
|
|
td => 'valign="top" align="left"',
|
|
extra_table => 1,
|
|
col_font => $FONT,
|
|
val_font => $FONT,
|
|
hide => [],
|
|
skip => [],
|
|
view => [],
|
|
disp_form => 1,
|
|
disp_html => 0,
|
|
url => $ENV{REQUEST_URI},
|
|
};
|
|
|
|
sub init {
|
|
# ---------------------------------------------------------------
|
|
# new() comes from GT::Base.
|
|
#
|
|
my $self = shift;
|
|
|
|
# Set any passed in options.
|
|
$self->set (@_);
|
|
|
|
# Try to set the URL
|
|
$self->{url} or eval { require GT::CGI; $self->{url} = GT::CGI->url(); };
|
|
$self->{url} ||= '';
|
|
|
|
# Make sure we have a database object.
|
|
# exists ($self->{db}) and (ref $self->{db}) or return $self->error ("BADARGS", "FATAL", "You must pass in a GT::SQL::Table object");
|
|
|
|
my $input = ref $self->{input};
|
|
if ($input and ($input eq 'GT::CGI')) {
|
|
$self->{input} = $self->{input}->get_hash;
|
|
}
|
|
elsif ($input and ($input eq 'CGI')) {
|
|
my $h = {};
|
|
foreach my $key ($self->{input}->param) {
|
|
$h->{$key} = $self->{input}->param($key);
|
|
}
|
|
$self->{input} = $h;
|
|
}
|
|
return $self;
|
|
}
|
|
|
|
sub reset_opts {
|
|
# ---------------------------------------------------------------
|
|
# Resets the display options.
|
|
#
|
|
my $self = shift;
|
|
while (my ($k, $v) = each %$ATTRIBS) {
|
|
next if $k eq 'db';
|
|
next if $k eq 'disp_form';
|
|
next if $k eq 'disp_html';
|
|
next if $k eq 'input';
|
|
if (! ref $v) {
|
|
$self->{$k} = $v;
|
|
}
|
|
elsif (ref $v eq 'HASH') {
|
|
$self->{$k} = {};
|
|
foreach my $k1 (keys %{$ATTRIBS->{$k}}) { $self->{$k}->{$k1} = $ATTRIBS->{$k}->{$k1}; }
|
|
}
|
|
elsif (ref $v eq 'ARRAY') {
|
|
$self->{$k} = [];
|
|
foreach my $v1 (@{$ATTRIBS->{$k}}) { push @{$self->{$k}}, $v1; }
|
|
}
|
|
else { $self->{$k} = $v; }
|
|
}
|
|
}
|
|
|
|
sub form {
|
|
# ---------------------------------------------------------------
|
|
# Display a record as an html form.
|
|
#
|
|
my $self = shift;
|
|
$_[0]->{disp_form} = 1;
|
|
$_[0]->{disp_html} = 0;
|
|
return $self->_display (@_);
|
|
}
|
|
|
|
sub display {
|
|
# ---------------------------------------------------------------
|
|
# Display a record as html.
|
|
#
|
|
my $self = shift;
|
|
$self->error ("NEEDSUBCLASS", "FATAL")
|
|
}
|
|
|
|
sub _get_defaults {
|
|
# -------------------------------------------------------------------
|
|
# Returns default values for fields. Bases it on what's passed in,
|
|
# cgi input, def file defaults, otherwise blank.
|
|
#
|
|
my $self = shift;
|
|
my @cols = $self->{db}->ordered_columns;
|
|
my $c = $self->{cols} || $self->{db}->cols;
|
|
my $values = {};
|
|
foreach my $col (@cols) {
|
|
my $value = '';
|
|
if (exists $self->{values}->{$col}) { $value = $self->{values}->{$col} }
|
|
elsif (exists $self->{input}->{$col}) { $value = $self->{input}->{$col} }
|
|
elsif ($self->{defaults} and exists $c->{$col}->{default}) {
|
|
if ($c->{$col}->{type} =~ /DATE|TIME|YEAR/) {
|
|
($c->{$col}->{default} =~ /0000/)
|
|
? ($value = $self->_get_time($c->{$col}))
|
|
: ($value = $c->{$col}->{default});
|
|
}
|
|
else {
|
|
$value = $c->{$col}->{default};
|
|
}
|
|
}
|
|
elsif ($self->{defaults} and $c->{$col}->{type} =~ /DATE|TIME|YEAR/) {
|
|
$value = $self->_get_time($c->{$col});
|
|
}
|
|
if ($c->{$col}->{form_type} and uc $c->{$col}->{form_type} eq 'FILE' ) {
|
|
for (qw/_filename _del/) {
|
|
$values->{$col.$_} = $self->{values}->{$col.$_} if exists $self->{values}->{$col.$_};
|
|
}
|
|
}
|
|
$values->{$col} = $value;
|
|
}
|
|
return $values;
|
|
}
|
|
|
|
sub _skip {
|
|
# -------------------------------------------------------------------
|
|
my ($self, $col) = @_;
|
|
|
|
# Skip timestamps, any fields requested to be skipped or any hidden fields (hidden forms appended at bottom).
|
|
return 1 if ($self->{hide_timestamp} and $self->{cols}->{$col}->{time_check});
|
|
return 1 if ($self->{skip} and (grep /^$col$/, @{$self->{skip}}));
|
|
return 1 if ($self->{hide} and (grep /^$col$/, @{$self->{hide}}));
|
|
return 0;
|
|
}
|
|
|
|
sub _get_form_display {
|
|
my ($self, $col) = @_;
|
|
|
|
if (
|
|
($self->{view_key} and
|
|
exists $self->{cols}->{$col}->{time_check} and
|
|
$self->{cols}->{$col}->{time_check})
|
|
||
|
|
($self->{view} and (grep /^$col$/, @{$self->{view}}))
|
|
)
|
|
{
|
|
return 'hidden_text';
|
|
}
|
|
|
|
my $form_type = lc $self->{cols}->{$col}->{form_type} or return 'default';
|
|
|
|
if ( $form_type eq 'password' and index( $self->{mode}, 'search_form' ) + 1 ) {
|
|
return 'default'
|
|
}
|
|
|
|
elsif ( $form_type and $self->can( $form_type ) ) {
|
|
return $form_type;
|
|
}
|
|
|
|
return 'default';
|
|
}
|
|
|
|
sub _get_html_display {
|
|
my $self = shift;
|
|
my $col = shift;
|
|
return 'display_text';
|
|
}
|
|
|
|
# Form types
|
|
sub default {
|
|
my ($self, $opts) = @_;
|
|
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to form creator _mk_char_form");
|
|
my $def = exists $opts->{def} ? $opts->{def} : return $self->error ("BADARGS", "FATAL", "No type hash passed to form creator _mk_char_form");
|
|
my $val = exists $opts->{value} ? $opts->{value} : (exists $def->{default} ? $def->{default} : '');
|
|
my $size = exists $opts->{form_size} ? $opts->{form_size} : (exists $def->{form_size} ? ($def->{form_size} || 30) : 30);
|
|
my $max = exists $opts->{size} ? $opts->{def}->{size} : (exists $def->{size} ? $def->{size} : 255);
|
|
|
|
defined ($val) or $val = '';
|
|
_escape(\$val);
|
|
return qq~<input type="text" name="$name" value="$val" maxlength="$max" size="$size" />~;
|
|
}
|
|
|
|
sub date {
|
|
my ($self, $opts) = @_;
|
|
$opts->{form_size} ||= 20;
|
|
return $self->text ($opts);
|
|
}
|
|
|
|
sub multiple { shift->select (@_) }
|
|
|
|
sub select {
|
|
# ---------------------------------------------------------------
|
|
# Make a select list. Valid options are:
|
|
# name => FORM_NAME
|
|
# values => { form_value => displayed_value }
|
|
# value => selected_value
|
|
# or
|
|
# value => [selected_value1, selected_value2]
|
|
# multiple => n - adds MULTIPLE SIZE=n to select list
|
|
# sort => coderef called to sort the list or array ref specifying the order in
|
|
# which the fields should be display. A code ref, when called, will be
|
|
# passed the following arguments: ($value{$a}, $value{$b}, $a, $b)
|
|
# blank => 1 or 0. If true, a blank first option will be printed, if false
|
|
# the blank first element will not be printed. Defaults to true.
|
|
my ($self, $opts) = @_;
|
|
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS1", "FATAL", "No form name passed to select");
|
|
my ($names, $values) = $self->_get_multi ($opts);
|
|
|
|
# Get the default value to display if nothing is selected.
|
|
my $def;
|
|
if (defined $opts->{value}) { $def = $opts->{value} }
|
|
else { $def = '' }
|
|
|
|
my %hash;
|
|
# Build key value pairs we can keep sorted
|
|
for (0 .. $#{$names}) {
|
|
$hash{$names->[$_]} = $values->[$_];
|
|
}
|
|
|
|
my ($sort_f, $sort_o);
|
|
if (ref $opts->{sort} eq 'CODE') {
|
|
$sort_f = $opts->{sort};
|
|
}
|
|
elsif (ref $opts->{sort} eq 'ARRAY') {
|
|
$sort_o = $opts->{sort};
|
|
}
|
|
# sort_order => [...] has been replaced with sort => [...] and so it
|
|
# is NOT mentioned in the subroutine comments.
|
|
elsif (ref $opts->{sort_order} eq 'ARRAY') {
|
|
$sort_o = $opts->{sort_order};
|
|
}
|
|
my $blank = exists $opts->{blank} ? $opts->{blank} : 1;
|
|
|
|
# Multiple was passed in
|
|
my $mult;
|
|
my $clean_name = $name;
|
|
if ($name =~ /^\d\-(.+)$/) {
|
|
$clean_name = $1;
|
|
}
|
|
if (exists $self->{cols}->{$clean_name} and $self->{cols}->{$clean_name}->{form_type} and $self->{cols}->{$clean_name}->{form_type} eq 'MULTIPLE') {
|
|
$mult = qq! multiple="multiple" size="$self->{cols}->{$clean_name}->{form_size}"!;
|
|
}
|
|
elsif (exists $opts->{multiple} and $opts->{multiple} > 1) {
|
|
$mult = qq! multiple="multiple" size="$opts->{multiple}"!;
|
|
}
|
|
elsif (exists $self->{cols}->{$clean_name} and $self->{cols}->{$clean_name}->{form_size}) {
|
|
$mult = qq! size="$self->{cols}->{$clean_name}->{form_size}"!;
|
|
}
|
|
else {
|
|
$mult = '';
|
|
}
|
|
my $class = ($opts->{def}->{class}) ? qq| class="$opts->{def}->{class}"| : "";
|
|
my $out = qq~<select$mult name="$name"$class>~;
|
|
$blank and ($out .= qq~<option value="">---</option>~);
|
|
|
|
# Figure out how to order this select list.
|
|
my @keys;
|
|
if ($sort_o) { @keys = @$sort_o }
|
|
elsif ($sort_f) { @keys = sort { $sort_f->($hash{$a}, $hash{$b}, $a, $b) } keys %hash }
|
|
else { @keys = @$names; }
|
|
|
|
if (! ref $def) {
|
|
$def = { map { ($_ => 1) } split (/\Q$INPUT_SEPARATOR\E%?/o, $def) };
|
|
}
|
|
else { # Array ref
|
|
$def = { map { ($_ => 1) } @$def };
|
|
}
|
|
for my $key (@keys) {
|
|
my $val = $hash{$key};
|
|
_escape(\$val);
|
|
$out .= qq~<option value="$key"~;
|
|
$out .= ' selected="selected"' if $def->{$key};
|
|
$out .= ">$val</option>";
|
|
}
|
|
$out .= "</select>\n";
|
|
return $out;
|
|
}
|
|
|
|
sub radio {
|
|
# ---------------------------------------------------------------
|
|
# Create a radio series.
|
|
#
|
|
my ($self, $opts) = @_;
|
|
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No name for field passed to radio");
|
|
my ($names, $values) = $self->_get_multi ($opts);
|
|
|
|
# Make sure we have something.
|
|
if (! @{$names} or ! @{$values}) {
|
|
return $self->error ("BADARGS", "FATAL", "No value hash passed to checkbox");
|
|
}
|
|
my $def;
|
|
if (defined $opts->{value}) { $def = $opts->{value} }
|
|
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
|
else { $def = '' }
|
|
|
|
my %hash;
|
|
# Build key value pairs we can keep sorted
|
|
for (0 .. $#{$names}) {
|
|
$hash{$names->[$_]} = $values->[$_];
|
|
}
|
|
|
|
my $sort_f = exists $opts->{sort} ? $opts->{sort} : sub { lc $hash{$a} cmp lc $hash{$b} };
|
|
my $sort_o = exists $opts->{sort_order} ? $opts->{sort_order} : '';
|
|
my $out;
|
|
|
|
# Figure out how to order this select list.
|
|
my @keys;
|
|
if ($sort_o) { @keys = @$sort_o; }
|
|
elsif ($sort_f) { @keys = sort { $sort_f->() } keys %hash; }
|
|
else { @keys = keys %hash; }
|
|
|
|
(ref $def eq 'ARRAY') or ($def = [$def]);
|
|
|
|
my $class = ($opts->{def}->{class}) ? qq| class="$opts->{def}->{class}"| : "";
|
|
KEY: foreach my $key (@keys) {
|
|
my $val = $hash{$key};
|
|
_escape(\$val);
|
|
VAL: foreach my $sel (@$def) {
|
|
($key eq $sel) and ($out .= qq~$val<input type="radio" value="$key"$class name="$name" checked="checked" /> ~) and next KEY;
|
|
}
|
|
$out .= qq~$val<input name="$name" type="radio" value="$key"$class /> ~;
|
|
}
|
|
return $out;
|
|
}
|
|
|
|
sub checkbox {
|
|
# ---------------------------------------------------------------
|
|
# Create a checkbox set.
|
|
#
|
|
my ($self, $opts) = @_;
|
|
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to select");
|
|
my ($names, $values) = $self->_get_multi ($opts);
|
|
|
|
# Make sure we have something.
|
|
if (! @{$names} or ! @{$values}) {
|
|
return $self->error ("BADARGS", "FATAL", "No value hash passed to checkbox");
|
|
}
|
|
my %hash;
|
|
# Build key value pairs we can keep sorted
|
|
for (0 .. $#{$names}) {
|
|
$hash{$names->[$_]} = $values->[$_];
|
|
}
|
|
|
|
my $def;
|
|
if (defined $opts->{value}) { $def = $opts->{value} }
|
|
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
|
else { $def = '' }
|
|
my $sort_f = exists $opts->{sort} ? $opts->{sort} : sub { lc $hash{$a} cmp lc $hash{$b} };
|
|
my $sort_o = exists $opts->{sort_order} ? $opts->{sort_order} : '';
|
|
my $out;
|
|
|
|
# Figure out how to order this select list.
|
|
my @keys;
|
|
if ($sort_o) { @keys = @$sort_o; }
|
|
elsif ($sort_f) { @keys = sort { $sort_f->() } keys %hash }
|
|
else { @keys = keys %hash }
|
|
|
|
if (! ref $def) {
|
|
$def = [sort split (/\Q$INPUT_SEPARATOR\E%?/o, $def)];
|
|
}
|
|
my $class = ($opts->{def}->{class}) ? qq| class="$opts->{def}->{class}"| : "";
|
|
KEY: foreach my $key (@keys) {
|
|
my $val = $hash{$key};
|
|
_escape(\$val);
|
|
VAL: foreach my $sel (@$def) {
|
|
($key eq $sel) and ($out .= qq~ <input name="$name" type="checkbox" value="$key" checked="checked"$class />$val~) and next KEY;
|
|
}
|
|
$out .= qq~ <input name="$name" type="checkbox" value="$key"$class />$val~;
|
|
}
|
|
return $out;
|
|
}
|
|
|
|
sub hidden {
|
|
# ---------------------------------------------------------------
|
|
# Create a hidden field.
|
|
#
|
|
my ($self, $opts) = @_;
|
|
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to select");
|
|
my $def;
|
|
if (defined $opts->{value}) { $def = $opts->{value} }
|
|
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
|
else { $def = '' }
|
|
_escape(\$def);
|
|
return qq~<input type="hidden" name="$name" value="$def" />~;
|
|
}
|
|
|
|
sub hidden_text {
|
|
my ($self, $opts) = @_;
|
|
my $out;
|
|
my $html = $self->_get_html_display;
|
|
$out .= "<font $self->{val_font}>";
|
|
$out .= $self->$html($opts);
|
|
my $def;
|
|
if (defined $opts->{value}) { $def = $opts->{value} }
|
|
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
|
elsif (exists $opts->{def}->{time_check}) { $def = $self->_get_time ($opts->{def}) }
|
|
else { $def = '' }
|
|
_escape(\$def);
|
|
$out .= qq~<input type="hidden" name="$opts->{name}" value="$def" /></font>~;
|
|
return $out;
|
|
}
|
|
|
|
sub file {
|
|
# ---------------------------------------------------------------
|
|
# creates a file field
|
|
#
|
|
# function is a bit large since it has to do a fair bit, with multiple options.
|
|
#
|
|
my ($self, $opts, $values, $display ) = @_;
|
|
|
|
$values ||= {};
|
|
$self->{file_field} or return $self->text($opts);
|
|
|
|
my @parts = split /\./, $opts->{name};
|
|
my $name = pop @parts;
|
|
my $dbname = shift @parts || $self->{db}->name;
|
|
my $prefix = $self->{db}->prefix;
|
|
$dbname =~ s,^$prefix,, if ($prefix);
|
|
|
|
my $def = $opts->{def};
|
|
my $out;
|
|
my $colname = $opts->{name}; $colname =~ s,^\d*-,,;
|
|
my $fname = $opts->{value};
|
|
_escape(\$fname);
|
|
|
|
# Find out if the file exists
|
|
my $tbl = $display->{db}->new_table( $dbname . "_Files" ) or return 'Associated _File table is missing';
|
|
my @pk = $self->{db}->pk; @pk == 1 or return 'File handling requires one primary key';
|
|
|
|
my $href = $tbl->get({ ForeignColName => $colname, ForeignColKey => $values->{$pk[0]} });
|
|
|
|
my $use_path = $self->{file_use_path} && -e $opts->{value};
|
|
if ($use_path or $href) {
|
|
|
|
require GT::SQL::File;
|
|
my $sfname = $values->{$colname."_filename"};
|
|
$out = $sfname || GT::SQL::File->get_filename($fname ||= $href->{File_Name});
|
|
$use_path and $out .= qq!<input name="$opts->{name}_path" type="hidden" value="$fname" />!;
|
|
$sfname and $out .= qq!<input type="hidden" name="$opts->{name}_filename" value="$sfname" />!;
|
|
|
|
if ( $fname and $self->{file_delete} ) {
|
|
|
|
if ( $def->{form_type} =~ /^file$/i and not $self->{hide_downloads} and $self->{url} ) {
|
|
my $url = _reparam_url(
|
|
$self->{url},
|
|
{
|
|
do => 'download_file',
|
|
id => $values->{$pk[0]},
|
|
cn => $colname,
|
|
db => $dbname,
|
|
src => $use_path ? 'path' : 'db',
|
|
fname => $fname
|
|
},
|
|
[qw( do id cn db src )]
|
|
);
|
|
$out .= qq! <font $self->{font}><font size="1"><i><a href="$url">download</a></i></font></font>!;
|
|
$url = _reparam_url(
|
|
$self->{url},
|
|
{
|
|
do => 'view_file',
|
|
id => $values->{$pk[0]},
|
|
cn => $colname,
|
|
db => $dbname,
|
|
src => $use_path ? 'path' : 'db',
|
|
fname => $fname
|
|
},
|
|
[qw( do id cn db src )]
|
|
);
|
|
$out .= qq! <font $self->{font}><font size="1"><i><a href="$url" target="_blank">view</a></i></font></font>!;
|
|
}
|
|
my $checked = $values->{"${colname}_del"} ? ' checked="checked" ' : '';
|
|
$out .= qq~ <input type="checkbox" name="$opts->{name}_del" value="delete"$checked /> Delete~;
|
|
}
|
|
}
|
|
my $class = ($opts->{def}->{class}) ? qq| class="$opts->{def}->{class}"| : "";
|
|
$out .= qq~<input type="file" name="$opts->{name}"$class />~;
|
|
|
|
return $out;
|
|
}
|
|
|
|
sub text {
|
|
# ---------------------------------------------------------------
|
|
# Create a text field.
|
|
#
|
|
my ($self, $opts) = @_;
|
|
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to select");
|
|
my $size = $opts->{def}->{form_size} ? $opts->{def}->{form_size} : $SIZE_FORMS{uc $opts->{def}->{type}};
|
|
$size ||= 20;
|
|
my $def;
|
|
if (defined $opts->{value}) { $def = $opts->{value} }
|
|
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
|
else { $def = '' }
|
|
_escape(\$def);
|
|
my $class = ($opts->{def}->{class}) ? qq| class="$opts->{def}->{class}"| : "";
|
|
return qq~<input type="text" name="$name" value="$def" size="$size"$class />~;
|
|
}
|
|
|
|
sub password {
|
|
# ---------------------------------------------------------------
|
|
# Create a password field.
|
|
#
|
|
my ($self, $opts) = @_;
|
|
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to select");
|
|
my $size = $opts->{def}->{form_size} ? $opts->{def}->{form_size} : $SIZE_FORMS{uc $opts->{def}->{type}};
|
|
$size ||= 20;
|
|
my $def;
|
|
if ( $opts->{blank} ) { $def = '' } # keep the password element blank
|
|
elsif (defined $opts->{value}) { $def = $opts->{value} }
|
|
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
|
else { $def = '' }
|
|
_escape(\$def);
|
|
my $class = ($opts->{def}->{class}) ? qq| class="$opts->{def}->{class}"| : "";
|
|
return qq~<input type="password" name="$name" value="$def" size="$size"$class />~;
|
|
}
|
|
|
|
sub textarea {
|
|
# ---------------------------------------------------------------
|
|
# Create a textarea.
|
|
#
|
|
my ($self, $opts) = @_;
|
|
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to select");
|
|
my $size = $opts->{def}->{form_size} ? $opts->{def}->{form_size} : $SIZE_FORMS{uc $opts->{def}->{type}};
|
|
$size ||= 20;
|
|
my ($cols, $rows) = (ref $size) ? (@{$size}) : ($size, 4);
|
|
|
|
my $def;
|
|
if (defined $opts->{value}) { $def = $opts->{value} }
|
|
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
|
else { $def = '' }
|
|
_escape(\$def);
|
|
my $class = ($opts->{def}->{class}) ? qq| class="$opts->{def}->{class}"| : "";
|
|
return qq~<textarea rows="$rows" cols="$cols" name="$name"$class>\n$def</textarea>~;
|
|
}
|
|
|
|
sub display_text {
|
|
# ---------------------------------------------------------------
|
|
my $self = shift;
|
|
my $opts = shift or return $self->error ("BADARGS", "FATAL", "No hash ref passed to form creator display_text");
|
|
my $values = shift;
|
|
my $def = exists $opts->{def} ? $opts->{def} : return $self->error ("BADARGS", "FATAL", "No type hash passed to view creator display_text (" . (caller())[2] . ")" );
|
|
my $val = exists $opts->{value} ? $opts->{value} : (exists $def->{default} ? $def->{default} : '');
|
|
my $pval = $val;
|
|
defined $val or ($val = '');
|
|
_escape(\$val);
|
|
|
|
# If they are using checkbox/radio/selects then we map form_names => form_values.
|
|
if (ref $def->{form_names} and ref $def->{form_values}) {
|
|
if (@{$def->{form_names}} and @{$def->{form_values}}) {
|
|
my %map = map { $def->{form_names}->[$_] => $def->{form_values}->[$_] } (0 .. $#{$def->{form_names}});
|
|
my @keys = split /\Q$INPUT_SEPARATOR\E|\n/, $val;
|
|
$val = '';
|
|
|
|
foreach (@keys) {
|
|
$val .= $map{$_} ? $map{$_} : $_;
|
|
$val .= "<br />";
|
|
}
|
|
}
|
|
}
|
|
|
|
if ($def->{form_type} and uc $def->{form_type} eq 'FILE' and not $self->{hide_downloads} and $self->{url}) {
|
|
$pval or return $val;
|
|
|
|
my @parts = split /\./, $opts->{name};
|
|
my $name = pop @parts;
|
|
my $dbname = shift @parts || $self->{db}->name;
|
|
my $prefix = $self->{db}->prefix;
|
|
$dbname =~ s,^$prefix,, if ($prefix);
|
|
my $colname = $opts->{name}; $colname =~ s,^$dbname\.,,g;
|
|
|
|
my @pk = $self->{db}->pk; @pk == 1 or return;
|
|
my $url = _reparam_url( $self->{url}, { do => 'download_file', id => $values->{$pk[0]}, cn => $colname, db => $dbname }, [qw( do id cn db )] );
|
|
$val .= qq! <font $self->{font}><font size="1"><i><a href="$url">download</a></i></font></font>!;
|
|
|
|
$url = _reparam_url( $self->{url}, { do => 'view_file', id => $values->{$pk[0]}, cn => $colname, db => $dbname }, [qw( do id cn db )] );
|
|
$val .= qq! <font $self->{font}><font size="1"><i><a href="$url" target="_blank">view</a></i></font></font>!;
|
|
}
|
|
|
|
return $val;
|
|
}
|
|
|
|
sub _reparam_url {
|
|
# ---------------------------------------------------------------
|
|
my $orig_url = shift;
|
|
my $add = shift || {};
|
|
my $remove = shift || [];
|
|
my %params = ();
|
|
my $new_url = $orig_url;
|
|
|
|
# get the original parameters
|
|
my $qloc = index( $orig_url, '?');
|
|
if ( $qloc > 0 ) {
|
|
require GT::CGI;
|
|
$new_url = substr( $orig_url, 0, $qloc );
|
|
my $base_parms = substr( $orig_url, $qloc+1 );
|
|
$base_parms = GT::CGI::unescape($base_parms);
|
|
|
|
# now parse the parameters
|
|
foreach my $param ( grep $_, split /[&;]/, $base_parms ) {
|
|
my $eloc = index( $param, '=' );
|
|
$eloc < 0 and push( @{$params{$param} ||= []}, undef ), next;
|
|
my $key = substr( $param, 0, $eloc );
|
|
my $value = substr( $param, $eloc+1 );
|
|
push( @{$params{$key} ||= []}, $value);
|
|
}
|
|
}
|
|
|
|
# delete a few parameters
|
|
foreach my $param ( @$remove ) { delete $params{$param}; }
|
|
|
|
# add a few parameters
|
|
foreach my $key ( keys %$add ) {
|
|
push( @{$params{$key} ||= []}, $add->{$key});
|
|
}
|
|
|
|
# put everything together
|
|
require GT::CGI;
|
|
my @params;
|
|
foreach my $key ( keys %params ) {
|
|
foreach my $value ( @{$params{$key}} ) {
|
|
push @params, GT::CGI::escape($key).'='.GT::CGI::escape($value);
|
|
}
|
|
}
|
|
$new_url .= "?" . join( '&', @params );
|
|
return $new_url;
|
|
}
|
|
|
|
sub toolbar {
|
|
# ---------------------------------------------------------------
|
|
# Display/calculate a "next hits" toolbar.
|
|
#
|
|
my $class = shift;
|
|
my ($nh, $maxhits, $numhits, $script) = @_;
|
|
my ($next_url, $max_page, $next_hit, $prev_hit, $left, $right, $upper, $lower, $first, $url, $last, $i);
|
|
|
|
# Return if there shouldn't be a speedbar.
|
|
return unless ($numhits > $maxhits);
|
|
|
|
# Strip nh=\d out of the query string, as we need to append it on. Try and keep
|
|
# the url looking nice (i.e. no double ;&, or extra ?.
|
|
$script =~ s/[&;]nh=\d+([&;]?)/$1/;
|
|
$script =~ s/\?nh=\d+[&;]?/\?/;
|
|
($script =~ /\?/) or ($script .= "?");
|
|
$script =~ s/&/&/g;
|
|
$next_hit = $nh + 1;
|
|
$prev_hit = $nh - 1;
|
|
$maxhits ||= 25;
|
|
$max_page = int ($numhits / $maxhits) + (($numhits % $maxhits) ? 1 : 0);
|
|
|
|
# First, set how many pages we have on the left and the right.
|
|
$left = $nh; $right = int($numhits/$maxhits) - $nh;
|
|
# Then work out what page number we can go above and below.
|
|
($left > 7) ? ($lower = $left - 7) : ($lower = 1);
|
|
($right > 7) ? ($upper = $nh + 7) : ($upper = int($numhits/$maxhits) + 1);
|
|
# Finally, adjust those page numbers if we are near an endpoint.
|
|
(7 - $nh >= 0) and ($upper = $upper + (8 - $nh));
|
|
($nh > ($numhits/$maxhits - 7)) and ($lower = $lower - ($nh - int($numhits/$maxhits - 7) - 1));
|
|
$url = "";
|
|
# Then let's go through the pages and build the HTML.
|
|
($nh > 1) and ($url .= qq~<a href="$script;nh=1">[<<]</a> ~);
|
|
($nh > 1) and ($url .= qq~<a href="$script;nh=$prev_hit">[<]</a> ~);
|
|
for ($i = 1; $i <= int($numhits/$maxhits) + 1; $i++) {
|
|
if ($i < $lower) { $url .= " ... "; $i = ($lower-1); next; }
|
|
if ($i > $upper) { $url .= " ... "; last; }
|
|
($i == $nh) ?
|
|
($url .= qq~$i ~) :
|
|
($url .= qq~<a href="$script&nh=$i">$i</a> ~);
|
|
if ($i * $maxhits == $numhits) { $nh == $i and $next_hit = $i; last; }
|
|
}
|
|
$url .= qq~<a href="$script;nh=$next_hit">[>]</a> ~ unless ($next_hit == $nh or ($nh * $maxhits > $numhits));
|
|
$url .= qq~<a href="$script;nh=$max_page">[>>]</a> ~ unless ($next_hit == $nh or ($nh * $maxhits > $numhits));
|
|
return $url;
|
|
}
|
|
|
|
sub escape {
|
|
# ---------------------------------------------------------------
|
|
# Public wrapper to private method.
|
|
#
|
|
return _escape ($_[1]);
|
|
}
|
|
|
|
# ================================================================================ #
|
|
# SEARCH WIDGETS #
|
|
# ================================================================================ #
|
|
|
|
sub _mk_search_opts {
|
|
# ---------------------------------------------------------------
|
|
# Create the search options boxes based on type.
|
|
#
|
|
my $self = shift;
|
|
my $opts = shift or return $self->error ("BADARGS", "FATAL", "No hash ref passed to form creator _mk_search_opts");
|
|
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to form creator _mk_search_opts");
|
|
my $def = exists $opts->{def} ? $opts->{def} : return $self->error ("BADARGS", "FATAL", "No type hash passed to form creator _mk_search_opts");
|
|
my $val = '';
|
|
CASE: {
|
|
exists $opts->{value} and $val = $opts->{value}, last CASE;
|
|
exists $self->{input}->{"$name-opt"} and $val = $self->{input}->{"$name-opt"}, last CASE;
|
|
$opts->{pk} and $val = '=', last CASE;
|
|
$opts->{unique} and $val = '=', last CASE;
|
|
}
|
|
$val = '>' if $val eq '>';
|
|
$val = '<' if $val eq '<';
|
|
|
|
my $type = $def->{type};
|
|
|
|
my ($hash, $so);
|
|
CASE: {
|
|
($type =~ /INT|FLOAT|DOUBLE|DECIMAL/i)
|
|
and $hash = { 'LIKE' => 'Like', '=' => 'Exact Match', '<>' => 'Not Equal', '>' => 'Greater Than', '<' => 'Less Than' },
|
|
$so = [ 'LIKE', '=', '<>', '>', '<' ],
|
|
$val ||= '=', last CASE;
|
|
($type =~ /CHAR/i)
|
|
and $hash = { 'LIKE' => 'Like', '=' => 'Exact Match', '<>' => 'Not Equal', },
|
|
$so = [ 'LIKE', '=', '<>' ], last CASE;
|
|
($type =~ /DATE|TIME/i)
|
|
and $hash = { '=' => 'Exact Match', '<>' => 'Not Equal', '>' => 'Greater Than', '<' => 'Less Than' },
|
|
$so = [ '=', '>', '<', '<>' ], last CASE;
|
|
}
|
|
|
|
if ($hash) {
|
|
return $self->select( { name => "$name-opt", values => $hash, sort_order => $so, value => $val, def => $def, blank => 0 } );
|
|
}
|
|
else {
|
|
return undef;
|
|
}
|
|
}
|
|
|
|
# ================================================================================ #
|
|
# UTILS #
|
|
# ================================================================================ #
|
|
|
|
sub _escape {
|
|
# ---------------------------------------------------------------
|
|
# Escape HTML quotes and < and >.
|
|
#
|
|
my $t = shift;
|
|
return unless $$t;
|
|
$$t =~ s/&/&/g;
|
|
$$t =~ s/"/"/g;
|
|
$$t =~ s/</</g;
|
|
$$t =~ s/>/>/g;
|
|
}
|
|
|
|
sub _get_time {
|
|
# ---------------------------------------------------------------
|
|
# Return current time for timestamp field.
|
|
#
|
|
my ($self, $col) = @_;
|
|
my ($sec,$min,$hr,$day,$mon,$yr) = (localtime())[0..5];
|
|
my $val;
|
|
$mon++; $yr = $yr + 1900;
|
|
($sec < 10) and ($sec = "0$sec"); ($min < 10) and ($min = "0$min"); ($hr < 10) and ($hr = "0$hr");
|
|
($day < 10) and ($day = "0$day"); ($mon < 10) and ($mon = "0$mon");
|
|
CASE: {
|
|
($col->{type} =~ /DATETIME|TIMESTAMP/) and ($val = "$yr-$mon-$day $hr:$min:$sec"), last CASE;
|
|
($col->{type} =~ /DATE/) and ($val = "$yr-$mon-$day"), last CASE;
|
|
($col->{type} =~ /YEAR/) and ($val = "$yr"), last CASE;
|
|
}
|
|
return $val;
|
|
}
|
|
|
|
sub _get_multi {
|
|
my ($self, $opts) = @_;
|
|
my ($names, $values) = ([], []);
|
|
$opts->{def} ||= $self->{db}->{schema}->{cols}->{$opts->{name}};
|
|
|
|
# Deep copy $opts->{def} => $def
|
|
my $def = {};
|
|
while (my ($k, $v) = each %{$opts->{def}}) {
|
|
if (! ref $v) {
|
|
$def->{$k} = $v;
|
|
}
|
|
elsif (ref $v eq 'HASH') {
|
|
$def->{$k} = {};
|
|
foreach my $k1 (keys %{$opts->{def}->{$k}}) { $def->{$k}->{$k1} = $opts->{def}->{$k}->{$k1}; }
|
|
}
|
|
elsif (ref $v eq 'ARRAY') {
|
|
$def->{$k} = [];
|
|
foreach my $v1 (@{$opts->{def}->{$k}}) { push @{$def->{$k}}, $v1; }
|
|
}
|
|
else { $def->{$k} = $v; }
|
|
}
|
|
if (
|
|
(exists $def->{form_names}) and
|
|
(ref ($def->{form_names}) eq 'ARRAY') and
|
|
(@{$def->{form_names}})
|
|
)
|
|
{
|
|
$names = $def->{form_names};
|
|
}
|
|
elsif (
|
|
(exists $def->{values}) and
|
|
(ref ($def->{values}) eq 'ARRAY') and
|
|
(@{$def->{values}})
|
|
)
|
|
{
|
|
$names = $def->{values};
|
|
}
|
|
|
|
# Get the values.
|
|
if (
|
|
(exists $def->{form_values}) and
|
|
(ref ($def->{form_values}) eq 'ARRAY') and
|
|
(@{$def->{form_values}})
|
|
)
|
|
{
|
|
$values = $def->{form_values};
|
|
}
|
|
elsif (
|
|
(exists $def->{values}) and
|
|
(ref ($def->{values}) eq 'ARRAY') and
|
|
(@{$def->{values}})
|
|
)
|
|
{
|
|
$values = $def->{values};
|
|
}
|
|
|
|
# Can pass in a hash here.
|
|
if (
|
|
(exists $opts->{values}) and
|
|
(ref ($opts->{values}) eq 'HASH') and
|
|
(keys %{$opts->{values}})
|
|
)
|
|
{
|
|
@{$names} = keys %{$opts->{values}};
|
|
@{$values} = values %{$opts->{values}};
|
|
}
|
|
|
|
@{$names} or @{$names} = @{$values};
|
|
@{$values} or @{$values} = @{$names};
|
|
|
|
return ($names, $values);
|
|
}
|
|
|
|
1;
|
|
|
|
# Options for display forms/views:
|
|
# hide_timestamp => 1 # Do not display timestamp fields
|
|
# search_opts => 1 # Add search options boxes.
|
|
# multiple => 1 # Prepend $multiple- to column names.
|
|
# defaults => 1 # Use .def defaults.
|
|
# values => {} # hash ref of values to use (overrides input)
|
|
# table => 'string' # table properties, defaults to 0 border.
|
|
# tr => 'string' # table row properties, defaults to none.
|
|
# td => 'string' # table cell properties, defaults to just aligns.
|
|
# extra_table => 0 # disable wrap form in extra table for looks.
|
|
# col_font => 'string' # font to use for columns, defaults to $FONT.
|
|
# val_font => 'string' # font to use for values, defaults to $FONT.
|
|
# hide => [] # display fields as hidden tags.
|
|
# view => [] # display fields as html with hidden tags as well.
|
|
# skip => [] # don't display array of column names.
|