saint/discourse-legacysite-perl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

First pass at adding key files

Browse Source
This commit is contained in:
dsainty
2024-06-17 21:49:12 +10:00
commit aa25e9347f
1274 changed files with 392549 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3042
site/glist/lib/GT/SQL/Admin.pm Normal file
View File

File diff suppressed because it is too large Load Diff

609
site/glist/lib/GT/SQL/Base.pm Normal file
View File

@ -0,0 +1,609 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Table
# CVS Info :
# $Id: Base.pm,v 1.69 2004/09/22 02:43:29 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description:
# Base class for GT::SQL::Table and GT::SQL::Relation
#
package GT::SQL::Base;
# ===============================================================
use GT::Base;
use GT::AutoLoader;
use strict;
use vars qw($ERRORS $DEBUG @ISA $VERSION $ERROR_MESSAGE);
@ISA = qw/GT::Base/;
$DEBUG = 0;
$VERSION = sprintf "%d.%03d", q$Revision: 1.69 $ =~ /(\d+)\.(\d+)/;
$ERROR_MESSAGE = 'GT::SQL';
# ============================================================================ #
# TABLE ACCESSSOR #
# ============================================================================ #
sub table {
# -------------------------------------------------------------------
# Returns a table or relation argument. Called with array of table names:
# my $relation = $db->table('Links', 'CatLinks', 'Category');
# my $table = $db->table('Links');
#
my ($self, @tables) = @_;
# Make sure we have a driver, and a list of tables were specified.
$self->{connect} or return $self->fatal(NODATABASE => 'table()');
@tables or return $self->fatal(BADARGS => 'Usage: $obj->table(@TABLES)');
for (@tables) { # Tables aren't passed to table() prefixed, so prefix them all.
$_ = $self->{connect}->{PREFIX} . $_;
}
my $cache_key = join("\0", @tables, $self->{connect}->{def_path});
$cache_key = (@tables > 1 ? "RELATION\0" : "TABLE\0") . $cache_key;
$self->{cache} and exists $GT::SQL::OBJ_CACHE{$cache_key} and return $GT::SQL::OBJ_CACHE{$cache_key};
my $obj;
if (@tables > 1) {
$obj = $self->new_relation(@tables);
}
else {
my $name = $self->{connect}->{def_path} . '/' . $tables[0] . '.def';
(-e $name) or return $self->fatal(FILENOEXISTS => $name);
$obj = $self->new_table($tables[0]);
}
# We don't need to worry about caching here - new_relation or new_table will add it to the cache.
return $obj;
}
# ============================================================================ #
# EDITOR ACCESSSOR #
# ============================================================================ #
$COMPILE{editor} = __LINE__ . <<'END_OF_SUB';
sub editor {
# -------------------------------------------------------------------
# Returns an editor object. Takes a table name as argument.
# my $editor = $db->editor('Links')
#
my $self = shift;
my $table_name = shift or return $self->fatal(BADARGS => 'Usage: $db->editor(\'tablename\')');
$self->{connect}->{driver} or return $self->fatal(NODATABASE => 'editor()');
my $table = $self->table($table_name);
# Set the error package to reflect the editor
$table->{_err_pkg} = 'GT::SQL::Editor';
$table->{_err_pkg} = 'GT::SQL::Editor';
# Get an editor object
require GT::SQL::Editor;
$self->debug("CREATING GT::SQL::Editor OBJECT") if $self->{_debug} > 2;
return GT::SQL::Editor->new(
debug => $self->{_debug},
table => $table,
connect => $self->{connect}
);
}
END_OF_SUB
$COMPILE{prefix} = __LINE__ . <<'END_OF_SUB';
sub prefix {
my $self = shift;
return $self->{connect}->{PREFIX};
}
END_OF_SUB
sub new_table {
# -------------------------------------------------------------------
# Creates a table object for a single table.
#
my ($self, $table) = @_;
my $cache_key = "TABLE\0$table\0$self->{connect}->{def_path}";
if ($self->{connect}->{obj_cache} and my $cached = $GT::SQL::OBJ_CACHE{$cache_key}) {
$self->debug("Returning table object for $table from cache") if $self->{_debug} and $self->{_debug} >= 2;
return $cached;
}
$self->debug("Creating new table object for $table") if $self->{_debug} and $self->{_debug} >= 2;
# Create a blank table object.
my $table_obj = GT::SQL::Table->new(
name => $table, # Already prefixed in schema
connect => $self->{connect},
debug => $self->{_debug},
_err_pkg => 'GT::SQL::Table'
);
# Create a new object if we are subclassed.
my $subclass = $table_obj->subclass;
my $name = $table_obj->name;
my $class = $subclass->{table}->{$name} || 'GT::SQL::Table';
if ($subclass and $subclass->{table}->{$name}) {
no strict 'refs';
$self->_load_module($class) or return;
my $errors = defined ${$class . "::ERRORS"} ? ${$class . "::ERRORS"} : {};
foreach (keys %$errors) {
$ERRORS->{$_} = $errors->{$_};
}
use strict 'refs';
$table_obj = $class->new(
name => $name, # Already prefixed in schema
connect => $self->{connect},
debug => $self->{_debug},
_err_pkg => 'GT::SQL::Table',
_schema => $table_obj->{schema}
);
}
$self->debug("CREATING $class OBJECT") if $self->{_debug} and $self->{_debug} > 2;
$GT::SQL::OBJ_CACHE{$cache_key} = $table_obj if $self->{connect}->{obj_cache};
return $table_obj;
}
sub new_relation {
# -------------------------------------------------------------------
# Creates the table objects and relation object for multi-table tasks.
# Internal use. Call table instead.
#
my ($self, @tables) = @_;
my $href = {};
my $tables_ord = [];
my $tables = {};
require GT::SQL::Relation;
my $cache_key = join "\0", "RELATION", @tables, $self->{connect}->{def_path};
if ($self->{connect}->{obj_cache} and my $cached = $GT::SQL::OBJ_CACHE{$cache_key}) {
$self->debug("Returning relation object for @tables from cache") if $self->{_debug} and $self->{_debug} >= 2;
return $cached;
}
# Build our hash of prefixed table name to table object.
foreach my $table (@tables) {
$self->debug("CREATING GT::SQL::Table OBJECT") if $self->{_debug} and $self->{_debug} > 2;
my $tmp = $self->new_table($table);
my $name = $tmp->name;
push @$tables_ord, $name;
$tables->{$name} = $tmp;
}
# Get our driver, class name and key to look up subclasses (without prefixes).
my $class = 'GT::SQL::Relation';
my $prefix = $self->{connect}->{PREFIX};
my $subclass_key = join "\0", map { s/^$prefix//; $_ } sort keys %{$tables};
# Look for any subclass to use, and load any error messages.
no strict 'refs';
foreach my $table (values %{$tables}) {
my $subclass = $table->subclass;
if ((!exists $self->{subclass} or $self->{subclass}) and exists $subclass->{relation}->{$prefix . $subclass_key}) {
$class = $subclass->{relation}->{$prefix . $subclass_key};
my $errors = defined ${$class . "::ERRORS"} ? ${$class . "::ERRORS"} : next;
foreach (keys %$errors) {
$ERRORS->{$_} = $errors->{$_};
}
}
}
use strict 'refs';
# Load our relation object.
$self->debug("CREATING $class OBJECT") if $self->{_debug} and $self->{_debug} > 2;
$self->_load_module($class) or return;
my $rel = $class->new(
tables => $tables,
debug => $self->{_debug},
connect => $self->{connect},
_err_pkg => 'GT::SQL::Relation',
tables_ord => $tables_ord
);
$GT::SQL::OBJ_CACHE{$cache_key} = $rel if ($self->{connect}->{obj_cache});
return $rel;
}
# ============================================================================ #
# CREATOR ACCESSSOR #
# ============================================================================ #
$COMPILE{creator} = __LINE__ . <<'END_OF_SUB';
sub creator {
# -------------------------------------------------------------------
# Returns a creator object. Takes a table name as argument.
# my $creator = $db->creator('Links')
#
my $self = shift;
my $table_name = shift or return $self->fatal(BADARGS => 'Usage: $db->creator(\'tablename\')');
$self->{connect}->{driver} or return $self->fatal(NODATABASE => 'creator()');
my $name = $self->{connect}->{PREFIX} . $table_name;
# Create either an empty schema or use an old one.
$self->debug("Creating new GT::SQL::Table object '$table_name' to be used in Creator.") if ($self->{_debug} > 2);
my $table = GT::SQL::Table->new(
name => $table_name,
connect => $self->{connect},
debug => $self->{_debug},
_err_pkg => 'GT::SQL::Creator'
);
# Return a creator object.
require GT::SQL::Creator;
$self->debug("CREATING GT::SQL::Creator OBJECT") if $self->{_debug} > 2;
return GT::SQL::Creator->new(
table => $table,
debug => $self->{_debug},
connect => $self->{connect}
);
}
END_OF_SUB
sub connect {
# -------------------------------------------------------------------
# Loads a driver object, and connects.
#
my $self = shift;
return 1 if $self->{driver};
$self->{connect} or return $self->fatal('NOCONNECT');
my $driver = uc $self->{connect}->{driver} || 'MYSQL';
$self->{driver} = GT::SQL::Driver->load_driver(
$driver,
schema => $self->{tables} || $self->{schema},
name => scalar $self->name,
connect => $self->{connect},
debug => $self->{_debug},
_err_pkg => $self->{_err_pkg}
) or return $self->fatal(CANTLOAD => $driver, $GT::SQL::error);
unless ($self->{driver}->connect) {
delete $self->{driver};
return;
}
return 1;
}
sub count {
# -------------------------------------------------------------------
# $obj->count;
# ------------
# Returns the number of tuples handled
# by this relation.
#
# $obj->count($condition);
# -------------------------
# Returns the number of tuples that matches
# that $condition.
#
my $self = shift;
my @cond;
if (!ref $_[0] and @_ % 2 == 0 and defined $_[0]) {
push @cond, {@_};
}
else {
for (@_) {
return $self->fatal(BADARGS => 'Arguments to count() must either be a hash, or one or more hash refs and/or GT::SQL::Condition objects')
unless ref eq 'GT::SQL::Condition' or ref eq 'HASH';
push @cond, $_;
}
}
my $sel_opts = $self->{sel_opts};
$self->{sel_opts} = [];
my $sth = $self->select('COUNT(*)' => @cond ? GT::SQL::Condition->new(@cond) : ()) or return;
$self->{sel_opts} = $sel_opts;
return int $sth->fetchrow;
}
$COMPILE{total} = __LINE__ . <<'END_OF_SUB';
sub total {
# -------------------------------------------------------------------
# total()
# IN : none
# OUT: total number of records in table
#
shift->count
}
END_OF_SUB
$COMPILE{quote} = __LINE__ . <<'END_OF_SUB';
sub quote {
# -------------------------------------------------------------------
# $obj->quote($value);
# ---------------------
# Returns the quoted representation of $value.
#
return GT::SQL::Driver::quote(pop)
}
END_OF_SUB
$COMPILE{hits} = __LINE__ . <<'END_OF_SUB';
sub hits {
# -----------------------------------------------------------
# hits()
# IN : none
# OUT: number of results in last search. (calls count(*) on
# demand from hits() or toolbar())
#
my $self = shift;
if (! defined $self->{last_hits}) {
$self->{last_hits} = (defined $self->{last_where} ? $self->count($self->{last_where}) : $self->count) || 0;
}
return $self->{last_hits};
}
END_OF_SUB
$COMPILE{_cgi_to_hash} = __LINE__ . <<'END_OF_SUB';
sub _cgi_to_hash {
# -------------------------------------------------------------------
# Internal Use
# $self->_cgi_to_hash($in);
# --------------------------
# Creates a hash ref from a cgi object.
#
my ($self, $cgi) = @_;
defined $cgi and ref $cgi =~ /CGI/ or return $self->fatal(BADARGS => "'$cgi' is not a CGI object");
my @keys = $cgi->param;
my $result = {};
for my $key (@keys) {
my @values = $cgi->param($key);
$result->{$key} = @values == 1 ? $values[0] : \@values;
}
return $result;
}
END_OF_SUB
$COMPILE{_get_search_opts} = __LINE__ . <<'END_OF_SUB';
sub _get_search_opts {
# -------------------------------------------------------------------
# Internal Use
# _get_search_opts($hash_ref);
# ----------------------------
# Gets the search options based on the hash ref
# passed in.
#
# sb => field_list # Return results sorted by field list.
# so => [ASC|DESC] # Sort order of results.
# mh => n # Return n results maximum, default to 25.
# nh => n # Return the n'th set of results, default to 1.
# rs => [col, col2] # A list of columns you want returned
#
my $self = shift;
my $opt_r = shift;
my $ret = {};
$ret->{nh} = (defined $opt_r->{nh} and $opt_r->{nh} =~ /^(\d+)$/) ? $1 : 1;
$ret->{mh} = (defined $opt_r->{mh} and $opt_r->{mh} =~ /^(-?\d+)$/) ? $1 : 25;
$ret->{so} = (defined $opt_r->{so} and $opt_r->{so} =~ /^(ASC|DESC)$/i) ? $1 : '';
$ret->{sb} = (defined $opt_r->{sb} and $opt_r->{sb} =~ /^([\w\s,.]+)$/) ? $1 : '';
# You can pass in 'Col ASC, Col2 DESC' in {sb} so we need to remove sort order then.
if ((lc $ret->{sb}) =~ /\s(?:asc|desc)/) {
$ret->{so} = '';
}
if (defined $ret->{rs} and ref $ret->{rs} eq 'ARRAY') {
my @valid;
foreach my $col (@{$ret->{rs}}) {
$col =~ /^([\w\s,]+)$/ and push @valid, $1;
}
$ret->{rs} = \@valid;
}
else {
$ret->{rs} = (defined $opt_r->{rs} and $opt_r->{rs} =~ /^([\w\s,]+)$/) ? $1 : '';
}
return $ret;
}
END_OF_SUB
# Transitional support. build_query_cond _was_ a private method
$COMPILE{_build_query_cond} = __LINE__ . <<'END_OF_SUB';
sub _build_query_cond {
my $self = shift;
warn "obj->_build_query_cond() is deprecated; use obj->build_query_cond()" if $self->{_debug};
$self->build_query_cond(@_)
}
END_OF_SUB
$COMPILE{build_query_cond} = __LINE__ . <<'END_OF_SUB';
sub build_query_cond {
# -------------------------------------------------------------------
# Builds a condition object based on form input.
# field_name => value # Find all rows with field_name = value
# field_name => ">=?value" # Find all rows with field_name > or >= value.
# field_name => "<=?value" # Find all rows with field_name < or <= value.
# field_name => "!value" # Find all rows with field_name != value.
# field_name-opt => >=?|<=?|=|<>|LIKE|STARTS|ENDS
# # Find all rows with field_name (whichever) value.
# field_name-gt => value # Find all rows with field_name > value.
# field_name-lt => value # Find all rows with field_name < value.
# field_name-ge => value # Find all rows with field_name >= value.
# field_name-le => value # Find all rows with field_name <= value.
# field_name-ne => value # Find all rows with field_name != value.
# keyword => value # Find all rows where any field_name = value
# query => value # Find all rows using GT::SQL::Search module
# ww => 1 # 1 => use = comparision, 0/unspecified => use LIKE '%value%' comparision
# ma => 1 # 1 => OR match 0/unspecified => AND match
#
my ($self, $opts, $c) = @_;
my $cond = new GT::SQL::Condition;
my ($cmp, $l);
($cmp, $l) = $opts->{ww} ? ('=', '') : ('LIKE', '%');
$cond->boolean($opts->{ma} ? 'OR' : 'AND');
my $ins = 0;
# First find the fields and find what we
# want to do with them.
if (defined $opts->{query} and $opts->{query} =~ /\S/) {
require GT::SQL::Search;
my $search = GT::SQL::Search->load_search({
%{$opts},
db => $self->{driver},
table => $self,
debug => $self->{debug},
_debug => $self->{_debug}
});
my $sth = $search->query();
$self->{last_hits} = $search->rows();
$self->{rejected_keywords} = $search->{rejected_keywords};
return $sth;
}
elsif (defined $opts->{keyword} and ($opts->{keyword} ne "") and ($opts->{keyword} ne '*')) {
my $val = $opts->{keyword};
my $is_dig = $val =~ /^[+-]*\d+\.?\d*$/;
foreach my $field (keys %$c) {
next unless (index($c->{$field}->{type}, 'DATE') == -1); # No DATE fields.
next unless (index($c->{$field}->{type}, 'TIME') == -1); # No TIME fields.
next unless (index($c->{$field}->{type}, 'ENUM') == -1); # No ENUM fields.
next if (!$is_dig and (index($c->{$field}->{type}, 'INT') != -1)); # No ints if not an int.
next if (!$is_dig and (index($c->{$field}->{type}, 'DECIMAL') != -1)); # No ints if not an int.
next if (!$is_dig and (index($c->{$field}->{type}, 'FLOAT') != -1)); # No ints if not an int.
$cond->add($field, $cmp, "$l$opts->{keyword}$l");
$ins = 1;
}
$cond->bool('OR');
}
else {
# Go through each column and build condition.
foreach my $field (keys %$c) {
my $comp = $cmp;
my $s = $l;
my $e = $l;
my @ins;
if ($opts->{"$field-opt"}) {
$comp = uc $opts->{"$field-opt"};
$s = $e = '';
if ( $comp eq 'LIKE' ) {
$e = $s = '%';
}
elsif ( $comp eq 'STARTS' ) {
$comp = 'LIKE';
$e = '%';
}
elsif ( $comp eq 'ENDS' ) {
$comp = 'LIKE';
$s = '%';
}
}
else {
if ($c->{$field}->{type} =~ /ENUM/i) {
$comp = '=';
$e = $s = '';
}
}
# Comp can only be: =, <, >, <=, >=, <>, LIKE, STARTS, ENDS
$comp = '=' unless $comp =~ /^(=|<=?|>=?|<>|LIKE)$/i;
if (exists $opts->{"$field-gt"} and ($opts->{"$field-gt"} ne "")) {
push @ins, [$field, '>', $opts->{$field . "-gt"}];
}
if (exists $opts->{"$field-lt"} and ($opts->{"$field-lt"} ne "")) {
push @ins, [$field, '<', $opts->{$field . "-lt"}];
}
if (exists $opts->{"$field-ge"} and ($opts->{"$field-ge"} ne "")) {
push @ins, [$field, '>=', $opts->{$field . "-ge"}];
}
if (exists $opts->{"$field-le"} and ($opts->{"$field-le"} ne "")) {
push @ins, [$field, '<=', $opts->{$field . "-le"}];
}
if (exists $opts->{"$field-ne"} and ($opts->{"$field-ne"} ne "")) {
my $c = new GT::SQL::Condition;
$c->add($field => '!=' => $opts->{"$field-ne"});
}
if (exists $opts->{$field} and ($opts->{$field} ne "")) {
if (ref($opts->{$field}) eq 'ARRAY' ) {
my $add = [];
for ( @{$opts->{$field}} ) {
next if !defined( $_ ) or !length( $_ ) or !/\S/;
push @$add, $_;
}
if ( @$add ) {
push @ins, [$field, 'IN', $add];
}
}
elsif ($opts->{$field} =~ /^(>=?|<=?|!)(.*)/) {
push @ins, [$field, ($1 eq '!') ? '<>' : $1, $2];
}
elsif ($opts->{$field} eq '+') {
push @ins, [$field, "<>", ''];
}
elsif ($opts->{$field} eq '-') {
push @ins, [$field, "=", ''];
}
elsif ($opts->{$field} eq '*') {
if ($opts->{"$field-opt"} and ($opts->{"$field-opt"} eq '<>')) {
push @ins, [$field, '=', ''];
}
else {
next;
}
}
else {
substr($opts->{$field}, 0, 1) = "" if substr($opts->{$field}, 0, 1) eq '\\';
push @ins, [$field, $comp, "$s$opts->{$field}$e"];
}
}
if (@ins) {
for (@ins) {
$cond->add($_);
}
$ins = 1;
}
}
}
return $ins ? $cond : '';
}
END_OF_SUB
sub _load_module {
# -------------------------------------------------------------------
# Loads a subclassed module.
#
my ($self, $class) = @_;
no strict 'refs';
return 1 if (UNIVERSAL::can($class, 'new'));
(my $pkg = $class) =~ s,::,/,g;
my $ok = 0;
my @err = ();
until ($ok) {
local ($@, $SIG{__DIE__});
eval { require "$pkg.pm" };
if ($@) {
push @err, $@;
# In case the module had compile errors, %class:: will be defined, but not complete.
undef %{$class . '::'} if defined %{$class . '::'};
}
else {
$ok = 1;
last;
}
my $pos = rindex($pkg, '/');
last if $pos == -1;
substr($pkg, $pos) = "";
}
unless ($ok and UNIVERSAL::can($class, 'new')) {
return $self->fatal(BADSUBCLASS => $class, join ", ", @err);
}
return 1;
}
1;

404
site/glist/lib/GT/SQL/Condition.pm Normal file
View File

@ -0,0 +1,404 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::Base
# Author: Scott Beck
# CVS Info :
# $Id: Condition.pm,v 1.44 2004/10/12 17:54:30 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description:
# Implements an SQL condition.
#
package GT::SQL::Condition;
# ===============================================================
use GT::Base;
use GT::AutoLoader;
use strict;
use vars qw/@ISA $ERROR_MESSAGE $VERSION/;
@ISA = qw/GT::Base/;
$ERROR_MESSAGE = 'GT::SQL';
$VERSION = sprintf "%d.%03d", q$Revision: 1.44 $ =~ /(\d+)\.(\d+)/;
sub new {
# -----------------------------------------------------------------------------
# CLASS->new;
# $obj->new;
# ----------
# This class method is the base constructor for the GT::SQL::Condition
# object. It can be passed the boolean operator that has to be used for that
# object ("AND" is the default), the conditions for this object.
#
my $class = shift;
$class = ref $class || $class;
my $self = {
cond => [],
not => 0,
bool => 'AND'
};
bless $self, $class;
if (@_ and defined $_[$#_] and (uc $_[$#_] eq 'AND' or uc $_[$#_] eq 'OR' or $_[$#_] eq ',') ) {
$self->boolean(uc pop);
}
$self->add(@_) if @_;
return $self;
}
$COMPILE{clone} = __LINE__ . <<'END_OF_SUB';
sub clone {
# -----------------------------------------------------------------------------
# Clones the current object - that is, gives you an identical object that
# doesn't reference the original at all.
#
my $self = shift;
my $newself = { not => $self->{not}, bool => $self->{bool} };
bless $newself, ref $self;
my @cond;
for (@{$self->{cond}}) {
# {cond} can contain two things - three-value array references
# ('COL', '=', 'VAL'), or full-fledged condition objects.
if (ref eq 'ARRAY') {
push @cond, [@$_];
}
elsif (UNIVERSAL::isa($_, __PACKAGE__)) {
push @cond, $_->clone;
}
}
$newself->{cond} = \@cond;
$newself;
}
END_OF_SUB
$COMPILE{not} = __LINE__ . <<'END_OF_SUB';
sub not {
# -----------------------------------------------------------------------------
# $obj->not;
# ----------------
# Negates the current condition.
#
$_[0]->{not} = 1;
return $_[0];
}
END_OF_SUB
$COMPILE{new_clean} = __LINE__ . <<'END_OF_SUB';
sub new_clean {
# -----------------------------------------------------------------------------
# $obj->new_clean;
# ----------------
# Returns the same condition object, but ready to be prepared again.
#
my $self = shift;
my $class = ref $self;
my $res = $class->new;
$res->boolean($self->boolean);
for my $cond (@{$self->{cond}}) {
$res->add($cond);
}
return $res;
}
END_OF_SUB
sub boolean {
# -----------------------------------------------------------------------------
# $obj->boolean;
# --------------
# Returns the boolean operator which is being used for the current object.
#
# $obj->boolean($string);
# ------------------------
# Sets $string as the boolean operator for this condition object. Typically
# this should be nothing else than "AND" or "OR", but no checks are
# performed, so watch out for typos!
#
my $self = shift;
$self->{bool} = shift || return $self->{bool};
}
sub add {
# -----------------------------------------------------------------------------
# $obj->add($col => $op => $val [, $col2 => $op2 => $val2, ...]);
# ----------------------------
# Adds a one or more COL OP VAL clauses to the current condition.
#
# $obj->add($condition [, $cond2, ...]);
# -----------------------
# Adds one or more condition clauses to the current condition.
#
my $self = shift;
while (@_) {
my $var = shift;
if (ref $var eq 'ARRAY' or UNIVERSAL::isa($var, __PACKAGE__)) {
push @{$self->{cond}}, $var;
}
elsif (ref $var eq 'HASH') {
for (keys %$var) {
push @{$self->{cond}}, [$_ => '=' => $var->{$_}];
}
}
else {
my $op = @_ >= 2 ? shift || '=' : '='; # To support $cond->add(foo => $bar);
my $val = shift;
if (not defined $val) {
if ($op eq '=' and $self->{bool} ne ',') {
$op = 'IS';
}
elsif ($op eq '!=' or $op eq '<>') {
$op = 'IS NOT';
}
}
push @{$self->{cond}}, [$var => $op => $val];
}
}
return 1;
}
sub sql {
# -----------------------------------------------------------------------------
# Returns a string for the current SQL object which is the SQL representation
# of that condition. The string can then be inserted after a SQL WHERE clause.
# Optionally takes an option which, if true, uses placeholders and returns
# ($sql, \@values, \@columns) instead of just $sql.
#
my ($self, $ph) = @_;
my $bool = $self->{bool};
my (@vals, @cols, @output);
foreach my $cond (@{$self->{cond}}) {
if (ref $cond eq 'ARRAY') {
my ($col, $op, $val) = @$cond;
# Perl: column => '=' => [1,2,3]
# SQL: column IN (1,2,3)
if (uc $op eq 'IN' || $op eq '=' and ref $val eq 'ARRAY') {
if (@$val > 1) {
$op = 'IN';
$val = '('
. join(',' => map !length || /\D/ ? quote($_) : $_, @$val)
. ')';
}
elsif (@$val == 0) {
($col, $op, $val) = (qw(1 = 0));
}
else {
$op = '=';
$val = quote($val->[0]);
}
push @output, "$col $op $val";
}
# Perl: column => '!=' => [1,2,3]
# SQL: NOT(column IN (1,2,3))
elsif ($op eq '!=' || $op eq '<>' and ref $val eq 'ARRAY') {
my $output;
if (@$val > 1) {
$output = "NOT ($col IN ";
$output .= '('
. join(',' => map !length || /\D/ ? quote($_) : $_, @$val)
. ')';
$output .= ')';
}
elsif (@$val == 0) {
$output = '1 = 1';
}
else {
$output = "$col $op " . quote($val->[0]);
}
push @output, $output;
}
elsif ($ph and defined $val and not ref $val) {
push @output, "$col $op ?";
push @cols, $col;
push @vals, $val;
}
else {
push @output, "$col $op " . quote($val);
}
}
elsif (UNIVERSAL::isa($cond, __PACKAGE__)) {
my @sql = $cond->sql($ph);
if ($sql[0]) {
push @output, "($sql[0])";
if ($ph) {
push @vals, @{$sql[1]};
push @cols, @{$sql[2]};
}
}
}
}
my $final = join " $bool ", @output;
$final &&= "NOT ($final)" if $self->{not};
return wantarray ? ($final, $ph ? (\@vals, \@cols) : ()) : $final;
}
$COMPILE{sql_ph} = __LINE__ . <<'END_OF_SUB';
sub sql_ph {
# -----------------------------------------------------------------------------
# Depreciated form of ->sql(1);
shift->sql(1);
}
END_OF_SUB
sub quote {
# -----------------------------------------------------------------------------
# this subroutines quotes (or not) a value given its column.
#
defined(my $val = pop) or return 'NULL';
return ref $val eq 'SCALAR' ? $$val : GT::SQL::Driver->quote($val);
}
sub as_hash {
# -----------------------------------------------------------------------------
# returns the condition object as a flattened hash.
#
my $cond = shift;
ref $cond eq 'HASH' and return $cond;
my %ret;
for my $arr (@{$cond->{cond}}) {
if (ref $arr eq 'ARRAY') {
$ret{$arr->[0]} = $arr->[2];
}
else {
my $h = as_hash($arr);
for my $k (keys %$h) {
$ret{$k} = $h->{$k};
}
}
}
return \%ret;
}
1;
__END__
=head1 NAME
GT::SQL::Condition - Creates complex where clauses
=head1 SYNOPSYS
my $cond = GT::SQL::Condition->new(Column => LIKE => 'foo%');
print $cond->sql;
my $cond = GT::SQL::Condition->new(
Column => LIKE => 'foo%',
Column2 => '<' => 'abc'
);
$cond->bool('OR');
print $cond->sql;
=head1 DESCRIPTION
The condition module is useful for generating complex SQL WHERE clauses. At
it's simplest, a condition is composed of three parts: column, condition and
value.
Here are some examples.
To find all users with a first name that starts with Alex use:
my $cond = GT::SQL::Condition->new(FirstName => LIKE => 'Alex%');
To find users with first name like alex, B<and> last name like krohn use:
my $cond = GT::SQL::Condition->new(
FirstName => LIKE => 'Alex%',
LastName => LIKE => 'Krohn%'
);
To find users with first name like alex B<or> last name like krohn use:
my $cond = GT::SQL::Condition->new(
FirstName => LIKE => 'Alex%',
LastName => LIKE => 'Krohn%'
);
$cond->bool('OR');
You may also specify this as:
my $cond = GT::SQL::Condition->new(
FirstName => LIKE => 'Alex%',
LastName => LIKE => 'Krohn%',
'OR'
);
Now say we wanted something a bit more complex that would normally involve
setting parentheses. We want to find users who have either first name like alex
or last name like krohn, and whose employer is Gossamer Threads. We could use:
my $cond1 = GT::SQL::Condition->new(
'FirstName', 'LIKE', 'Alex%',
'LastName', 'LIKE', 'Krohn%'
);
$cond1->bool('or');
my $cond2 = GT::SQL::Condition->new(
$cond1,
Employer => '=' => 'Gossamer Threads'
);
By default, all values are quoted, so you don't need to bother using any quote
function. If you don't want something quoted (say you want to use a function
for example), then you pass in a reference.
For example, to find users who have a last name that sounds like 'krohn', you
could use your SQL engines SOUNDEX function:
my $cond = GT::SQL::Condition->new(LastName => '=' => \"SOUNDEX('krohn')");
and the right side wouldn't be quoted.
You can also use a condition object to specify a list of multiple values, which
will become the SQL 'IN' operator. For example, to match anyone with a first
name of Alex, Scott or Jason, you can do:
my $cond = GT::SQL::Condition->new(FirstName => IN => ['Alex', 'Scott', 'Jason']);
which will turn into:
FirstName IN ('Alex', 'Scott', 'Jason')
Note that when using multiple values, you can use '=' instead of 'IN'. Empty
lists will be treated as an impossible condition (1 = 0). This is primarily
useful for list handling list of id numbers.
To match NULL values, you can use C<undef> for the value passed to the add()
method. If specifying '=' as the operator, it will automatically be changed to
'IS':
$cond->add(MiddleName => '=' => undef);
becomes:
MiddleName IS NULL
To negate your queries you can use the C<not> function.
my $cond = GT::SQL::Condition->new(a => '=' => 5);
$cond->not;
would translate into NOT (a = '5'). You can also do this all on one line like:
print GT::SQL::Condition->new(a => '=' => '5')->not->sql;
This returns the sql right away.
=head1 COPYRIGHT
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
http://www.gossamer-threads.com/
=head1 VERSION
Revision: $Id: Condition.pm,v 1.44 2004/10/12 17:54:30 jagerman Exp $
=cut

1216
site/glist/lib/GT/SQL/Creator.pm Normal file
View File

File diff suppressed because it is too large Load Diff

887
site/glist/lib/GT/SQL/Display/HTML.pm Normal file
View File

@ -0,0 +1,887 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Display::HTML
# Author: Scott & Alex
# $Id: HTML.pm,v 1.92 2005/04/05 18:47:08 jagerman 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.92 $ =~ /(\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' ) {
$values->{$col."_filename"} = $self->{values}->{$col."_filename"};
}
$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 SIZE="$self->{cols}->{$clean_name}->{form_size}"!;
}
elsif (exists $opts->{multiple} and $opts->{multiple} > 1) {
$mult = qq!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}) ? " 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" 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}) ? " 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> ~) 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}) ? " 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$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]} });
unless ( ( not $href and not $self->{file_use_path} ) or
( not ( -e $opts->{value}) and $self->{file_use_path} ) ) {
require GT::SQL::File;
my $sfname = $values->{$colname."_filename"};
$out = $sfname || GT::SQL::File::get_filename($fname ||= $href->{File_Name} );
$self->{file_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" type=hidden 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 => ( $self->{file_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 => ( $self->{file_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>!;
}
$out .= qq~ <input type=checkbox name="$opts->{name}_del" value="delete"> Delete~;
}
}
my $class = ($opts->{def}->{class}) ? " class='$opts->{def}->{class}'" : "";
$out .= qq~<p><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}) ? " 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}) ? " 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}) ? " class='$opts->{def}->{class}'" : "";
return qq~<textarea rows="$rows" cols="$cols" name="$name"$class>$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/&/&amp;/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">[&lt;&lt;]</a> ~);
($nh > 1) and ($url .= qq~<a href="$script;nh=$prev_hit">[&lt;]</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&amp;nh=$i">$i</a> ~);
if ($i * $maxhits == $numhits) { $nh == $i and $next_hit = $i; last; }
}
$url .= qq~<a href="$script;nh=$next_hit">[&gt;]</a> ~ unless ($next_hit == $nh or ($nh * $maxhits > $numhits));
$url .= qq~<a href="$script;nh=$max_page">[&gt;&gt;]</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 = '&gt;' if $val eq '>';
$val = '&lt;' 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', '&gt;' => 'Greater Than', '&lt;' => 'Less Than'},
$so = [ 'LIKE', '=', '<>', '&gt;', '&lt;' ], 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', '&gt;' => 'Greater Than', '&lt;' => 'Less Than'},
$so = [ '=', '&gt;', '&lt;', '<>' ], 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 || '';
$$t =~ s/&/&amp;/g;
$$t =~ s/"/&quot;/g;
$$t =~ s/</&lt;/g;
$$t =~ s/>/&gt;/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.

278
site/glist/lib/GT/SQL/Display/HTML/Relation.pm Normal file
View File

@ -0,0 +1,278 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Display::HTML
# Author: Scott & Alex
# $Id: Relation.pm,v 1.18 2004/08/28 03:53:45 jagerman 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::Relation;
# ===============================================================
use strict;
use vars qw/@ISA $AUTOLOAD $VERSION $ERROR_MESSAGE $ATTRIBS $DEBUG $FONT %SIZE_FORMS/;
use GT::SQL::Display::HTML;
@ISA = qw/GT::SQL::Display::HTML/;
$FONT = 'face="Tahoma,Arial,Helvetica" size=2';
$VERSION = sprintf "%d.%03d", q$Revision: 1.18 $ =~ /(\d+)\.(\d+)/;
$DEBUG = 0;
$ERROR_MESSAGE = 'GT::SQL';
$ATTRIBS = {
db => undef,
input => undef,
code => {},
mode => '',
font => $FONT,
hide_timestamp => 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,
file_field => 0,
file_delete => 0,
file_use_path => 0,
};
sub display {
# ---------------------------------------------------------------
# Display a record as html.
#
my $self = shift;
my $opts = shift;
$self->reset_opts;
$opts->{disp_form} = 0;
$opts->{disp_html} = 1;
return $self->_display ($opts || ());
}
sub _display {
# ---------------------------------------------------------------
# Handles displaying of a form or a record.
#
my $self = shift;
# Initiate if we are passed in any arguments as options.
if (@_) { $self->init (@_); }
# Get the column hash and primary key
$self->{pk} = [$self->{db}->pk] unless $self->{pk};
$self->{cols} = $self->{db}->ordered_columns;
# Output
my $out = '';
# Hide the primary keys.
$self->{view_key} and push (@{$self->{view}}, @{$self->{pk}}) if ($self->{pk});
# Now go through each column and print out a column row.
my @ntables = values %{$self->{db}->{tables}};
my (@tmp, @tables);
for my $t (@ntables) {
my @cols = $t->ordered_columns;
my %fk = $t->fk;
my %cols = $t->cols;
my $name = $t->name;
my $found = 0;
COL: foreach my $col_name (@cols) {
if (exists $self->{values}->{$col_name}) {
$self->{values}->{$name . '.' . $col_name} = delete $self->{values}->{$col_name};
}
$self->{cols}->{$name . '.' . $col_name} = $cols{$col_name};
FK: for (keys %fk) {
if (exists $self->{db}->{tables}->{$_}) {
if (exists $fk{$_}->{$col_name}) {
$found = 1;
last FK;
}
}
}
}
$found ? (push (@tmp, $t)) : (@tables = ($t));
}
push @tables, @tmp;
# Calculate the form values.
my $values = $self->_get_defaults;
# Set the table widths depending on if we need a third column.
my ($cwidth, $vwidth) = ('30%', '70%');
if ($self->{search_opts}) { $cwidth = "30%"; $vwidth = "60%" }
for my $table (@tables) {
$out .= $self->mk_table (
table => $table,
values => $values,
cwidth => $cwidth,
vwidth => $vwidth
);
}
$out .= '<br>';
foreach (@{$self->{hide}}) {
my $field_name = $self->{multiple} ? "$self->{multiple}-$_" : $_;
my $val = $values->{$_};
if (exists $self->{cols}->{$_}->{time_check} and $self->{cols}->{$_}->{time_check}) {
$val ||= $self->_get_time ($self->{cols}->{$_});
}
defined $val or ($val = '');
GT::SQL::Display::HTML::_escape(\$val);
$out .= qq~<input type="hidden" name="$field_name" value="$val">~;
}
$self->{extra_table} and ($out .= "</td></tr></table>\n");
return $out;
}
sub mk_table {
my $self = shift;
my %opt = @_;
my $out = '';
$self->{extra_table} and ($out .= "<p><table border=1 cellpadding=0 cellspacing=0><tr><td>");
my $cols = $opt{table}->cols;
my $name = $opt{table}->name;
$out .= qq(
<table $self->{table}>
<tr><td colspan=3 bgcolor=navy>
<FONT FACE="MS Sans Serif, arial,helvetica" size=1 COLOR="#FFFFFF">$name</font>
</td></tr>
);
my @cols = $opt{table}->ordered_columns;
my %fk = $opt{table}->fk;
COL: foreach my $col_name (@cols) {
$out .= $self->mk_row (%opt, col_name => $col_name, fk => \%fk);
}
$out .= "</table>\n";
$out .= "</table></p>\n" if $self->{extra_table};
return $out;
}
sub mk_row {
my $self = shift;
my %opt = @_;
my $out = '';
for (keys %{$opt{fk}}) {
if (exists $self->{db}->{tables}->{$_}) {
(exists $opt{fk}->{$_}->{$opt{col_name}}) and return '';
}
}
my $col = $opt{table}->name . '.' . $opt{col_name};
# Run any code refs that have been setup.
if (exists $self->{code}->{$col} and (ref $self->{code}->{$col} eq 'CODE')) {
$out .= $self->{code}->{$col}->($self, $self->{cols}->{$col}, $opt{values});
return '';
}
return '' if $self->_skip ($col);
# Set the form name (using increment for multiple if requested) and also the display name.
my $field_name = $self->{multiple} ? "$self->{multiple}-$col" : $col;
my $display_name = exists ($self->{cols}->{$col}->{form_display}) ? $self->{cols}->{$col}->{form_display} : $col;
my $value = $opt{values}->{$col};
my $disp = $self->{disp_form} ? $self->_get_form_display ($col) : $self->_get_html_display ($col);
$disp eq 'hidden' and push (@{$self->{hide}}, $col) and return '';
$out .= "<tr $self->{tr}><td $self->{td} width='$opt{cwidth}'><font $self->{col_font}>$display_name</font></td><td $self->{td} width='$opt{vwidth}'><font $self->{val_font}>";
# Get the column display subroutine
$out .= $self->$disp( { name => $field_name, def => $self->{cols}->{$col}, value => $value }, $opt{values}, $self );
$out .= "</font></td>";
# Display any search options if requested.
if ($self->{search_opts}) {
my $is_pk = 0;
for (@{$self->{pk}}) {
$is_pk = 1, last if ($_ eq $col);
}
$out .= qq~<td $self->{td} width="10%"><font $self->{val_font}>~;
$out .= $self->_mk_search_opts({
name => $field_name,
def => $self->{cols}->{$col},
pk => $is_pk
}) || '&nbsp;';
$out .= "</font></td>";
}
$out .= "\n";
return $out;
}
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 @ntables = values %{$self->{db}->{tables}};
my @cols = $self->{db}->ordered_columns;
my $c = $self->{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/) {
(defined $c->{$col}->{default} and $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});
}
$values->{$col} = $value;
}
return $values;
}
1;
__END__
=pod
# 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.
=cut

289
site/glist/lib/GT/SQL/Display/HTML/Table.pm Normal file
View File

@ -0,0 +1,289 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Display::HTML
# Author: Scott & Alex
# $Id: Table.pm,v 1.26 2004/10/01 21:52:12 jagerman 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::Table;
# ===============================================================
use strict;
use vars qw/@ISA $AUTOLOAD $VERSION $ERROR_MESSAGE $ATTRIBS $DEBUG $FONT %SIZE_FORMS/;
use GT::SQL::Display::HTML;
@ISA = qw/GT::SQL::Display::HTML/;
$FONT = 'face="Tahoma,Arial,Helvetica" size=2';
$VERSION = sprintf "%d.%03d", q$Revision: 1.26 $ =~ /(\d+)\.(\d+)/;
$DEBUG = 0;
$ERROR_MESSAGE = 'GT::SQL';
$ATTRIBS = {
db => undef,
input => undef,
code => {},
font => $FONT,
hide_timestamp => 0,
view_key => 0,
defaults => 0,
search_opts => 0,
values => {},
multiple => 0,
table => 'border=0 width=500',
tr => '',
mode => '',
td => 'valign=top align=left',
extra_table => 1,
col_font => $FONT,
val_font => $FONT,
hide => [],
skip => [],
view => [],
disp_form => 1,
disp_html => 0,
file_field => 0,
file_delete => 0,
file_use_path => 0
};
sub display_row {
# ---------------------------------------------------------------
# Display a record row as html.
#
my ($self, $opts) = @_;
$opts->{disp_form} = 0;
$opts->{disp_html} = 1;
return $self->_display_row ($opts || ());
}
sub display_row_cols {
# ---------------------------------------------------------------
# returns the <td></td> for each of the title names for columns
#
my $self = shift;
# Initiate if we are passed in any arguments as options.
if (@_) { $self->init (@_); }
# Get the column hash and primary key
$self->{cols} = $self->{db}->cols unless exists $self->{cols};
$self->{pk} = [$self->{db}->pk] unless exists $self->{pk};
# Output
my $out = '';
# Hide the primary keys.
$self->{view_key} and push (@{$self->{view}}, @{$self->{pk}});
# Calculate the form values.
my $values = $self->_get_defaults;
# Now go through each column and print out a column row.
my @cols = $self->{db}->ordered_columns;
my $script = GT::CGI->url();
$script =~ s/[\&;]?sb=([^&;]*)//g;
my $sb = $1;
$script =~ s/[\&;]?so=(ASC|DESC)//g;
my $so = $1;
foreach my $col (@cols) {
$out .= qq!\n\t<td><font $self->{col_font}><b>!;
$out .= qq!<a href="$script&sb=$col&so=! . ( ( ( $col eq $sb ) and $so eq 'ASC' ) ? 'DESC' : 'ASC' ) . qq!">!;
$out .= exists $self->{db}->{schema}->{cols}->{$col}->{form_display} ? $self->{db}->{schema}->{cols}->{$col}->{form_display} : $col;
$out .= ( ( $col eq $sb ) ? ( ($so eq 'ASC') ? " ^" : " v" ) : '' ) . "</a>";
$out .= qq!</b></font></td>\n!;
}
return $out;
}
sub _display_row {
# ---------------------------------------------------------------
# Handles displaying of a form or a record.
#
my $self = shift;
# Initiate if we are passed in any arguments as options.
if (@_) { $self->init (@_); }
# Get the column hash and primary key
$self->{cols} = $self->{db}->cols unless exists $self->{cols};
$self->{pk} = [$self->{db}->pk] unless exists $self->{pk};
# Output
my $out = '';
# Hide the primary keys.
$self->{view_key} and push (@{$self->{view}}, @{$self->{pk}});
# Calculate the form values.
my $values = $self->_get_defaults;
# Now go through each column and print out a column row.
my @cols = $self->{db}->ordered_columns;
foreach my $col (@cols) {
# Run any code refs that have been setup.
if (exists $self->{code}->{$col} and (ref $self->{code}->{$col} eq 'CODE')) {
$out .= $self->{code}->{$col}->($self, $self->{cols}->{$col}, $values);
next;
}
next if $self->_skip ($col);
# Set the form name (using increment for multiple if requested) and also the display name.
my $field_name = $self->{multiple} ? "$self->{multiple}-$col" : $col;
my $display_name = exists $self->{cols}->{$col}->{form_display} ? $self->{cols}->{$col}->{form_display} : $col;
my $value = $values->{$col};
my $disp = $self->{disp_form} ? $self->_get_form_display ($col) : $self->_get_html_display ($col);
$disp eq 'hidden' and push (@{$self->{hide}}, $col) and next;
$out .= qq!\n\t<td valign=texttop><font $self->{col_font}>!;
# Get the column display subroutine
$out .= $self->$disp( { name => $field_name, def => $self->{cols}->{$col}, value => $value });
$out .= qq!</font></td>\n!;
}
return $out;
}
sub display {
# ---------------------------------------------------------------
# Display a record as html.
#
my ($self, $opts) = @_;
$opts->{disp_form} = 0;
$opts->{disp_html} = 1;
return $self->_display ($opts || ());
}
sub _display {
# ---------------------------------------------------------------
# Handles displaying of a form or a record.
#
my $self = shift;
# Initiate if we are passed in any arguments as options.
if (@_) { $self->init (@_); }
# Get the column hash, primary keys, and unique columns
$self->{cols} = $self->{db}->cols unless exists $self->{cols};
$self->{pk} = [$self->{db}->pk] unless exists $self->{pk};
# Output
my $out = '';
# Hide the primary keys.
$self->{view_key} and push (@{$self->{view}}, @{$self->{pk}});
# Opening table.
$self->{extra_table} and ($out .= "<table border=1 cellpadding=0 cellspacing=0><tr><td>");
$out .= "<table $self->{table}>";
# Set the table widths depending on if we need a third column.
my ($cwidth, $vwidth);
if ($self->{search_opts}) { $cwidth = "30%"; $vwidth = "60%" }
else { $cwidth = "30%"; $vwidth = "70%" }
# Calculate the form values.
my $values = $self->_get_defaults;
# Now go through each column and print out a column row.
my @cols = $self->{db}->ordered_columns;
foreach my $col (@cols) {
# Run any code refs that have been setup.
if (exists $self->{code}->{$col} and (ref $self->{code}->{$col} eq 'CODE')) {
$out .= $self->{code}->{$col}->($self, $self->{cols}->{$col}, $values);
next;
}
next if $self->_skip ($col);
# Set the form name (using increment for multiple if requested) and also the display name.
my $field_name = $self->{multiple} ? "$self->{multiple}-$col" : $col;
my $display_name = (exists $self->{cols}->{$col}->{form_display} and length $self->{cols}->{$col}->{form_display})
? $self->{cols}->{$col}->{form_display} : $col;
my $value = $values->{$col};
my $disp = $self->{disp_form} ? $self->_get_form_display ($col) : $self->_get_html_display ($col);
$disp eq 'hidden' and push (@{$self->{hide}}, $col) and next;
$out .= "<tr $self->{tr}><td $self->{td} width='$cwidth'><font $self->{col_font}>$display_name</font></td><td $self->{td} width='$vwidth'><font $self->{val_font}>";
# Get the column display subroutine
my $o = $self->$disp(
{
name => (defined $field_name ? $field_name : ''),
def => $self->{cols}->{$col},
value => (defined $value ? $value : '')
},
($values || {}),
$self
);
$out .= $o if defined $o;
$out .= "</font></td>";
# Display any search options if requested.
if ($self->{search_opts}) {
$out .= qq~<td $self->{td} width="10%"><font $self->{val_font}>~;
$out .= $self->_mk_search_opts({
name => $field_name,
def => $self->{cols}->{$col},
pk => $self->{db}->_is_pk($col),
unique => $self->{db}->_is_unique($col)
}) || '&nbsp;';
$out .= "</font></td>";
}
$out .= "\n";
}
$out .= "</table>\n";
my %seen;
foreach (@{$self->{hide}}) {
next if $seen{$_}++;
my $field_name = $self->{multiple} ? "$self->{multiple}-$_" : $_;
my $val = $values->{$_};
if (exists $self->{cols}->{$_}->{time_check} and $self->{cols}->{$_}->{time_check}) {
$val ||= $self->_get_time ($self->{cols}->{$_});
}
defined $val or ($val = '');
GT::SQL::Display::HTML::_escape(\$val);
$out .= qq~<input type="hidden" name="$field_name" value="$val">~;
}
$self->{extra_table} and ($out .= "</td></tr></table>\n");
return $out;
}
1;
__END__
=pod
# 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.
=cut

897
site/glist/lib/GT/SQL/Driver.pm Normal file
View File

@ -0,0 +1,897 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Driver
# CVS Info :
# $Id: Driver.pm,v 2.5 2005/02/25 03:37:29 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description:
# Overview: This implements a driver class.
#
package GT::SQL::Driver;
# ===============================================================
use strict;
use GT::SQL::Table;
use GT::AutoLoader;
use GT::SQL::Driver::Types;
use GT::SQL::Driver::debug;
use Exporter();
require GT::SQL::Driver::sth;
use vars qw/%CONN @ISA $DEBUG $VERSION $ERROR_MESSAGE $ATTRIBS %QUERY_MAP/;
use constant PROTOCOL => 2;
$ATTRIBS = {
name => '',
schema => '',
dbh => '',
connect => {}
};
$ERROR_MESSAGE = 'GT::SQL';
$VERSION = sprintf "%d.%03d", q$Revision: 2.5 $ =~ /(\d+)\.(\d+)/;
$DEBUG = 0;
@ISA = qw/GT::SQL::Driver::debug/;
%QUERY_MAP = (
# QUERY => METHOD (will be prefixed with '_prepare_' or '_execute_')
CREATE => 'create',
INSERT => 'insert',
ALTER => 'alter',
SELECT => 'select',
UPDATE => 'update',
DROP => 'drop',
DELETE => 'delete',
DESCRIBE => 'describe',
'SHOW TABLES' => 'show_tables',
'SHOW INDEX' => 'show_index'
);
$DBI::errstr if 0;
sub load_driver {
# -----------------------------------------------------------------------------
# Loads a sub-driver (i.e. GT::SQL::Driver::MYSQL, GT::SQL::Driver::PG, etc.),
# and creates and returns a new driver object. The first argument should be
# the name of the driver (e.g. 'PG'), and the remaining arguments are passed to
# new() - which could well be handled by the driver.
#
my ($class, $driver, @opts) = @_;
# Old GT::SQL versions had an 'ODBC' driver that wasn't an ODBC driver, but an
# MSSQL driver that used ODBC.
$driver = 'MSSQL' if $driver eq 'ODBC';
my $pkg = "GT::SQL::Driver::$driver";
my $lib_path = $INC{'GT/SQL/Driver.pm'};
$lib_path =~ s|GT/SQL/Driver\.pm$||;
{
# Ensure that the driver is loaded from the same location as GT/SQL/Driver.pm
local @INC = ($lib_path, @INC);
require "GT/SQL/Driver/$driver.pm";
}
my $protocol = $pkg->protocol_version;
return $class->fatal(DRIVERPROTOCOL => PROTOCOL, $protocol) if $protocol != PROTOCOL;
return $pkg->new(@opts);
}
sub new {
# -----------------------------------------------------------------------------
# Generic new() method for drivers to inherit; load_driver() should be used
# instead to get a driver object.
#
my $this = shift;
my $class = ref $this || $this;
my $self = bless {}, $class;
my $opts = $self->common_param(@_) or return $self->fatal(BADARGS => "$class->new(HASH REF or HASH); invalid parameter: '@_'");
# Otherwise we need to make sure we have a schema.
$opts->{schema} and ref $opts->{schema} or return $self->fatal(BADARGS => "$class->new(HASH REF or HASH); must specify schema and name");
$self->{name} = $opts->{name};
$self->{schema} = $opts->{schema};
$self->{connect} = $opts->{connect};
$self->{_debug} = $opts->{debug} || $DEBUG;
$self->{_err_pkg} = $opts->{_err_pkg} || 'GT::SQL';
$self->{dbh} = undef;
$self->{hints} = { $self->hints };
$self->debug("New driver object loaded from table: $self->{name}.") if ($self->{_debug} > 2);
return $self;
}
# This method is designed to be subclassed to provide "hints" for simple, small
# differences between drivers, which simplifies the code over using a subclass.
# It returns a hash of hints, with values of "1" unless otherwise indicated.
# Currently supported hints are:
# case_map # Corrects ->fetchrow_hashref column case when the database doesn't
# prefix_indexes # Indexes will be prefixed with the table name (including the table's prefix)
# fix_index_dbprefix # Look for erroneous (db_prefix)(index) when dropping indexes
# now # Specifies an SQL value to use instead of NOW() (for 'time_check' columns, among other things)
# bind # An array ref of: [\%BIND_HASH, ('COLUMNTYPE' => $bind_type, 'TYPE2' => $bind_type2, ...)] for drivers that need special placeholder binding for certain column types
# ai # Contains a string to use for an AI column; or a code reference that is passed ($table, $column) and returns the string, or an array reference of queries to run to create the ai sequence after the column/table has been created
# drop_pk_constraint # use ALTER TABLE ... DROP CONSTRAINT pkeyname to drop a primary key
sub hints { () }
# Removing the () breaks under 5.00404, as it will return @_ in list context
$COMPILE{protocol_version} = __LINE__ . <<'END_OF_SUB';
sub protocol_version {
# -----------------------------------------------------------------------------
# This checks the GT::SQL::Driver protocol, and dies if the versions aren't
# equal. The protocol version only changes for major driver changes such as
# the v2.000 version of this module, which had the drivers do their own queries
# (as opposed to the previous hack of having drivers trying to return alternate
# versions of MySQL's queries). All protocol v2 and above drivers are required
# to override this - any driver that does not is, by definition, a protocol v1
# driver.
#
# The current protocol version is defined by the PROTOCOL constant - but
# drivers that haven't overridden protocol_version() are, by definition, v1.
#
1;
}
END_OF_SUB
sub available_drivers {
# -----------------------------------------------------------------------------
# Returns a list of available GT::SQL::Driver::* drivers
#
my $driver_path = $INC{'GT/SQL/Driver.pm'};
$driver_path =~ s/\.pm$//;
my $dh = \do { local *DH; *DH };
my @drivers;
opendir $dh, $driver_path or return ();
while (defined(my $driver = readdir $dh)) {
# By convention, only all-uppercase modules are accepted as GT::SQL drivers
next unless $driver =~ /^([A-Z_][A-Z0-9_]*)\.pm$/;
push @drivers, $1;
}
@drivers;
}
sub connect {
# -------------------------------------------------------------------
# Returns the current database handle.
#
my $self = shift;
$self->{dbh} and return $self->{dbh};
eval { require DBI };
if ($@) {
return $self->warn(CANTCONNECT => "DBI module not installed. You must install the perl database module DBI from: http://www.perl.com/CPAN/modules/by-module/DBI");
}
# Make sure we have a database, otherwise probably an error.
exists $self->{connect}->{database} or return $self->fatal(CANTCONNECT => "No connection string passed to tbl->connect, make sure your table object got a connection hash.");
keys %{$self->{schema}} or return $self->fatal(CANTCONNECT => "Unable to connect to database without a valid schema.");
my $dsn = $self->dsn($self->{connect});
my $conn_key = "$dsn\0$self->{connect}->{login}\0$self->{connect}->{password}";
if (defined $CONN{$conn_key}) {
$self->{dbh} = $CONN{$conn_key};
$self->debug("Using stored connection: $dsn") if ($self->{_debug} > 1);
return $CONN{$conn_key};
}
# Connect to the database.
$self->debug("Connecting to database with: '$dsn', '$self->{connect}->{login}', '******'") if ($self->{_debug} > 1);
my $res = eval {
$CONN{$conn_key} = DBI->connect($dsn, $self->{connect}->{login}, $self->{connect}->{password}, { RaiseError => $self->{connect}->{RaiseError}, PrintError => $self->{connect}->{PrintError}, AutoCommit => 1 })
or die "$DBI::errstr\n";
1;
};
$res or return $self->warn(CANTCONNECT => "$@");
$self->{dbh} = $CONN{$conn_key};
$self->debug("Connected successfully to database.") if $self->{_debug} > 1;
return $self->{dbh};
}
$COMPILE{dsn} = __LINE__ . <<'END_OF_SUB';
sub dsn {
# -------------------------------------------------------------------
# Creates the data source name used by DBI to connect to the database.
# Since this is database-dependant, this is just a stub.
#
require Carp;
Carp::croak("Driver has no dsn()");
}
END_OF_SUB
$COMPILE{prepare_raw} = __LINE__ . <<'END_OF_SUB';
sub prepare_raw {
# ---------------------------------------------------------------
# Returns a raw sth object.
# WARNING: MAKE SURE YOUR SQL IS PORTABLE AS NO ALTERATIONS WILL
# BE MADE! ALSO YOU MUST MANUALLY CALL ->finish ON THESE!
#
my ($self, $query) = @_;
$self->debug("Preparing RAW query: $query") if $self->{_debug} > 1;
my $sth = $self->{dbh}->prepare($query) or return $self->warn(CANTPREPARE => $query);
$self->debug("RAW STH is prepared: $query") if $self->{_debug} > 1;
return $sth;
}
END_OF_SUB
$COMPILE{prepare} = __LINE__ . <<'END_OF_SUB';
sub prepare {
# ---------------------------------------------------------------
# We can override whatever type of queries we need to alter by replacing
# the _prepare_* functions.
#
my ($self, $query) = @_;
if (! defined $query) {
return $self->warn(CANTPREPARE => "", "Empty Query");
}
# For any drivers that need hacked-in limit support (currently MS SQL and Oracle):
delete @$self{qw/_limit _lim_offset _lim_rows/};
if (my $now = $self->{hints}->{now}) {
$query =~ s/\bNOW\(\)/$now/g;
}
if ($query =~ /^\s*SHOW\s+TABLES\s*(?:;\s*)?$/i) {
$self->{do} = 'SHOW TABLES';
}
elsif ($query =~ /^\s*SHOW\s+INDEX\s+FROM\s+\w+\s*(?:;\s*)?$/i) {
# See 'Driver-specific notes' below
$self->{do} = 'SHOW INDEX';
}
else {
$self->{do} = uc +($query =~ /(\w+)/)[0];
}
if (my $meth = $QUERY_MAP{$self->{do}}) {
$meth = "_prepare_$meth";
$query = $self->$meth($query) or return;
}
$self->{query} = $query;
$self->debug("Preparing query: $query") if $self->{_debug} > 1;
$self->{sth} = $self->{dbh}->prepare($query)
or return $self->warn(CANTPREPARE => $query, $DBI::errstr);
my $pkg = ref($self) . '::sth';
$self->debug("CREATING $pkg OBJECT") if $self->{_debug} > 2;
return $pkg->new($self);
}
END_OF_SUB
# Define one generic prepare, and alias all the specific _prepare_* functions to it
sub _generic_prepare { $_[1] }
for (*_prepare_create, *_prepare_insert, *_prepare_alter, *_prepare_select, *_prepare_update, *_prepare_drop, *_prepare_delete, *_prepare_describe) {
$_ = \&_generic_prepare;
}
# Driver-specific notes:
# 'SHOW TABLES'
# The driver should return single-column rows of non-system tables in the
# database. The name of the column is not important, and users of SHOW TABLE
# should not depend on it (i.e. do not use ->fetchrow_hashref)
*_prepare_show_tables = \&_generic_prepare;
# 'SHOW INDEX FROM table'
# Drivers should return one row per column per index, having at least the keys:
# - index_name: the name of the index
# - index_column: the name of the column
# - index_unique: 1 if the index is unique, 0 otherwise
# - index_primary: 1 if the column is a primary key, 0 otherwise
#
# The rows must be grouped by index, and ordered by the position of the column
# within said groupings.
#
# So, for a unique index named 'unique1' on columns 'col1', 'col2', 'col3', and
# a normal index named 'index1' on 'col3', 'col4', and a primary key on
# 'colpk', you should get (at a minimum; extra columns are permitted):
# +------------+--------------+--------------+---------------+
# | index_name | index_column | index_unique | index_primary |
# +------------+--------------+--------------+---------------+
# | unique1 | col1 | 1 | 0 |
# | unique1 | col2 | 1 | 0 |
# | unique1 | col3 | 1 | 0 |
# | index1 | col3 | 0 | 0 |
# | index1 | col4 | 0 | 0 |
# | PRIMARY | colpk | 1 | 1 |
# +------------+--------------+--------------+---------------+
# 'PRIMARY' above should be changed by drivers whose databases have named
# primary keys, otherwise using 'PRIMARY' for the primary key is recommended.
#
# Any other information may be returned; users of this query mapping should
# always use ->fetchrow_hashref, and access the above four keys for
# portability.
#
# Note that index_primary results may overlap other indexes for some databases
# - Oracle, in particular, will bind a primary key onto an existing index if
# possible. In such a case, you'll get the index indicated normally, but some
# of the columns may make up the primary key. For example, the following
# result would indicate that there is one index on col1, col2, col3, and that
# there is a primary key made up of (col1, col2):
#
# +------------+--------------+--------------+---------------+
# | index_name | index_column | index_unique | index_primary |
# +------------+--------------+--------------+---------------+
# | index1 | col1 | 0 | 1 |
# | index1 | col2 | 0 | 1 |
# | index1 | col3 | 0 | 0 |
# +------------+--------------+--------------+---------------+
#
# Currently, results such as the above are known to occur in Oracle databases
# where a primary key was added to an already-indexed column after creating the
# table - other databases give primary keys an independant index.
#
# Although _prepare_show_index is defined here, no drivers actually satisfy the
# above without some query result remapping, and as such all currently override
# either this or _execute_show_index.
*_prepare_show_index = \&_generic_prepare;
$COMPILE{extract_index_name} = __LINE__ . <<'END_OF_SUB';
sub extract_index_name {
# -----------------------------------------------------------------------------
# Takes an table name and database index name (which could be prefixed, if the
# database uses prefixes) and returns the GT::SQL index name (i.e. without
# prefix).
my ($self, $table, $index) = @_;
if ($self->{hints}->{prefix_indexes}) {
$index =~ s/^\Q$table\E(?=.)//i;
}
$index;
}
END_OF_SUB
sub disconnect {
# -------------------------------------------------------------------
# Disconnect from the database.
#
my $self = shift;
$self->{dbh} and $self->{dbh}->disconnect;
}
sub reset_env {
# -------------------------------------------------------------------
# Remove all database connections that aren't still alive
#
@GT::SQL::Driver::debug::QUERY_STACK = ();
for my $dsn (keys %CONN) {
next if ($CONN{$dsn} and $CONN{$dsn}->ping);
$CONN{$dsn}->disconnect if ($CONN{$dsn});
delete $CONN{$dsn};
}
}
sub do {
# -------------------------------------------------------------------
# Do a query.
#
my $self = shift;
($self->prepare(@_) or return)->execute;
}
$COMPILE{do_raw_transaction} = __LINE__ . <<'END_OF_SUB';
sub do_raw_transaction {
# -----------------------------------------------------------------------------
# Do a series of queries as a single transaction - note that this is only
# supported under DBI >= 1.20; older versions of DBI result in the queries
# being performed without a transaction.
# This subroutine should be passed a list of queries; the queries will be run
# in order. Each query may optionally be an array reference where the first
# element is the query, and remaining elements are placeholders to use when
# executing the query. Furthermore, you may pass a reference to the string
# or array reference to specify a non-critical query.
#
# For example:
# $self->do_raw_transaction(
# "QUERY1",
# \["QUERY2 ?", $value],
# \"QUERY3",
# ["QUERY4 ?, ?", $value1, $value2]
# );
#
# This will attempt to run the 4 queries, and will abort if query 1 or 4 do not
# succeed.
#
# Also note that this is ONLY meant to be used by individual drivers as it
# assumes the queries passed in are ready to run without any rewriting. As
# such, any use outside of individual drivers should be considered an error.
#
# Returns '1' on success, undef on failure of any query (excepting non-critical
# queries, see above).
#
my ($self, @queries) = @_;
my $transaction = $DBI::VERSION >= 1.20;
$self->{dbh}->begin_work if $transaction;
$self->debug("Begin query transaction") if $self->{_debug};
$self->debug("Transaction not possible; DBI version < 1.20") if $self->{_debug} and not $transaction;
my $time;
$time = Time::HiRes::time() if $self->{_debug} and exists $INC{"Time/HiRes.pm"};
for (@queries) {
my $critical = not(ref eq 'SCALAR' or ref eq 'REF');
my $q = $critical ? $_ : $$_;
my ($query, @ph) = ref $q ? @$q : $q;
if ($self->{_debug}) {
my $debugquery = GT::SQL::Driver::debug->replace_placeholders($query, @ph);
$self->debug("Executing query $debugquery");
}
my $did = $self->{dbh}->do($query, undef, @ph);
if (!$did and $critical) {
$self->warn(CANTEXECUTE => $query => $DBI::errstr);
$self->debug("Critical query failed, transaction aborted; performing transaction rollback")
if $self->{_debug} and $transaction;
$self->{dbh}->rollback if $transaction;
return undef;
}
}
$self->debug("Transaction complete; committing") if $self->{_debug};
$self->{dbh}->commit if $transaction;
if ($self->{_debug} and exists $INC{"Time/HiRes.pm"}) {
my $elapsed = Time::HiRes::time() - $time;
$self->debug(sprintf("Transaction execution took: %.6fs", $elapsed));
}
1;
}
END_OF_SUB
sub quote {
# -----------------------------------------------------------
# This subroutines quotes (or not) a value.
#
my $val = pop;
return 'NULL' if not defined $val;
return $$val if ref $val eq 'SCALAR' or ref $val eq 'LVALUE';
(values %CONN)[0]->quote($val);
}
$COMPILE{create_table} = __LINE__ . <<'END_OF_SUB';
sub create_table {
# -------------------------------------------------------------------
# Creates a table.
#
my $self = shift;
$self->connect or return;
my $table = $self->{name};
# Figure out the order of the create, and then build the create statement.
my %pos = map { $_ => $self->{schema}->{cols}->{$_}->{pos} } keys %{$self->{schema}->{cols}};
my (@field_defs, $ai_queries);
for my $field (sort { $pos{$a} <=> $pos{$b} } keys %{$self->{schema}->{cols}}) {
my %field_def = map { defined $self->{schema}->{cols}->{$field}->{$_} ? ($_ => $self->{schema}->{cols}->{$field}->{$_}) : () } keys %{$self->{schema}->{cols}->{$field}};
my $is_ai = $self->{schema}->{ai} && $field eq $self->{schema}->{ai};
delete $field_def{default} if $is_ai;
my $def = $field . ' ' . ($self->column_sql(\%field_def) or return);
if ($is_ai) {
my $ai = $self->{hints}->{ai} || 'AUTO_INCREMENT';
$ai = $ai->($table, $field) if ref $ai eq 'CODE';
if (ref $ai eq 'ARRAY') {
$ai_queries = $ai;
}
else {
$def .= " $ai";
}
}
push @field_defs, $def;
}
# Add the primary key.
if (@{$self->{schema}->{pk}}) {
push @field_defs, "PRIMARY KEY (" . join(",", @{$self->{schema}->{pk}}) . ")";
}
# Create the table
my $create_query = "\n\tCREATE TABLE $table (\n\t\t";
$create_query .= join ",\n\t\t", @field_defs;
$create_query .= "\n\t)";
$self->do($create_query) or return;
# If the database needs separate queries to set up the auto-increment, run them
if ($ai_queries) {
for (@$ai_queries) {
$self->do($_);
}
}
# Create the table's indexes
for my $type (qw/index unique/) {
my $create_index = "create_$type";
while (my ($index_name, $index) = each %{$self->{schema}->{$type}}) {
$self->$create_index($table => $index_name => @$index) if @$index;
}
}
1;
}
END_OF_SUB
$COMPILE{column_sql} = __LINE__ . <<'END_OF_SUB';
sub column_sql {
# -----------------------------------------------------------------------------
# Converts a column definition into an SQL string used in the create table
# statement, and (for some drivers) when adding a new column to a table.
#
my ($self, $opts) = @_;
ref $opts eq 'HASH' or return $self->fatal(BADARGS => '$obj->column_sql (HASH_REF)');
$opts->{type} or return $self->fatal(BADARGS => 'Column definition does not have a SQL type defined');
my $pkg = ref($self) . '::Types';
my $type = uc $opts->{type};
if ($pkg->can($type)) {
$self->debug("Using driver specific SQL for type $opts->{type}") if $self->{_debug} > 1;
}
elsif (GT::SQL::Driver::Types->can($type)) {
$pkg = 'GT::SQL::Driver::Types';
}
else {
return $self->fatal(BADTYPE => $opts->{type});
}
$pkg->$type({%$opts});
}
END_OF_SUB
$COMPILE{insert} = __LINE__ . <<'END_OF_SUB';
sub insert {
# -----------------------------------------------------------------------------
# This subroutine, using a couple driver hints, handles insertions for every
# driver currently supported.
#
my ($self, $input) = @_;
my (@names, @values, @placeholders, @binds);
my %got;
my $ai = $self->{schema}->{ai};
my $bind = $self->{hints}->{bind};
my $cols = $self->{schema}->{cols};
while (my ($col, $val) = each %$input) {
++$got{$col};
next if $ai and $col eq $ai and !$val;
push @names, $col;
my $def = $cols->{$col};
if ($def->{time_check} and (not defined $val or $val eq '' or $val eq 'NOW()')) {
push @values, $self->{hints}->{now} || 'NOW()';
}
elsif ($def->{type} =~ /DATE/ and (not defined $val or $val eq '')) {
push @values, 'NULL';
}
elsif (ref $val eq 'SCALAR' or ref $val eq 'LVALUE') {
push @values, $$val;
}
else {
push @placeholders, $val;
push @values, '?';
if ($bind and defined $val) {
for (my $i = 1; $i < @$bind; $i += 2) {
if ($def->{type} =~ /$bind->[$i]/) {
push @binds, [scalar @placeholders, $col, $bind->[$i+1]];
last;
}
}
}
}
}
# Update any timestamp columns to current time.
for my $col (keys %$cols) {
next unless not $got{$col} and $cols->{$col}->{time_check};
push @names, $col;
push @values, $self->{hints}->{now} || 'NOW()';
$got{$col} = 1;
}
# Add an auto increment field if required
if ($ai and not $input->{$ai}) {
my @ai_insert = $self->ai_insert($ai);
if (@ai_insert) {
push @names, $ai_insert[0];
push @values, $ai_insert[1];
}
}
# Fill in any missing defaults
for my $col (keys %$cols) {
next if $ai and $col eq $ai
or $got{$col}
or not exists $cols->{$col}->{default};
my $val = $cols->{$col}->{default};
push @names, $col;
push @values, '?';
push @placeholders, $val;
$got{$col} = 1;
if ($bind and defined $val) {
my $def = $cols->{$col};
for (my $i = 1; $i < @$bind; $i += 2) {
if ($def->{type} =~ /$bind->[$i]/) {
push @binds, [scalar @placeholders, $col, $bind->[$i+1]];
last;
}
}
}
}
# Create the SQL and statement handle.
my $query = "INSERT INTO $self->{name} (";
$query .= join ',', @names;
$query .= ") VALUES (";
$query .= join ',', @values;
$query .= ")";
$bind->[0]->{$query} = \@binds if $bind;
my $sth = $self->prepare($query) or return;
$sth->execute(@placeholders) or return;
$sth;
}
END_OF_SUB
sub ai_insert {
# -----------------------------------------------------------------------------
# Returns a column name and value to use for the AI column when inserting a
# row. If this returns an empty list, no value will be inserted. This will
# only be called when the table has an auto-increment column, so checking is
# not necessary. The sole argument passed in is the name of the column.
#
my ($self, $ai) = @_;
return $ai, 'NULL';
}
$COMPILE{insert_multiple} = __LINE__ . <<'END_OF_SUB';
sub insert_multiple {
# -----------------------------------------------------------------------------
# Performs a multiple-insertion. By default, this is simply done as multiple
# executes on a single insertion, and as a single transaction if under
# DBI >= 1.20.
#
my ($self, $cols, $args) = @_;
$self->{dbh}->begin_work if $DBI::VERSION >= 1.20;
my $count;
for my $val (@$args) {
my %set;
for my $i (0 .. $#$cols) {
$set{$cols->[$i]} = $val->[$i];
}
++$count if $self->insert(\%set);
}
$self->{dbh}->commit if $DBI::VERSION >= 1.20;
$count;
}
END_OF_SUB
sub update {
# -------------------------------------------------------------------
my ($self, $set, $where) = @_;
my $c = $self->{schema}->{cols};
my %set;
for my $cond (@{$set->{cond}}) {
if (ref $cond eq 'ARRAY') {
$set{$cond->[0]}++ if exists $c->{$cond->[0]} and $c->{$cond->[0]}->{time_check};
}
}
for my $col (keys %$c) {
next unless not $set{$col} and $c->{$col}->{time_check};
$set->add($col, '=', \($self->{hints}->{now} || 'NOW()'));
}
my ($sql_set, $set_vals, $set_cols) = $set->sql(1);
my ($sql_where, $where_vals, $where_cols) = $where->sql(1);
my $i = 1;
# Set up binds, if necessary
my @binds;
my $bind = $self->{hints}->{bind};
if ($bind) {
for my $col (@$set_cols) {
next unless exists $c->{$col};
for (my $j = 1; $j < @$bind; $j += 2) {
if ($c->{$col}->{type} =~ /$bind->[$j]/) {
push @binds, [scalar $i, $col, $bind->[$j+1]];
last;
}
}
$i++;
}
}
my $query = "UPDATE $self->{name} SET $sql_set";
$query .= " WHERE $sql_where" if $sql_where;
$bind->[0]->{$query} = \@binds if $bind;
my $sth = $self->prepare($query) or return;
$sth->execute(@$set_vals, @$where_vals) or return;
$sth;
}
sub delete {
# -------------------------------------------------------------------
my ($self, $where) = @_;
my ($sql_where, $where_vals) = $where ? $where->sql(1) : ();
my $sql = "DELETE FROM $self->{name}";
$sql .= " WHERE $sql_where" if $sql_where;
my $sth = $self->prepare($sql) or return;
$sth->execute(@$where_vals) or return;
$sth;
}
sub select {
# -------------------------------------------------------------------
my ($self, $field_arr, $where, $opts) = @_;
my ($fields, $opt_clause) = ('', '');
if (ref $field_arr and @$field_arr) {
$fields = join ",", @$field_arr;
}
else {
$fields = '*';
}
my ($sql_where, $where_vals) = $where->sql(1);
$sql_where and ($sql_where = " WHERE $sql_where");
if ($opts) {
for my $opt (@$opts) {
next if (! defined $opt);
$opt_clause .= " $opt";
}
}
my $sql = "SELECT $fields FROM " . $self->{name};
$sql .= $sql_where if $sql_where;
$sql .= $opt_clause if $opt_clause;
my $sth = $self->prepare($sql) or return;
$sth->execute(@$where_vals) or return;
$sth;
}
$COMPILE{drop_table} = __LINE__ . <<'END_OF_SUB';
sub drop_table {
# -------------------------------------------------------------------
# Drops the table passed in.
#
my ($self, $table) = @_;
$self->do("DROP TABLE $table");
}
END_OF_SUB
$COMPILE{column_exists} = __LINE__ . <<'END_OF_SUB';
sub column_exists {
# -----------------------------------------------------------------------------
# Returns true or false value depending on whether the column exists in the
# table. This defaults to a DESCRIBE of the table, then looks for the column
# in the DESCRIBE results - but many databases probably have a much more
# efficient alternative.
#
my ($self, $table, $column) = @_;
my $sth = $self->prepare("DESCRIBE $table") or return;
$sth->execute or return;
my $found;
while (my ($col) = $sth->fetchrow) {
$found = 1, last if $col eq $column;
}
$found;
}
END_OF_SUB
$COMPILE{add_column} = __LINE__ . <<'END_OF_SUB';
sub add_column {
# -------------------------------------------------------------------
# Adds a column to a table.
#
my ($self, $table, $column, $def) = @_;
$self->do("ALTER TABLE $table ADD $column $def");
}
END_OF_SUB
$COMPILE{drop_column} = __LINE__ . <<'END_OF_SUB';
sub drop_column {
# -------------------------------------------------------------------
# Drops a column from a table.
#
my ($self, $table, $column) = @_;
$self->do("ALTER TABLE $table DROP $column");
}
END_OF_SUB
$COMPILE{alter_column} = __LINE__ . <<'END_OF_SUB';
sub alter_column {
# -----------------------------------------------------------------------------
# Changes a column. Takes table name, column name, definition for the new
# column (string), and the old column definition (hash ref). The new column
# definition should already be set in the table object
# ($self->{table}->{schema}->{cols}->{$column_name}).
#
my ($self, $table, $column, $new_def, $old_col) = @_;
$self->do("ALTER TABLE $table CHANGE $column $column $new_def");
}
END_OF_SUB
$COMPILE{create_index} = __LINE__ . <<'END_OF_SUB';
sub create_index {
# -----------------------------------------------------------------------------
# Adds an index - checks driver hints for whether or not to prefix the index
# with the prefixed table name.
#
my ($self, $table, $index_name, @index_cols) = @_;
$index_name = $table . $index_name if $self->{hints}->{prefix_indexes};
$self->do("CREATE INDEX $index_name ON $table (" . join(",", @index_cols) . ")");
}
END_OF_SUB
$COMPILE{create_unique} = __LINE__ . <<'END_OF_SUB';
sub create_unique {
# -----------------------------------------------------------------------------
# Adds a unique index to a table, using the prefixed table name as a prefix.
#
my ($self, $table, $unique_name, @unique_cols) = @_;
$unique_name = $table . $unique_name if $self->{hints}->{prefix_indexes};
$self->do("CREATE UNIQUE INDEX $unique_name ON $table (" . join(",", @unique_cols) . ")");
}
END_OF_SUB
$COMPILE{drop_index} = __LINE__ . <<'END_OF_SUB';
sub drop_index {
# -----------------------------------------------------------------------------
# Drops an index.
#
my ($self, $table, $index_name) = @_;
$index_name = $table . $index_name if $self->{hints}->{prefix_indexes};
my $dropped = $self->do("DROP INDEX $index_name");
$dropped ||= $self->do("DROP INDEX $self->{connect}->{PREFIX}$index_name") if $self->{hints}->{fix_index_dbprefix};
$dropped;
}
END_OF_SUB
$COMPILE{create_pk} = __LINE__ . <<'END_OF_SUB';
sub create_pk {
# -------------------------------------------------------------------
# Adds a primary key to a table.
#
my ($self, $table, @cols) = @_;
$self->do("ALTER TABLE $table ADD PRIMARY KEY (" . join(",", @cols) . ")");
}
END_OF_SUB
$COMPILE{drop_pk} = __LINE__ . <<'END_OF_SUB';
sub drop_pk {
# -------------------------------------------------------------------
# Drop a primary key.
#
my ($self, $table) = @_;
my $do;
if ($self->{hints}->{drop_pk_constraint}) {
# To drop a primary key in ODBC or Pg, you drop the primary key
# constraint, which implicitly drops the index implicitly created by a
# primary key.
my $sth = $self->prepare("SHOW INDEX FROM $table") or return;
$sth->execute or return;
my $pk_constraint;
while (my $index = $sth->fetchrow_hashref) {
if ($index->{index_primary}) {
$pk_constraint = $index->{index_name};
last;
}
}
$pk_constraint or return $self->warn(CANTEXECUTE => "ALTER TABLE $table DROP PRIMARY KEY" => "No primary key found for $table");
$do = "ALTER TABLE $table DROP CONSTRAINT $pk_constraint";
}
else {
$do = "ALTER TABLE $table DROP PRIMARY KEY";
}
$self->do($do);
}
END_OF_SUB
1;

521
site/glist/lib/GT/SQL/Driver/MSSQL.pm Normal file
View File

@ -0,0 +1,521 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Driver::MSSQL
# CVS Info :
# $Id: MSSQL.pm,v 2.6 2005/06/28 23:36:43 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description: MSSQL driver for GT::SQL
#
package GT::SQL::Driver::MSSQL;
# ====================================================================
use strict;
use vars qw/@ISA $ERROR_MESSAGE %BINDS/;
use DBI qw/:sql_types/;
use GT::SQL::Driver;
use GT::AutoLoader;
$ERROR_MESSAGE = 'GT::SQL';
@ISA = qw/GT::SQL::Driver/;
sub protocol_version { 2 }
sub connect {
# ------------------------------------------------------------------
# Need to set some session preferences.
#
my $self = shift;
my $dbh = $self->SUPER::connect(@_) or return;
# Set max read properties for DBI
$dbh->{LongReadLen} = 1_048_576;
# Newer DBD::ODBC sets this to 0 which can cause cast errors
$dbh->{odbc_default_bind_type} = SQL_VARCHAR;
$dbh->do("SET QUOTED_IDENTIFIER ON");
$dbh->do("SET ANSI_NULLS ON");
$dbh->do("SET ANSI_PADDING OFF");
$dbh->do("SET ANSI_WARNINGS OFF");
return $dbh;
}
sub dsn {
# -------------------------------------------------------------------
# Override the default create dsn, with our own. Creates DSN like:
# DBI:ODBC:DSN
#
my ($self, $connect) = @_;
$self->{driver} = $connect->{driver} = 'ODBC';
return "DBI:$connect->{driver}:$connect->{database}";
}
sub hints {
fix_index_dbprefix => 1,
case_map => 1,
bind => [
\%BINDS,
'TEXT' => DBI::SQL_LONGVARCHAR,
'DATE|TIME' => DBI::SQL_VARCHAR
],
now => 'GETDATE()',
ai => 'IDENTITY(1,1)',
drop_pk_constraint => 1
}
sub _prepare_select {
# -----------------------------------------------------------------------------
# Track limits as ODBC has no built-in limit support; this driver hacks it in.
#
my ($self, $query) = @_;
my ($limit, $offset);
# Look for either PG or MySQL limits
$query =~ s/\bLIMIT\s+(\d+)\s+OFFSET\s+(\d+)/($limit, $offset) = ($1, $2); ''/ie
or $query =~ s/\bOFFSET\s+(\d+)\s+LIMIT\s+(\d+)/($limit, $offset) = ($2, $1); ''/ie
or $query =~ s/\bLIMIT\s+(\d+)\s*(?:,\s*(\d+))?/($limit, $offset) = ($2 || $1, $2 ? $1 : 0); ''/ie;
if ($limit) {
$self->{_limit} = 1;
$self->{_lim_offset} = $offset;
my $top = $limit + $offset;
$query =~ s/(SELECT(?:\s+DISTINCT)?)/$1 TOP $top/i;
if (!$offset) {
delete @$self{qw/_limit _lim_offset/};
}
}
return $query;
}
sub _prepare_describe {
# -----------------------------------------------------------------------------
# For compatibility with old code, 'DESCRIBE TABLE' is mapped to something that
# looks something like a MySQL 'DESCRIBE TABLE' result.
#
my ($self, $query) = @_;
if ($query =~ /DESCRIBE\s+(\w+)/i) {
return <<QUERY;
SELECT
c.name AS "Field",
CASE
WHEN t.name LIKE '%int' THEN t.name + '(' + CAST(t.prec AS VARCHAR) + ')'
WHEN t.name LIKE '%char' THEN t.name + '(' + CAST(c.length AS VARCHAR) + ')'
WHEN t.name = 'decimal' THEN t.name + '(' + CAST(c.prec AS VARCHAR) + ',' + CAST(c.scale AS VARCHAR) + ')'
WHEN t.name = 'float' THEN 'double'
ELSE t.name
END AS "Type",
ISNULL(c.collation, 'binary') AS "Collation",
CASE WHEN c.isnullable = 1 THEN 'YES' ELSE '' END AS "Null",
(
SELECT TOP 1
CASE
WHEN m.text LIKE '(''%' THEN SUBSTRING(m.text, 3, LEN(m.text) - (CASE WHEN m.text LIKE '%'')' THEN 4 ELSE 2 END))
WHEN m.text LIKE '(%' THEN SUBSTRING(m.text, 2, LEN(m.text) - (CASE WHEN m.text LIKE '%)' THEN 2 ELSE 1 END))
ELSE m.text
END
FROM syscomments m, sysobjects d
WHERE m.id = d.id AND d.xtype = 'D' AND d.info = c.colid AND d.parent_obj = o.id
) AS "Default",
CASE WHEN c.status & 0x80 = 0x80 THEN 'auto_increment' ELSE '' END AS "Extra"
FROM
syscolumns c, systypes t, sysobjects o
WHERE
c.id = o.id AND
o.name = '$1' AND
o.type = 'U' AND
c.xtype = t.xtype
ORDER BY
c.colid
QUERY
}
else {
return $self->warn(CANTPREPARE => $query, "Invalid/unsupported DESCRIBE query");
}
# The following could be used above for "Key" - but it really isn't that useful
# considering there's a working SHOW INDEX:
# (
# SELECT
# CASE WHEN COUNT(*) >= 1 THEN 'PRI' ELSE '' END
# FROM sysindexes i, sysindexkeys k
# WHERE
# i.indid = 1 AND i.id = o.id AND k.id = i.id AND k.indid = i.indid AND
# k.colid = c.colid
# ) AS "Key",
}
sub column_exists {
my ($self, $table, $column) = @_;
my $sth = $self->{dbh}->prepare(<<EXISTS);
SELECT
COUNT(*)
FROM syscolumns c, sysobjects o
WHERE
c.id = o.id AND
o.type = 'U' AND
o.name = ? AND
c.name = ?
EXISTS
$sth->execute($table, $column);
return scalar $sth->fetchrow;
}
sub _prepare_show_tables {
# -----------------------------------------------------------------------------
# MS SQL's version of MySQL's 'SHOW TABLES'; there is also 'sp_tables', but
# that returns more information (and more tables - it includes system tables)
# than we want.
#
my $self = shift;
$self->{do} = 'SELECT';
"SELECT name as table_name FROM sysobjects WHERE xtype = 'U'";
}
sub _prepare_show_index {
# -----------------------------------------------------------------------------
# See the 'Driver-specific notes' comment in GT::SQL::Driver
#
my ($self, $query) = @_;
if ($query =~ /^\s*SHOW\s+INDEX\s+FROM\s+(\w+)\s*$/i) {
$self->{do} = 'SELECT';
return <<QUERY;
SELECT
sysindexes.name AS index_name,
syscolumns.name AS index_column,
INDEXPROPERTY(sysindexes.id, sysindexes.name, 'IsUnique') AS index_unique,
CASE
WHEN sysindexes.indid = 1 AND (
SELECT COUNT(*) FROM sysconstraints
WHERE sysconstraints.id = sysobjects.id AND sysconstraints.status & 7 = 1
) > 0 THEN 1
ELSE 0
END AS index_primary
FROM
sysindexes, sysobjects, sysindexkeys, syscolumns
WHERE
sysindexes.indid >= 1 AND sysindexes.indid < 255 AND
sysindexes.id = sysobjects.id AND sysindexes.id = sysindexkeys.id AND sysindexes.id = syscolumns.id AND
sysindexkeys.colid = syscolumns.colid AND
sysindexes.status = 0 AND
sysindexes.indid = sysindexkeys.indid AND
sysobjects.xtype = 'U' AND sysobjects.name = '$1'
ORDER BY
sysindexkeys.indid, sysindexkeys.keyno
QUERY
}
else {
return $self->warn(CANTPREPARE => $query, "Invalid/unsupported SHOW INDEX query");
}
}
# MS SQL shouldn't have the AI column in the insert list
sub ai_insert { () }
# Returns a list of default constraints given a table and column
sub _defaults {
my ($self, $table_name, $column_name) = @_;
my $query = <<" QUERY";
SELECT o.name
FROM sysconstraints d, sysobjects t, syscolumns c, sysobjects o
WHERE d.status & 5 = 5 -- status with '5' bit set indicates a default constraint
AND d.id = t.id -- constraint table to table
AND c.id = t.id -- column's table to table
AND d.colid = c.colid -- constraint column to column
AND d.constid = o.id -- constraint id to object
AND t.name = '$table_name' -- the table we're looking for
AND c.name = '$column_name' -- the column we're looking for
QUERY
my $sth = $self->{dbh}->prepare($query)
or return $self->warn(CANTPREPARE => $query, $DBI::errstr);
$sth->execute()
or return $self->warn(CANTEXECUTE => $query, $DBI::errstr);
my @defaults;
while (my $default = $sth->fetchrow) {
push @defaults, $default;
}
return @defaults;
}
sub drop_column {
# -------------------------------------------------------------------
# Generates the SQL to drop a column.
#
my ($self, $table, $column, $old_col) = @_;
my @queries;
# Delete any indexes on the column, as MSSQL does not do this automatically
my $sth = $self->prepare("SHOW INDEX FROM $table");
$sth->execute;
my %drop_index;
while (my $index = $sth->fetchrow_hashref) {
if ($index->{index_column} eq $column) {
$drop_index{$index->{index_name}}++;
}
}
push @queries, map "DROP INDEX $table.$_", keys %drop_index;
for ($self->_defaults($table, $column)) {
# Drop any default constraints
push @queries, "ALTER TABLE $table DROP CONSTRAINT $_";
}
push @queries, "ALTER TABLE $table DROP COLUMN $column";
$self->do_raw_transaction(@queries);
}
sub alter_column {
# -------------------------------------------------------------------
# Changes a column in a table.
#
my ($self, $table, $column, $new_def, $old_col) = @_;
# make a copy so as not to clobber the original reference
my %col = %{$self->{schema}->{cols}->{$column}};
if ($col{type} =~ /TEXT$/i) {
# You can't alter a TEXT column in MSSQL, so we have to create an
# entirely new column, copy the data, drop the old one, then rename the
# new one using sp_rename.
my $tmpcol = "tempcol__" . time . "__" . ('a' .. 'z', 'A' .. 'Z')[rand 52];
# We don't have to worry about dropping indexes because TEXT's can't be indexed.
my @constraints = $self->_defaults($table, $column);
# Added columns must have a default, which unfortunately cannot be a column, so
# if the definition doesn't already have a default, add a fake one. We use ''
# for the default - though not allowed by GT::SQL, it _is_ allowed by MSSQL.
my $no_default;
if (not defined $col{default}) {
$col{default} = '';
$new_def = $self->column_sql(\%col);
$no_default = 1;
}
# This cannot be done in one single transaction as the columns won't
# completely exist yet, as far as MSSQL is concerned.
$self->do("ALTER TABLE $table ADD $tmpcol $new_def") or return;
push @constraints, $self->_defaults($table, $tmpcol) if $no_default;
my @q = "UPDATE $table SET $tmpcol = $column";
push @q, map "ALTER TABLE $table DROP CONSTRAINT $_", @constraints;
push @q, "ALTER TABLE $table DROP COLUMN $column";
$self->do_raw_transaction(@q) or return;
$self->do("sp_rename '$table.$tmpcol', '$column'") or return;
return 1;
}
# An ALTER COLUMN in MS SQL cannot contain a default, so if a default is
# specified that isn't the same as the old one, we drop the default
# constraint and add a new one.
my $new_default = delete $col{default};
my $old_default = $old_col->{default};
my $default_changed = (
defined $new_default and defined $old_default and $new_default ne $old_default
or
defined $new_default ne defined $old_default
);
my @queries;
if ($default_changed) {
if (defined $old_default) {
push @queries, map "ALTER TABLE $table DROP CONSTRAINT $_", $self->_defaults($table, $column);
}
if (defined $new_default) {
push @queries, "ALTER TABLE $table ADD CONSTRAINT default_${table}_$column DEFAULT " . $self->quote($new_default) . " FOR $column";
}
}
if (defined $new_default) {
# Rewrite the column def without the DEFAULT (an ALTER COLUMN cannot contain a default in MSSQL)
$new_def = $self->column_sql(\%col);
}
push @queries, "ALTER TABLE $table ALTER COLUMN $column $new_def";
return @queries > 1
? $self->do_raw_transaction(@queries)
: $self->do($queries[0]);
}
sub drop_index {
# -------------------------------------------------------------------
# Drops an index. Versions of this module prior to 2.0 were quite broken -
# first, the index naming was (database prefix)(index name) in some places, and
# (prefixed table name)(index name) in others. Furthermore, no prefixing of
# indexes is needed at all as, like MySQL, indexes are per-table. As such,
# this driver now looks for all three types of index when attempting to remove
# existing indexes.
#
my ($self, $table, $index_name) = @_;
return $self->do("DROP INDEX $table.$index_name")
or $self->do("DROP INDEX $table.$table$index_name")
or $self->do("DROP INDEX $table.$self->{connect}->{PREFIX}$index_name");
}
sub extract_index_name {
# -----------------------------------------------------------------------------
my ($self, $table, $index) = @_;
$index =~ s/^\Q$table\E(?=.)//i # broken (tablename)(index name) format
or $index =~ s/^\Q$self->{connect}->{PREFIX}\E(?=.)//i; # broken (prefix)(index name) format;
$index;
}
package GT::SQL::Driver::MSSQL::sth;
# ====================================================================
use strict;
use vars qw/@ISA $ERROR_MESSAGE $DEBUG/;
use GT::SQL::Driver::sth;
use GT::AutoLoader;
$ERROR_MESSAGE = 'GT::SQL';
$DEBUG = 0;
@ISA = qw/GT::SQL::Driver::sth/;
sub insert_id {
# -------------------------------------------------------------------
# Retrieves the current sequence.
#
my $self = shift;
return $self->{_insert_id} if $self->{_insert_id};
my $sth = $self->{dbh}->prepare('SELECT @@IDENTITY') or return $self->fatal(CANTPREPARE => 'SELECT @@IDENTITY', $DBI::errstr);
$sth->execute or return $self->fatal(CANTEXECUTE => 'SELECT @@IDENTITY', $DBI::errstr);
$self->{_insert_id} = $sth->fetchrow;
}
sub execute {
# -------------------------------------------------------------------
# Fetch off only rows we are interested in.
#
my $self = shift;
if ($self->{_need_preparing}) {
$self->{sth} = $self->{dbh}->prepare($self->{query}) or return $self->warn(CANTPREPARE => $self->{query}, $DBI::errstr);
}
if (my $binds = $GT::SQL::Driver::MSSQL::BINDS{$self->{query}}) {
for my $bind (@$binds) {
my ($index, $col, $type) = @$bind;
$self->{sth}->bind_param($index, $_[$index-1], $type);
}
}
else {
# We need to look for any values longer than 8000 characters and bind_param them
# to SQL_LONGVARCHAR's to avoid an implicit rebinding that results in a
# "Can't rebind placeholder x" error.
for (my $i = 0; $i < @_; $i++) {
if (defined $_[$i] and length $_[$i] > 8000) {
$self->{sth}->bind_param($i+1, $_[$i], DBI::SQL_LONGVARCHAR);
}
}
}
my $time;
if ($self->{_debug}) {
$self->last_query($self->{query}, @_);
my $stack = '';
if ($self->{_debug} > 1) {
$stack = GT::Base->stack_trace(1,1);
$stack =~ s/<br>/\n /g;
$stack =~ s/&nbsp;/ /g;
$stack = "\n $stack\n"
}
my $query = GT::SQL::Driver::debug->replace_placeholders($self->{query}, @_);
$self->debug("Executing query: $query$stack");
$time = Time::HiRes::time() if exists $INC{"Time/HiRes.pm"};
}
my $rc = $self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
$self->{_names} = $self->{_results} = $self->{_insert_id} = undef;
# Attempting to access ->{NAME} is not allowed for queries that don't actually
# returning anything (such as 'ALTER TABLE foo ADD COLUMN a INT'); as such, try
# to avoid them here. The eval is there just in case a query runs that isn't
# caught.
unless ($self->{do} =~ /^(?:ALTER|CREATE|INSERT|UPDATE|DROP|DELETE|SP_RENAME)$/) {
eval {
$self->{_names} = $self->{sth}->{NAME};
};
}
# Limit the results if needed.
if ($self->{do} eq 'SELECT' or $self->{do} eq 'DESCRIBE') {
my $none;
if ($self->{_limit}) {
my $begin = $self->{_lim_offset} || 0;
for (1 .. $begin) {
# Discard any leading rows that we don't care about
$self->{sth}->fetchrow_arrayref or $none = 1, last;
}
}
$self->{_results} = $none ? [] : $self->{sth}->fetchall_arrayref;
$self->{rows} = @{$self->{_results}};
}
elsif ($self->{query} =~ /^\s*sp_/) {
$self->{_results} = $self->{sth}->fetchall_arrayref;
$self->{rows} = @{$self->{_results}};
}
else {
$self->{rows} = $self->{sth}->rows;
}
$self->{sth}->finish;
$self->{_need_preparing} = 1;
if ($self->{_debug} and exists $INC{"Time/HiRes.pm"}) {
my $elapsed = Time::HiRes::time() - $time;
$self->debug(sprintf("Query execution took: %.6fs", $elapsed));
}
return $rc;
}
# ------------------------------------------------------------------------------------------------ #
# DATA TYPE MAPPINGS
# ------------------------------------------------------------------------------------------------ #
package GT::SQL::Driver::MSSQL::Types;
use strict;
use GT::SQL::Driver::Types;
use Carp qw/croak/;
use vars qw/@ISA/;
@ISA = 'GT::SQL::Driver::Types';
# MSSQL has a TINYINT type, however it is always unsigned, so only use it if
# the column is _meant_ to be unsigned - otherwise use SMALLINT, which is
# always signed.
sub TINYINT {
my ($class, $args) = @_;
my $type = $args->{unsigned} ? 'TINYINT' : 'SMALLINT';
$class->base($args, $type);
}
# Though MSSQL supports a CHAR type, it can't be used because it doesn't trim
# trailing spaces, and that would most likely break things designed to work
# with the way 'CHAR's currently work.
sub DATE { $_[0]->base($_[1], 'DATETIME') }
sub TIMESTAMP { $_[0]->base($_[1], 'DATETIME') }
sub TIME { croak "MSSQL does not support 'TIME' columns" }
sub YEAR { $_[0]->base($_[1], 'DATETIME') }
# MSSQL doesn't support BLOB's, but has binary 'IMAGE' and 'VARBINARY' types -
# the one (rather large) caveat to these being that they require escaping and
# unescaping of input and output.
1;

226
site/glist/lib/GT/SQL/Driver/MYSQL.pm Normal file
View File

@ -0,0 +1,226 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Driver::MYSQL
# CVS Info :
# $Id: MYSQL.pm,v 2.1 2005/04/14 00:56:30 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description: MySQL driver for GT::SQL
#
package GT::SQL::Driver::MYSQL;
# ====================================================================
use strict;
use vars qw/@ISA $ERROR_MESSAGE/;
use GT::SQL::Driver;
use DBD::mysql 1.19_03;
$ERROR_MESSAGE = 'GT::SQL';
@ISA = qw/GT::SQL::Driver/;
sub protocol_version { 2 }
sub dsn {
# -----------------------------------------------------------------------------
# Creates the data source name used by DBI to connect to the database.
#
my ($self, $connect) = @_;
my $dsn;
$connect->{driver} ||= 'mysql';
$connect->{host} ||= 'localhost';
$self->{driver} = $connect->{driver};
$dsn = "DBI:$connect->{driver}:";
$dsn .= join ';', map { $connect->{$_} ? "$_=$connect->{$_}" : () } qw/database host port/;
return $dsn;
}
sub _prepare_select {
# -----------------------------------------------------------------------------
# Prepares a query; rewrites PG-style LIMIT x OFFSET y into MySQL's confusing
# LIMIT y, n
#
my ($self, $query) = @_;
$query =~ s/\bLIMIT\s+(\d+)\s+OFFSET\s+(\d+)/LIMIT $2, $1/i
or $query =~ s/\bOFFSET\s+(\d+)\s+LIMIT\s+(\d+)/LIMIT $1, $2/i;
$query;
}
sub insert_multiple {
# -----------------------------------------------------------------------------
# Performs a multiple-insertion. We have to watch the maximum query length,
# performing multiple queries if necessary.
#
my ($self, $cols, $args) = @_;
my $has_ai;
$has_ai = grep $_ eq $self->{schema}->{ai}, @$cols if $self->{schema}->{ai};
my $names = join ",", @$cols;
$names .= ",$self->{schema}->{ai}" if $self->{schema}->{ai} and not $has_ai;
my $ret;
my $values = '';
for (@$args) {
my $new_val;
$new_val = "(" . join(",", map GT::SQL::Driver::quote($_), @$_);
$new_val .= ",NULL" if $self->{schema}->{ai} and not $has_ai;
$new_val .= ")";
if ($values and length($values) + length($new_val) > 1_000_000) {
++$ret if $self->do("INSERT INTO $self->{name} ($names) VALUES $values");
$values = '';
}
$values .= "," if $values;
$values .= $new_val;
}
if ($values) {
++$ret if $self->do("INSERT INTO $self->{name} ($names) VALUES $values");
}
$ret;
}
# If making a nullable TEXT column not null, make sure we update existing NULL
# columns to get the default value.
sub alter_column {
my ($self, $table, $column, $new_def, $old_col) = @_;
my %col = %{$self->{schema}->{cols}->{$column}};
if ($col{type} =~ /TEXT$/i
and $col{not_null}
and not $old_col->{not_null}
and defined $col{default}
and not defined $old_col->{default}) {
$self->{dbh}->do("UPDATE $table SET $column = ? WHERE $column IS NULL", undef, $col{default});
}
return $self->SUPER::alter_column(@_[1 .. $#_])
}
sub create_index {
my ($self, $table, $index_name, @index_cols) = @_;
$self->do("ALTER TABLE $table ADD INDEX $index_name (" . join(',', @index_cols) . ")");
}
sub create_unique {
my ($self, $table, $index_name, @index_cols) = @_;
$self->do("ALTER TABLE $table ADD UNIQUE $index_name (" . join(',', @index_cols) . ")");
}
sub drop_index {
my ($self, $table, $index_name) = @_;
$self->do("ALTER TABLE $table DROP INDEX $index_name");
}
package GT::SQL::Driver::MYSQL::sth;
# ====================================================================
use strict;
use vars qw/@ISA $ERROR_MESSAGE/;
use GT::SQL::Driver::sth;
$ERROR_MESSAGE = 'GT::SQL';
@ISA = qw/GT::SQL::Driver::sth/;
sub insert_id {
# -------------------------------------------------------------------
# Catch mysql's auto increment field.
#
my $self = shift;
return $self->{sth}->{mysql_insertid} || $self->{sth}->{insertid};
}
sub rows { shift->{sth}->rows }
sub _execute_show_index {
my $self = shift;
$self->{sth}->execute or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
my @results;
# Mysql columns are: Table Non_unique Key_name Seq_in_index Column_name Collation Cardinality Sub_part Packed Null Index_type Comment
my @names = @{$self->row_names};
# We need to add index_name, index_column, index_unique, index_primary (see GT::SQL::Driver)
push @names, qw/index_name index_column index_unique index_primary/ unless $self->{_names};
while (my $row = $self->{sth}->fetchrow_arrayref) {
my %h = map { $names[$_] => $row->[$_] } 0 .. $#$row;
push @results, [@$row, $h{Key_name}, $h{Column_name}, $h{Non_unique} ? 0 : 1, $h{Key_name} eq 'PRIMARY' ? 1 : 0];
}
$self->{rows} = @results;
$self->{_names} = \@names;
$self->{_results} = \@results;
}
package GT::SQL::Driver::MYSQL::Types;
use strict;
use GT::SQL::Driver::Types;
use vars qw/@ISA/;
@ISA = 'GT::SQL::Driver::Types';
# Integers. MySQL supports non-standard unsigned and zerofill properties;
# unsigned, though unportable, is supported here, however zerofill - whose
# usefulness is dubious at best - is not.
sub TINYINT { $_[0]->base($_[1], 'TINYINT', ['unsigned']) }
sub SMALLINT { $_[0]->base($_[1], 'SMALLINT', ['unsigned']) }
sub MEDIUMINT { $_[0]->base($_[1], 'MEDIUMINT', ['unsigned']) }
sub INT { $_[0]->base($_[1], 'INT', ['unsigned']) }
sub BIGINT { $_[0]->base($_[1], 'BIGINT', ['unsigned']) }
# Floats - MySQL's 'REAL' is really a 64-bit floating point number, while for
# everything else 'REAL' is a 32-bit floating point number, so we override the
# defaults here to FLOAT.
sub FLOAT { $_[0]->base($_[1], 'FLOAT') }
sub REAL { $_[0]->base($_[1], 'FLOAT') }
sub CHAR {
my ($class, $args, $out) = @_;
$args->{size} = 255 unless $args->{size} and $args->{size} <= 255;
$out ||= 'CHAR';
$out .= "($args->{size})";
$out .= ' BINARY' if $args->{binary}; # MySQL-only
$out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}) if defined $args->{default};
$out .= ' NOT NULL' if $args->{not_null};
return $out;
}
sub TEXT {
my ($class, $args) = @_;
my $type = 'LONGTEXT';
delete $args->{default}; # MySQL is the only driver that doesn't support defaults on TEXT's
if ($args->{size}) {
if ($args->{size} < 256) {
$type = 'TINYTEXT';
}
elsif ($args->{size} < 65536) {
$type = 'TEXT';
}
elsif ($args->{size} < 16777216) {
$type = 'MEDIUMTEXT';
}
}
$class->base($args, $type);
}
# MySQL supports ENUM; the generic ENUM is mapped to a VARCHAR
sub ENUM {
my ($class, $args) = @_;
@{$args->{'values'}} or return;
my $out = 'ENUM(' . join(",", map GT::SQL::Driver->quote($_), @{$args->{values}}) . ')';
$out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}) if defined $args->{default};
$out .= ' NOT NULL' if $args->{not_null};
$out;
}
sub BLOB {
my ($class, $attrib, $blob) = @_;
delete $attrib->{default};
$class->base($attrib, $blob || 'BLOB');
}
1;

541
site/glist/lib/GT/SQL/Driver/ORACLE.pm Normal file
View File

@ -0,0 +1,541 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Driver::ORACLE
# CVS Info :
# $Id: ORACLE.pm,v 2.1 2005/02/01 02:01:18 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description: Oracle 8+ driver for GT::SQL
#
package GT::SQL::Driver::ORACLE;
# ====================================================================
use strict;
use vars qw/@ISA $ERROR_MESSAGE $ERRORS %BINDS/;
use DBD::Oracle qw/:ora_types/;
use GT::SQL::Driver;
use GT::AutoLoader;
$ERROR_MESSAGE = 'GT::SQL';
@ISA = qw/GT::SQL::Driver/;
sub protocol_version { 2 }
sub connect {
# ------------------------------------------------------------------
# Need to set some session preferences.
#
my $self = shift;
# ORACLE_HOME must be set for the DBD::Oracle driver to function properly.
return $self->warn('NOORACLEHOME') unless exists $ENV{ORACLE_HOME};
my $dbh = $self->SUPER::connect(@_) or return;
# Set the date format to same format as other drivers use.
$dbh->do("ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS'")
or return $self->fatal(NONLSDATE => $DBI::errstr);
# Set max read properties for DBI.
$dbh->{LongReadLen} = 1_048_576;
return $dbh;
}
sub dsn {
# -------------------------------------------------------------------
# Oracle DSN looks like:
# DBI:Oracle:host=HOST;port=POST;sid=SID
#
my ($self, $connect) = @_;
$connect->{driver} ||= 'Oracle';
$connect->{host} ||= 'localhost';
$self->{driver} = $connect->{driver};
my $dsn = "DBI:$connect->{driver}:";
$dsn .= "host=$connect->{host}";
$dsn .= ";port=$connect->{port}" if $connect->{port};
$dsn .= ";sid=$connect->{database}";
return $dsn;
}
sub hints {
case_map => 1,
prefix_indexes => 1,
bind => [
\%BINDS,
'TEXT' => ORA_CLOB,
'BLOB' => ORA_BLOB
],
now => 'SYSDATE',
ai => sub {
my ($table, $column) = @_;
my $seq = "${table}_seq";
my @q;
push @q, \"DROP SEQUENCE $seq";
push @q, "CREATE SEQUENCE $seq INCREMENT BY 1 START WITH 1 NOCYCLE";
\@q;
}
}
sub prepare {
# -----------------------------------------------------------------------------
# Clear our limit counters. Oracle does not have built-in limit support, so it
# is handled here by fetching all the results that were asked for into _results
# and our own fetchrow methods work off that.
#
my ($self, $query) = @_;
# Oracle uses "SUBSTR" instead of "SUBSTRING"
$query =~ s/\bSUBSTRING\(/SUBSTR(/gi;
$self->SUPER::prepare($query);
}
sub _prepare_select {
# -----------------------------------------------------------------------------
# Need to store what the requested result set; no built in LIMIT support like
# mysql.
#
my ($self, $query) = @_;
my ($limit, $offset);
# Handle either PG or MySQL limits
$query =~ s/\bLIMIT\s+(\d+)\s+OFFSET\s+(\d+)/($limit, $offset) = ($1, $2); ''/ie
or $query =~ s/\bOFFSET\s+(\d+)\s+LIMIT\s+(\d+)/($limit, $offset) = ($2, $1); ''/ie
or $query =~ s/\bLIMIT\s+(\d+)\s*(?:,\s*(\d+))?/($limit, $offset) = ($2 || $1, $2 ? $1 : 0); ''/ie;
if ($limit) {
$self->{_limit} = 1;
$self->{_lim_rows} = $limit;
$self->{_lim_offset} = $offset;
}
# LEFT OUTER JOIN is not supported, instead:
# ... FROM Table1, Table2 WHERE col1 = col2(+) ...
$query =~ s{FROM\s+(\w+)\s+LEFT OUTER JOIN\s+(\w+)\s+ON\s+([\w.]+)\s*=\s*([\w.]+)(\s+WHERE\s+)?}{
my ($table1, $table2, $col1, $col2, $where) = ($1, $2, $3, $4, $5);
my $from_where = "FROM $table1, $table2 WHERE ";
$from_where .= index($col1, "$table1.") == 0
? "$col1 = $col2(+)"
: "$col2 = $col1(+)";
$from_where .= " AND " if $where;
$from_where;
}ie;
$query;
}
sub _prepare_describe {
# ------------------------------------------------------------------
# Oracle supports USER_TAB_COLUMNS to get information
# about a table.
#
my ($self, $query) = @_;
if ($query =~ /DESCRIBE\s+(\w+)/i) {
return <<" QUERY";
SELECT COLUMN_NAME, DATA_TYPE, DATA_LENGTH, DATA_PRECISION, DATA_SCALE, NULLABLE, DATA_DEFAULT
FROM USER_TAB_COLUMNS
WHERE TABLE_NAME = '\U$1\E'
ORDER BY COLUMN_ID
QUERY
}
else {
return $self->warn(CANTPREPARE => $query, "Cannot get properties from db_tab_columns");
}
}
sub column_exists {
my ($self, $table, $column) = @_;
my $sth = $self->{dbh}->prepare(<<EXISTS);
SELECT COUNT(*)
FROM USER_TAB_COLUMNS
WHERE TABLE_NAME = ? AND COLUMN_NAME = ?
EXISTS
$sth->execute(uc $table, uc $column);
return scalar $sth->fetchrow;
}
sub _prepare_show_tables {
# -----------------------------------------------------------------------------
# Oracle's equivelant to SHOW TABLES
#
my $self = shift;
$self->{do} = 'SELECT';
'SELECT table_name FROM USER_TABLES ORDER BY table_name';
}
sub _prepare_show_index {
# -----------------------------------------------------------------------------
# Get an index list; see 'Driver-specific notes' comment in GT::SQL::Driver
my ($self, $query) = @_;
if ($query =~ /^\s*SHOW\s+INDEX\s+FROM\s+(\w+)\s*$/i) {
# The below isn't quite perfect - Oracle 8 doesn't support CASE (9 does), so
# the 'index_unique' still has to be mapped to a 1/0 value in execute(). Also
# worth noting is that primary keys in Oracle don't always get their own index
# - in particular, when adding a primary key to a table using a column that is
# already indexed, the primary key will simply use the existing index instead
# of creating a new one.
return <<QUERY;
SELECT
ic.index_name AS "index_name",
ic.column_name AS "index_column",
(
SELECT COUNT(*) FROM user_constraints c, user_cons_columns cc
WHERE c.index_name = i.index_name AND c.constraint_name = cc.constraint_name
AND c.constraint_type = 'P' AND cc.column_name = ic.column_name
) "index_primary",
uniqueness AS "index_unique"
FROM
user_ind_columns ic,
user_indexes i
WHERE
ic.index_name = i.index_name AND
LOWER(ic.table_name) = '\L$1\E'
ORDER BY
ic.index_name,
ic.column_position
QUERY
}
else {
return $self->warn(CANTPREPARE => $query, "Invalid/unsupported SHOW INDEX query: $query");
}
}
sub drop_table {
# -------------------------------------------------------------------
# Drops a table, including a sequence if necessary
#
my ($self, $table) = @_;
my $seq = uc "${table}_seq";
my $sth = $self->{dbh}->prepare("SELECT SEQUENCE_NAME FROM USER_SEQUENCES WHERE SEQUENCE_NAME = '$seq'");
$sth->execute();
if (my $seq_name = $sth->fetchrow) {
my $sth = $self->{dbh}->prepare("DROP SEQUENCE $seq");
$sth->execute or $self->warn(CANTEXECUTE => "DROP SEQUENCE $seq", $GT::SQL::error);
}
return $self->SUPER::drop_table($table);
}
sub ai_insert {
my ($self, $ai) = @_;
return $ai, "$self->{name}_seq.NEXTVAL";
}
sub alter_column {
# -------------------------------------------------------------------
# Changes a column. Takes table name, column name, and new column definition.
#
my ($self, $table, $column, $new_def, $old_col) = @_;
# make a copy so the original reference doesn't get clobbered
my %col = %{$self->{schema}->{cols}->{$column}};
# If the default value was removed, then make sure that the default constraint
# from the previous instance is deactivated.
if (not exists $col{default} and defined $old_col->{default} and length $old_col->{default}) {
$col{default} = \'NULL';
}
# Oracle doesn't like being told to make an already NOT NULL column NOT NULL:
if ($col{not_null} and $old_col->{not_null}) {
delete $col{not_null};
}
$new_def = $self->column_sql(\%col);
# But it needs an explicit NULL to drop the field's NOT NULL
if (not $col{not_null} and $old_col->{not_null}) {
$new_def .= ' NULL';
}
# Oracle doesn't need the data type, and won't accept it on CLOB/BLOB columns
$new_def =~ s/^[BC]LOB ?//;
$new_def or return 1; # If the def is empty now, there really isn't anything to be done.
$self->do("ALTER TABLE $table MODIFY $column $new_def");
}
sub drop_column {
# -------------------------------------------------------------------
# Drops a column
#
my ($self, $table, $column) = @_;
$self->do("ALTER TABLE $table DROP COLUMN $column");
}
sub create_pk {
# -------------------------------------------------------------------
# Adds a primary key to a table.
#
my ($self, $table, @cols) = @_;
$self->create_index($table, "${table}_pkey", @cols);
$self->do("ALTER TABLE $table ADD CONSTRAINT ${table}_pkey PRIMARY KEY (" . join(",", @cols) . ")");
}
package GT::SQL::Driver::ORACLE::sth;
# ====================================================================
use strict;
use vars qw/@ISA $ERROR_MESSAGE $DEBUG/;
use GT::SQL::Driver::sth;
use GT::AutoLoader;
$ERROR_MESSAGE = 'GT::SQL';
$DEBUG = 0;
@ISA = qw/GT::SQL::Driver::sth/;
sub insert_id {
# -------------------------------------------------------------------
# Retrieves the current sequence.
#
my $self = shift;
return $self->{_insert_id} if $self->{_insert_id};
my ($table) = $self->{query} =~ /\s*insert\s*into\s*(\w+)/i;
$table ||= $self->{name};
my $seq = $table . "_seq.CURRVAL";
my $query = "SELECT $seq FROM $table";
my $sth = $self->{dbh}->prepare($query) or return $self->fatal(CANTPREPARE => $query, $DBI::errstr);
$sth->execute or return $self->fatal(CANTEXECUTE => $query, $DBI::errstr);
my ($id) = $sth->fetchrow_array;
$self->{_insert_id} = $id;
return $id;
}
sub execute {
# -------------------------------------------------------------------
# Fetch off only desired rows.
#
my $self = shift;
my $time;
if ($self->{_debug}) {
$self->last_query($self->{query}, @_);
my $stack = '';
if ($self->{_debug} > 1) {
$stack = GT::Base->stack_trace(1,1);
$stack =~ s/<br>/\n /g;
$stack =~ s/&nbsp;/ /g;
$stack = "\n $stack\n"
}
my $query = GT::SQL::Driver::debug->replace_placeholders($self->{query}, @_);
$self->debug("Executing query: $query$stack");
$time = Time::HiRes::time() if exists $INC{"Time/HiRes.pm"};
}
if ($GT::SQL::Driver::ORACLE::BINDS{$self->{query}}) {
for my $bind (@{$GT::SQL::Driver::ORACLE::BINDS{$self->{query}}}) {
my ($index, $col, $type) = @$bind;
$self->{sth}->bind_param($index, $_[$index - 1], { ora_type => $type, ora_field => $col });
}
}
my $rc = $self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
$self->{_results} = [];
$self->{_insert_id} = '';
$self->{_names} = $self->{sth}->{NAME};
if ($self->{do} eq 'SELECT') {
$self->{_lim_cnt} = 0;
if ($self->{_limit}) {
my $begin = $self->{_lim_offset} || 0;
my $end = $begin + $self->{_lim_rows};
my $i = -1;
while (my $rec = $self->{sth}->fetchrow_arrayref) {
$i++;
next if $i < $begin;
last if $i >= $end;
push @{$self->{_results}}, [@$rec]; # Must copy as ref is reused in DBI.
}
}
else {
$self->{_results} = $self->{sth}->fetchall_arrayref;
}
$self->{rows} = @{$self->{_results}};
}
elsif ($self->{do} eq 'SHOW INDEX') {
$self->{_names} = $self->{sth}->{NAME_lc};
$self->{_results} = $self->{sth}->fetchall_arrayref;
my $i = 0;
for (@{$self->{_names}}) { last if $_ eq 'index_unique'; $i++ }
for (@{$self->{_results}}) {
$_->[$i] = uc($_->[$i]) eq 'UNIQUE' ? 1 : 0;
}
$self->{rows} = @{$self->{_results}};
}
elsif ($self->{do} eq 'DESCRIBE') {
$rc = $self->_fixup_describe();
}
else {
$self->{rows} = $self->{sth}->rows;
}
if ($self->{_debug} and exists $INC{"Time/HiRes.pm"}) {
my $elapsed = Time::HiRes::time() - $time;
$self->debug(sprintf("Query execution took: %.6fs", $elapsed));
}
return $rc;
}
sub _fixup_describe {
# ---------------------------------------------------------------
# Converts output of 'sp_columns tablename' into similiar results
# of mysql's describe tablename.
#
my $self = shift;
my @results;
# Mysql Cols are: Field, Type, Null, Key, Default, Extra
my $table = uc $self->{name};
while (my $col = $self->{sth}->fetchrow_hashref) {
my ($table, $field, $type, $size, $prec, $scale) = @$col{qw/TABLE_NAME COLUMN_NAME DATA_TYPE DATA_LENGTH DATA_PRECISION DATA_SCALE/};
my $null = $col->{NULLABLE} eq 'Y';
my $default = (not defined $col->{DATA_DEFAULT} or $col->{DATA_DEFAULT} =~ /^''\s*/) ? '' : $col->{DATA_DEFAULT};
$size = length $default if length $default > $size;
if ($type =~ /VARCHAR2|CHAR/) {
$type = "varchar($size)";
}
elsif ($type =~ /NUMBER/ and !$scale) {
if ($prec) {
$type =
$prec >= 11 ? 'bigint' :
$prec >= 9 ? 'int' :
$prec >= 6 ? 'mediumint' :
$prec >= 4 ? 'smallint' :
'tinyint';
}
else {
$type = 'bigint';
}
}
elsif ($type =~ /NUMBER/ and length $prec and length $scale) {
$type = "decimal($prec, $scale)";
}
elsif ($type =~ /FLOAT/) {
$type = (!$prec or $prec > 23) ? 'double' : 'real';
}
elsif ($type =~ /LONG|CLOB|NCLOB/) {
$type = 'text';
}
elsif ($type =~ /DATE/) {
$type = 'datetime';
}
$type = lc $type;
$default =~ s,^NULL\s*,,;
$default =~ s,^\(?'(.*)'\)?\s*$,$1,;
$null = $null ? 'YES' : '';
push @results, [$field, $type, $null, '', $default, ''];
}
( $#results < 0 ) and return;
# Fetch the Primary key
my $que_pk = <<" QUERY";
SELECT COL.COLUMN_NAME
FROM USER_CONS_COLUMNS COL, USER_CONSTRAINTS CON
WHERE COL.TABLE_NAME = '\U$table\E'
AND COL.TABLE_NAME = CON.TABLE_NAME
AND COL.CONSTRAINT_NAME = CON.CONSTRAINT_NAME
AND CON.CONSTRAINT_TYPE='P'
QUERY
my $sth_pk = $self->{dbh}->prepare($que_pk);
$sth_pk->execute;
my $indexes = {};
while ( my $col = $sth_pk->fetchrow_array ) {
$indexes->{$col} = "PRI";
}
$sth_pk->finish;
# Fetch the index information.
my $que_idx = <<" QUERY";
SELECT *
FROM USER_INDEXES IND, USER_IND_COLUMNS COL
WHERE IND.TABLE_NAME = '\U$table\E'
AND IND.TABLE_NAME = COL.TABLE_NAME
AND IND.INDEX_NAME = COL.INDEX_NAME
QUERY
my $sth_idx = $self->{dbh}->prepare($que_idx);
$sth_idx->execute;
while ( my $col = $sth_idx->fetchrow_hashref ) {
my $key = $col->{UNIQUENESS} =~ /UNIQUE/ ? 'UNIQUE' : 'MUL';
exists $indexes->{$col->{COLUMN_NAME}} or $indexes->{$col->{COLUMN_NAME}} = $key;
}
for my $result (@results) {
if (defined $indexes->{$result->[0]}) {
$result->[3] = $indexes->{$result->[0]};
if ($result->[1] =~ /int/) { # Set extra
my $sth = $self->{dbh}->prepare("SELECT SEQUENCE_NAME FROM USER_SEQUENCES WHERE SEQUENCE_NAME = '\U$table\E_SEQ'");
$sth->execute;
$result->[5] = 'auto_increment' if $sth->fetchrow;
$sth->finish;
}
}
}
$sth_idx->finish;
$self->{_results} = \@results;
$self->{_names} = [qw/Field Type Null Key Default Extra/];
$self->{rows} = @{$self->{_results}};
return 1;
}
sub finish {
# -----------------------------------------------------------------------------
my $self = shift;
delete $GT::SQL::Driver::ORACLE::BINDS{$self->{query}};
$self->SUPER::finish;
}
# -----------------------------------------------------------------------------
# DATA TYPE MAPPINGS
# -----------------------------------------------------------------------------
package GT::SQL::Driver::ORACLE::Types;
use strict;
use GT::SQL::Driver::Types;
use Carp qw/croak/;
use vars qw/@ISA/;
@ISA = 'GT::SQL::Driver::Types';
# Quoting table and/or column names gives case-sensitivity to the table and
# column names in Oracle - however, because this needs to be compatible with
# older versions of this driver that didn't properly handle table/column case,
# we can't use that to our advantage, as all the old unquoted tables/columns
# would be upper-case - TABLE or COLUMN will be the name in the database, and
# "Table" or "column" would not exist. It would, however, still be nice to
# support this at some point:
# sub base {
# my ($class, $args, $name, $attribs) = @_;
# $class->SUPER::base($args, qq{"$name"}, $attribs);
# }
sub TINYINT { $_[0]->base($_[1], 'NUMBER(3)') }
sub SMALLINT { $_[0]->base($_[1], 'NUMBER(5)') }
sub MEDIUMINT { $_[0]->base($_[1], 'NUMBER(8)') }
sub INT { $_[0]->base($_[1], 'NUMBER(10)') }
sub BIGINT { $_[0]->base($_[1], 'NUMBER(19)') }
sub REAL { $_[0]->base($_[1], 'FLOAT(23)') }
sub DOUBLE { $_[0]->base($_[1], 'FLOAT(52)') }
sub DATETIME { $_[0]->base($_[1], 'DATE') }
sub TIMESTAMP { $_[0]->base($_[1], 'DATE') }
sub TIME { croak "Oracle does not support 'TIME' columns\n" }
sub YEAR { croak "Oracle does not support 'YEAR' columns\n" }
sub CHAR { $_[0]->SUPER::CHAR($_[1], 'VARCHAR2') }
sub VARCHAR { $_[0]->SUPER::CHAR($_[1], 'VARCHAR2') }
sub TEXT { $_[0]->base($_[1], 'CLOB') }
sub BLOB { delete $_[1]->{default}; $_[0]->base($_[1], 'BLOB') }
1;

643
site/glist/lib/GT/SQL/Driver/PG.pm Normal file
View File

@ -0,0 +1,643 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Driver::PG
# CVS Info :
# $Id: PG.pm,v 2.2 2005/02/01 02:00:47 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description: PostgreSQL driver for GT::SQL
#
package GT::SQL::Driver::PG;
# ====================================================================
use strict;
use vars qw/@ISA $ERROR_MESSAGE/;
use GT::SQL::Driver;
use GT::AutoLoader;
use DBI();
$ERROR_MESSAGE = 'GT::SQL';
@ISA = qw/GT::SQL::Driver/;
sub protocol_version { 2 }
sub dsn {
# -----------------------------------------------------------------------------
# Creates a postgres-specific DSN, such as:
# DBI:Pg:dbname=database;host=some_hostname
# host is omitted if set to 'localhost', so that 'localhost' can be used for a
# non-network connection. If you really want to connect to localhost, use
# 127.0.0.1.
#
my ($self, $connect) = @_;
$connect->{driver} ||= 'Pg';
$connect->{host} ||= 'localhost';
$self->{driver} = $connect->{driver};
my $dsn = "DBI:$connect->{driver}:";
$dsn .= "dbname=$connect->{database}";
$dsn .= ";host=$connect->{host}" unless $connect->{host} eq 'localhost';
$dsn .= ";port=$connect->{port}" if $connect->{port};
return $dsn;
}
sub hints {
prefix_indexes => 1,
fix_index_dbprefix => 1,
case_map => 1,
ai => sub {
my ($table, $column) = @_;
my $seq = "${table}_seq";
my @q;
push @q, \"DROP SEQUENCE $seq";
push @q, "CREATE SEQUENCE $seq INCREMENT 1 START 1";
\@q;
},
drop_pk_constraint => 1
}
$COMPILE{_version} = __LINE__ . <<'END_OF_SUB';
sub _version {
my $self = shift;
return $self->{pg_version} if $self->{pg_version};
my $ver = $self->{dbh}->get_info(18); # SQL_DBMS_VERSION
if ($ver) {
local $^W;
$ver = sprintf "%.2f", $ver;
}
return $self->{pg_version} = $ver;
}
END_OF_SUB
sub _prepare_select {
# -----------------------------------------------------------------------------
# Rewrite MySQL-style LIMIT y,x into PG's nicer LIMIT x OFFSET y format
#
my ($self, $query) = @_;
$query =~ s/\bLIMIT\s+(\d+)\s*,\s*(\d+)/LIMIT $2 OFFSET $1/i;
$query;
}
sub _prepare_describe {
# ------------------------------------------------------------------
# Postgres-specific describe code
#
my ($self, $query) = @_;
$query =~ /DESCRIBE\s*(\w+)/i
or return $self->warn(CANTPREPARE => $query, "Invalid describe query: $query");
# atttypmod contains the scale and precision, but has to be extracted using bit operations:
my $prec_bits = 2**26-2**15-1; # bits 16 through 26 give the precision (given a max prec of 1000)
my $scale_bits = 2**10-1; # bits 1 through 10 give the scale + 4 (given a max scale of 1000)
<<QUERY
SELECT
a.attname as "Field",
CASE
WHEN t.typname = 'int4' THEN 'int(10)'
WHEN t.typname = 'int2' THEN 'smallint(5)'
WHEN t.typname = 'int8' THEN 'bigint(19)'
WHEN t.typname = 'float4' THEN 'real'
WHEN t.typname = 'float8' THEN 'double'
WHEN t.typname = 'bpchar' THEN 'char(' || (a.atttypmod - 4) || ')'
WHEN t.typname = 'varchar' THEN 'varchar(' || (a.atttypmod - 4) || ')'
WHEN t.typname = 'numeric' THEN 'decimal(' || ((atttypmod & $prec_bits)>>16) || ',' || ((a.atttypmod & $scale_bits)-4) || ')'
ELSE t.typname
END AS "Type",
CASE WHEN a.attnotnull = 't' THEN '' ELSE 'YES' END AS "Null",
(
SELECT
CASE
WHEN adsrc SIMILAR TO '''%''::[a-zA-Z0-9]+' THEN substring(adsrc from '''#"%#"''::[a-zA-Z0-9]+' for '#')
WHEN adsrc SIMILAR TO '[0-9.e+-]+' THEN adsrc
ELSE NULL
END
FROM pg_attrdef
WHERE adrelid = c.relfilenode AND adnum = a.attnum
) AS "Default",
(
SELECT
CASE WHEN d.adsrc LIKE 'nextval(%)' THEN 'auto_increment' ELSE '' END
FROM pg_attrdef d
WHERE d.adrelid = c.relfilenode AND adnum = a.attnum
) AS "Extra"
FROM
pg_class c, pg_attribute a, pg_type t
WHERE
a.atttypid = t.oid AND a.attrelid = c.oid AND
relkind = 'r' AND
a.attnum > 0 AND
c.relname = '\L$1\E'
ORDER BY
a.attnum
QUERY
# The following could be used above for Key - but it's left off because SHOW
# INDEX is much more useful:
# (
# SELECT CASE WHEN COUNT(*) >= 1 THEN 'PRI' ELSE '' END
# FROM pg_index keyi, pg_class keyc, pg_attribute keya
# WHERE keyi.indexrelid = keyc.oid AND keya.attrelid = keyc.oid and keyi.indrelid = c.oid
# and indisprimary = 't' and keya.attname = a.attname
# ) AS "Key",
}
sub column_exists {
my ($self, $table, $column) = @_;
my $sth = $self->{dbh}->prepare(<<EXISTS);
SELECT
COUNT(*)
FROM
pg_class c, pg_attribute a
WHERE
a.attrelid = c.oid AND
c.relkind = 'r' AND a.attnum > 0 AND
c.relname = ? AND a.attname = ?
EXISTS
$sth->execute(lc $table, lc $column);
return scalar $sth->fetchrow;
}
sub _prepare_show_tables {
# -----------------------------------------------------------------------------
# pg-specific 'SHOW TABLES'-equivelant
#
<<' QUERY';
SELECT relname AS tables
FROM pg_class
WHERE relkind = 'r' AND NOT (relname LIKE 'pg_%' OR relname LIKE 'sql_%')
ORDER BY relname
QUERY
}
sub _prepare_show_index {
# -----------------------------------------------------------------------------
# Get index list
#
my ($self, $query) = @_;
unless ($query =~ /^\s*SHOW\s+INDEX\s+FROM\s+(\w+)\s*$/i) {
return $self->warn(CANTPREPARE => $query, "Invalid/unsupported SHOW INDEX query: $query");
}
<<" QUERY";
SELECT
c.relname AS index_name,
attname AS index_column,
CASE WHEN indisunique = 't' THEN 1 ELSE 0 END AS index_unique,
CASE WHEN indisprimary = 't' THEN 1 ELSE 0 END AS index_primary
FROM
pg_index i,
pg_class c,
pg_class t,
pg_attribute a
WHERE
i.indexrelid = c.oid AND
a.attrelid = c.oid AND
i.indrelid = t.oid AND
t.relname = '\L$1\E'
ORDER BY
i.indexrelid, a.attnum
QUERY
}
sub drop_table {
# -----------------------------------------------------------------------------
# Drops the table passed in - drops a sequence if needed. Takes a second
# argument that, if true, causes the sequence _not_ to be dropped - used when
# the table is being recreated.
#
my ($self, $table) = @_;
my $sth = $self->{dbh}->prepare("SELECT relname FROM pg_class WHERE relkind = 'S' AND relname = '\L$table\E_seq'");
$sth->execute();
if (my $seq_name = $sth->fetchrow) {
$self->do("DROP SEQUENCE $seq_name")
or $self->warn(CANTEXECUTE => "DROP SEQUENCE $seq_name", $GT::SQL::error);
}
return $self->SUPER::drop_table($table);
}
sub drop_column {
# -------------------------------------------------------------------
# Drops a column from a table.
#
my ($self, $table, $column) = @_;
my $ver = $self->_version();
# Postgresql 7.3 and above support ALTER TABLE $table DROP $column
return $self->SUPER::drop_column($table, $column) if $ver and $ver >= 7.03;
$self->_recreate_table();
}
$COMPILE{_recreate_table} = __LINE__ . <<'END_OF_SUB';
sub _recreate_table {
# -----------------------------------------------------------------------------
# Adds/removes/changes a column, but very expensively as it involves recreating
# and copying the entire table. Takes argument pairs, currently:
#
# with => 'adding_this_column' # optional
#
# Keep in mind that the various columns depend on the {cols} hash of the table
# having been updated to reflect the change.
#
# We absolutely require DBI 1.20 in this subroutine for transaction support.
# However, we won't get here if using PG >= 7.3, so you can have either an
# outdated PG, or an outdated DBI, but not both.
#
my ($self, %opts) = @_;
DBI->require_version(1.20);
my $ver = $self->_version;
my $table = $self->{name} or $self->fatal(BADARGS => 'No table specified');
my $cols = $self->{schema}->{cols};
my %pos = map { $_ => $cols->{$_}->{pos} } keys %$cols;
my (@copy_cols, @select_cols);
for (keys %$cols) {
push @copy_cols, "$_ " . $self->column_sql($cols->{$_});
push @select_cols, $_;
}
if ($opts{with}) { # a column was added, so we can't select it from the old table
@select_cols = grep $_ ne $opts{with}, @select_cols;
}
$self->{dbh}->begin_work;
my $temptable = "GTTemp" . substr(time, -4) . int rand 10000;
my $select_cols = join ', ', @select_cols;
my $lock = "LOCK TABLE $table";
my $createtemp = "CREATE TABLE $temptable AS SELECT * FROM $table";
my $insert = "INSERT INTO $table ( $select_cols ) SELECT $select_cols FROM $temptable";
my $drop_temp = "DROP TABLE $temptable";
for my $precreate ($lock, $createtemp) {
unless ($self->{dbh}->do($precreate)) {
$self->warn(CANTEXECUTE => $precreate => $DBI::errstr);
$self->{dbh}->rollback;
return undef;
}
}
unless ($self->drop_table($table)) {
$self->{dbh}->rollback;
return undef;
}
unless ($self->create_table) {
$self->{dbh}->rollback;
return undef;
}
for my $postcreate ($insert, $drop_temp) {
unless ($self->{dbh}->do($postcreate)) {
$self->warn(CANTEXECUTE => $postcreate => $DBI::errstr);
$self->{dbh}->rollback;
return undef;
}
}
$self->{dbh}->commit;
return 1;
}
END_OF_SUB
sub alter_column {
# -----------------------------------------------------------------------------
# Changes a column in a table. The actual path done depends on multiple
# things, including your version of postgres. The following are supported
# _without_ recreating the table; anything more complicated requires the table
# be recreated via _recreate_table().
#
# - changing/dropping a default, with >= 7.0 (doesn't require DBI >= 1.20,
# everything else does)
# - adding/dropping a not null contraint, with >= 7.3
# - any other changes, with >= 7.3, by adding a new column, copying data into
# it, dropping the old column
#
# Anything else calls _recreate_table(), which also requires DBI 1.20, but is
# much more involved as the table has to be dropped and recreated.
#
my ($self, $table, $column, $new_def, $old_col) = @_;
my $ver = $self->_version;
return $self->_recreate_table() if $ver < 7;
my $cols = $self->{schema}->{cols};
my $new_col = $cols->{$column};
my @onoff = qw/not_null/; # true/false attributes
my @changeable = qw/default size scale precision/; # changeable attributes
my %add = map { ($new_col->{$_} and not $old_col->{$_}) ? ($_ => 1) : () } @onoff;
my %rem = map { ($old_col->{$_} and not $new_col->{$_}) ? ($_ => 1) : () } @onoff;
my %change = map { (
exists $new_col->{$_} and exists $old_col->{$_} # exists in both old and new
and (
defined($new_col->{$_}) ne defined($old_col->{$_}) # one is undef, the other isn't
or
defined $new_col->{$_} and defined $old_col->{$_} and $new_col->{$_} ne $old_col->{$_} # both are defined, but !=
)
) ? ($_ => 1) : () } @changeable;
{
my %add_changeable = map { (exists $new_col->{$_} and not exists $old_col->{$_}) ? ($_ => 1) : () } @changeable;
my %rem_changeable = map { (exists $old_col->{$_} and not exists $new_col->{$_}) ? ($_ => 1) : () } @changeable;
%add = (%add, %add_changeable);
%rem = (%rem, %rem_changeable);
}
if ($ver < 7.03) {
# In 7.0 - 7.2, defaults can be added/dropped/changed, but anything
# more complicated needs a table recreation
if (
keys %change == 1 and exists $change{default} and not keys %add and not keys %rem # Changed a default
or keys %add == 1 and exists $add{default} and not keys %change and not keys %rem # Added a default
or keys %rem == 1 and exists $rem{default} and not keys %change and not keys %add # Dropped a default
) {
my $query = "ALTER TABLE $table ALTER COLUMN $column ";
my $ph;
if ($add{default} or $change{default}) {
$query .= "SET DEFAULT ?";
$ph = $new_col->{default};
}
else {
$query .= "DROP DEFAULT";
}
$self->{dbh}->do($query, defined $ph ? (undef, $ph) : ())
or return $self->warn(CANTEXECUTE => $query => $DBI::errstr);
return 1;
}
return $self->_recreate_table();
}
# PG 7.3 or later
if (
keys %rem == 1 and $rem{not_null} and not keys %add and not keys %change # DROP NOT NULL
or keys %add == 1 and $add{not_null} and not keys %rem and not keys %change # SET NOT NULL
) {
# All we're doing is changing a not_null constraint
my $query = "ALTER TABLE $table ALTER COLUMN $column ";
$query .= $rem{not_null} ? 'DROP' : 'SET';
$query .= ' NOT NULL';
$self->{dbh}->do($query)
or return $self->warn(CANTEXECUTE => $query => $DBI::errstr);
return 1;
}
if (keys(%change) - ($change{default} ? 1 : 0) - (($ver >= 8 and $change{type}) ? 1 : 0) == 0 # No changes other than 'default' (and type, for PG >= 8)
and keys(%add) - ($add{default} ? 1 : 0) - ($add{not_null} ? 1 : 0) == 0 # No adds other than default or not_null
and keys(%rem) - ($rem{default} ? 1 : 0) - ($rem{not_null} ? 1 : 0) == 0 # No rems other than default or not_null
) {
my @query;
# Change type (PG 8+ only)
if ($ver >= 8 and $change{type}) {
push @query, "ALTER TABLE $table ALTER COLUMN $column TYPE $new_col->{type}";
}
# Change default
if ($add{default} or $change{default}) {
push @query, ["ALTER TABLE $table ALTER COLUMN $column SET DEFAULT ?", $new_col->{default}];
}
elsif ($rem{default}) {
push @query, "ALTER TABLE $table ALTER COLUMN $column DROP DEFAULT";
}
# Change not_null
if ($rem{not_null}) {
push @query, "ALTER TABLE $table ALTER COLUMN $column DROP NOT NULL";
}
elsif ($add{not_null}) {
if ($add{default}) {
push @query, ["UPDATE $table SET $column = ? WHERE $column IS NULL", $new_col->{default}];
}
push @query, "ALTER TABLE $table ALTER COLUMN $column SET NOT NULL";
}
return $self->do_raw_transaction(@query);
}
# We've got more complex changes than PG's ALTER COLUMN can handle; we need
# to add a new column, copy the data, drop the old column, and rename the
# new one to the old name.
my (@queries, %index, %unique);
push @queries, "LOCK TABLE $table";
my %add_def = %$new_col;
my $not_null = delete $add_def{not_null};
my $default = delete $add_def{default};
my $add_def = $self->column_sql(\%add_def);
my $tmpcol = 'GTTemp' . substr(time, -4) . int(rand 10000);
push @queries, "ALTER TABLE $table ADD COLUMN $tmpcol $add_def";
push @queries, "UPDATE $table SET $tmpcol = $column";
push @queries, ["UPDATE $table SET $tmpcol = ? WHERE $tmpcol IS NULL", $default] if $add{not_null} and defined $default;
push @queries, ["ALTER TABLE $table ALTER COLUMN $tmpcol SET DEFAULT ?", $default] if defined $default;
push @queries, "ALTER TABLE $table ALTER COLUMN $tmpcol SET NOT NULL" if $not_null;
push @queries, "ALTER TABLE $table DROP COLUMN $column";
push @queries, "ALTER TABLE $table RENAME COLUMN $tmpcol TO $column";
for my $type (qw/index unique/) {
while (my ($index, $columns) = each %{$new_col->{$type}}) {
my $recreate;
for (@$columns) {
if ($_ eq $column) {
$recreate = 1;
last;
}
}
next unless $recreate;
if ($type eq 'index') {
$index{$index} = $columns;
}
else {
$unique{$index} = $columns;
}
}
}
$self->do_raw_transaction(@queries);
while (my ($index, $columns) = each %index) {
$self->create_index($table, $index, @$columns);
}
while (my ($index, $columns) = each %unique) {
$self->create_unique($table, $index, @$columns);
}
1;
}
sub add_column {
# -----------------------------------------------------------------------------
# Adds a new column to the table.
#
my ($self, $table, $column, $def) = @_;
# make a copy so the original reference doesn't get clobbered
my %col = %{$self->{schema}->{cols}->{$column}};
# Defaults and not_null have to be set _after_ adding the column.
my $default = delete $col{default};
my $not_null = delete $col{not_null};
my $ver = $self->_version;
return $self->_recreate_table(with => $column)
if $ver < 7 and defined $default or $ver < 7.03 and $not_null;
my @queries;
if (defined $default or $not_null) {
$def = $self->column_sql(\%col);
}
push @queries, ["ALTER TABLE $table ADD $column $def"];
push @queries, ["ALTER TABLE $table ALTER COLUMN $column SET DEFAULT ?", $default] if defined $default;
push @queries, ["UPDATE $table SET $column = ?", $default] if defined $default and $not_null;
push @queries, ["ALTER TABLE $table ALTER COLUMN $column SET NOT NULL"] if $not_null;
$self->do_raw_transaction(@queries);
}
sub create_pk {
my ($self, $table, @cols) = @_;
my $ver = $self->_version;
if ($ver < 7.2) {
return $self->do("ALTER TABLE $table ADD PRIMARY KEY (" . join(',', @cols) . ")");
}
else {
# ALTER TABLE ... ADD PRIMARY KEY (...) was added in PG 7.2 - on prior
# versions we have to recreate the entire table.
return $self->_recreate_table();
}
}
sub drop_pk {
# -----------------------------------------------------------------------------
# Drop a primary key. Look for the primary key, then call drop_index with it.
#
my ($self, $table) = @_;
my $sth = $self->prepare("SHOW INDEX FROM $table") or return;
$sth->execute or return;
my $pk_name;
while (my $index = $sth->fetchrow_hashref) {
if ($index->{index_primary}) {
$pk_name = $index->{index_name};
last;
}
}
$pk_name or return $self->warn(CANTEXECUTE => "ALTER TABLE $table DROP PRIMARY KEY" => "No primary key found for $table");
$self->do("ALTER TABLE $table DROP CONSTRAINT $pk_name");
}
sub ai_insert {
my ($self, $ai) = @_;
return $ai, "NEXTVAL('$self->{name}_seq')";
}
sub insert_multiple {
# -----------------------------------------------------------------------------
# Performs multiple insertions in a single transaction, for much better speed.
#
my $self = shift;
# ->begin_work and ->commit were not added until 1.20
return $self->SUPER::insert_multiple(@_) if $DBI::VERSION < 1.20;
$self->{dbh}->begin_work;
my ($cols, $args) = @_;
my $names = join ",", @$cols, $self->{schema}->{ai} || ();
my $ret;
my $ai_insert = $self->{schema}->{ai} ? "NEXTVAL('$self->{name}_seq')" : undef;
my $query = "INSERT INTO $self->{name} ($names) VALUES (" . join(',', ('?') x @$cols, $ai_insert || ()) . ')';
my $sth = $self->{dbh}->prepare($query) or return $self->warn(CANTPREPARE => $query);
for (@$args) {
if ($sth->execute(@$_)) {
++$ret;
}
else {
$self->warn(CANTEXECUTE => $query);
}
}
$self->{dbh}->commit;
$ret;
}
sub quote {
# -----------------------------------------------------------------------------
# This subroutines quotes (or not) a value. Postgres can't handle any text
# fields containing null characters, so this has to go beyond the ordinary
# quote() in GT::SQL::Driver by stripping out null characters.
#
my $val = pop;
return 'NULL' if not defined $val;
return $$val if ref $val eq 'SCALAR' or ref $val eq 'LVALUE';
$val =~ y/\x00//d;
(values %GT::SQL::Driver::CONN)[0]->quote($val);
}
package GT::SQL::Driver::PG::sth;
# ====================================================================
use strict;
use vars qw/@ISA $ERROR_MESSAGE/;
use GT::SQL::Driver;
use GT::AutoLoader;
$ERROR_MESSAGE = 'GT::SQL';
@ISA = qw/GT::SQL::Driver::sth/;
sub insert_id {
# -------------------------------------------------------------------
# Retrieves the current sequence.
#
my $self = shift;
my ($table) = $self->{query} =~ /\s*insert\s*into\s*(\w+)/i;
$table ||= $self->{name};
my $query = "SELECT CURRVAL('${table}_seq')";
my $sth = $self->{dbh}->prepare($query) or return $self->fatal(CANTPREPARE => $query => $DBI::errstr);
$sth->execute or return $self->fatal(CANTEXECUTE => $query => $DBI::errstr);
my $id = $sth->fetchrow;
return $id;
}
# ------------------------------------------------------------------------------------------------ #
# DATA TYPE MAPPINGS
# ------------------------------------------------------------------------------------------------ #
package GT::SQL::Driver::PG::Types;
# ===============================================================
use strict;
use GT::SQL::Driver::Types;
use Carp qw/croak/;
use vars qw/@ISA/;
@ISA = 'GT::SQL::Driver::Types';
sub DATETIME { $_[0]->base($_[1], 'TIMESTAMP WITHOUT TIME ZONE') }
sub TIMESTAMP { $_[0]->base($_[1], 'TIMESTAMP WITHOUT TIME ZONE') }
sub TIME { $_[0]->base($_[1], 'TIME WITHOUT TIME ZONE') }
sub YEAR { croak "PostgreSQL does not support 'YEAR' columns" }
# Postgres doesn't have BLOB's, but has a binary 'BYTEA' type - the one (big)
# caveat to this type, however, is that it requires escaping for any input, and
# unescaping for any output.
1;

191
site/glist/lib/GT/SQL/Driver/Types.pm Normal file
View File

@ -0,0 +1,191 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Driver::Types
# CVS Info :
# $Id: Types.pm,v 2.1 2004/09/07 20:56:59 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description:
# Implements subroutines for each type to convert into SQL string.
# See GT::SQL::Types for documentation
#
# Supported types are:
# TINYINT SMALLINT MEDIUMINT INT INTEGER BIGINT - 8, 16, 24, 32, 32, 64 bits
# REAL FLOAT DOUBLE - 32, 32, 64 bits
# DECIMAL - decimal precision
# DATE DATETIME TIMESTAMP TIME YEAR - for storing dates/times/etc.
# CHAR VARCHAR - 1-255 characters, CHAR typically takes a fixed amount of space
# TEXT - up to 2GB-1 text data; takes a 'size' parameter which /may/ change to smaller type
# TINYTEXT SMALLTEXT MEDIUMTEXT LONGTEXT - TEXT with 255, 64KB-1, 16MB-1, 2GB-1 size values, respectively
# TINYBLOB BLOB MEDIUMBLOB LONGBLOB - Heavily deprecrated, somewhat-binary data types with 255, 65535, 16777215, 2GB sizes
# ENUM - MySQL-only type, implemented as CHAR by everything else; discouraged for portability reasons.
# FILE - GT::SQL pseudo-type
package GT::SQL::Driver::Types;
use vars qw/$VERSION @EXPORT_OK $ERROR_MESSAGE @ISA/;
use strict;
use Exporter();
use GT::Base();
*import = \&Exporter::import;
$ERROR_MESSAGE = 'GT::SQL';
@ISA = 'GT::Base';
$VERSION = sprintf "%d.%03d", q$Revision: 2.1 $ =~ /(\d+)\.(\d+)/;
@EXPORT_OK = qw/base/;
sub base {
# ------------------------------------------------------------------
# Base function takes care of most of the types that don't require
# much special formatting.
#
my ($class, $args, $name, $attribs) = @_;
$attribs ||= [];
my $out = $name;
for my $attrib (@$attribs) {
$out .= ' ' . $attrib if $args->{$attrib};
}
$out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}) if defined $args->{default};
$out .= ' NOT NULL' if $args->{not_null};
$out;
}
# Integers. None of the following are supported by Oracle, which can only
# define integer types by the number of digits supported (see
# GT/SQL/Driver/ORACLE.pm), and TINYINT and MEDIUMINT are only supported by
# MySQL (though MS SQL will use it's unsigned TINYINT type if the unsigned
# attribute is also passed in). All int types are signed - an 'unsigned'
# column attribute can be used to /suggest/ that the integer type be unsigned -
# but it is only for some databases and/or INT types, and so not guaranteed.
sub TINYINT { $_[0]->base($_[1], 'SMALLINT') } # 8-bit int
sub SMALLINT { $_[0]->base($_[1], 'SMALLINT') } # 16-bit int
sub MEDIUMINT { $_[0]->base($_[1], 'INT') } # 24-bit int
sub INT { $_[0]->base($_[1], 'INT') } # 32-bit int
sub BIGINT { $_[0]->base($_[1], 'BIGINT') } # 64-bit int
sub INTEGER { $_[0]->INT($_[1]) } # alias for INT, above
# Floating point numbers
sub DOUBLE { $_[0]->base($_[1], 'DOUBLE PRECISION') } # 64-bit float (52 bit precision)
sub REAL { $_[0]->base($_[1], 'REAL') } # 32-bit float (23 bit precision), despite what MySQL thinks
sub FLOAT { $_[0]->REAL($_[1]) } # alias for REAL
sub DECIMAL {
# ------------------------------------------------------------------
# Takes care of DECIMAL's precision.
#
my ($class, $args, $out, $attribs) = @_;
$out ||= 'DECIMAL';
$attribs ||= [];
# 'scale' and 'precision' are the proper names, but a prior version used
# the unfortunate 'display' and 'decimal' names, which have no relevant
# meaning in SQL.
my $scale = defined $args->{scale} ? $args->{scale} : defined $args->{decimal} ? $args->{decimal} : undef;
my $precision = defined $args->{precision} ? $args->{precision} : defined $args->{display} ? $args->{display} : undef;
$scale ||= 0;
$precision ||= 10;
$out .= "($precision, $scale)";
for my $attrib (@$attribs) {
$out .= ' ' . $attrib if $args->{$attrib};
}
defined $args->{default} and $out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default});
$args->{not_null} and $out .= ' NOT NULL';
return $out;
}
# Dates - just about every database seems to do things differently here.
sub DATE { $_[0]->base($_[1], 'DATE') }
sub DATETIME { $_[0]->base($_[1], 'DATETIME') }
sub TIMESTAMP { $_[0]->base($_[1], 'TIMESTAMP') }
sub TIME { $_[0]->base($_[1], 'TIME') }
sub YEAR { $_[0]->base($_[1], 'YEAR') }
# Everything (even Oracle) supports CHAR for sizes from 1 to at least 255.
# Everything except Oracle handles VARCHAR's - Oracle, having deprecated
# VARCHAR's, uses VARCHAR2's. However, only MySQL supports the 'BINARY'
# attribute to turn this into a "binary" char (meaning, really,
# case-insensitive, not binary) - for everything else, a "binary" argument is
# simply ignored.
sub CHAR {
my ($class, $args, $out) = @_;
# Important the set the size before calling BINARY, because BINARY's
# behaviour is different for sizes <= 255.
$args->{size} = 255 unless $args->{size} and $args->{size} <= 255;
# See the CHAR notes in GT::SQL::Types regarding why we default to VARCHAR
$out ||= 'VARCHAR';
$out .= "($args->{size})";
$out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}) if defined $args->{default};
$out .= ' NOT NULL' if $args->{not_null};
return $out;
}
sub VARCHAR { $_[0]->CHAR($_[1], 'VARCHAR') }
# By default, all TEXT types are mapped to 'TEXT'; drivers can override this to
# provide different types based on the 'size' attribute.
sub TEXT {
my ($class, $attrib) = @_;
$class->base($attrib, 'TEXT')
}
# .+TEXT is for compatibility with old code, and should be considered
# deprecated. Takes the args hash and the size desired.
sub _OLD_TEXT {
my ($class, $args, $size) = @_;
$args = {$args ? %$args : ()};
$args->{size} = $size unless $args->{size} and $args->{size} < $size;
$class->TEXT($args);
}
sub TINYTEXT { $_[0]->_OLD_TEXT($_[1] => 255) }
sub SMALLTEXT { $_[0]->_OLD_TEXT($_[1] => 65535) }
sub MEDIUMTEXT { $_[0]->_OLD_TEXT($_[1] => 16777215) }
sub LONGTEXT { $_[0]->_OLD_TEXT($_[1] => 2147483647) }
# The BLOB* columns below are heavily deprecated - they're still here just in
# case someone is still using them. Storing binary data inside an SQL row is
# generally a poor idea; a much better approach is to store a pointer to the
# data (such as a filename) in the database, and the actual data in a file.
#
# As such, the default behaviour is to fatal if BLOB's are used - only drivers
# that supported BLOB's prior to protocol v2 should override this. Should a
# binary type be desired in the future, a 'BINARY' pseudo-type is recommended.
sub BLOB {
my ($driver) = $_[0] =~ /([^:]+)$/;
$driver = $driver eq 'PG' ? 'Postgres' : $driver eq 'ORACLE' ? 'Oracle' : $driver eq 'MYSQL' ? 'MySQL' : $driver;
$_[0]->fatal(DRIVERTYPE => $driver => 'BLOB')
}
sub TINYBLOB { $_[0]->BLOB($_[1], 'TINYBLOB') }
sub MEDIUMBLOB { $_[0]->BLOB($_[1], 'MEDIUMBLOB') }
sub LONGBLOB { $_[0]->BLOB($_[1], 'LONGBLOB') }
# Enums - a non-standard SQL type implemented only by MySQL - the default
# implementation is to implement it as a CHAR (or TEXT if the longest value is
# more than 255 characters - but in that case, are you really sure you want to
# use this type?)
sub ENUM {
my ($class, $args) = @_;
my $max = 0;
@{$args->{'values'}} or return;
for my $val (@{$args->{'values'}}) {
my $len = length $val;
$max = $len if $len > $max;
}
my $meth = $max > 255 ? 'TEXT' : 'CHAR';
$class->$meth({ size => $max, default => $args->{default}, not_null => $args->{not_null} });
}
# File handling
sub FILE {
my ($class, $args) = @_;
$class->VARCHAR({ binary => 1, size => $args->{size}, not_null => $args->{not_null} });
}
1;

175
site/glist/lib/GT/SQL/Driver/debug.pm Normal file
View File

@ -0,0 +1,175 @@
# ====================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Driver::debug
# Author: Jason Rhinelander
# CVS Info :
# $Id: debug.pm,v 2.0 2004/08/28 03:51:31 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ====================================================================
#
# Description:
# GT::SQL::Driver debugging module
#
package GT::SQL::Driver::debug;
use strict;
use strict;
use GT::AutoLoader;
use vars qw/$LAST_QUERY @QUERY_STACK @STACK_TRACE $QUERY_STACK_SIZE @ISA/;
@ISA = qw(GT::Base);
$QUERY_STACK_SIZE = 100;
$COMPILE{last_query} = __LINE__ . <<'END_OF_SUB';
sub last_query {
# -------------------------------------------------------------------
# Get, or set the last query.
#
my $self = shift;
return $self->error('NEEDDEBUG', 'WARN') if (! $self->{_debug});
@_ > 0 or return $LAST_QUERY || '';
$LAST_QUERY = shift;
$LAST_QUERY = GT::SQL::Driver::debug->replace_placeholders($LAST_QUERY, @_) if (@_);
# Display stack traces if requested via debug level.
my $stack = '';
if ($self->{_debug} > 2) {
($stack, $LAST_QUERY) = js_stack(3, $LAST_QUERY);
}
elsif ($self->{_debug} > 1) {
package DB;
my $i = 2;
my $ls = defined $ENV{REQUEST_METHOD} ? '<br>' : "\n";
my $spc = defined $ENV{REQUEST_METHOD} ? '&nbsp;' : ' ';
while (my ($file, $line, $sub, $args) = (caller($i++))[1,2,3,4]) {
my @args;
for (@DB::args) {
eval { my $a = $_ }; # workaround for a reference that doesn't think it's a reference
my $print = $@ ? \$_ : $_;
push @args, defined $print ? $print : '[undef]';
}
if (@args) {
my $args = join ", ", @args;
$args =~ s/\n\s*\n/\n/g;
$args =~ s/\n/\n$spc$spc$spc$spc/g;
$stack .= qq!$sub called at $file line $line with arguments $ls$spc$spc ($args).$ls!;
}
else {
$stack .= qq!$sub called at $file line $line with no arguments.$ls!;
}
}
}
push @QUERY_STACK, $LAST_QUERY;
push @STACK_TRACE, "<blockquote>\n" . $stack . "\n</blockquote>\n" if ($self->{_debug} and $stack);
# Pesistance such as Mod_Perl
@QUERY_STACK > $QUERY_STACK_SIZE and shift @QUERY_STACK;
@STACK_TRACE > $QUERY_STACK_SIZE and shift @STACK_TRACE;
return $LAST_QUERY || '';
}
END_OF_SUB
$COMPILE{js_stack} = __LINE__ . <<'END_OF_SUB';
sub js_stack {
# -------------------------------------------------------------------
# Create a nicely formatted javascript browser that (unfortunately)
# only works in ie, netscape sucks.
#
my ($sp, $title) = @_;
my $nb = @QUERY_STACK;
my ($stack, $dump_out);
{
package DB;
require GT::Dumper;
my $i = 0;
while (my ($file, $line, $sub, $args) = (caller($sp++))[1,2,3,4]) {
if (@DB::args) {
$args = "with arguments<br>&nbsp;&nbsp; ";
my @args;
for (@DB::args) {
eval { my $a = $_ }; # workaround for a reference that doesn't think it's a reference
my $print = $@ ? \$_ : $_;
my $arg = defined $print ? $print : '[undef]';
$args .= "<a href='#a$nb$i'>$arg</a>, ";
my $dump = GT::Dumper::Dumper($arg);
$dump_out .= qq~
<a name="a$nb$i"></a>
<a href="#top">Top</a>
<pre>$dump</pre>
~;
$i++;
}
chop $args; chop $args;
}
else {
$args = "with no arguments";
}
$stack .= qq!<li>$sub called at $file line $line $args.<br></li>\n!;
}
}
$stack =~ s/\\/\\\\/g;
$stack =~ s/[\n\r]+/\\n/g;
$stack =~ s/'/\\'/g;
$stack =~ s,script,sc'+'ript,g;
$dump_out =~ s/\\/\\\\/g;
$dump_out =~ s/[\n\r]+/\\n/g;
$dump_out =~ s/'/\\'/g;
$dump_out =~ s,script,sc'+'ript,g;
my $var = <<HTML;
<script language="JavaScript">
function my$nb () {
msg = window.open('','my$nb','resizable=yes,width=700,height=500,scrollbars=yes');
msg.document.write('<html><body><a name="top"></a>STACK TRACE<BR><OL>$stack</OL>$dump_out</BODY></HTML>');
msg.document.close();
}
HTML
my $link = qq!<a href="javascript:my$nb();">$title</a><br>!;
return $var, $link;
}
END_OF_SUB
$COMPILE{quick_quote} = __LINE__ . <<'END_OF_SUB';
sub quick_quote {
# -------------------------------------------------------------------
# Quick quote to replace ' with \'.
#
my $str = shift;
defined $str and ($str eq "") and return "''";
$str =~ s/'/\\'/g;
return $str;
}
END_OF_SUB
$COMPILE{replace_placeholders} = __LINE__ . <<'END_OF_SUB';
sub replace_placeholders {
# -------------------------------------------------------------------
# Replace question marks with the actual values
#
my ($self, $query, @args) = @_;
if (@args > 0) {
my @vals = split /('(?:[^']+|''|\\')')/, $query;
VALUE: for my $val (@args) {
SUBSTRING: for my $i (0 .. $#vals) {
next SUBSTRING if $i % 2;
next VALUE if $vals[$i] =~ s/\?/defined $val ? ( $val =~ m,\D, ? "'".quick_quote($val)."'" : quick_quote($val) ) : 'NULL'/e;
}
}
$query = join '', @vals;
}
return $query;
}
END_OF_SUB
1;

293
site/glist/lib/GT/SQL/Driver/sth.pm Normal file
View File

@ -0,0 +1,293 @@
# ====================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Driver::sth
# Author: Jason Rhinelander
# CVS Info :
# $Id: sth.pm,v 2.1 2004/09/30 01:09:46 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ====================================================================
#
# Description:
# Generic statement handle wrapper
#
package GT::SQL::Driver::sth;
use strict;
use GT::Base;
use GT::AutoLoader(NEXT => '_AUTOLOAD');
require GT::SQL::Driver;
use GT::SQL::Driver::debug;
use vars qw(@ISA $AUTOLOAD $DEBUG $ERROR_MESSAGE);
$DEBUG = 0;
@ISA = qw/GT::SQL::Driver::debug/;
$ERROR_MESSAGE = 'GT::SQL';
# Get rid of a 'used only once' warnings
$DBI::errstr if 0;
sub new {
# --------------------------------------------------------
# Create a new driver sth.
#
my $this = shift;
my $class = ref $this || $this;
my $opts = {};
my $self = bless {}, $class;
if (@_ == 1 and ref $_[0]) { $opts = shift }
elsif (@_ and @_ % 2 == 0) { $opts = {@_} }
else { return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH)") }
$self->{_debug} = $opts->{_debug} || $DEBUG;
$self->{_err_pkg} = $opts->{_err_pkg} || 'GT::SQL';
# Drivers can set this to handle name case changing for fetchrow_hashref
$self->{hints} = $opts->{hints} || {};
for (qw/dbh do query sth schema name _limit _lim_rows _lim_offset/) {
$self->{$_} = $opts->{$_} if exists $opts->{$_};
}
$self->debug("OBJECT CREATED") if ($self->{_debug} > 2);
return $self;
}
$COMPILE{execute} = __LINE__ . <<'END_OF_SUB';
sub execute {
# --------------------------------------------------------
# Execute the query.
#
my $self = shift;
my $do = $self->{do};
my $rc;
# Debugging, stack trace is printed if debug >= 2.
my $time;
if ($self->{_debug}) {
$self->last_query($self->{query}, @_);
my $stack = '';
if ($self->{_debug} > 1) {
$stack = GT::Base->stack_trace(1,1);
$stack =~ s/<br>/\n /g;
$stack =~ s/&nbsp;/ /g;
$stack = "\n $stack\n"
}
my $query = GT::SQL::Driver::debug->replace_placeholders($self->{query}, @_);
$self->debug("Executing query: $query$stack");
$time = Time::HiRes::time() if exists $INC{"Time/HiRes.pm"};
}
if (my $meth = $GT::SQL::Driver::QUERY_MAP{$do}) {
$meth = "_execute_$meth";
$rc = $self->$meth(@_) or return;
}
else {
$rc = $self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
}
if ($self->{_debug} and exists $INC{"Time/HiRes.pm"}) {
my $elapsed = Time::HiRes::time() - $time;
$self->debug(sprintf("Query execution took: %.6fs", $elapsed));
}
$rc;
}
END_OF_SUB
# Define one generic execute, and alias all the specific _execute_* functions to it
sub _generic_execute {
my $self = shift;
$self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
}
for (*_execute_create, *_execute_insert, *_execute_alter, *_execute_select, *_execute_update, *_execute_drop, *_execute_delete, *_execute_describe, *_execute_show_tables, *_execute_show_index) {
$_ = \&_generic_execute;
}
sub rows {
my $self = shift;
return $self->{_rows} if exists $self->{_rows};
return $self->{rows} if exists $self->{rows};
$self->{sth}->rows;
}
sub fetchrow_arrayref {
# -----------------------------------------------------------------------------
my $self = shift;
$self->{_results} or return $self->{sth}->fetchrow_arrayref;
return shift @{$self->{_results}};
}
sub fetchrow_array {
# -----------------------------------------------------------------------------
# When called in scalar context, returns either the first or last row, as per
# DBI, so avoid using in scalar context when fetching more than one row.
#
my $self = shift;
$self->{_results} or return $self->{sth}->fetchrow_array;
my $arr = shift @{$self->{_results}};
return $arr ? wantarray ? @$arr : $arr->[0] : ();
}
# -----------------------------------------------------------------------------
# Alias for fetchrow_array (DBI code comments this as an "old" alias, and DBI's
# documentation no longer mentions it at all).
*fetchrow = \&fetchrow_array; *fetchrow if 0;
sub fetchrow_hashref {
# -----------------------------------------------------------------------------
my $self = shift;
return $self->_fetchrow_hashref() if $self->{hints}->{case_map} or $self->{_results};
$self->{sth}->fetchrow_hashref;
}
$COMPILE{_fetchrow_hashref} = __LINE__ . <<'END_OF_SUB';
sub _fetchrow_hashref {
# -----------------------------------------------------------------------------
# Handles row fetching for driver that can't use the default ->fetchrow_hashref
# due to needing column case mapping ($sth->{hints}->{case_map}), or special
# result handling (e.g. PG's DESCRIBE handling, Oracle & ODBC's limit
# handling).
#
my $self = shift;
my %case_map; # returnedname => ReturnedName, but only for columns that use upper case
if ($self->{hints}->{case_map}) {
if (exists $self->{schema}->{cols}) {
my $cols = $self->{schema}->{cols};
%case_map = map { lc $_ => $_ } keys %$cols;
}
else {
for my $table (keys %{$self->{schema}}) {
for my $col (keys %{$self->{schema}->{$table}->{schema}->{cols}}) {
$case_map{lc $col} = $col;
}
}
}
}
if ($self->{_results}) {
my $arr = shift @{$self->{_results}} or return;
my $i;
my %selected = map { lc $_ => $i++ } @{$self->{_names}};
my %hash;
for my $lc_col (keys %selected) {
if (exists $case_map{$lc_col}) {
$hash{$case_map{$lc_col}} = $arr->[$selected{$lc_col}];
}
else {
$hash{$self->{_names}->[$selected{$lc_col}]} = $arr->[$selected{$lc_col}];
}
}
return \%hash;
}
else {
my $h = $self->{sth}->fetchrow_hashref or return;
for (keys %$h) {
$h->{$case_map{lc $_}} = delete $h->{lc $_} if exists $case_map{lc $_};
}
return $h;
}
}
END_OF_SUB
sub fetchall_arrayref {
# ---------------------------------------------------------------
my $self = shift;
return $self->{sth}->fetchall_arrayref(@_) unless $self->{_results};
my $opt = shift;
if ($opt and ref $opt eq 'HASH') {
my @ret;
while (my $row = $self->fetchrow_hashref) {
for (keys %$row) {
delete $row->{$_} unless exists $opt->{$_};
}
push @ret, $row;
}
return \@ret;
}
my $results = $self->{_results};
$self->{_results} = [];
return $results;
}
sub fetchall_list { map @$_, @{shift->fetchall_arrayref} }
sub fetchall_hashref {
# -----------------------------------------------------------------------------
# This is very different from DBI's fetchall_hashref - this is actually
# equivelant to DBI's ->fetchall_arrayref({})
#
my $self = shift;
my @results;
while (my $hash = $self->fetchrow_hashref) {
push @results, $hash;
}
return \@results;
}
sub row_names {
my $self = shift;
$self->{_names} || $self->{sth}->{NAME};
}
$COMPILE{insert_id} = __LINE__ . <<'END_OF_SUB';
sub insert_id {
# -------------------------------------------------------------------
# Returns the value of the last record inserted.
#
return $_[0]->{sth}->{insertid};
}
END_OF_SUB
sub DESTROY {
# -------------------------------------------------------------------
# Calls finish on the row when it is destroyed.
#
my $self = shift;
$self->debug("OBJECT DESTROYED") if $self->{_debug} > 2;
$self->{sth}->finish if ref $self->{sth} and $self->{sth}->can("finish");
}
sub _AUTOLOAD {
# -------------------------------------------------------------------
# Autoloads any unknown methods to the DBI::st object.
#
my ($self, @param) = @_;
my ($attrib) = $AUTOLOAD =~ /::([^:]+)$/;
if (exists $DBI::st::{$attrib}) {
local *code = $DBI::st::{$attrib};
if (*code{CODE}) {
$self->debug("Calling DBI::st::$attrib") if $self->{_debug} > 1;
return code($self->{sth}, @param);
}
}
$GT::SQL::Driver::debug::AUTOLOAD = $AUTOLOAD;
goto &GT::SQL::Driver::debug::AUTOLOAD;
}
$COMPILE{debug} = __LINE__ . <<'END_OF_SUB';
sub debug {
# -------------------------------------------------------------------
# DBI::st has a debug that autoload is catching.
#
my $self = shift;
my $i = 1;
my ( $package, $file, $line, $sub );
while ( ( $package, $file, $line ) = caller($i++) ) {
last if index( $package, 'GT::SQL' ) != 0;
}
while ( $sub = (caller($i++))[3] ) {
last if index( $sub, 'GT::SQL' ) != 0;
}
return $self->SUPER::debug( "$_[0] from $sub at $file line $line\n" );
}
END_OF_SUB
1;

1080
site/glist/lib/GT/SQL/Editor.pm Normal file
View File

File diff suppressed because it is too large Load Diff

1079
site/glist/lib/GT/SQL/File.pm Normal file
View File

File diff suppressed because it is too large Load Diff

150
site/glist/lib/GT/SQL/Monitor.pm Normal file
View File

@ -0,0 +1,150 @@
# ====================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Monitor
# Author: Jason Rhinelander
# CVS Info :
# $Id: Monitor.pm,v 1.2 2005/04/18 22:10:09 brewt Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ====================================================================
#
package GT::SQL::Monitor;
use strict;
use vars qw/@EXPORT_OK $CSS/;
use Carp qw/croak/;
use GT::CGI qw/:escape/;
require Exporter;
@EXPORT_OK = qw/query/;
use constant CSS => <<'CSS';
<style type="text/css">
.sql_monitor td {
border-bottom: 1px solid rgb(128, 128, 128);
border-right: 1px solid rgb(128, 128, 128);
padding: 2px;
}
.sql_monitor th {
border-bottom: 2px solid rgb(128, 128, 128);
border-right: 1px solid rgb(128, 128, 128);
padding: 2px;
}
table.sql_monitor {
border-collapse: collapse;
border-left: 2px solid rgb(128, 128, 128);
border-top: 2px solid rgb(128, 128, 128);
border-bottom: 2px solid rgb(128, 128, 128);
border-right: 2px solid rgb(128, 128, 128);
}
.sql_monitor pre {
margin-bottom: 0px;
margin-top: 0px;
}
</style>
CSS
sub query {
# -----------------------------------------------------------------------------
# Handles the 'SQL Monitor' function of various Gossamer Threads products.
# Takes a hash of options:
# table - any GT::SQL table object
# style - the style to use - 'tab', 'text' or 'html'; defaults to 'text'
# html - ('tab' or 'text' mode) whether values should be SQL escaped and the whole thing surrouned by a <pre> tag
# query - the query to run
# css - if defined, the value will be used for the CSS in 'html' style; otherwise _css() is used
# Returned is a hash reference containing:
# db_prefix - the database prefix currently in use
# style - the value of the 'style' option
# query - the query performed
# rows - the number of rows returned by the query, or possibly the number of rows affected
# results - a scalar reference to the result of the query, if a SELECT/SHOW/sp_*
# error - set to 1 if an error occured
# error_connect - set to an error message if the database connection failed
# error_prepare - set to an error message if the prepare failed
# error_execute - set to an error message if the execute failed
#
my %opts = @_;
$opts{table} and $opts{query} or croak "query() called without table and/or query options";
$opts{table}->connect or return { error => 1, error_connect => $GT::SQL::error };
my %ret = (
db_prefix => $opts{table}->{connect}->{PREFIX},
pretty_style => $opts{pretty_style},
query => $opts{query}
);
my $sth = $opts{table}->prepare($opts{query}) or return { %ret, error => 1, error_prepare => $GT::SQL::error };
my $rv = $sth->execute or return { %ret, error => 1, error_execute => $GT::SQL::error };
my $names = $sth->row_names;
$ret{rows} = $sth->rows || 0;
if ($opts{query} =~ /^\s*(SELECT|DESCRIBE|SHOW|sp_)/i) {
my $table = '';
my $data = $sth->fetchall_arrayref;
if ($opts{style} and $opts{style} eq 'html') {
$table .= defined $opts{css} ? $opts{css} : CSS;
$table .= qq|<table class="sql_monitor">\n|;
$table .= " <tr>\n";
$table .= join '', map ' <th><pre>' . html_escape($_) . "</pre></th>\n",
@$names;
$table .= " </tr>\n";
for (@$data) {
$table .= " <tr>\n";
for (@$_) {
my $val = html_escape($_);
$val .= "<br />" unless $val =~ /\S/;
$table .= qq| <td><pre>$val</pre></td>\n|;
}
$table .= " </tr>\n";
}
$table .= "</table>";
}
elsif ($opts{style} and $opts{style} eq 'tabs') {
$table = $opts{html} ? '<pre>' : '';
for (@$data) {
$table .= join("\t", $opts{html} ? (map html_escape($_), @$_) : @$_) . "\n";
}
$table .= "</pre>" if $opts{html};
}
else { # style = 'text'
$table = $opts{html} ? '<pre>' : '';
my @max_width = (0) x @$names;
for ($names, @$data) {
for my $i (0 .. $#$_) {
my $width = length $_->[$i];
$max_width[$i] = $width if $width > $max_width[$i];
}
}
$table = $opts{html} ? '<pre>' : '';
$table .= join('+', '', map("-" x ($_ + 2), @max_width), '') . " \n";
$table .= '|';
for my $i (0 .. $#$names) {
$table .= sprintf " %-$max_width[$i]s |", $opts{html} ? html_escape($names->[$i]) : $names->[$i];
}
$table .= " \n";
$table .= join('+', '', map("-" x ($_ + 2), @max_width), '') . " \n";
for (@$data) {
$table .= '|';
for my $i (0 .. $#$names) {
$table .= sprintf " %-$max_width[$i]s |", $opts{html} ? html_escape($_->[$i]) : $_->[$i];
}
$table .= " \n";
}
$table .= join('+', '', map("-" x ($_ + 2), @max_width), '') . " \n";
$table .= $opts{html} ? '</pre>' : '';
}
$ret{results} = \$table;
}
else {
$ret{results} = "Rows affected: $ret{rows}";
}
return \%ret;
}

1897
site/glist/lib/GT/SQL/Relation.pm Normal file
View File

File diff suppressed because it is too large Load Diff

584
site/glist/lib/GT/SQL/Search.pm Normal file
View File

@ -0,0 +1,584 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Search
# Author : Aki Mimoto
# CVS Info :
# $Id: Search.pm,v 1.60 2004/08/28 03:53:43 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description:
# highlevel class for searching, works with GT::SQL::Indexer
#
package GT::SQL::Search;
#--------------------------------------------------------------------------------
# pragmas
use strict;
use vars qw/@ISA $ERRORS $ERROR_MESSAGE $VERSION/;
# includes
use GT::Base;
use GT::AutoLoader;
# variables
$VERSION = sprintf "%d.%03d", q$Revision: 1.60 $ =~ /(\d+)\.(\d+)/;
@ISA = qw(GT::Base);
$ERROR_MESSAGE = 'GT::SQL';
$ERRORS = {
UNKNOWNDRIVER => 'Unknown driver requested: %s',
NOTABLE => 'Cannot find reference to table object'
};
sub load_search {
#--------------------------------------------------------------------------------
# checks if there is driver for this current database and if so, loads that
# instead (since it would be faster)
#
my $class = shift;
my $opts = ref $_[0] ? $_[0] : {@_};
$opts->{mode} = 'Search';
my $driver = $class->load_driver( $opts ) or return;
my $pkg = "GT::SQL::Search::${driver}::Search";
return $pkg->load(@_);
}
sub load_indexer {
#--------------------------------------------------------------------------------
# checks if there is driver for this current database and if so, loads that
# instead (since it would be faster)
#
my $class = shift;
my $opts = ref $_[0] ? $_[0] : {@_};
$opts->{mode} = 'Indexer';
my $driver = $class->load_driver( $opts ) or return;
my $pkg = "GT::SQL::Search::${driver}::Indexer";
return $pkg->load(@_);
}
sub driver_ok {
#--------------------------------------------------------------------------------
# checks to see if a particular driver is allowed on this system
#
my $class = shift;
my $driver = uc shift or return;
my $opts = ref $_[0] ? $_[0] : {@_};
my $mode = $opts->{mode} || 'Indexer';
my $tbl = $opts->{table} or return GT::SQL::Search->error( 'NOTABLE', 'FATAL' );
my $pkg = 'GT::SQL::Search::' . $driver . '::' . $mode;
eval { require "GT/SQL/Search/$driver/$mode.pm" };
$@ and return GT::SQL::Search->error('UNKNOWNDRIVER', 'WARN', $driver);
return $pkg->can('ok') ? $pkg->ok($tbl) : 1;
}
sub load_driver {
#--------------------------------------------------------------------------------
# Loads a driver into memory.
#
my $class = shift;
my $opts = ref $_[0] ? $_[0] : {@_};
my $tbl = $opts->{table};
my $mode = $opts->{mode} || 'Indexer';
my $driver = uc($opts->{driver} || $tbl->{schema}->{search_driver} || 'NONINDEXED');
require "GT/SQL/Search/$driver/$mode.pm";
return $driver;
}
sub available_drivers {
#--------------------------------------------------------------------------------
# Returns a list of available drivers.
#
my $class = shift;
(my $path = $INC{'GT/SQL/Search.pm'}) =~ s/\.pm$//;
opendir DHANDLE, $path or return $class->fatal(CANTOPENDIR => $path, "$!");
my @arr;
for my $driver_name (readdir DHANDLE) {
next if $driver_name =~ y/a-z//;
-f "$path/$driver_name/Search.pm" and -r _ or next;
-f "$path/$driver_name/Indexer.pm" and -r _ or next;
my $loaded = eval {
require "GT/SQL/Search/$driver_name/Search.pm";
require "GT/SQL/Search/$driver_name/Indexer.pm";
};
push @arr, $driver_name if $loaded;
}
closedir DHANDLE;
return wantarray ? @arr : \@arr;
}
1;
__END__
=head1 NAME
GT::SQL::Search - internal driver for searching
=head1 SYNOPSIS
This implements the query string based searching scheme for GT::SQL. Driver
based, it is designed to take advantage of the different indexing schemes
available on different database engines.
=head1 DESCRIPTION
Instead of describing how Search.pm is interfaced* this will describe how a
driver should be structured and how a new driver can be implemented.
* as it is never accessed directly by the programmer as it was designed to be
called through the functions GT::SQL::Table::query and GT::SQL::Table::query_sth
=head2 Drivers
A driver has two parts. The Indexer and the Search packages are the most
important. Howserver, for any driver in the search, there must exist a directory
with the name of the driver in ALL CAPS. For exampel, MYSQL for MySQL, POSTGRES
for Postgres. Within each driver directory, The Indexer and Search portions of
the driver contains all the information required for initializing the database
table and searching the database.
The Indexing package of the driver handles all the data that is manipulated in
the database and also the initializes and the database for indexing.
The Search package handles the queries and retrieves results for the eventual
consumption by the calling program.
Drivers are simply subclasses of the base driver module, GT::SQL::Search::Base
and operate by overriding certain key functions.
The next few sections will cover how to create a search driver, and assumes a
fair bit of familiarity with GT::SQL.
=head2 Structure of an Indexing Driver
The following is an absolutely simple skeleton driver that does nothing and but
called "CUSTOM". Found in the CUSTOM directory, this is the search package, and
would be call Search.pm in the GT/SQL/Search/CUSTOM library directory.
package GT::SQL::Search::CUSTOM::Search;
#------------------------------------------
use strict;
use vars qw/ @ISA /;
use GT::SQL::Search::Base::Search;
@ISA = qw( GT::SQL::Search::Base::Search );
sub load { my $package_name = shift; return GT::SQL::Search::CUSTOM::Search->new(@_) };
# overrides would go here
1;
For the indexer, another file, Indexer.pm would be found in the
GT/SQL/Search/CUSTOM directory.
package GT::SQL::Search::CUSTOM::Indexer;
#------------------------------------------
use strict;
use vars qw/ @ISA /;
use GT::SQL::Search::Base;
@ISA = qw/ GT::SQL::Search::Base::Indexer /;
sub load { my $package_name = shift; return GT::SQL::Search::CUSTOM::Indexer->new(@_) };
# overrides would go here
1;
The almost empty subs that immediately return with a value are functions that
can be overridden to do special tasks. More will be detailed later.
The Driver has been split into two packages. The original package name,
GT::SQL::Search::Nothing, houses the Search package.
GT::SQL::Search::Nothing::Indexer is the Indexing portion of the seach system.
"::Indexer" must be appended to the orginial search name for the indexer.
Each of the override functions are triggered at points just before and after a
major event occurs in GT::SQL. Depending on the type of actions you require, you
pick and chose which events you'd like your driver to attach to.
=head2 Structure of Indexing Driver
The Indexer is responsible for creating all the indexes, maintaining them and
when the table is dropped, removing all the associated indexes.
The following header must be defined for the Indexer.
GT::SQL::Search::Base::Indexer is the superclass that our driver inherits from.
package GT::SQL::Search::CUSTOM::Indexer;
#------------------------------------------
use strict;
use vars qw/ @ISA /;
use GT::Base;
use GT::SQL::Search::Base::Indexer;
@ISA = qw/ GT::SQL::Search::Base::Indexer /;
In addition to the header, the following function must be defined.
GT::SQL::Search::Driver::Indexer::load creates the new object and allows for
special preinitialization that must occur. You can also create another driver
silently (such as defaulting to INTERNAL after a version check fails).
sub load { my $package_name = shift; return GT::SQL::Search::CUSTOM::Indexer->new(@_) };
Finally, there are the overrides. None of the override functions need be defined
in your driver. Any calls made to undefined methods will silently fallback to
the superclass driver's methods. When a method has been overridden, the function
must return a true value when it is successful, otherwise the action will fail
and an error generated.
Whenever a object is created it will receive one property $self->{table} which
is the table that is being worked upon. This property is available in all the
method calls and is required for methods such as _create_table and
_drop_search_driver methods.
When a table is first created or when a table is destroyed the following two
functions are called. They are not passed any special values, however, these are
all class methods and $self->{table} will be a reference to the current table in
use.
This set of overrides are used by GT::SQL::Creator when the ::create method is
called. They are called just prior and then after the create table sql query has
been executed.
=over 2
=item pre_create_table
=item post_create_table
These functions receive no special parameters. They will receive the data to the
table in the $self->{table} property.
=back
This next set of functions take place in GT::SQL::Editor.
=over 2
=item drop_search_driver
This method receives no special parameters but is responsible for removing all
indexes and "things" associated with the indexing schema.
=item add_search_driver
Receives no extra parameters. Creates all indexes and does all actions required
to initialize indexing scheme.
=item pre_add_column
=item post_add_column
The previous two functions are called just before and after a new column is
added.
pre_add_column accepts $name (of column), $col (hashref of column attributes).
The method will only be called if the column has a weight associated with it.
The function must return a non-zero value if successful. Note that the returned
value will be passed into the post_add_column so temporary values can be passed
through if required.
post_add_column accepts $name (of column), $col (hashref of column attributes),
$results (of pre_add_column). This method is called just after the column has
been inserted into the database.
=item pre_delete_column
=item post_delete_column
These previous functions are called just before and after the sql for a old
column is deleted. They must remove all objects and "things" associated with a
particular column's index.
pre_delete_column accepts $name (of column), $col (hashref of column
attributes). The method will only be called if the column has a weight
associated with it. The function must return a non-zero value if successful.
Note that the returned value will be passed into the post_delete_column so
temporary values can be passed through if required.
post_delete_column accepts $name (of column), $col (hashref of column
attributes), $results (of pre_add_column). This method is called just after the
column has been dropped from the database.
=item pre_drop_table
=item post_drop_table
The two previous methods are used before and after the table is dropped. The
methods must remove any tables or "things" related to indexing from the table.
pre_drop_table receives no arguments. It can find a copy of the current table
and columns associated in $self->{table}.
post_drop_table receives one argument, which is the result of the
pre_drop_table.
=back
The following set of functions take place in GT::SQL::Table
=over 2
=item pre_add_record
=item post_add_record
Called just before and after an insert occurs. These functions take the record
and indexes them as required.
pre_add_record will receive one argument, $rec, hashref, which is the record
that will be inserted into the database. Table information can be found by
accessing $self->{table} Much like the other functions, on success the result
will be cached and fed into the post_add_record function.
post_add_record receives $rec, a hashref to describing the new result, the $sth
of the insert query, and the result of the pre_add_record method. The result
from $sth->insert_id if there is a ai field will be the new unique primary key.
=item pre_update_record
=item post_update_record
Intercepts the update request before and just after the sql query is executed.
This override has the potential of being rather messy. More than one record can
be modified in this action and the indexer must work a lot to ensure the
database is up to snuff.
pre_update_record receives two parameters, $set_cond, $where_cond. $set_cond is
a hashref containing the new values that must be set, and $where_cond is a
GT::SQL::Condition object selecting records to update. The result once again, is
cached and if undef is considered an error.
post_update_record takes the same parameters as pre_update_record, except one
extra paremeter, the result of pre_update_record.
=item pre_delete_record
=item post_delete_record
Called just before and after the deletion request for records are called.
pre_delete_record, has only one parameter, $where, a GT::SQL::Condition object
telling which records to delete. The results of this method are passed to
post_delete_record.
post_delete_record, has one addition parameter to pre_delete_record and like
most post_ methods, is the result of the pre_delete_record method.
=item pre_delete_all_records
=item post_delete_all_records
These two functions are quite simple, but they are different from drop search
driver in that though the records are all dropped, the framework for all the
indexing is not dropped as well.
Neither function is passed any special data, except for post_delete_all_records
which receives the rsults of the pre_delete_all_records method.
=item reindex_all
This function is sometimes called by the user to refresh the index. The
motivation for this, in the case of the INTERNAL driver, is sometimes due to
outside manipulation of the database tables, the index can become
non-representative of the data in the tables. This method is to force the
indexing system to fix errors that have passed.
=item ok
This function is called by GT::SQL::Search as a package method,
GT::SQL::Search::EXAMPLE::Indexer->ok( $table ); and is passed a table object
reference. What this function must do is to return a true or false value that
tells the search system if this driver can be used. The MYSQL driver has a good
example for this, it tests to ensure that the mysql database system version is
at least 3.23.23.
=back
=head2 Structure of a Search Driver
The Searcher is responsible for only one thing, to return results from a query
search. You can override the parser, however, subclassing the following methods
will have full parsing for all things such as +/-, string parsing and substring
matching.
The structures passed into the methods get a little complicated so beware!
ALL the following functions receive two parameters, the first is a search
parameters detailing the words/phrases to search for, the second parameter is
the current result set of IDs => scores.
There are two types of search parameters, one for words and the other for
phrases. The structure is a little messy so I'll detail them here.
For words, the structure is like the following:
$word_search = {
'word' => {
substring => '1', # set to 1 if this is substring match
phrase => 0, # not a phrase
keyword => 1, # is a keyword
mode => '', # can also be must, cannot to mean +/-
},
'word2' => ...
}
For phrases the structure will become:
$phrase_search => {
'phrase' => {
substring => undef # never required
phrase => [
'word1',
'word2',
'word3',
...
], # for searching by indiv word if required
keyword => 0, # not a keyword
mode => '' # can also be must, cannot
},
'phrase2' => ...
}
Based on these structures, hopefully it will be easy enough to build whatever is
required to grab the appropriate records.
Finally, the second item passed in will be a hash filled with ID => score values
of search results. They look something like this:
$results = {
1 => 56,
2 => 31,
4 => 6
}
It is important for all the methods to take the results and return the results,
as the result set will be daisychained down like a set to be operated on by
various searching schemes.
At the end of the query, the results in this set will be sorted and returned to
the user as an sth.
Operations on this set are preformed by the following five methods.
=over 2
=item _query
This method is called just after all the query string has been parsed and put
into their proper buckets. This method is overridden by the INTERNAL driver to
decide it wants to switch to the NONINDEX driver for better performance.
Two parameters are passed in, ( $input, $buckets ). $input is a hash that
contains all the form/cgi parameters passed to the $tbl->query function and
$buckets is s the structure that is created after the query string is parsed.
You may also call $self->SUPER::_query( $input, $buckets ) to pass the request
along normally.
You must return undef or an STH from this function.
=item _union_query
This method takes a $word_search and does a simple match query. If it finds
records with any of the words included, it will append the results to the list.
Passed in is the $results and it must return the altered results set.
This method must also implement substring searching.
=item _phrase_query
Just like the union_query, however it searches based on phrases.
=item _phrase_intersect_query
This takes a $phrase_search and a $result as parameters. This method must look
to find results that are found within the current result set that have the
passed phrases as well. However, if there are no results found, this method can
look for more results.
=item _intersect_query
Takes two parameters, a $word_search, and $results. Just like the
_phrase_intersect query, if there are results already, tries to whittle away the
result set. If there are no results, tries to look for results that have all the
keywords in a record.
This method must also implement substring searching.
=item _disjoin_query
Takes two parameters, a $word_search, and $results. This will look through the
result set and remove all matches to any of the keywords.
This method must also implement substring searching.
=item _phrase_disjoin_query
Two parameters, $phrase_search and $results are passed to this method. This does
the exact same thing as _disjoin_query but it looks for phrases.
=item query
If you choose to override this method, you will have full control of the query.
This method accepts a $CGI or a $HASH object and performs the following
Options:
- paging
mh : max hits
nh : number hit (or page of hits)
sb : column to sort by (default is by score)
- searching
ww : whole word
ma : 1 => OR match, 0 => AND match, undefined => QUERY
substring : search for substrings of words
bool : 'and' => and search, 'or' => or search, '' => regular query
query : the string of things to ask for
- filtering
field_name : value # Find all rows with field_name = value
field_name : ">value" # Find all rows with field_name > value.
field_name : "<value" # Find all rows with field_name < value.
field_name-gt : value # Find all rows with field_name > value.
field_name-lt : value # Find all rows with field_name < value.
The function must return a STH object. However, you may find useful the
GT::SQL::Search::STH object, which will automatically handle mh, nh, and
alternative sorting requests. All you will have to do is
sub query { ... your code ... return $self->sth( $results ); }
Where results is a hashref containing primarykeyvalue => scorevalues.
=item alternate_driver_query
There is no reason to override this method, however, if you would like to use
another driver's search instead of the current, this method will let you do so.
Accepting 2 parameters, ( $drivername, $input ), where $drivername is the name
of the driver you'd like to use and $input is the parameters passed to the
method. Returned is an $sth value (undef if an error has occured). This method
was used in the INTERNAL driver to shunt to NONINDEXED if it found the search
would take too long.
=back
=head1 COPYRIGHT
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
http://www.gossamer-threads.com/
=head1 VERSION
Revision: $Id: Search.pm,v 1.60 2004/08/28 03:53:43 jagerman Exp $
=cut

82
site/glist/lib/GT/SQL/Search/Base/Common.pm Normal file
View File

@ -0,0 +1,82 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Search::Base::Common
# Author : Aki Mimoto
# CVS Info :
# $Id: Common.pm,v 1.8 2004/10/13 21:45:02 aki Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description:
# Base classes upon which all search drivers are based
#
package GT::SQL::Search::Base::Common;
use strict;
use Exporter;
use vars qw/ @ISA @EXPORT $STOPWORDS /;
@ISA = qw( Exporter );
@EXPORT = qw( &_tokenize &_check_word $STOPWORDS );
$STOPWORDS = { map { $_ => 1 } qw/
of about or all several also she among since an some and such are than
as that at the be them because there been these between they both this
but those by to do toward during towards each upon either for from was
had were has what have when he where her which his while however with if
within in would into you your is it its many more most must on re it
test not above add am pm jan january feb february mar march apr april
may jun june jul july aug august sep sept september oct october nov
november dec december find &amp &gt &lt we http com www inc other
including
/ };
sub _tokenize {
#--------------------------------------------------------------------------------
# takes a strings and chops it up into little bits
my $self = shift;
my $text = shift;
my ( @words, $i, %rejected, $word, $code );
# split on any non-word (includes accents) characters
@words = split /[^\w\x80-\xFF\-]+/, lc $text;
$self->debug_dumper( "Words: ", \@words ) if ($self->{_debug});
# drop all words that are too small, etc.
$i = 0;
while ( $i <= $#words ) {
$word = $words[ $i ];
if ((exists $self->{stopwords}{$word} and ($code = 'STOPWORD')) or
(length($word) < $self->{min_word_size} and $code = 'TOOSMALL' ) or
(length($word) > $self->{max_word_size} and $code = 'TOOBIG')) {
splice( @words, $i, 1 );
$rejected{$word} = $self->{'rejections'}->{$code};
}
else {
$i++; # Words ok.
}
}
$self->debug_dumper( "Accepted Words: ", \@words ) if ($self->{_debug});
$self->debug_dumper( "Rejected Words: ", \%rejected ) if ($self->{_debug});
return ( \@words, \%rejected );
}
sub _check_word {
#--------------------------------------------------------------------------------
# Returns an error code if it is an invalid word, otherwise returns nothing.
#
my $self = shift;
my $word = shift;
my $code;
if ((exists $self->{stopwords}{$word} and ($code = 'STOPWORD')) or
(length($word) < $self->{min_word_size} and $code = 'TOOSMALL' ) or
(length($word) > $self->{max_word_size} and $code = 'TOOBIG')) {
return $code;
}
return;
}
1;

78
site/glist/lib/GT/SQL/Search/Base/Indexer.pm Normal file
View File

@ -0,0 +1,78 @@
# ====================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Search::Base::Indexer
# Author: Aki Mimoto
# CVS Info :
# $Id: Indexer.pm,v 1.4 2004/01/13 01:35:19 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ====================================================================
#
# Description:
#
#
package GT::SQL::Search::Base::Indexer;
use strict;
use vars qw/@ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /;
use GT::Base;
use GT::SQL::Search::Base::Common;
#--------------------------------------------------------------------------------
# Preamble information related to the object
$DEBUG = 0;
$VERSION = sprintf "%d.%03d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/;
@ISA = qw/GT::Base GT::SQL::Search::Base::Common/;
$ATTRIBS = {
driver => undef,
stopwords => $STOPWORDS,
rejections => {
STOPWORD => "is a stopword",
TOOSMALL => "is too small a word",
TOOBIG => "is too big a word"
},
table => '',
init => 0,
debug => 0,
min_word_size => 3,
max_word_size => 50,
};
sub drop_search_driver { 1 }
sub add_search_driver { 1 }
# found in GT::SQL::Creator
sub pre_create_table { 1 }
sub post_create_table { 1 }
# GT::SQL::Editor
sub pre_add_column { 1 }
sub post_add_column { 1 }
sub pre_delete_column { 1 }
sub post_delete_column { 1 }
sub pre_drop_table { 1 }
sub post_drop_table { 1 }
# GT::SQL::Table
sub pre_add_record { 1 }
sub post_add_record { 1 }
sub pre_update_record { 1 }
sub post_update_record { 1 }
sub pre_delete_record { 1 }
sub post_delete_record { 1 }
sub pre_delete_all_records { 1 }
sub post_delete_all_records { 1 }
sub driver_ok { 1 }
sub reindex_all { 1 }
1;

287
site/glist/lib/GT/SQL/Search/Base/STH.pm Normal file
View File

@ -0,0 +1,287 @@
# ====================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Search::STH
# Author: Aki Mimoto
# CVS Info :
# $Id: STH.pm,v 1.25 2004/08/28 03:53:46 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ====================================================================
#
package GT::SQL::Search::STH;
#--------------------------------------------------------------------------------
use strict;
use vars qw/@ISA $ATTRIBS $VERSION $DEBUG $ERRORS $ERROR_MESSAGE /;
use GT::Base;
@ISA = ('GT::Base');
$ATTRIBS = {
'_debug' => 0,
'sth' => undef,
'results' => {},
'db' => undef,
'table' => undef,
'index' => 0,
'order' => [],
'sb' => 'score',
'so' => '',
'score_col' => 'SCORE',
'score_sort'=> 0,
'nh' => 0,
'mh' => 0
};
$ERROR_MESSAGE = 'GT::SQL';
$ERRORS = {
BADSB => 'Invalid character found in so: "%s"',
};
sub init {
#--------------------------------------------------------------------------------
my $self = shift;
# setup the options
$self->set(@_);
# correct a few of the values
--$self->{nh} if $self->{nh};
my $sth;
my $results = $self->{results};
$self->{rows} = scalar( $results ? keys %{$results} : 0 );
# if we have asked to have sorting by another column (non score), create the part of the query that handles taht
$self->debug( "Setting up sorting for GT::SQL::Search::STH" ) if ($self->{_debug});
my $sb;
# clean up the sort by columns.
unless ($self->{'score_sort'}) {
$sb = GT::SQL::Search::Base::Search->clean_sb($self->{sb}, $self->{so});
}
# setup the max hits and the offsets
$self->{index} = $self->{nh} * $self->{mh} || 0;
$self->{max_index} = $self->{index} + $self->{mh} - 1; # index + mh is the first record which should not be returned.
if ( $self->{max_index} > $self->{rows} ) {
$self->{max_index} = $self->{rows};
$self->{rows} = $self->{rows} - $self->{index};
$self->{rows} < 0 ? $self->{rows} = 0 : 0;
}
else {
$self->{rows} = $self->{mh};
}
# if we are sorting by another column, handle that
if ( $sb and (keys %{$self->{results}})) {
my ( $table, $pk ) = $self->_table_info();
my ( $query, $where, $st, $limit );
$where = qq!$pk in(! . join( ",", keys %{$self->{results}}) . ')';
$self->{mh} and $limit = qq!LIMIT $self->{index}, $self->{rows}!;
$query = qq!
SELECT $pk
FROM $table
WHERE $where
$sb
$limit
!;
$self->debug( "Row fetch query: $query" ) if ($self->{_debug});
$sth = $self->{table}->{driver}->prepare( $query );
$sth->execute();
# fix the counts
$self->{index} = 0;
$self->{max_hits} = $self->{rows};
# now return them
my $order = $sth->fetchall_arrayref();
$sth->finish();
$self->{'order'} = [ map { $_->[0] } @{$order} ];
}
else {
$self->{'order'} = [ sort {
( $results->{$b} || return 0 ) <=> ( $results->{$a} || 0 )
} keys %{$results} ];
$self->debug_dumper( "Results will be presented in the following order: ", $self->{'order'} ) if ($self->{_debug});
}
}
sub cache_results {
#--------------------------------------------------------------------------------
my $self = shift;
my $results = $self->{'results'};
my ($sth, @records, $i, %horder, @order, $in_list);
my $table = $self->{table};
my $tname = $table->name();
my ($pk) = $self->{table}->pk;
use GT::SQL::Condition;
# we know what we're doing here so shut off warns (complains about uninit'd values in range
# if thee aren't enough elements in the order array)
my $w = $^W; $^W = 0;
@order = grep $_, @{$self->{'order'} || []}[$self->{index}..$self->{max_index}] or return [];
$^W = $w;
$i = 0; %horder = ( map { ( $_ => $i++) } @order );
$in_list = join ( ",", @order );
my $query = qq|
SELECT *
FROM
$tname
WHERE
$pk IN($in_list)
|;
# the following is left commented out as...
# if $tbl->select is used $table->hits() will not
# return an accurate count of the number of all the hits. instead, will return
# a value up to mh. $tbl->hits() is important because the value is used
# in toolbar calculations
#
# $sth = $table->select( GT::SQL::Condition->new( $pk, 'IN', \"($in_list)" ) );
$sth = $table->do_query( $query );
while ( my $href = $sth->fetchrow_hashref() ) {
$records[$horder{$href->{$pk}}] = \%$href
}
return \@records;
}
sub fetchrow_array {
#--------------------------------------------------------------------------------
return @{ $_[0]->fetchrow_arrayref() || [] };
}
sub fetchrow_arrayref {
#--------------------------------------------------------------------------------
my $self = shift;
my $records = $self->{cache} ||= $self->cache_results;
my $href = shift @$records or return;
return $self->_hash_to_array($href);
}
sub fetchrow_hashref {
#--------------------------------------------------------------------------------
my $self = shift;
my $results = $self->{'results'};
my $records = $self->{cache} ||= $self->cache_results;
my $table = $self->{table};
my ($pk) = $self->{table}->pk;
my $href = shift @$records or return;
$href->{$self->{'score_col'}} = ( $self->{score} = $results->{$href->{$pk}} );
return $href;
}
sub fetchall_hashref {
#--------------------------------------------------------------------------------
my $self = shift;
my @results;
while (my $res = $self->fetchrow_hashref) {
push @results, $res;
}
return \@results;
}
sub fetchall_list {
#--------------------------------------------------------------------------------
return { map { @$_ } @{shift->fetchall_arrayref} }
}
sub fetchall_arrayref {
#--------------------------------------------------------------------------------
my $self = shift;
$self->{order} or return [];
my $results = $self->{results};
my ($pk) = $self->{table}->pk;
my $scol = $self->{score_col};
if (!$self->{allref_cache}) {
$self->{allref_cache} ||= $self->cache_results;
for my $i ( 0 .. $#{$self->{allref_cache}} ) {
my $element = $self->{allref_cache}->[$i];
if ( $_[0] eq 'HASH' ) {
$element->{$scol} = $results->{$element->{$pk}};
}
else {
$element->{$scol} = $self->_hash_to_array( $element->{$scol} );
}
};
}
my $records = $self->{allref_cache};
return $records;
}
sub score {
#--------------------------------------------------------------------------------
my $self = shift;
return $self->{score};
}
sub _hash_to_array {
#--------------------------------------------------------------------------------
my $self = shift;
my $href = shift or return;
my $results = $self->{'results'};
my $table = $self->{table};
my $cols = $table->cols();
my $ordercols = ( $self->{ordercols} ||= [ sort { $cols->{$a}->{pos} <=> $cols->{$b}->{pos} } keys %$cols ] );
my ($pk) = $self->{table}->pk;
my $aref = [ map { $href->{$_} } @$ordercols, ( $self->{score} = $results->{$href->{$pk}} ) ];
return $aref;
}
sub rows {
#--------------------------------------------------------------------------------
my $self = shift;
return $self->{rows};
}
sub _table_info {
#--------------------------------------------------------------------------------
my $self = shift;
my $table = $self->{table}->name() or return $self->error('NOSCHEMA', 'FATAL');
my ($pk) = $self->{table}->pk;
return ( $table, $pk );
}
sub DESTROY {
#--------------------------------------------------------------------------------
my $self = shift;
$self->{'sth'} and $self->{'sth'}->finish();
}
sub debug_dumper {
#--------------------------------------------------------------------------------
# calls debug but also dumps all the messages
my $self = shift;
my $message = shift;
my $level = ref $_[0] ? 1 : shift;
if ( $self->{_debug} >= $level ) {
require GT::Dumper;
$self->debug( $message . join( "", map { GT::Dumper::Dumper($_) } @_ )) if ($self->{_debug});
}
}
1;

572
site/glist/lib/GT/SQL/Search/Base/Search.pm Normal file
View File

@ -0,0 +1,572 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Search::Base
# Author : Aki Mimoto
# CVS Info :
# $Id: Search.pm,v 1.25 2004/08/28 03:53:46 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description:
# Base classes upon which all search drivers are based
#
package GT::SQL::Search::Base::Search;
use strict;
use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /;
use GT::Base;
use GT::SQL::Search::Base::Common;
@ISA = qw( GT::Base GT::SQL::Search::Base::Common);
#--------------------------------------------------------------------------------
# Preamble information related to the object
$DEBUG = 0;
$VERSION = sprintf "%d.%03d", q$Revision: 1.25 $ =~ /(\d+)\.(\d+)/;
@ISA = qw/ GT::Base /;
$ATTRIBS = {
'stopwords' => $STOPWORDS,
'mh' => 25,
'nh' => 1,
'ww' => undef,
'ma' => undef,
'bool' => undef,
'substring' => 0,
'query' => '',
'sb' => 'score',
'so' => '',
'score_col' => 'SCORE',
'score_sort'=> 0,
'debug' => 0,
'_debug' => 0,
# query related
'db' => undef,
'table' => undef,
'filter' => undef,
'callback' => undef,
# strict matching of indexed words, accents on words do count
'sm' => 0,
'min_word_size' => 3,
'max_word_size' => 50,
};
sub init {
#--------------------------------------------------------------------------------
# Initialises the Search object
#
my $self = shift;
my $input = $self->common_param(@_);
$self->set($input);
# now handle filters...,
my $tbl = $self->{table};
my $cols = $tbl->cols();
my %filters = map {
(my $tmp = $_) =~ s/-[lg]t$//;
exists $cols->{$tmp} ? ($_ => $input->{$_}) : ()
} keys %{$input};
if ( keys %filters ) {
$self->debug_dumper( "INIT: Creating Filters: ", \%filters ) if ( $self->{_debug} );
$self->filter(\%filters);
}
$self->{table}->connect;
}
sub query {
#--------------------------------------------------------------------------------
# Returns a sth based on a query
#
# Options:
# - paging
# mh : max hits
# nh : number hit (or page of hits)
#
# - searching
# ww : whole word
# ma : 1 => OR match, 0 => AND match, undefined => QUERY
# substring : search for substrings of words
# bool : 'and' => and search, 'or' => or search, '' => regular query
# query : the string of things to ask for
#
# - filtering
# field_name : value # Find all rows with field_name = value
# field_name : ">value" # Find all rows with field_name > value.
# field_name : "<value" # Find all rows with field_name < value.
# field_name-gt : value # Find all rows with field_name > value.
# field_name-lt : value # Find all rows with field_name < value.
#
# Parameters:
# ( $CGI ) : a single cgi object
# ( $HASH ) : a hash of the parameters
#
my $self = shift;
# find out what sort of a parameter we're dealing with
my $input = $self->common_param(@_);
# add additional parameters if required
foreach my $parameter ( keys %{$ATTRIBS} ) {
if ( not exists $input->{$parameter} ) {
$input->{$parameter} = $self->{$parameter};
}
}
# parse query...,
$self->debug( "Search Query: $$input{query}", 1 ) if ($self->{_debug});
my ( $query, $rejected ) = $self->_parse_query_string( $input->{'query'} );
$self->{'rejected_keywords'} = $rejected;
# setup the additional input parameters
$query = $self->_preset_options( $query, $input );
$self->debug_dumper( "Set the pre-options: ", $query ) if ($self->{_debug});
# now sort into distinct buckets
my $buckets = &_create_buckets( $query );
$self->debug_dumper( "Created Buckets for querying: ", $buckets ) if ($self->{_debug});
return $self->_query($input, $buckets);
}
sub _query {
#--------------------------------------------------------------------------------
my ( $self, $input, $buckets ) = @_;
# now handle the separate possibilities
my $results = {};
# query can have phrases
$results = $self->_phrase_query( $buckets->{phrases}, $results );
$self->debug_dumper("Did phrase union query. Current result set and scores: ", $results ) if ($self->{_debug});
# query have keywords
$results = $self->_union_query( $buckets->{keywords}, $results );
$self->debug_dumper("Did keyword union query. Current result set and scores: ", $results ) if ($self->{_debug});
# query must have phrases
$results = $self->_phrase_intersect_query( $buckets->{phrases_must}, $results );
$self->debug_dumper("Did phrase intersect query. Current result set and scores: ", $results ) if ($self->{_debug});
# query must have keywords
$results = $self->_intersect_query( $buckets->{keywords_must}, $results );
$self->debug_dumper("Did keyword intersect query. Current result set and scores: ", $results ) if ($self->{_debug});
# query cannot have keywords
$results = $self->_disjoin_query( $buckets->{keywords_cannot}, $results );
$self->debug_dumper("Did keyword disjoin query. Current result set and scores: ", $results ) if ($self->{_debug});
# query cannot have phrases
$results = $self->_phrase_disjoin_query( $buckets->{phrases_cannot}, $results);
$self->debug_dumper("Did phrase disjoin query. Current result set and scores: ", $results ) if ($self->{_debug});
# now handle filters
my $cols = $self->{'table'}->cols();
my %filters = map {
(my $tmp = $_) =~ s/-[lg]t$//;
$cols->{$tmp} ? ($_ => $input->{$_}) : ()
} keys %{$input};
if (keys %filters) {
$self->debug( "Creating Filters: ", \%filters ) if ($self->{_debug});
$results = $self->filter(\%filters, $results);
}
elsif ($self->{filter}) {
$self->debug( "Filtering results", $self->{filter} ) if ($self->{_debug});
$results = $self->_filter_query( $self->{filter}, $results );
}
else {
$self->debug( "No filters being used.") if ($self->{_debug});
}
# now this query should probably clear the filters once it's been used, so i'll dothat here
$self->{filter} = undef;
# now run through a callback function if needed.
if ($self->{callback}) {
unless (ref $self->{callback} and ref $self->{callback} eq 'CODE') {
return $self->error ('BADARGS', 'FATAL', "callback '$self->{callback}' must be a code ref!");
}
$self->debug_dumper ("Running results through callback. Had: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug});
$results = $self->{callback}->($self, $results);
$self->debug_dumper ("New result set: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug});
}
# so how many hits did we get?
$self->{table}->{last_hits} = ( $self->{rows} = scalar($results ? keys %{$results} : ()) );
# and now create a search sth object to handle all this
return $self->sth( $results );
}
sub sth {
#--------------------------------------------------------------------------------
my $self = shift;
my $results = shift;
require GT::SQL::Search::Base::STH;
my $sth = GT::SQL::Search::STH->new(
'results' => $results,
'db' => $self->{table}->{driver},
# pass the following attributes down to the STH handler
map({ ($_ => $self->{$_}) } qw/ table sb so score_col score_sort nh mh rows _debug /)
);
return $sth;
}
sub rows {
#--------------------------------------------------------------------------------
# after a query is run, returns the number of rows
my $self = shift;
return $self->{rows} || 0;
}
sub _add_filters {
#--------------------------------------------------------------------------------
# creates the filter object
my $self = shift;
my $filter;
# find out how we're calling the parameters
if ( ref $_[0] eq 'GT::SQL::Condition' ) {
$filter = shift;
}
elsif ( ref $_[0] eq 'HASH' ) {
# setup the query condition using the build_query condition method
# build the condition object
my %opts = %{ shift() || {} };
delete $opts{query};
$filter = $self->{table}->build_query_cond( \%opts, $self->{table}{schema}{cols} );
}
else {
return $self->error ('BADARGS', 'FATAL', "Invalid argument: $_[0] passed to _add_filter");
}
# Use ref, as someone can pass in filter => 1 and mess things up.
ref $self->{filter} ? $self->{filter}->add ($filter) : ($self->{filter} = $filter);
$self->debug_dumper( "Filters: ", $self->{filter} ) if ($self->{_debug});
return $self->{filter};
}
sub _preset_options {
#--------------------------------------------------------------------------------
# sets up word parameters
my $self = shift;
my $query = shift or return;
my $input = shift or return $query;
# whole word searching
if ( defined $input->{'ww'} or defined $self->{'ww'}) {
if ( defined $input->{'ww'} ? $input->{'ww'} : $self->{'ww'} ) {
for ( keys %{$query} ) { $query->{$_}->{mode} = 'substring'; }
}
}
# substring searching
if ( defined $input->{'substring'} or defined $self->{'substring'}) {
if ( defined $input->{'substring'} ? $input->{'substring'} : $self->{'substring'} ) {
for ( keys %{$query} ) { $query->{$_}->{'substring'} = 1; }
}
}
if ( defined $input->{'ma'} or defined $self->{'ma'} ) {
# each keyword must be included
if ( defined $input->{'ma'} ? $input->{'ma'} : $self->{'ma'} ) {
for ( keys %{$query} ) {
next if $query->{$_}->{mode} eq 'cannot';
$query->{$_}->{mode} = 'must';
}
}
# each word can be included but is not necessary
else {
for ( keys %{$query} ) { $query->{$_}->{mode} = 'can'; }
}
}
# some more and or searches, only if user hasn't put +word -word
if ( lc( $input->{'bool'} || $self->{'bool'} ) eq 'and' ) {
unless ($input->{query} =~ /(?:^|\s)[+-]\w/) {
for ( keys %{$query} ) {
next if $query->{$_}->{mode} eq 'cannot';
$query->{$_}->{mode} = 'must';
}
}
}
elsif ( lc( $input->{'bool'} || $self->{'bool'} ) eq 'or' ) {
unless ($input->{query} =~ /(?:^|\s)[+-]\w/) {
for ( keys %{$query} ) { $query->{$_}->{mode} = 'can'; }
}
}
return $query;
}
sub _phrase_query { $_[1] }
sub _union_query { $_[1] }
sub _phrase_intersect_query { $_[1] }
sub _intersect_query { $_[1] }
sub _disjoin_query { $_[1] }
sub _phrase_disjoin_query { $_[1] }
sub filter {
#--------------------------------------------------------------------------------
# adds a filter
#
my $self = shift;
# add filters..,
my $filters = $self->_add_filters( shift );
my $results = shift;
# see if we need to execute a search, otherwise just return the current filterset
defined $results or return $results;
# start doing the filter stuff
return $self->_filter_query( $filters, $results );
}
sub _parse_query_string {
#------------------------------------------------------------
# from Mastering Regular Expressions altered a fair bit
# takes a space delimited string and breaks it up.
#
my $self = shift;
my $text = shift;
my %words = ();
my %reject = ();
my %mode = (
'+' => 'must',
'-' => 'cannot',
'<' => 'greater',
'>' => 'less'
);
# work on the individual elements
my @new = ();
while ( $text =~ m{
# the first part groups the phrase inside the quotes.
# see explanation of this pattern in MRE
([+-]?"[^\"\\]*(?:\\.[^\"\\]*)*)" ?
| (\+?[\w\x80-\xFF\-\*]+),?
| ' '
}gx ) {
my $match = lc $+;
# strip out buffering spaces
$match =~ s/^\s+//; $match =~ s/\s+$//;
# don't bother trying if there is nothing there
next unless $match;
# find out the searching mode
my ($mode, $substring, $phrase);
if (my $m = $mode{substr($match,0,1)}) {
$match = substr($match,1);
$mode = $m;
}
# do we need to substring match?
if ( substr( $match, -1, 1 ) eq "*" ) {
$match = substr($match,0,length($match)-1);
$substring = 1;
}
# find out if we're dealing with a phrase
if ( substr($match,0,1) eq '"' ) {
$self->debug( "Dealing with a phrase: $match" ) if ($self->{_debug});
$match = substr($match,1);
# however, we want to make sure it's a phrase and not something else
my ( $word_list, $rejected ) = $self->_tokenize( $match );
$self->debug_dumper( "Phrase reduced to: ", $word_list ) if ($self->{_debug});
$self->debug_dumper( "Phrase words rejected: ", $rejected ) if ($self->{_debug});
my $word_count = @$word_list;
if ( $word_count > 1 ) { $phrase = $word_list } # ok, standard phrase
elsif ($word_count == 1) { $match = $word_list->[0] } # just a standard word, don't worry about searching by phrase
}
# make sure we can use this word
if ( not $phrase and my $code = $self->_check_word( $match, $self->{stopwords} ) ) {
$reject{ $match } = $code;
next;
}
# now, see if we should toss this word
$words{$match} = {
mode => $mode,
phrase => $phrase,
substring => $substring,
keyword => not $phrase,
};
}
# words is a hashref of:
# {
# word => {
# paramaters => 'values'
# },
# word1 => {
# ...
# },
# ...
# }
#
return( \%words, \%reject );
}
sub _filter_query {
#--------------------------------------------------------------------------------
# get the results from the filter
#
my $self = shift;
my $filters = shift;
my $results = shift or return {};
keys %{$results} or return $results;
my $table = $self->{table};
my $tname = $table->name();
# setup the where clause
my $where = $filters->sql() or return $results;
my ($pk) = $table->pk;
$where .= qq! AND $pk IN (! . join(',', keys %$results) . ')';
# now do the filter
my $query = qq!
SELECT $pk
FROM
$tname
WHERE
$where
!;
$self->debug( "Filter Query: $query" ) if ($self->{_debug});
my $sth = $self->{table}->{driver}->prepare($query);
$sth->execute();
# get all the results
my $aref = $sth->fetchall_arrayref;
return {
map {
$_->[0] => $results->{$_->[0]}
} @$aref
};
}
sub _create_buckets {
#------------------------------------------------------------
# takes the output from _parse_query_string and creates a
# bucket hash of all the different types of searching
# possible
my $query = shift or return;
my %buckets;
# put each word in the appropriate hash bucket
foreach my $parameter ( keys %{$query} ) {
my $word_data = $query->{$parameter};
# the following is slower, however, done that way to be syntatically legible
if ( $word_data->{'phrase'} and ( defined $word_data->{'mode'} and ($word_data->{'mode'} =~ /(must|cannot)/ ))) {
$buckets{"phrases_$1"}->{$parameter} = $word_data;
}
elsif ( $word_data->{'phrase'} ) {
$buckets{'phrases'}->{$parameter} = $word_data;
}
elsif ( $word_data->{'keyword'} and ( defined $word_data->{'mode'} and ($word_data->{'mode'}=~ /(must|cannot|greater|less)/) )) {
$buckets{"keywords_$1"}->{$parameter} = $word_data;
}
else {
$buckets{'keywords'}->{$parameter} = $word_data;
}
}
return \%buckets;
}
sub alternate_driver_query {
#--------------------------------------------------------------------------------
my ( $self, $drivername, $input ) = @_;
$drivername = uc $drivername;
require GT::SQL::Search;
my $driver = GT::SQL::Search->load_search({ %$input, table => $self->{table}, driver => $drivername });
my $sth = $driver->query( $input );
foreach ( qw( rows rejected_keywords ) ) { $self->{$_} = $driver->{$_}; }
return $sth;
}
sub clean_sb {
# -------------------------------------------------------------------------------
# Convert the sort by, sort order into an sql string.
#
my ($class, $sb, $so) = @_;
my $output = '';
return $output unless ($sb);
# Remove score attribute, used only for internal indexes.
$sb =~ s/^\s*score\b//;
$sb =~ s/,?\s*\bscore\b//;
if ($sb and not ref $sb) {
if ($sb =~ /^[\w\s,]+$/) {
if ($sb =~ /\s(?:asc|desc)/i) {
$output = 'ORDER BY ' . $sb;
}
else {
$output = 'ORDER BY ' . $sb . ' ' . $so;
}
}
else {
$class->error('BADSB', 'WARN', $sb);
}
}
elsif (ref $sb eq 'ARRAY') {
foreach ( @$sb ) {
/^[\w\s,]+$/ or $class->error( 'BADSB', 'WARN', $sb ), next;
}
$output = 'ORDER BY ' . join(',', @$sb);
}
return $output;
}
sub debug_dumper {
#--------------------------------------------------------------------------------
# calls debug but also dumps all the messages
my $self = shift;
my $message = shift;
my $level = ref $_[0] ? 1 : defined $_[0] ? shift : 0;
if ( $self->{_debug} >= $level ) {
require GT::Dumper;
$self->debug( $message . join( "", map { GT::Dumper::Dumper($_) } @_ )) if ($self->{_debug});
}
}
1;

411
site/glist/lib/GT/SQL/Search/INTERNAL/Indexer.pm Normal file
View File

@ -0,0 +1,411 @@
# ====================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Search::INTERNAL::Indexer
# Author: Aki Mimoto
# CVS Info :
# $Id: Indexer.pm,v 1.11 2004/01/13 01:35:19 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ====================================================================
#
package GT::SQL::Search::INTERNAL::Indexer;
# ------------------------------------------------------------------------------
# Preamble information related to the object
use strict;
use vars qw/@ISA $ATTRIBS $VERSION $DEBUG /;
use GT::SQL::Search::Base::Indexer;
@ISA = qw/ GT::SQL::Search::Base::Indexer /;
$DEBUG = 0;
$VERSION = sprintf "%d.%03d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/;
sub load {
shift;
return GT::SQL::Search::INTERNAL::Indexer->new(@_)
}
sub drop_search_driver {
# ------------------------------------------------------------------------------
my $self = shift;
my $table = $self->{table}->name;
my $rc1 = $self->{table}->do_query(qq!DROP TABLE $table! ."_Word_List");
my $rc2 = $self->{table}->do_query(qq!DROP TABLE $table! ."_Score_List");
return 1;
}
sub add_search_driver {
# ------------------------------------------------------------------------------
my $self = shift;
my $name = $self->{table}->name;
# first create the table that handles the words.
my $creator = $self->{table}->creator ( $name . "_Word_List" );
$creator->cols(
Word_ID => {
pos => 1,
type => 'int',
not_null => 1,
unsigned => 1
},
Word => {
pos => 2,
type => 'varchar',
not_null=> 1,
size => '50'
},
Frequency => {
pos => 3,
type => 'int',
not_null=> 1
}
);
$creator->pk('Word_ID');
$creator->ai('Word_ID');
$creator->unique({ $name . "_wordndx" => ['Word'] });
$creator->create('force') or return;
# now create the handler for scores
$creator = $self->{table}->creator( $name . '_Score_List' );
$creator->cols(
Word_ID => {
pos => 1,
type => 'int',
not_null => 1,
unsigned => 1
},
Item_ID => {
pos => 2,
type => 'int',
not_null => 1,
unsigned => 1
},
Score => {
pos => 3,
type => 'int',
not_null => 1
},
Word_Pos => {
pos => 4,
type => 'int',
not_null => 1
}
);
$creator->index({ 'wndx' => ['Word_ID', 'Item_ID', 'Score'], 'itndx' => ['Item_ID'] });
$creator->create('force') or return;
return 1;
}
sub post_create_table {
# ------------------------------------------------------------------------------
# creates the index tables..
#
return $_[0]->add_search_driver(@_);
}
sub post_drop_table {
# -------------------------------------------------------
# Remove the index tables.
#
return $_[0]->drop_search_driver(@_);
}
sub init_queries {
# -------------------------------------------------------
# Pre-load all our queries.
#
my $self = shift;
my $queries = shift;
my $driver = $self->{table}->{driver} or return $self->error ('NODRIVER', 'FATAL');
my $table_name = $self->{table}->name() or return $self->error('NOSCHEMA', 'FATAL');
my $wtable = $table_name . '_Word_List';
my $seq = $wtable . '_seq';
my $stable = $table_name . '_Score_List';
my %ai_queries = (
ins_word_ORACLE => "INSERT INTO $wtable (Word_ID, Word, Frequency) VALUES ($seq.NEXTVAL, ?, ?)",
ins_word_PG => "INSERT INTO $wtable (Word_ID, Word, Frequency) VALUES (NEXTVAL('$seq'), ?, ?)",
ins_word => "INSERT INTO $wtable (Word, Frequency) VALUES (?, ?)"
);
my %queries = (
upd_word => "UPDATE $wtable SET Frequency = ? WHERE Word_ID = ?",
sel_word => "SELECT Word_ID,Word,Frequency FROM $wtable WHERE Word = ?",
sel_freq => "SELECT Frequency FROM $wtable WHERE Word_ID = ?",
del_word => "DELETE FROM $wtable WHERE Word_ID = ?",
mod_word => "UPDATE $wtable SET Frequency = Frequency - ? WHERE Word_ID = ?",
ins_scor => "INSERT INTO $stable (Word_ID, Item_ID, Score, Word_Pos) VALUES (?, ?, ?, ?)",
item_cnt => "SELECT Word_ID, COUNT(*) FROM $stable WHERE Item_ID = ? GROUP BY Word_ID",
scr_del => "DELETE FROM $stable WHERE Item_ID = ?",
dump_word => "DELETE FROM $wtable",
dump_scor => "DELETE FROM $stable"
);
my $type = uc $self->{table}->{connect}->{driver};
$self->{ins_word} = $driver->prepare($ai_queries{"ins_word_$type"} || $ai_queries{"ins_word"});
# check to see if the table exist
$self->{table}->new_table( $wtable ) or return $self->error('CANTPREPARE','WARN', 'Loading of table', $GT::SQL::error);
$self->{table}->new_table( $stable ) or return $self->error('CANTPREPARE','WARN', 'Loading of table', $GT::SQL::error);
if ($type eq 'MYSQL') {
foreach my $query (keys %queries) {
$self->{$query} = $driver->prepare_raw ($queries{$query}) or return $self->error ('CANTPREPARE', 'WARN', $query, $GT::SQL::error);
}
}
else {
foreach my $query (keys %queries) {
$self->{$query} = $driver->prepare ($queries{$query}) or return $self->error ('CANTPREPARE', 'WARN', $query, $GT::SQL::error);
}
}
}
sub post_add_record {
# -------------------------------------------------------
# indexes a single record
my ($self, $rec, $insert_sth ) = @_;
# Only continue if we have weights and a primary key.
my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' );
my %weights = $tbl->_weight_cols() or return;
my ($pk) = $tbl->pk();
my $item_id = ( $tbl->ai() and $insert_sth ) ? $insert_sth->insert_id() : $rec->{$pk};
my $index = 0;
$self->{init} or $self->init_queries;
# Go through each column and index it.
foreach my $column ( keys %weights ) {
my ($word_list, $rejected) = $self->_tokenize( $rec->{$column} );
$word_list or next;
# Build a hash of word => frequency.
my %words;
foreach my $word (@{$word_list}) {
$words{$word}++;
}
# Add the words in, or update frequency.
my %word_ids = ();
while (my ($word, $freq) = each %words) {
$self->{sel_word}->execute($word) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
my $word_r = $self->{sel_word}->fetchrow_arrayref; # Word_ID, Word, Frequency
if ($word_r) {
$word_r->[2] += $freq;
$word_ids{$word} = $word_r->[0];
$self->{upd_word}->execute ($word_r->[2], $word_r->[0]) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
}
else {
$self->{ins_word}->execute ($word, $words{$word}) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
$word_ids{$word} = $self->{ins_word}->insert_id();
}
}
# now that we have the word ids, insert each of the word-points
my $weight = $weights{$column};
foreach my $word ( @{$word_list} ) {
$self->{ins_scor}->execute ($word_ids{$word}, $item_id, $weight, $index++) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
}
$index++;
}
return 1;
}
sub reindex_all {
# -------------------------------------------------------
my $self = shift;
my $table = shift;
my $opts = shift;
my $tick = $opts->{tick} || 0;
my $max = $opts->{max} || 5000;
my %weights = $self->{table}->_weight_cols() or return;
my @weight_list = keys %weights;
my @weight_arr = map { $weights{$_} } @weight_list;
my ($pk) = $self->{table}->pk();
my $index = 0;
my $word_id = 1;
$self->{init} or $self->init_queries;
# first nuke the current index
$self->dump_index();
# Go through the table and index each field.
my $iterations = 1;
my $count = 0;
while (1) {
if ($max) {
my $offset = ($iterations-1) * $max;
$table->select_options ( "LIMIT $offset,$max");
}
my $cond = $opts->{cond} || {};
my $sth = $table->select($cond, [ $pk, @weight_list] );
my $done = 1;
while ( my $arrayref = $sth->fetchrow_arrayref() ) {
# the primary key value
my $i = 0;
my $item_id = $arrayref->[($i++)];
$index = 0;
$done = 0;
# start going through the record data
foreach my $weight ( @weight_arr ) {
my ($word_list, $junk) = $self->_tokenize( $arrayref->[$i++] );
$word_list or next;
# Build a hash of word => frequency.
my %words;
foreach my $word (@{$word_list}) {
$words{$word}++;
}
# Add the words in, or update frequency.
my %word_ids = ();
while (my ($word, $freq) = each %words) {
$self->{sel_word}->execute($word) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
my $word_r = $self->{sel_word}->fetchrow_arrayref; # WordID,Word,Freq
if ($word_r) {
$word_r->[2] += $freq;
$word_ids{$word} = $word_r->[0];
$self->{upd_word}->execute ($word_r->[2], $word_r->[0]) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
}
else {
$self->{ins_word}->execute ($word, $words{$word}) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
$word_ids{$word} = $self->{ins_word}->insert_id();
}
}
# now that we have the word ids, insert each of the word-points
foreach my $word ( @{$word_list} ) {
$self->{ins_scor}->execute ($word_ids{$word}, $item_id, $weight, $index++) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
}
$index++;
}
if ($tick) {
$count++;
$count % $tick or (print "$count ");
$count % ($tick*10) or (print "\n");
}
}
return if ($done);
$iterations++;
return if (! $max);
}
}
sub pre_delete_record {
# -------------------------------------------------------
# Delete a records index values.
#
my $self = shift;
my $where = shift;
my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' );
my %weights = $tbl->_weight_cols() or return;
my ($pk) = $tbl->pk();
my $q = $tbl->select( $where, [ $pk ] );
while ( my $aref = $q->fetchrow_arrayref() ) {
my $item_id = $aref->[0] or next;
my @weight_list = keys %weights;
my $index = 0;
$self->{init} or $self->init_queries;
# Get a frequency count for each word
$self->{item_cnt}->execute($item_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
# Now go through and either decrement the freq, or remove the entry.
while ( my ($word_id, $frequency) = $self->{item_cnt}->fetchrow_array() ) {
$self->{sel_freq}->execute($word_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
$self->debug( "Deleting frequencies for $word_id. decreasing by $frequency" ) if ($self->{_debug});
if (my $freq = $self->{sel_freq}->fetchrow_arrayref) {
if ($freq->[0] == $frequency) {
$self->{del_word}->execute($word_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
}
else {
$self->{mod_word}->execute($frequency, $word_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
}
}
}
# Remove the listings from the scores table.
$self->{scr_del}->execute($item_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
}
return 1;
}
sub post_update_record {
# -------------------------------------------------------
my ( $self, $set_cond, $where_cond, $tmp ) = @_;
# delete the previous record
$self->pre_delete_record( $where_cond ) or return;
#
# the new record
my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' );
my $q = $tbl->select( $where_cond );
while ( my $href = $q->fetchrow_hashref() ) {
$self->post_add_record( $href );
}
return 1;
}
sub reindex_record {
# -------------------------------------------------------
# reindexes a record. basically deletes all associated records from current db abnd does an index.
# it's safe to use this
my $self = shift;
my $rec = shift;
$self->delete_record($rec);
$self->index_record($rec);
}
sub dump_index {
# -------------------------------------------------------
my $self = shift;
$self->{init} or $self->init_queries;
$self->{dump_word}->execute() or $self->error('CANTEXECUTE', 'WARN', $DBI::errstr);
$self->{dump_scor}->execute() or $self->error('CANTEXECUTE', 'WARN', $DBI::errstr);
}
sub debug_dumper {
# ------------------------------------------------------------------------------
# calls debug but also dumps all the messages
my $self = shift;
my $message = shift;
my $level = ref $_[0] ? 1 : shift;
if ( $self->{_debug} >= $level ) {
require GT::Dumper;
$self->debug( $message . join( "", map { GT::Dumper::Dumper($_) } @_ ));
}
}
sub DESTROY {
# ------------------------------------------------------------------------------
# Calls finish on init queries.
#
my $self = shift;
return unless ($self->{init});
$self->{upd_word}->finish;
# $self->{ins_word}->finish; will get finished automatically
$self->{sel_word}->finish;
$self->{sel_freq}->finish;
$self->{del_word}->finish;
$self->{mod_word}->finish;
$self->{ins_scor}->finish;
$self->{item_cnt}->finish;
$self->{scr_del}->finish;
$self->{dump_word}->finish;
$self->{dump_scor}->finish;
$self->{init} = 0;
}
1;

604
site/glist/lib/GT/SQL/Search/INTERNAL/Search.pm Normal file
View File

@ -0,0 +1,604 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Indexer
# Author : Aki Mimoto
# CVS Info :
# $Id: Search.pm,v 1.18 2004/08/28 03:53:47 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description:
# Class used to make changes to tables and create tables.
#
package GT::SQL::Search::INTERNAL::Search;
# ------------------------------------------------------------------------------
use strict;
use vars qw/@ISA $VERSION $DEBUG $ATTRIBS /;
use GT::SQL::Search::Base::Search;
@ISA = qw( GT::SQL::Search::Base::Search );
# ------------------------------------------------------------------------------
# Preamble information related to the object
$DEBUG = 0;
$VERSION = sprintf "%d.%03d", q$Revision: 1.18 $ =~ /(\d+)\.(\d+)/;
$ATTRIBS = {
# the max number of links that can be handled by UNION before it should simply
# shunt the searching pipe to NONINDEXED system
'union_shunt_threshold' => '5000',
'phrase_shunt_threshold' => '1000',
};
################################################################################
# Internal functions
################################################################################
sub load {
shift;
return GT::SQL::Search::INTERNAL::Search->new(@_)
}
sub _query {
# ------------------------------------------------------------------------------
# this just checks to ensure that the words are not all search keywords
#
my ( $self, $input, $buckets ) = @_;
# calculate wordids and frequencies
foreach ( keys %$buckets ) {
$buckets->{$_} = $self->get_wordids( $buckets->{$_}, ( /phrase/ ? "phrases" : "keywords" ) );
}
# the following is a bit tricky and will be replaced however, if the number
# of results from a union is more than the maximum shunt value, it will
# simply do a nonindexed query
if ( $buckets->{keywords} ) {
my $rec = _count_frequencies( $buckets->{keywords} );
my $count = 0;
foreach ( values %$rec ) { $count += $_; }
if ($count > $self->{union_shunt_threshold}) {
$self->debug_dumper("Too many results using internal search, falling back to nonindexed. Counts are: ", $rec) if ($self->{_debug});
return $self->alternate_driver_query( 'NONINDEXED', $input );
}
}
# Now test the phrases. Just due to how the phrase searching works, the queries
# can grow in size extremely rapidly, and slowdown the search. So the limit for
# phrase searching is separate as it requires a different cutoff value than
# the keyword search which is usually much lower!
if ($buckets->{phrases}) {
foreach my $phrase ( keys %{$buckets->{phrases} || {} } ) {
my $rec = _count_frequencies( $buckets->{phrases}->{$phrase}->{word_info} );
my ( $count ) = sort values %$rec; # Get smallest frequency.
if ( $count > $self->{phrase_shunt_threshold} ) {
$self->debug_dumper("Too many results using internal search, falling back to nonindexed. Counts are: ", $rec) if ($self->{_debug});
return $self->alternate_driver_query( 'NONINDEXED', $input );
}
}
}
if ($buckets->{phrases_must}) {
foreach my $phrase ( keys %{$buckets->{phrases_must} || {} } ) {
my $rec = _count_frequencies( $buckets->{phrases_must}->{$phrase}->{word_info} );
my ( $count ) = sort values %$rec; # Get smallest frequency.
if ( $count > $self->{phrase_shunt_threshold} ) {
$self->debug_dumper("Too many results using internal search, falling back to nonindexed. Counts are: ", $rec) if ($self->{_debug});
return $self->alternate_driver_query( 'NONINDEXED', $input );
}
}
}
return $self->SUPER::_query( $input, $buckets );
}
sub _count_frequencies {
# ------------------------------------------------------------------------------
my $word_info = shift;
my $rec = {};
foreach my $word ( keys %$word_info ) {
my $freq = 0;
foreach ( values %{$word_info->{$word}->{word_info}} ) {
$freq += $_;
}
$rec->{$word} = $freq;
}
return $rec;
}
sub _table_names {
# ------------------------------------------------------------------------------
# return the table names
#
my $self = shift;
my $table = $self->{table}->name() or return $self->error('NOSCHEMA', 'FATAL');
my $wtable = $table . '_Word_List';
my $stable = $table . '_Score_List';
return ( $table, $wtable, $stable);
}
sub _word_infos {
# ------------------------------------------------------------------------------
# get the word ids and frequencies
#
my $self = shift;
my $word_infos = shift;
my $rec = {};
foreach my $word ( keys %$word_infos ) {
my $wi = $word_infos->{$word}->{word_info};
$rec->{$word} = [ map { [ $_, $wi->{$_} ] } keys %$wi ];
}
return $rec;
}
sub _union_query {
# ------------------------------------------------------------------------------
# Takes a list of words and gets all words that match
# returns { itemid -> score } of hits that match
#
my $self = shift;
my $words = shift;
my $results = shift || {};
my ( $query, $where, $db, $word_infos );
my ( $table, $wtable, $stable) = $self->_table_names();
$db = $self->{table}->{driver} or return $self->error( 'NODRIVER', 'FATAL' );
$word_infos = $self->_word_infos( $words ) or return $results;
return $results unless (keys %{$word_infos});
$self->debug_dumper( "Getting words: ", $words) if ($self->{_debug});
# build the where clause
my @word_ids;
foreach my $word_synonym_list ( values %$word_infos ) {
next unless ( $word_synonym_list );
foreach my $word_id ( @{$word_synonym_list }) {
next unless ( ref $word_id eq 'ARRAY' ); # ensure it's a reference
push @word_ids, $word_id->[0]; # we need to shed the word quantities
}
}
return $results unless ( @word_ids );
$where = 'Word_ID IN(' . join(",", @word_ids) . ")";
# build the query
$query = qq!
SELECT Item_ID, SUM(Score)
FROM $stable
WHERE
$where
GROUP BY Item_ID
!;
$self->debug( "Union Query: $query" ) if ($self->{_debug});
# prepare the query
my $sth = $db->prepare( $query ) or return;
$sth->execute() or return;
# get the results
my %word_infos = $sth->fetchall_list;
# merge the current result set into found
foreach my $item ( keys %{$results} ) {
$word_infos{$item} += $results->{$item};
};
return \%word_infos;
}
sub _intersect_query {
# ------------------------------------------------------------------------------
# Takes a list of words and gets all words that match all the keywords
# returns { itemid -> score } of hits that match
#
my $self = shift;
my $words = shift;
my $results = shift || {};
$words or return $results;
keys %{$words} or return $results;
my ( $query, $where, $db, $word_infos, $word_hits );
my ( $table, $wtable, $stable) = $self->_table_names();
# have we left any of our words out?
$db = $self->{table}->{driver} or return $self->error( 'NODRIVER', 'FATAL' );
$word_infos = $self->_word_infos( $words ) or return {};
if ( keys %{$word_infos} < keys %{$words} ) {
return {};
}
$self->debug_dumper( "Keyword Intersect words: ", $word_infos ) if ($self->{_debug});
# take the words and get a hash of the word scores
foreach my $word ( keys %{$word_infos} ) {
my $total_freq = 0;
foreach my $word_synonyms ( @{$word_infos->{$word}} ) {
$total_freq += $word_synonyms->[1];
}
$word_hits->{$word} = $total_freq or return;
}
# so now, sort out the words from lowest frequency to highest frequency
my @search_order = sort { $word_hits->{$a} <=> $word_hits->{$b} } keys %{$word_hits};
$self->debug_dumper( "Searching words in this order: ", \@search_order) if ($self->{_debug});
# find out how we're going to handle the searching, if the first elements
################################################################################
### The following part is for smaller intersect subsets
################################################################################
my $intersect = $results;
foreach my $word ( @search_order ) {
# setup the where clause to get all the words associated
my $where = "Word_ID in(" . join(",", map( { $_->[0] } @{$word_infos->{$word}} )) . ")";
# setup the intersect for the previous if required. for iterative intersecting
if ( keys %{$intersect} ) {
$where .= " AND Item_ID in(" . join(",",keys %{$intersect}) . ")";
}
# make the database engine work a little bit
$query = qq!
SELECT Item_ID, SUM(Score) AS Score
FROM $stable
WHERE
$where
GROUP BY Item_ID
!;
$self->debug( "Intersect Query: $query" ) if ($self->{_debug});
my $intersect_sth = $db->prepare( $query );
$intersect_sth->execute();
# get a list of all the matches
my $matches = $intersect_sth->fetchall_arrayref();
$self->debug_dumper( "Matches found for $word: ", $matches ) if ($self->{_debug});
# go through all the matches and intersect them
my %tmp = ();
foreach my $row ( @{$matches} ) {
my ( $itemid, $score ) = @{$row};
$intersect->{$itemid} ||= 0;
$tmp{ $itemid } = $intersect->{$itemid} + $score;
}
# inform the system of that development
%tmp or return;
$intersect = \%tmp;
}
return $intersect;
}
sub _disjoin_query {
#------------------------------------------------------------
my $self = shift;
my $words = shift;
my $results = shift || {};
$words or return $results;
my ( $query, $where, $db, $word_infos, $word_hits );
my ( $table, $wtable, $stable) = $self->_table_names();
$db = $self->{table}->{driver} or return $results;
# have we left any of our words out?
$word_infos = $self->_word_infos( $words ) or return $results;
# if ( keys %{$word_infos} < keys %{$words} ) {
# return $results;
# }
# take the words and get a hash of the word scores
foreach my $word ( keys %{$word_infos} ) {
my $total_freq = 0;
foreach my $word_synonyms ( $word_infos->{$word} ) {
$total_freq += ( $word_synonyms->[0] || 0 );
}
# if the value is null this mean there is actually no results, whoops!
$total_freq and $word_hits->{$word} = $total_freq;
}
# so now, sort out the words from lowest frequency to highest frequency
my @search_order = sort { $word_hits->{$b} <=> $word_hits->{$b} } keys %{$word_hits};
$self->debug_dumper( "Disjoining words in the following order: ", \@search_order) if ($self->{_debug});
################################################################################
### This following part is for smaller disjoin presets
################################################################################
foreach my $word ( @search_order ) {
# setup the where clause to get all the words associated
my $where = "Word_ID in(" . join(",", map( { $_->[0] } @{$word_infos->{$word}} )) . ")";
# setup the intersect for the previous if required. for iterative intersecting
if ( keys %{$results} ) {
$where .= " AND Item_ID in(" . join(",", keys %{$results}) . ")";
}
# make the database engine work a little bit
$query = qq!
SELECT Item_ID
FROM $stable
WHERE
$where
GROUP BY Item_ID
!;
$self->debug($query) if ($self->{_debug});
my $intersect_sth = $db->prepare( $query );
$intersect_sth->execute();
# get a list of all the matches
my $matches = $intersect_sth->fetchall_arrayref();
# strip the matches from the current result set
foreach my $word ( map { $_->[0] } @{$matches}) {
delete $results->{$word};
}
}
return $results;
}
sub _phrase_disjoin_query {
#------------------------------------------------------------
# subtracts the found phrases from the list
my $self = shift;
my $phrases = shift;
my $results = shift || {};
$phrases or return $results;
foreach my $phrase ( values %{$phrases} ) {
my $temp = $self->_get_phrase( $phrase->{'phrase'}, $phrase->{word_info} );
# perform disjoin
foreach my $itemid ( keys %{$temp} ) {
$self->debug( "Deleting $itemid from list" ) if ($self->{_debug});
delete $results->{$itemid};
}
}
return $results;
}
sub _phrase_intersect_query {
#------------------------------------------------------------
# intersects phrases together
my $self = shift;
my $phrases = shift;
my $results = shift || {};
$phrases or return $results;
foreach my $phrase ( values %{$phrases} ) {
my $temp = $self->_get_phrase( $phrase->{'phrase'}, $phrase->{word_info} );
# perform intersect
foreach my $itemid ( keys %{$temp} ) {
$temp->{$itemid} += $results->{$itemid} || 0;
}
$results = $temp;
}
return $results;
}
sub _phrase_query {
#------------------------------------------------------------
# this is a phrase union query
my $self = shift;
my $phrases = shift or return;
my $results = shift || {};
foreach my $phrase ( values %{$phrases} ) {
$self->debug_dumper( "Unioning: ", $phrase ) if ($self->{_debug});
$results = $self->_get_phrase( $phrase->{'phrase'}, $phrase->{word_info}, $results );
}
return $results;
}
sub _get_phrase {
#------------------------------------------------------------
my $self = shift;
my $wordlist= shift;
my $word_info = shift;
my $results = shift || {};
$wordlist or return $results;
my ( $query, $where, $db, $word_infos, %word_hits );
my ( $table, $wtable, $stable) = $self->_table_names();
my ($pk) = $self->{table}->pk;
$self->debug_dumper( "Getting words: ", $wordlist ) if ($self->{_debug});
# get all the word ids that we want to handle
$db = $self->{table}->{driver} or return $self->error( 'NODRIVER', 'FATAL' );
$word_infos = $self->_word_infos( $word_info ) or return;
$self->debug_dumper( "Word infos: ", $word_infos ) if ($self->{_debug});
# take the words and get a hash of the word scores
foreach my $word ( keys %{$word_infos} ) {
@{$word_infos->{$word} || []} or return;
my $total_freq = 0;
foreach my $word_synonyms ( @{$word_infos->{$word}} ) {
$total_freq += $word_synonyms->[1];
}
# if the value is null this mean there is actually no results, whoops!
$word_hits{$word} = $total_freq;
}
$self->debug_dumper( "With synonyms tallied: ", \%word_hits ) if ($self->{_debug});
# so now, setup the order of search
my $i = 0;
my %word_order = map { $_ => $i++ } @{$wordlist};
my @search_order = sort { $word_hits{$a} <=> $word_hits{$b} } keys %word_hits;
$self->debug_dumper( "Word search order: ", \@search_order ) if ($self->{_debug});
################################################################################
### This following part is for smaller phrases
################################################################################
# start getting words in order of their frequency
my %matches = ();
my $index = 0;
foreach my $word ( @search_order ) {
# setup the where clause for the individual words, firstly
if ( keys %matches ) {
my $vector = $word_order{$word} - $index;
$where = '(';
$where =
'(' .
join(
" OR ",
map(
"Item_ID = $_ AND Word_Pos IN(" . join(",", map $_->[0] + $vector, @{$matches{$_}}) . ')',
keys %matches
)
) .
") AND ";
}
else {
$where = '';
}
$where .= "Word_ID IN(" . ( join ",", map { $_->[0] || () } @{$word_infos->{$word}} or return $results ) . ')';
$query = qq!
SELECT
Item_ID, Score, Word_Pos
FROM
$stable
WHERE
$where
!;
$self->debug( "Phrase get for '$word': " . $query ) if ($self->{_debug});
my $sth = $db->prepare( $query );
$sth->execute();
%matches = ();
while (my $hit = $sth->fetchrow_arrayref) {
push @{$matches{$hit->[0]}}, [ $hit->[2], $hit->[1] ];
}
# If there are no values stored in %matches, it means that for
# this keyword, there have been no hits based upon position.
# In that case, terminate and return a null result
keys %matches or last;
# where were we in the string?
$index = $word_order{$word};
}
# now tally up all the scores and merge the new records in
foreach my $itemid ( keys %matches ) {
my $score = 0;
foreach my $sub_total ( @{$matches{$itemid}} ) {
$score += $sub_total->[1];
}
$results->{$itemid} += $score;
}
return $results;
}
sub get_wordids {
# ------------------------------------------------------------------------------
# Get a list of words
#
my $self = shift;
my $elements = shift or return;
my $mode = lc shift || 'keywords';
if ( $mode eq 'keywords' ) {
$elements = $self->_get_wordid($elements);
}
else {
foreach my $phrase ( keys %$elements ) {
my $results = $self->_get_wordid({
map { ($_ => { substring => 0 }) } @{$elements->{$phrase}->{phrase}}
});
$elements->{$phrase}->{word_info} = $results;
}
}
return $elements;
}
sub _get_wordid {
# ------------------------------------------------------------------------------
# Get a list of words
#
my $self = shift;
my $words = shift;
my $tbl = $self->{table};
my ( $table, $wtable, $stable) = $self->_table_names();
foreach my $word ( keys %$words ) {
my $query =
qq!SELECT Word_ID, Frequency FROM $wtable WHERE Word LIKE '! .
quotemeta($word) .
( $words->{$word}->{substring} ? '%' : '' ) .
"'";
my $sth = $tbl->do_query($query) or next;
my $tmp = { $sth->fetchall_list };
$words->{$word}->{word_info} = $tmp;
}
return $words;
}
##
# Internal Use
# $self->_cgi_to_hash ($in);
# --------------------------
# Creates a hash ref from a cgi object.
##
sub _cgi_to_hash {
my ($self, $cgi) = @_;
$cgi and UNIVERSAL::can($cgi, 'param') or return $self->error(NODRIVER => 'FATAL');
my @keys = $cgi->param;
my $result = {};
foreach my $key (@keys) {
my @values = $cgi->param($key);
if (@values == 1) { $result->{$key} = $values[0] }
else { $result->{$key} = \@values }
}
return $result;
}
1;

98
site/glist/lib/GT/SQL/Search/MSSQL/Indexer.pm Normal file
View File

@ -0,0 +1,98 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::Search::MSSQL::Indexer
# Author: Alex Krohn
# CVS Info :
# $Id: Indexer.pm,v 1.6 2004/08/28 03:53:48 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description:
# Supports MS SQL full text indexer on MS SQL 2000 only.
#
package GT::SQL::Search::MSSQL::Indexer;
#--------------------------------------------------------------------------------
use strict;
use vars qw/@ISA $VERSION $DEBUG $ERRORS $ERROR_MESSAGE/;
use GT::SQL::Search::Base::Indexer;
@ISA = qw/ GT::SQL::Search::Base::Indexer /;
$DEBUG = 0;
$VERSION = sprintf "%d.%03d", q$Revision: 1.6 $ =~ /(\d+)\.(\d+)/;
$ERRORS = {
NOTFROMWEB => 'There are far too many records in table %s for create/destroy of this indexing scheme from the web. Please use alternative method.',
MSSQLNONSUPPORT => 'You must be using MS SQL 2000 in order to use full text indexing. Current Database: %s',
CREATEINDEX => 'Problem Creating Full Text Index: %s'
};
$ERROR_MESSAGE = 'GT::SQL';
sub load {
my $class = shift;
return $class->new(@_);
}
sub ok {
#--------------------------------------------------------------------------------
my ($class, $tbl) = @_;
unless (uc $tbl->{connect}->{driver} eq 'ODBC') {
return $class->error ('MSSQLNONSUPPORT', 'WARN', $tbl->{connect}->{driver});
}
return 1;
}
sub drop_search_driver {
#--------------------------------------------------------------------------------
my $self = shift;
my $table = $self->{table};
my $name = $table->name;
my $cat = $name . '_ctlg';
my $res = eval {
$table->do_query(" sp_fulltext_table '$name', 'drop' ");
$table->do_query(" sp_fulltext_catalog '$cat', 'drop' ");
1;
};
$res ? return 1 : return;
}
sub add_search_driver {
#--------------------------------------------------------------------------------
my $self = shift;
my $table = $self->{table};
my $name = $table->name;
my $cat = $name . '_ctlg';
my %weights = $table->weight;
my ($pk) = $table->pk;
# Enable a database for full text indexing
$table->do_query(" sp_fulltext_database 'enable' ") or $self->error('CREATEINDEX', 'FATAL', $GT::SQL::error);
# Create a full text catalog to store the data.
$table->do_query(" sp_fulltext_catalog '$cat', 'create' ") or $self->error('CREATEINDEX', 'WARN', $GT::SQL::error);
# Make a unique index on primary key (not sure why it isn't by default.
$table->do_query(" create unique index PK_$name on $name ($pk) ");
# Mark this table as using the full text catalog created
$table->do_query(" sp_fulltext_table '$name', 'create', '$cat', 'PK_$name' ") or $self->error('CREATEINDEX', 'WARN', $GT::SQL::error);
# Specify which columns are to be indexed
foreach my $col (keys %weights) {
if ($weights{$col}) {
$table->do_query(" sp_fulltext_column '$name', '$col', 'add' ") or $self->error('CREATEINDEX', 'WARN', $GT::SQL::error);
}
}
# Must have a timestamp field.
$table->do_query(" alter table $name add timestamp ");
# Build the index.
$table->do_query(" sp_fulltext_table '$name', 'start_change_tracking' ") or $self->error('CREATEINDEX', 'WARN', $GT::SQL::error);
$table->do_query(" sp_fulltext_table '$name', 'start_background_updateindex' ") or $self->error('CREATEINDEX', 'WARN', $GT::SQL::error);
return 1;
}
sub post_create_table {
#--------------------------------------------------------------------------------
shift->add_search_driver(@_);
}
1;

179
site/glist/lib/GT/SQL/Search/MSSQL/Search.pm Normal file
View File

@ -0,0 +1,179 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::Search::MSSQL::Search
# Author : Aki Mimoto
# CVS Info :
# $Id: Search.pm,v 1.9 2004/08/28 03:53:48 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description:
# Class used to search indexed tables.
#
package GT::SQL::Search::MSSQL::Search;
#--------------------------------------------------------------------------------
use strict;
use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /;
use GT::SQL::Search::Base::Search;
@ISA = qw( GT::SQL::Search::Base::Search );
#--------------------------------------------------------------------------------
# Preamble information related to the object
$DEBUG = 0;
$VERSION = sprintf "%d.%03d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/;
$ATTRIBS = {
min_word_size => 2,
};
sub load {
shift;
return GT::SQL::Search::MSSQL::Search->new(@_)
}
sub query {
#--------------------------------------------------------------------------------
# overruns the usual query system with the mssql version
#
my $self = shift;
# Find out what sort of a parameter we're dealing with
my $input = $self->common_param(@_);
# Add additional parameters if required
foreach my $parameter ( keys %{$ATTRIBS} ) {
if ( not exists $input->{$parameter} ) {
$input->{$parameter} = $self->{$parameter};
}
}
# Parse query...,
my ( $query, $rejected ) = $self->_parse_query_string( $input->{'query'} );
$self->{'rejected_keywords'} = $rejected;
# Setup the additional input parameters
$query = $self->_preset_options( $query, $input );
# Now sort into distinct buckets
my $buckets = GT::SQL::Search::Base::Search::_create_buckets( $query );
my $tbl = $self->{table} or $self->error( 'BADARGS', 'FATAL', 'Must have table object defined' );
my $string = $self->_string ($buckets);
return $self->sth({}) unless ($string =~ /\w/);
my $table_name = $tbl->name();
my ($pk) = $tbl->pk;
# create the filter
my $filter_sql = $self->{filter} ? "WHERE ( " . $self->{filter}->sql . ' )' : '';
# If we have a callback, we need all results.
if ($self->{callback}) {
$query = qq!
SELECT $pk, K.RANK
FROM $table_name AS T INNER JOIN
CONTAINSTABLE ( $table_name, *,
'$string'
) AS K
ON T.$pk = K.[KEY]
$filter_sql
!;
my %results = $tbl->do_query($query)->fetchall_list;
my $results = $self->{callback}->($self, \%results);
$self->{rows} = $results ? scalar keys %$results : 0;
return $self->sth($results);
}
else {
my $mh = (defined $input->{nh} and $input->{nh} =~ /^(\d+)$/) ? $1 : 1;
my $nh = (defined $input->{mh} and $input->{mh} =~ /^(\d+)$/) ? $1 : 25;
# First get the total.
$query = qq!
SELECT COUNT(*)
FROM $table_name AS T INNER JOIN
CONTAINSTABLE ( $table_name, *,
'$string'
) AS K
ON T.$pk = K.[KEY]
$filter_sql
!;
my ($count) = $tbl->do_query($query)->fetchrow;
# Now get results.
$query = qq!
SELECT $pk, K.RANK
FROM $table_name AS T INNER JOIN
CONTAINSTABLE ( $table_name, *,
'$string'
) AS K
ON T.$pk = K.[KEY]
$filter_sql
ORDER BY K.RANK DESC
!;
my %results = $tbl->do_query($query)->fetchall_list;
$self->{rows} = $count;
return $self->sth(\%results);
}
}
sub _string {
# -------------------------------------------------------------------
# Returns the string to use for containstable.
#
my ($self, $buckets) = @_;
# union
my $tmp_bucket = $buckets->{keywords};
my $union_request_str = join(
" or ",
map(
qq!"$_"!,
keys %{$buckets->{phrases}}
),
map(
($tmp_bucket->{$_}->{substring} ? "$_*" : $_),
keys %$tmp_bucket
)
);
# intersect
$tmp_bucket = $buckets->{keywords_must};
my $intersect_request_str = join(
" and ",
map(
qq!"$_"!,
keys %{$buckets->{phrases_must}}
),
map(
($tmp_bucket->{$_}->{substring} ? "$_*" : $_),
keys %$tmp_bucket
)
);
# disjoin
$tmp_bucket = $buckets->{keywords_cannot};
my $disjoin_request_str = join(
" and ",
map(
qq!"$_"!,
keys %{$buckets->{phrases_cannot}}
),
map(
($tmp_bucket->{$_}->{substring} ? "$_*" : $_),
keys %$tmp_bucket
)
);
# now build the query
my $tmp_request_str = join(
" and ",
($union_request_str ? "( $union_request_str )" : ()),
($intersect_request_str ? "( $intersect_request_str )" : ()),
($disjoin_request_str ? "NOT ( $disjoin_request_str )" : ())
);
return $tmp_request_str;
}
1;

187
site/glist/lib/GT/SQL/Search/MYSQL/Indexer.pm Normal file
View File

@ -0,0 +1,187 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::Search::MYSQL::Indexer
# Author : Aki Mimoto
# CVS Info :
# $Id: Indexer.pm,v 1.17 2004/08/28 03:53:49 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description:
# Class used to search indexed tables.
#
package GT::SQL::Search::MYSQL::Indexer;
# ------------------------------------------------------------------------------
use strict;
use vars qw/@ISA $VERSION $DEBUG $ERRORS $ERROR_MESSAGE/;
use GT::SQL::Search::Base::Indexer;
@ISA = qw/GT::SQL::Search::Base::Indexer/;
$DEBUG = 0;
$VERSION = sprintf "%d.%03d", q$Revision: 1.17 $ =~ /(\d+)\.(\d+)/;
$ERRORS = {
NOTFROMWEB => 'There are far too many records in table %s for create/destroy of this indexing scheme from the web. Please use alternative method.',
MYSQLNONSUPPORT => 'Driver MYSQL requires MySQL version 3.23.23 or greater. Currently MySQL version: %s'
};
@$GT::SQL::ERRORS{ keys %$ERRORS } = values %$ERRORS;
$ERROR_MESSAGE = 'GT::SQL';
sub load {
my $class = shift;
return $class->new(@_);
}
sub ok {
# ------------------------------------------------------------------------------
my ($class, $tbl) = @_;
unless (uc $tbl->{connect}->{driver} eq 'MYSQL') {
return $class->error ('MYSQLNONSUPPORT', 'WARN', $tbl->{connect}->{driver});
}
my $sth = $tbl->do_query(qq!SELECT VERSION()!);
my $version = $sth->fetchrow;
my ($maj, $min) = split (/\./, $version);
unless ($maj > 3 or ($maj == 3 and $min >= 23)) {
return $class->error(MYSQLNONSUPPORT => WARN => $version);
}
return 1;
}
sub drop_search_driver {
# ------------------------------------------------------------------------------
my $self = shift;
$self->too_much() and return;
my $tbl = $self->{table} or return;
$tbl->connect();
my %weights = $tbl->weight() or return;
my $tblname = $tbl->name();
# Group the fulltext columns by value of the weight
my %cols_grouped;
foreach ( keys %weights ) {
my $val = $weights{$_} or next;
push @{$cols_grouped{$val}}, $_;
}
# Drop unified fulltext columns if required
if ( keys %cols_grouped > 1 ) {
$cols_grouped{-1} = [ grep { $weights{$_} } keys %weights ];
}
# For each value grouped column set create a full text
# column
foreach my $v ( keys %cols_grouped ) {
my $ft_name = 'ft_'.join("_", sort @{$cols_grouped{$v}});
my $res = eval {
$tbl->do_query(qq!
ALTER TABLE $tblname
DROP INDEX $ft_name
!);
};
# Break on errors that can't be handled
if ( $@ ) {
next if $@ !~ /exist/i;
$self->warn( "$@" );
return;
}
}
return 1;
}
sub add_search_driver {
# ------------------------------------------------------------------------------
my $self = shift;
$self->too_much() and return;
my $tbl = $self->{table} or return $self->error(BADARGS => FATAL => "table must be passed into add_search_driver.");
my %weights = $tbl->weight() or return $self->error(NOWEIGHTS => 'WARN');
my $tblname = $tbl->name() or return $self->error(BADARGS => FATAL => "table does not have a name?");
# group the fulltext columns by value of the weight
my %cols_grouped;
foreach ( keys %weights ) {
my $val = $weights{$_} or next;
push @{$cols_grouped{$val}}, $_;
}
# Create unified fulltext columns if required
if ( keys %cols_grouped > 1 ) {
$cols_grouped{-1} = [ grep { $weights{$_} } keys %weights ];
}
# for each value grouped column set create a full text
# column
foreach my $v ( keys %cols_grouped ) {
my $cols = join(",", sort @{$cols_grouped{$v}});
my $ft_name = 'ft_'.join("_", sort @{$cols_grouped{$v}});
my $res = eval {
$tbl->do_query(qq!
ALTER TABLE $tblname
ADD FULLTEXT $ft_name ( $cols )
!);
};
# break on errors that can't be handled
if ( $@ ) {
next if $@ =~ /duplicate/i;
$self->warn( "$@" );
return;
}
}
return 1;
}
sub too_much {
# ------------------------------------------------------------------------------
# returns true if there are too many records to be used on the Web
#
if ( $ENV{REQUEST_METHOD} ) {
my $self = shift;
my $tbl = $self->{table};
if ( $tbl->count() > 5000 ) {
$self->error( 'NOTFROMWEB', 'WARN', $tbl->name() );
return 1
}
}
return;
}
sub post_create_table {
# ------------------------------------------------------------------------------
shift->add_search_driver(@_);
}
sub reindex_all {
# ------------------------------------------------------------------------------
# this will drop all the fulltext columns and reindex all of them. This should
# not be required unless the user changes the weights on one of their columns.
# Unfortunately, this method is not particularly smart and risks not dropping
# certain index columns and reindexes even when it's not required. It must be
# recoded at a future date, but as this action won't happen frequently and will
# rarely affect the user, it is not a priority.
#
my $self = shift;
$self->drop_search_driver;
$self->add_search_driver;
}
1;

51
site/glist/lib/GT/SQL/Search/MYSQL/Search.pm Normal file
View File

@ -0,0 +1,51 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::Search::MYSQL::Search
# Author : Aki Mimoto
# CVS Info :
# $Id: Search.pm,v 1.14 2004/01/13 01:35:19 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description:
# Class used to search indexed tables.
#
package GT::SQL::Search::MYSQL::Search;
# ------------------------------------------------------------------------------
use strict;
use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /;
use GT::SQL::Search::Base::Search;
@ISA = qw( GT::SQL::Search::Base::Search );
# ------------------------------------------------------------------------------
# Preamble information related to the object
$DEBUG = 0;
$VERSION = sprintf "%d.%03d", q$Revision: 1.14 $ =~ /(\d+)\.(\d+)/;
$ATTRIBS = {
min_word_size => 4
};
sub load {
# --------------------------------------------------
my $self = shift;
my $opts = $self->common_param( @_ );
# determine which mysql search variant to use.
my $tbl = $opts->{table};
my $ver_sth = $tbl->do_query( 'SELECT VERSION()' );
my $version = $ver_sth->fetchrow_array();
my ( $maj, $min ) = split /\./, $version;
my $pkg = 'GT::SQL::Search::MYSQL::';
$pkg .= $maj > 3 ? 'VER4' : 'VER3';
eval "require $pkg";
return $pkg->new(@_)
}
1;

178
site/glist/lib/GT/SQL/Search/MYSQL/VER3.pm Normal file
View File

@ -0,0 +1,178 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::Search::MYSQL::VER3
# Author : Aki Mimoto
# CVS Info :
# $Id: VER3.pm,v 1.3 2004/08/28 03:53:49 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description:
# Class used to search indexed tables.
#
package GT::SQL::Search::MYSQL::VER3;
# ------------------------------------------------------------------------------
use strict;
use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /;
use GT::SQL::Search::Base::Search;
@ISA = qw( GT::SQL::Search::Base::Search );
# ------------------------------------------------------------------------------
# Preamble information related to the object
$DEBUG = 0;
$VERSION = sprintf "%d.%03d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/;
$ATTRIBS = {
min_word_size => 4
};
sub _phrase_query {
# ------------------------------------------------------------------------------
my $self = shift;
my $phrases = shift or return $_[0];
my $results = shift || {};
foreach my $phrase ( values %{$phrases} ) {
$self->debug_dumper( "Unioning: ", $phrase ) if ($self->{_debug});
my $tmp = {};
foreach my $keyword ( @{ $phrase->{phrase}|| [] } ) {
$tmp = $self->_get_words ( [ $keyword ], $tmp, 'intersect' );
keys %$tmp or return {};
}
foreach my $key ( keys %$tmp ) { $results->{$key} += $tmp->{$key} }
}
return $results;
}
sub _get_phrase {
# ------------------------------------------------------------------------------
# one day change this so it does words properly
return _get_words(@_);
}
sub _union_query {
# ------------------------------------------------------------------------------
return _get_words(@_);
}
sub _intersect_query {
# ------------------------------------------------------------------------------
my ( $self, $keywords, $results ) = @_;
$keywords or return $results;
foreach my $keyword ( keys %{ $keywords || {} } ) {
$results = $self->_get_words ( [ $keyword ], $results, 'intersect' );
keys %$results or return {};
}
return $results;
}
sub _phrase_intersect_query {
# ------------------------------------------------------------------------------
my $self = shift;
my $phrases = shift or return $_[0];
my $results = shift || {};
my $tmp = $self->_phrase_query ( $phrases, $results );
keys %$results or return $tmp;
foreach my $key ( keys %$results ) {
if ( $tmp->{$key} ) {
$results->{$key} += $tmp->{$key};
}
else {
delete $results->{$key}
}
}
return $results;
}
sub _disjoin_query {
# ------------------------------------------------------------------------------
my $self = shift;
my $words = shift or return shift;
my $results = shift || {};
$results = $self->_get_words([ keys %{$words || {}} ], $results, 'disjoin' );
return $results;
}
sub _phrase_disjoin_query {
# ------------------------------------------------------------------------------
my $self = shift;
my $phrases = shift or return shift;
my $results = shift || {};
my $tmp = $self->_phrase_query ( $phrases, $results );
keys %$results or return $tmp;
foreach my $key ( keys %$results ) {
$tmp->{$key} and delete $results->{$key};
}
}
sub _get_words {
# ------------------------------------------------------------------------------
my $self = shift;
my $words = shift or return $_[0] || {};
my $results = shift || {};
my $mode = lc shift;
my $tbl = $self->{table} or $self->error( 'BADARGS', 'FATAL', 'Must have table object defined' );
my $tname = $tbl->name();
my $wordlist = join " ", ( ref $words ? ( ref $words eq 'HASH' ? keys %$words : @$words ) : $words ) ;
my ($pk) = $tbl->pk;
my %weights = $tbl->_weight_cols();
my $cols = join(",", keys %weights);
my $qwrds = quotemeta( $wordlist );
my $where = ( $results and keys %$results )
? ("AND $pk IN(" . join(',', keys %$results) . ")")
: '';
my $query = qq!
SELECT $pk, MATCH($cols) AGAINST ('$qwrds') AS SCORE
FROM $tname
WHERE MATCH($cols) AGAINST ('$qwrds')
$where
!;
my $sth = $tbl->do_query( $query ) or return;
if ( $mode eq 'disjoin' ) {
while ( my $result = $sth->fetchrow ) {
delete $results->{$result};
}
}
elsif ( $mode eq 'intersect' ) {
my $tmp = {};
while ( my $aref = $sth->fetchrow_arrayref ) {
$tmp->{$aref->[0]} = $aref->[1];
}
if ( $results and keys %$results ) {
while (my ($id, $score) = each %$results) {
if (not defined $tmp->{$id}) {
delete $results->{$id};
next;
}
$results->{$id} += $score;
}
}
else {
$results = $tmp;
}
}
else {
while ( my $aref = $sth->fetchrow_arrayref ) {
$results->{$aref->[0]} += $aref->[1];
}
}
return $results;
}
1;

355
site/glist/lib/GT/SQL/Search/MYSQL/VER4.pm Normal file
View File

@ -0,0 +1,355 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::Search::MYSQL::VER4
# Author : Aki Mimoto
# CVS Info :
# $Id: VER4.pm,v 1.9 2004/01/13 01:35:19 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description:
# Class used to search indexed tables.
#
package GT::SQL::Search::MYSQL::VER4;
# ------------------------------------------------------------------------------
use strict;
use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD $STOPWORDS /;
use GT::SQL::Search::Base::Search;
@ISA = qw( GT::SQL::Search::Base::Search );
# ------------------------------------------------------------------------------
# Preamble information related to the object
$DEBUG = 0;
$VERSION = sprintf "%d.%03d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/;
$STOPWORDS = { map { $_ => 1 } qw/
a's able about above according accordingly across actually after
afterwards again against ain't all allow allows almost alone
along already also although always am among amongst an and another
any anybody anyhow anyone anything anyway anyways anywhere apart
appear appreciate appropriate are aren't around as aside ask asking
associated at available away awfully be became because become becomes
becoming been before beforehand behind being believe below beside
besides best better between beyond both brief but by c'mon c's came
can can't cannot cant cause causes certain certainly changes clearly
co com come comes concerning consequently consider considering
contain containing contains corresponding could couldn't course currently
definitely described despite did didn't different do does doesn't
doing don't done down downwards during each edu eg eight either else
elsewhere enough entirely especially et etc even ever every everybody
everyone everything everywhere ex exactly example except far few
fifth first five followed following follows for former formerly
forth four from further furthermore get gets getting given gives
go goes going gone got gotten greetings had hadn't happens hardly
has hasn't have haven't having he he's hello help hence her here
here's hereafter hereby herein hereupon hers herself hi him himself
his hither hopefully how howbeit however i'd i'll i'm i've ie if ignored
immediate in inasmuch inc indeed indicate indicated indicates inner
insofar instead into inward is isn't it it'd it'll it's its itself
just keep keeps kept know knows known last lately later latter latterly
least less lest let let's like liked likely little look looking looks
ltd mainly many may maybe me mean meanwhile merely might more
moreover most mostly much must my myself name namely nd near nearly
necessary need needs neither never nevertheless new next nine no
nobody non none noone nor normally not nothing novel now nowhere
obviously of off often oh ok okay old on once one ones only onto
or other others otherwise ought our ours ourselves out outside over
overall own particular particularly per perhaps placed please plus
possible presumably probably provides que quite qv rather rd re
really reasonably regarding regardless regards relatively respectively
right said same saw say saying says second secondly see seeing seem
seemed seeming seems seen self selves sensible sent serious seriously
seven several shall she should shouldn't since six so some somebody
somehow someone something sometime sometimes somewhat somewhere
soon sorry specified specify specifying still sub such sup sure
t's take taken tell tends th than thank thanks thanx that that's
thats the their theirs them themselves then thence there there's
thereafter thereby therefore therein theres thereupon these they
they'd they'll they're they've think third this thorough thoroughly
those though three through throughout thru thus to together too
took toward towards tried tries truly try trying twice two un
under unfortunately unless unlikely until unto up upon us use used
useful uses using usually value various very via viz vs want wants
was wasn't way we we'd we'll we're we've welcome well went were
weren't what what's whatever when whence whenever where where's
whereafter whereas whereby wherein whereupon wherever whether
which while whither who who's whoever whole whom whose why will
willing wish with within without won't wonder would would wouldn't
yes yet you you'd you'll you're you've your yours yourself
yourselves zero
/ };
$ATTRIBS = {
min_word_size => 4,
stopwords => $STOPWORDS,
};
sub query {
# --------------------------------------------------
# Returns a sth based on a query
#
# Options:
# - paging
# mh : max hits
# nh : number hit (or page of hits)
#
# - searching
# ww : whole word
# ma : 1 => OR match, 0 => AND match, undefined => QUERY
# substring : search for substrings of words
# bool : 'and' => and search, 'or' => or search, '' => regular query
# query : the string of things to ask for
#
# - filtering
# field_name : value # Find all rows with field_name = value
# field_name : ">value" # Find all rows with field_name > value.
# field_name : "<value" # Find all rows with field_name < value.
# field_name-gt : value # Find all rows with field_name > value.
# field_name-lt : value # Find all rows with field_name < value.
#
# Parameters:
# ( $CGI ) : a single cgi object
# ( $HASH ) : a hash of the parameters
#
my $self = shift;
# create an easily accessible argument hash
my $args = $self->common_param(@_);
# see if we can setup the filtering constraints
my $filter = { %$args };
my $query = delete $args->{query} || $self->{query} || '';
my $ftr_cond;
# parse query
$self->debug( "Search Query: $query" ) if ($self->{_debug});
my ( $query_struct, $rejected ) = $self->_parse_query_string( $query );
$self->{rejected_keywords} = $rejected;
# setup the additional input parameters
$query_struct = $self->_preset_options( $query_struct, $args );
# now sort into distinct buckets
my $buckets = GT::SQL::Search::Base::Search::_create_buckets( $query_struct );
$self->debug_dumper( "Created Buckets for querying: ", $buckets ) if ($self->{_debug});
# with the buckets, it's now possible to create a query string
# that can be passed directly into the FULLTEXT search.
my $query_string = '';
foreach my $search_type ( keys %$buckets ) {
my $bucket = $buckets->{$search_type};
foreach my $token ( keys %$bucket ) {
next unless $token;
my $properties = $bucket->{$token} or next;
my $e = ' ';
# handle boolean operations
$properties->{mode} ||= '';
if ( $properties->{mode} eq 'must' ) {
$e .= '+';
}
elsif ( $properties->{mode} eq 'cannot' ) {
$e .= '-';
}
# deal with phrase vs keyword
if ( $properties->{phrase} ) {
$e .= '"' . quotemeta( $token ) . '"';
}
else {
$e .= quotemeta $token;
# substring match
$e .= '*' if $properties->{substring};
}
$query_string .= $e;
}
}
# start building the GT::SQL::COndition object that will allow us to
# to retreive the data
require GT::SQL::Condition;
my $tbl = $self->{table};
my $constraints = GT::SQL::Condition->new;
# create the GT::SQL::Condition object that will become the filtering
# constraints
my $filt = $self->{filter};
if ( $filt and ref $filt eq 'HASH' ) {
foreach my $fkey ( keys %$filt ) {
next if exists $args->{$fkey};
$args->{$fkey} = $filt->{$fkey};
}
}
if ( my $filter_cond = $tbl->build_query_cond( $args ) ) {
$constraints->add( $filter_cond );
}
# if the cached filter object is a Condition object, append
# it to the filter set
if ( $filt and UNIVERSAL::isa( $filt, 'GT::SQL::Condition' ) ) {
$constraints->add( $filt );
}
# create our fulltext query condition
my %weights = $tbl->_weight_cols();
my $cols = join(",", keys %weights);
if ( $query_string ) {
$constraints->add( GT::SQL::Condition->new(
"MATCH( $cols )",
"AGAINST",
\"('$query_string' IN BOOLEAN MODE)" ) );
}
# calculate the cursor constraints
foreach my $k (qw( nh mh so sb )) {
next if defined $args->{$k};
$args->{$k} = $self->{$k} || '';
}
$args->{nh} = (defined $args->{nh} and $args->{nh} =~ /^(\d+)$/) ? $1 : 1;
$args->{mh} = (defined $args->{mh} and $args->{mh} =~ /^(\d+)$/) ? $1 : 25;
$args->{sb} = (defined $args->{sb} and $args->{sb} =~ /^([\w ]+)$/ ) ? $1 : 'score';
# if the sorting method is "score" the order is forced to "descend" (as there
# is almost no reason to order by worst matches)
# if the storing key is not "score", the default order will be "ascend"
$args->{so} =
$args->{sb} eq 'score' ? 'desc' : # comment out this entire line to prevent "descend" order forcing
( (defined $args->{so} and $args->{so} =~ /^(asc(?:end)?|desc(?:end)?)$/i) ? $1 : 'asc' );
# check that sb is not dangerous
my $sb = $self->clean_sb($args->{sb}, $args->{so});
$self->debug_dumper( "About to query. Constraint object: ", $constraints) if ($self->{_debug});
# Setup a limit only if there is no callback. The callback argument requires a full results list
unless ( $self->{callback} ) {
my $offset = ( $args->{nh} - 1 ) * $args->{mh};
$tbl->select_options($sb) if ($sb);
$tbl->select_options("LIMIT $offset, $args->{mh}");
}
my $sth;
# if the weights are all the same value, the query can be optimized
# to use just one MATCH AGAINST argument. However, if the weights
# are different, each element must be sectioned and queried separately
# with the weight value multipler
# check to see if all the weight values are the same.
my $base_weight;
my $weights_same = 1;
foreach ( values %weights ) {
$base_weight ||= $_ or next; # init and skip 0s
next if $base_weight == $_;
$weights_same = 0;
last;
}
# multiplex the action
my $result_cols = $self->{callback} ? ($tbl->pk)[0] : '*';
unless ( $query_string ) {
$sth = $tbl->select( [ $result_cols ], $constraints ) or return;
}
elsif ( $weights_same ) {
$sth = $tbl->select( [ $result_cols, "MATCH($cols) AGAINST ('$query_string' IN BOOLEAN MODE) AS score" ], $constraints )
or return;
}
else {
# group the multiplier counts
my %column_multiplier;
foreach ( keys %weights ) {
push @{$column_multiplier{$weights{$_}}}, $_;
}
my @search_parameters;
foreach my $val ( keys %column_multiplier ) {
next unless $val;
my $cols_ar = $column_multiplier{ $val } or next;
my $search_cols = join ",", @$cols_ar;
if ( $val > 1 ) {
push @search_parameters, "( ( MATCH($search_cols) AGAINST ('$query_string' IN BOOLEAN MODE) ) * $val )";
}
else {
push @search_parameters, "( MATCH($search_cols) AGAINST ('$query_string' IN BOOLEAN MODE) )";
}
}
my $search_sql = "( " . join( " + ", @search_parameters ) . " ) AS score";
$sth = $tbl->select( [ $result_cols, $search_sql ], $constraints )
or return;
}
# If we have a callback, we fetch the primary key => score and pass that hash into
# the filter.
if ($self->{callback}) {
unless (ref $self->{callback} and ref $self->{callback} eq 'CODE') {
return $self->error('BADARGS', 'FATAL', "callback '$self->{callback}' must be a code ref!");
}
my %results = map { $_->[0] => $_->[1] } @{$sth->fetchall_arrayref};
$self->debug_dumper("Running results through callback. Had: " . scalar (keys %results) . " results.", \%results) if ($self->{_debug});
my $filtered = $self->{callback}->($self, \%results) || {};
$self->debug_dumper("New result set: " . scalar (keys %$filtered) . " results.", $filtered) if ($self->{_debug});
$self->{rows} = scalar keys %$filtered;
return $self->sth($filtered);
}
# count the number of hits. create a query for this purpose only if we are required to.
$self->{rows} = $sth->rows();
if (($args->{nh} > 1) or ($self->{rows} == $args->{mh})) {
$self->{rows} = $tbl->count($constraints);
}
return $sth;
}
sub clean_sb {
# -------------------------------------------------------------------------------
# Convert the sort by, sort order into an sql string.
#
my ($class, $sb, $so) = @_;
my $output = '';
return $output unless ($sb);
if ($sb and not ref $sb) {
if ($sb =~ /^[\w\s,]+$/) {
if ($sb =~ /\s(?:asc|desc)/i) {
$output = 'ORDER BY ' . $sb;
}
else {
$output = 'ORDER BY ' . $sb . ' ' . $so;
}
}
else {
$class->error('BADSB', 'WARN', $sb);
}
}
elsif (ref $sb eq 'ARRAY') {
foreach ( @$sb ) {
/^[\w\s,]+$/ or $class->error( 'BADSB', 'WARN', $sb ), next;
}
$output = 'ORDER BY ' . join(',', @$sb);
}
return $output;
}
1;

25
site/glist/lib/GT/SQL/Search/NONINDEXED/Indexer.pm Normal file
View File

@ -0,0 +1,25 @@
# ====================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Search::NONINDEXED::Indexer
# Author: Aki Mimoto
# CVS Info :
# $Id: Indexer.pm,v 1.3 2004/01/13 01:35:20 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ====================================================================
#
package GT::SQL::Search::NONINDEXED::Indexer;
#--------------------------------------------------------------------------------
use strict;
use vars qw/@ISA $DEBUG/;
use GT::SQL::Search::Base::Indexer;
@ISA = qw/ GT::SQL::Search::Base::Indexer /;
sub load {
shift;
return GT::SQL::Search::NONINDEXED::Indexer->new(@_)
}
1;

255
site/glist/lib/GT/SQL/Search/NONINDEXED/Search.pm Normal file
View File

@ -0,0 +1,255 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Search::NONINDEXED::Search
# Author : Alex Krohn
# CVS Info :
# $Id: Search.pm,v 1.28 2004/08/28 03:53:50 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description:
# Nonindex search system
#
package GT::SQL::Search::NONINDEXED::Search;
# ==================================================================
use strict;
use vars qw/@ISA $ATTRIBS $VERSION $DEBUG/;
use GT::SQL::Search::Base::Search;
use GT::SQL::Condition;
@ISA = qw( GT::SQL::Search::Base::Search );
$DEBUG = 0;
$VERSION = sprintf "%d.%03d", q$Revision: 1.28 $ =~ /(\d+)\.(\d+)/;
$ATTRIBS = {
# parse based on latin characters
latin_query_parse => 0
};
sub load {
shift;
return GT::SQL::Search::NONINDEXED::Search->new(@_)
}
sub query {
#--------------------------------------------------------------------------------
# Returns a sth based on a query
#
# Options:
# - paging
# mh : max hits
# nh : number hit (or page of hits)
#
# - searching
# ww : whole word
# ma : 1 => OR match, 0 => AND match, undefined => QUERY
# substring : search for substrings of words
# bool : 'and' => and search, 'or' => or search, '' => regular query
# query : the string of things to ask for
#
# - filtering
# field_name : value # Find all rows with field_name = value
# field_name : ">value" # Find all rows with field_name > value.
# field_name : "<value" # Find all rows with field_name < value.
# field_name-gt : value # Find all rows with field_name > value.
# field_name-lt : value # Find all rows with field_name < value.
#
# Parameters:
# ( $CGI ) : a single cgi object
# ( $HASH ) : a hash of the parameters
#
my $self = shift;
# find out what sort of a parameter we're dealing with
my $input = $self->common_param(@_);
# add additional parameters if required
foreach my $parameter ( keys %{$ATTRIBS} ) {
if ( not exists $input->{$parameter} ) {
$input->{$parameter} = $self->{$parameter};
}
}
# parse query
$self->debug( "Search Query: $$input{query}", 1 ) if ($self->{_debug});
my ( $query, $rejected ) = $self->_parse_query_string( $input->{'query'} );
$self->{rejected_keywords} = $rejected;
# setup the additional input parameters
$query = $self->_preset_options( $query, $input );
$self->debug( "Set the pre-options: ", $query ) if ($self->{_debug});
# now sort into distinct buckets
my $buckets = GT::SQL::Search::Base::Search::_create_buckets( $query );
$self->debug_dumper( "Created Buckets for querying: ", $buckets ) if ($self->{_debug});
require GT::SQL::Condition;
my $query_condition = new GT::SQL::Condition;
# now handle the separate possibilities
# the union
my $union_cond = $self->_get_condition( $buckets->{keywords}, $buckets->{phrases} );
$query_condition->add(GT::SQL::Condition->new(@$union_cond, 'OR')) if $union_cond;
# the intersect
my $intersect_cond = $self->_get_condition( $buckets->{keywords_must}, $buckets->{phrases_must} );
$query_condition->add(GT::SQL::Condition->new(@$intersect_cond)) if $intersect_cond;
# the disjoin
my $disjoin_cond = $self->_get_condition( $buckets->{keywords_cannot}, $buckets->{phrases_cannot} );
$query_condition->add(GT::SQL::Condition->new(@$disjoin_cond, 'OR')->not) if $disjoin_cond;
# now handle filters
my $cols = $self->{'table'}->cols();
my %filters = map {
(my $column = $_) =~ s/-[lg]t$//;
exists $cols->{$column}
? ($_ => $input->{$_})
: ()
} keys %{$input};
# if there was no query nor filter return nothing.
keys %$query or keys %filters or return $self->sth({});
if (keys %filters) {
$self->debug( "Creating Filters: ", \%filters ) if ($self->{_debug});
$self->_add_filters( \%filters );
$query_condition = GT::SQL::Condition->new( keys %$query ? $query_condition : (), $self->{filter} );
}
elsif ($self->{filter} and keys %{$self->{filter}} ) {
$self->debug( "Filtering results", $self->{filter} ) if ($self->{_debug});
$query_condition = GT::SQL::Condition->new( keys %$query ? $query_condition : (), $self->{filter} );
}
else {
$self->debug( "No filters being used.") if ($self->{_debug});
}
# now this query should probably clear the filters once it's been used, so i'll do that here
$self->{filter} = undef;
my $tbl = $self->{table};
my ($pk) = $tbl->pk;
# now run through a callback function if needed.
if ($self->{callback}) {
# Warning: this slows things a heck of a lot.
unless (ref $self->{callback} and ref $self->{callback} eq 'CODE') {
return $self->error ('BADARGS', 'FATAL', "callback '$self->{callback}' must be a code ref!");
}
my $sth = $tbl->select( [ $pk ], $query_condition );
my $results = {};
while (my $result = $sth->fetchrow) {
$results->{$result} = undef;
}
$self->debug_dumper("Running results through callback. Had: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug});
$results = $self->{callback}->($self, $results);
$self->debug_dumper("New result set: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug});
$self->{rows} = scalar($results ? keys %{$results} : ());
return $self->sth( $results );
}
# and now create a search sth object to handle all this
$input->{nh} = (defined $input->{nh} and $input->{nh} =~ /^(\d+)$/) ? $1 : 1;
$input->{mh} = (defined $input->{mh} and $input->{mh} =~ /^(\d+)$/) ? $1 : 25;
$input->{so} = (defined $input->{so} and $input->{so} =~ /^(asc(?:end)?|desc(?:end)?)$/i) ? $1 : '';
# check that sb is not dangerous
my $sb = $self->clean_sb($input->{sb}, $input->{so});
my $offset = ( $input->{nh} - 1 ) * $input->{mh};
$tbl->select_options($sb) if ($sb);
$tbl->select_options("LIMIT $offset, $input->{mh}");
my $sth = $tbl->select( $query_condition ) or return;
# so how many hits did we get?
$self->{rows} = $sth->rows();
if (($input->{nh} > 1) or ($self->{rows} == $input->{mh})) {
$self->{rows} = $tbl->count($query_condition);
}
return $sth;
}
sub _get_condition {
#-------------------------------------------------------------------------------
my ( $self, $keywords, $phrases ) = @_;
my @list = ( keys %$keywords, keys %$phrases );
my $tbl = $self->{table} or return $self->error( 'NODRIVER', 'FATAL' );
my @cond = ();
my %tmp = $tbl->weight();
my @weights = keys %tmp or return;
foreach my $element ( @list ) {
my @where = ();
foreach my $cols ( @weights ) {
push @where, [$cols, 'LIKE', "%$element%"]; # Condition does quoting by default.
}
push @cond, GT::SQL::Condition->new(@where, 'OR');
}
@cond or return;
return \@cond;
}
sub _parse_query_string {
#------------------------------------------------------------
# Parses a query string '+foo -"bar this" alpha' into a hash of
# words and modes.
#
my ($self, $text) = @_;
my %modes = (
'+' => 'must',
'-' => 'cannot',
'<' => 'greater',
'>' => 'less'
);
# Latin will break up on actual words and punctuation.
if ($self->{latin_query_parse}) {
return $self->SUPER::_parse_query_string( $text );
}
else {
my $words = {};
my @terms;
my $i = 0;
foreach my $term (split /"/, $text) {
push @terms, ($i++ % 2 ? $term : split ' ', $term);
}
for (my $i = 0; $i < @terms; $i++) {
my $word = $terms[$i];
$word =~ s/^\s*|\s*$//g;
next if ($word eq '');
($word eq '-') and ($word = '-' . $terms[++$i]);
($word eq '+') and ($word = '+' . $terms[++$i]);
$word =~ s/^([<>+-])//;
my $mode = ($1 and $modes{$1} or 'can');
my $substring = ($word =~ s/\*$//) || 0;
if ($word =~ /\s/) {
$words->{$word} = {
mode => $mode,
phrase => 1,
substring => $substring,
keyword => 0,
};
}
else {
$words->{$word} = {
mode => $mode,
phrase => 0,
substring => $substring,
keyword => 1,
};
}
}
return $words;
}
}
1;

2955
site/glist/lib/GT/SQL/Table.pm Normal file
View File

File diff suppressed because it is too large Load Diff

1268
site/glist/lib/GT/SQL/Tree.pm Normal file
View File

File diff suppressed because it is too large Load Diff

237
site/glist/lib/GT/SQL/Tree/Rebuild.pm Normal file
View File

@ -0,0 +1,237 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Table
# Author: Jason Rhinelander
# CVS Info :
# $Id: Rebuild.pm,v 1.10 2005/04/06 23:11:08 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description:
# This goes hand in hand with GT::SQL::Tree and is very useful in
# turning an existing table without the root, and/or depth columns
# into a GT::SQL::Tree-compatible format.
#
package GT::SQL::Tree::Rebuild;
# ===============================================================
use strict;
use vars qw/$DEBUG $VERSION $ERROR_MESSAGE @ISA $AUTOLOAD/;
use constants TREE_COLS_ROOT => 0,
TREE_COLS_FATHER => 1,
TREE_COLS_DEPTH => 2;
@ISA = qw/GT::SQL::Base/;
$DEBUG = 0;
$VERSION = sprintf "%d.%03d", q$Revision: 1.10 $ =~ /(\d+)\.(\d+)/;
$ERROR_MESSAGE = 'GT::SQL';
# New returns a GT::SQL::Tree::Rebuild object when you can pass to GT::SQL::Tree.
# When you are adding a tree to an existing table, but the table does not have
# the root and/or depth columns, you get a Rebuild object, then pass it to
# ->add_tree so that your tree can be built anyway.
# You need to call new with the following options:
# table => $Table_object
# missing_root => sub { ... }, # Only if you are missing the root. The code reference should return the pk of the root.
# missing_depth => 1, # Only if you are missing the depth. The code reference should return the depth of the node.
# missing_father => 1, # Only if you are missing the father. The code reference should return the pk of the father.
# cols => [...], # The columns you want %row (discussed below) to contain
#
# The code references are passed two arguments:
# \%row, # A row from the table. If using the cols option, it will only have those columns.
# $table_object, # This is the same object you pass to new()
# \%all # This is a hash reference of all rows; each key is a primary key, each value the row. This may or may not be of use to you.
#
# For depth, %all will have root and father ids set, for roots father ID's will be set.
#
# NOTE: The father, root, and depth columns must exist beforehand.
sub new {
my $this = shift;
my $opts = $this->common_param(@_) or return $this->error(BADARGS => FATAL => '$obj->new(HASH or HASH REF)');
my $self = bless {}, $this;
$self->{table} = $opts->{table} or return $self->error(BADARGS => FATAL => '$obj->new({ ... table => $table_obj ... })');
for (qw(missing_root missing_depth missing_father)) {
next unless exists $opts->{$_};
$self->{$_} = $opts->{$_};
ref $self->{$_} eq 'CODE' or return $self->error(BADARGS => FATAL => '$obj->new({ ... ' . $_ . ' => sub { ... } ... })');
}
$self->{cols} = $opts->{cols} if $opts->{cols};
$self->{cols} = [$self->{cols}] if $self->{cols} and not ref $self->{cols};
$self->{cols} ||= [];
$self->{order_by} = $opts->{order_by} if $opts->{order_by};
$self->{missing_root} or $self->{missing_depth} or $self->{missing_father} or return $self->error(BADARGS => FATAL => 'At least one of "missing_root", "missing_depth", or "missing_father" must be passed to $obj->new({ ... })');
$self->{_debug} = $opts->{debug} || $DEBUG || 0;
$self;
}
# Called internally by the GT::SQL::Tree object. This does all the calculations.
# Note that this only rebuilds the table itself, GT::SQL::Tree->create will still
# have to create its tree table.
sub _rebuild {
my ($self, $pk, $root_col, $father_col, $depth_col) = @_;
my $table = $self->{table};
my $count = $table->count();
for (my $i = 0; $i < $count; $i += 10000) {
$table->select_options("ORDER BY $self->{order_by}") if exists $self->{order_by};
$table->select_options("LIMIT 10000" . ($i ? " OFFSET $i" : ""));
my $sth = $table->select(@{$self->{cols}});
while (my $row = $sth->fetchrow_hashref) {
my %update;
if ($self->{missing_father}) {
my $father_id = $self->{missing_father}->($row, $table);
$update{$father_col} = $father_id unless $row->{$father_col} == $father_id;
$row->{$father_col} = $father_id;
}
if ($self->{missing_root}) {
my $root_id = $self->{missing_root}->($row, $table);
$update{$root_col} = $root_id unless $row->{$root_col} == $root_id;
$row->{$root_col} = $root_id;
}
if ($self->{missing_depth}) {
my $depth = $self->{missing_depth}->($row, $table);
$update{$depth_col} = $depth unless $row->{$depth_col} == $depth;
$row->{$depth_col} = $depth;
}
$table->update(\%update, { $pk => $row->{$pk} }) if keys %update; # If the new value(s) is/are 0, like the default value(s), %update will be empty
}
}
return 1;
}
1;
__END__
=head1 NAME
GT::SQL::Tree::Rebuild - Helps to turn a table into one usable by GT::SQL::Tree.
=head1 SYNOPSIS
use GT::SQL::Tree;
use GT::SQL::Tree::Rebuild;
my $rebuild = GT::SQL::Tree::Rebuild->new(
table => $DB->table('MyTable'),
missing_root => \&root_code,
missing_father => \&father_code,
missing_depth => \&depth_code,
order_by => 'column_name'
);
$DB->editor('MyTable')->add_tree(root => $root_col, father => $father_col, depth => $depth_col, rebuild => $rebuild);
=head1 DESCRIPTION
GT::SQL::Tree::Rebuild is designed to go hand-in-hand with GT::SQL::Tree and
aids in turning an existing table into one with the neccessary root, father and
depth columns needed by GT::SQL::Tree.
The main purpose is to do a one-shot conversion of a table to make it compatible
with GT::SQL::Tree.
=head2 new - Create a Rebuild object
There is only one method that is called - new. You pass the arguments needed
and get back a GT::SQL::Tree::Rebuild object. This object should then be passed
into GT::SQL::Tree->create (typically via C<$editor-E<gt>add_tree()>)
new() takes a hash with up to 4 argument pairs: "table" (required), and one or
more of "missing_root", "missing_father", or "missing_depth". The values are
explained below.
=over 4
=item table
Required. You specify the table object for the table to rebuild. For example, if
you are going to add a tree to the "Category" table, you provide the "Category"
table object here.
=item cols
By default, an entire row will be returned. To speed up the process and lower
the memory usage, you can use the C<cols> option, which specifies the columns to
select for $row. It is recommended that you only select columns that you need as
doing so will definately save time and memory.
=item missing_father, missing_root, missing_depth
Each of these arguments takes a code reference as its value. The arguments to
the code references are as follows:
=over 4
=item $row
The first argument is a hash reference of the row being examined. Your job, in
the code reference, is to examine $row and determine the missing value,
depending on which code reference is being called. missing_root needs to return
the root_id for this row; missing_father needs to return the father_id, and the
missing_depth code reference should return the depth for the row.
=item $table
The second argument passed to the code references is the same table object that
you pass into new(), which you can select from if neccessary.
=back
=item missing_father
The C<missing_father> code reference is called first - before C<missing_root>
and C<missing_depth>. The code reference is called as described above and should
return the ID of the father of the row passed in. A false return (0 or undef) is
interpreted as meaning that this is a root and therefore has no father.
=item missing_root
C<missing_root> has to return the root of the row passed in. This is called
after C<missing_father>, so the $row will contain whatever you returned in
C<missing_father> in the father ID column. Of course, this only applies if using
both C<missing_root> and C<missing_father>.
=item missing_depth
C<missing_depth> has to return the depth of the row passed in. This is called
last, so if you are also using C<missing_father> and/or C<missing_root>, you
will have whatever was returned by those code refs available in the $row.
=item order_by
The query done to retrieve records can be sorted using the C<order_by> option.
It should be anything valid for "ORDER BY _____". Often it can be useful to have
your results returned in a certain order - for example:
order_by => 'depth_column ASC'
would insure that parents come before roots. Of course, this example wouldn't
work if you are using "missing_depth" since none of the depth values will be
set.
=back
Once you have a GT::SQL::Tree::Rebuild object, you should pass it into
C<GT::SQL::Tree-E<gt>create> (which typically involves passing it into
C<$editor-E<gt>add_tree()>, which passed it through). Before calculating the
tree, GT::SQL::Tree will call on the rebuild object to reproduce the father,
root, and/or depth columns (whichever you specified).
=head1 COPYRIGHT
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
http://www.gossamer-threads.com/
=head1 VERSION
Revision: $Id: Rebuild.pm,v 1.10 2005/04/06 23:11:08 jagerman Exp $
=cut

385
site/glist/lib/GT/SQL/Types.pm Normal file
View File

@ -0,0 +1,385 @@
1;
__END__
=head1 NAME
GT::SQL::Driver::Types - Column types supported by GT::SQL
=head1 SYNOPSIS
my $c = $DB->creator('new_table');
$c->cols({
column_name => { type => 'INT', default => 42, not_null => 1, unsigned => 1 }
# ... more columns ...
});
my $e = $DB->editor('table_name');
$e->add_col(column_name2 => { type => 'CHAR', size => 10, default => 'abc' });
=head1 DESCRIPTION
This module should not be used directly, however the documentation here
describes the different types support by GT::SQL and any caveats associated
with those types.
=head1 ATTRIBUTES
All types are specified as a C<column_name =E<gt> { column definition }> pair,
where the column definition should contain at least a C<type> key containing
one of the L</"TYPES"> outlined below. Commonly accepted attributes are:
=over 4
=item not_null
Used to specify that a column should not be allowed to contain NULL values.
Note that for character/string data types, a 0-character string (and, for
C<CHAR>/C<VARCHAR> columns, strings containing only spaces), B<are> considered
NULL values are are not permitted if the column is specified as C<not_null>.
The value passed to not_null should be true.
=item default
Used to specify a default value to be used for the column when no explicit
value is provided when a row is inserted. The default value is also used for
the value in existing rows when adding a not_null column to an existing table -
in such a case, the C<default> is B<required>.
Also see the L<C<TEXT>|/TEXT> section regarding caveats and limitations of
using C<default>'s for C<TEXT> types.
=back
Other column attributes are supported as outlined below. In addition to
attributes mentioned in this document, various attributes are available that
influence automatically-generated forms displayed by GT::SQL::Admin - see
L<GT::SQL::Creator> for details on these attributes.
=head1 TYPES
=head2 Integer types
=over 4
=item TINYINT
The C<TINYINT> type specifies an 8-bit integer able to handle values from -128
to 127. Some databases will allow larger values due to not supporting an
appropriate data type. The C<unsigned> column attribute I<may> turn this into
an unsigned value supporting values from 0 to 255; due to this type being
implemented as a larger integer type in some databases (which, incidentally,
coincide with the databases not supporting an unsigned 8-bit C<TINYINT>) using
an C<unsigned> TINYINT type will result in a column able to store any value
from 0-255, unlike most of the larger integer types below.
=item SMALLINT
The C<SMALLINT> type specifies a 16-bit integer able to handle values from
-32768 to 32767. The C<unsigned> column attribute I<may> turn this into an
unsigned value supporting values from 0 to 65535, however this is B<not>
guaranteed. If you need to store values in the 32768-65535 range, a larger
type is recommended.
=item MEDIUMINT
The C<MEDIUMINT> type (only natively supported by MySQL) specifies a 24-bit
integer type able to hold values from -8388608 to 8388607. If the C<unsigned>
column attribute is specified, this allows values from 0 to 16777215. Due to
this being supported with the C<unsigned> attribute, or implemented as a larger
data type, an C<unsigned> C<MEDIUMINT> will always supported values up to
16777215.
=item INT, INTEGER
The C<INT> type specifies a 32-bit integer able to hold values from -2147483648
to 2147483647. If the C<unsigned> column attribute is specified, the column
I<may> support values from 0 to 4294967295, however this is B<not> guaranteed.
If values larger than 2147483647 are needed, using the C<BIGINT> type below is
recommended. C<INTEGER> is an alias for C<INT>.
=item BIGINT
The largest integral type, C<BIGINT> specifies a 64-bit integer value able to
hold values from -9223372036854775808 to 9223372036854775807. If specified as
C<unsigned>, the column I<may> support values from 0 to 18446744073709551616,
but this is B<not> guaranteed. If larger values are needed, use the C<DECIMAL>
type with a C<scale> value of C<0>.
=item back
=head2 Float-point types
=over 4
=item REAL, FLOAT
The C<REAL> type specifies a 32-bit floating-point (i.e. fractional) number,
accurate to 23 binary digits (which works out to I<approximately> 6 decimal
digits). The values may be signed, and can range from at least as small as
10^-37 to at least as large as 10^37. For more precise values, the C<DOUBLE>
type is recommended. For exact precision (i.e. for monetary values), the
(often slower) C<DECIMAL> type is recommended. C<FLOAT> is an alias for
C<REAL>.
=item DOUBLE
The C<DOUBLE> type specifies a 64-bit floating-point (i.e. fractional) number,
accurate to 52 binary digits (I<approximately> 15 decimal digits). The values
may be signed, and can range from at least as small as 10^-307 to at least as
large as 10^308 (except under Oracle - see below). For exact precision (i.e.
for monetary values), the (often slower) C<DECIMAL> type is recommended.
Take note that Oracle doesn't properly support the full range supported by
other databases' C<DOUBLE> types - the smallest number supported (assuming
precision to digits) is 10^-113 - specifically, the number of digits after the
decimal place may not exceed 128 - so 1.2345678901e-117 is acceptable, while
1.23456789012e-117 is not. The larger number Oracle supports is just less than
1e+126 (i.e. 9.999...e+125), as opposed to other databases' 1e+307. If you
need to store numbers larger or smaller than this amount, you'll have to find
some other way to store your numbers (i.e. Math::BigFloat with a C<VARCHAR>).
=back
=head2 Aribtrary precision numbers
=over 4
=item DECIMAL
The C<DECIMAL> type is provided to support numbers of arbitrary precision. It
requires two attributes, C<scale> and C<precision>, where C<scale> specifies
the number of decimal places, and precision specifies the number of overall
digits. For example, C<123.45> has a C<precision> of 5, and a C<scale> of 2.
C<42> has a C<precision> or 2, and a C<scale> of 0. C<scale> must be less than
C<precision>, and C<precision> must not exceed 38. Also, although the value
stored and retrieved is completely accurate within it's given precision and
scale range, the accuracy available for comparisons (i.e. column = number) is
only reliably accurate to approximately the same level as DOUBLE's - that is,
about 15 digits.
=back
=head2 Character types
=over 4
=item CHAR
The C<CHAR> type is used to specify a string of characters from 1 to 255
characters long. It takes a C<size> attribute which must be 255 or less, and
specifies the size of the column values - if not specified, 255 will be used.
This implementation's C<CHAR> type, for historic reasons, B<will not> pad
inserted values with spaces, but B<may> trim trailing spaces when retrieving
and/or comparing values. Note that this is B<not> SQL compliant C<CHAR>
behaviour - SQL-compliant C<CHAR>'s are padded with spaces up to their size.
What this ends up meaning is that for everything except MySQL, C<CHAR> columns
will be mapped to C<VARCHAR> columns. Note that even MySQL, which is the only
database for which C<CHAR>'s are not automatically mapped into C<VARCHAR>'s,
will I<transparently> convert C<CHAR> columns to C<VARCHAR> columns if any
non-fixed-size datatype (anything other than a C<CHAR> or numeric types) is
used in or added to the table. As a general rule, C<VARCHAR> is preferred over
C<CHAR> except when dealing with columns whose values don't vary significantly
in length B<and> are in a table that only contains fixed-size data types
(C<CHAR>'s and numeric types). Everywhere else, use C<VARCHAR>'s, since that's
what you'll be getting anyway.
A C<binary> attribute is supported, which I<may> indicates that comparisons
with this field should be case-sensitive. Note that this only works on
databases that actually have a case-sensitive C<CHAR> field - currently, only
MySQL.
=item VARCHAR
The C<VARCHAR> type is identical to the above C<CHAR> type B<except> as
follows. Unlike a C<CHAR>, a C<VARCHAR> column does not take up C<size> bytes
of storage space - typically the storage space is only slightly larger
(typically 1 byte) than the size of the value stored. As such, C<VARCHAR>'s
are almost always preferred over columns, except for nearly-constant sized
data, or tables with all fixed-width data types (C<CHAR>'s, C<INT>'s, and
non-C<DECIMAL> numeric types). C<VARCHAR> columns will not be padded with
whitespace up to C<size>, however trailing whitespace C<may> be trimmed from
values.
As with C<CHAR>, the C<binary> attribute I<may> make the C<VARCHAR> values
case-sensitive for the matching purposes.
=item TEXT
The C<TEXT> type is similar to C<VARCHAR> types, except that they are always
case-insensitive for matching/equality, and can contain longer values. The
C<TEXT> type takes a C<size> attribute which contains the length required - if
not provided, a value of approximately 2 billion is used. Note that the
maximum size of the column will usually be larger than the value you specify to
C<size> - it simply indicates to the driver to use a field capable of at least
the size specified. The values of C<TEXT> fields are case-insensitive in terms
of matches and equality. The maximum C<size> value, and the default, is
approximately 2 billion.
Certain aliases are provided with implicit size defaults - C<TINYTEXT>,
C<SMALLTEXT>, C<MEDIUMTEXT>, and C<LONGTEXT>, which are equivelant to C<TEXT>
with C<size> values of 255, 65535, 16777215, and 2147483647, respectively.
Depending on the C<size> value, certain databases _may_ use different
underlying types. MySQL, for example, uses the smallest possible type between
its native C<TINYTEXT>, C<TEXT>, C<MEDIUMTEXT>, and C<LONGTEXT> types. As
such, it is recommended that you use a sufficiently large C<size> value unless
absolutely sure that you will never need a larger value.
Also note that C<TEXT> types B<do not> support normal equality operations - in
fact, the only portable things that can be done with C<TEXT> columns is C<IS
NULL> tests (in GT::SQL this means "=" C<undef>) and C<LIKE> comparisons - but,
for portability with all supported databases, the argument of a C<LIKE> may not
exceed 4000 characters.
Also note that the C<default> value will be ignored by MySQL, which does not
support having default values on C<TEXT> columns. Everything else, however,
will properly support this, and the default will still be used when inserting
with GT::SQL even when using MySQL. Also note that the default value of
C<TEXT> types B<must not> exceed 3998 characters, due to limits imposed by some
databases. Longer indexes may work in some cases, but are not guaranteed - for
example, a table resync on MSSQL will not work.
=item ENUM
The C<ENUM> type is a MySQL-only type that supports certain fixed string
values. On non-MySQL databases, it is simply mapped to a C<VARCHAR> column.
It requires a C<values> option which should have a value of an array reference
of string values that the ENUM should permit. The C<ENUM> type is generally
discouraged in favour of a C<CHAR>, C<VARCHAR>, or an
L<integral type|/"Integer types"> column, all of which provide more flexibility
(i.e. if you want to add a new possible value) and are not a single
database-specific type.
=back
=head2 Date/time types
All of the date/time types support by MySQL will be handled by GT::SQL, for
compatibility reasons. However, all types other than DATE and C<DATETIME>
should be considered deprecated as cross-database compatibility is not possible
using these types. In particular, C<TIMESTAMP> will work exactly like a
C<DATETIME> on every non-MySQL database; C<TIME> and C<DATE> will work in
Postgres just like they do in MySQL; under everything else, C<TIME> won't work
at all, and C<DATE> will work like C<DATETIME>.
GT::SQL users are urged to at least consider using an INT column, designed to
contain Perl's time() value, in lieu of any of the Date/time types as it avoids
many problems typically associated with storing local times - such as time zone
issues and non-local databases. That said, if you are certain you want a
Date/time type, a DATETIME is preferred as it will work (almost) the same
everywhere.
=over 4
=item DATETIME
A date field, which stores values in C<YYYY-MM-DD HH:MM:SS> format (where
C<'HH'> is a 24-hour hour). Inserted values may omit the seconds
(C<YYYY-MM-DD HH:MM>), or time (C<YYYY-MM-DD>) portions of the value. Omitted
values will default to C<0>.
Note that C<DATETIME> values returned from a database I<may> include
fractional-second precision values such as C<2004-01-01 12:00:07.123>.
Currently MSSQL and Postgres exhibit this behaviour. MSSQL's C<DATETIME> type
always includes exactly three decimal digits, while Postgres' C<TIMESTAMP> type,
used for GT::SQL C<DATETIME>'s, stores times with 6 decimal-digit precision.
Unlike MSSQL, however, Postgres will only display decimal digits if a
significant decimal value has been stored in the database. This happens with
the C<time_check> option, below, and when an explicit fractional second value
has been inserted into the database.
A C<time_check> attribute may be passed with a true value; if set, any update
to the row that doesn't explicitly set the column will have the column updated
to the B<database's> current local time. Due to issues with times and/or
timezones, this option should be considered deprecated and discouraged - it is
recommended instead that you update the value yourself using a value that
I<your script> thinks is local time (or, better yet, use an C<INT> column with
unix time values (i.e. time() in Perl), which are timezone-independent to begin
with), rather than trying to depend on a database having the same time and time
zone as your script.
=item DATE
Just like C<DATETIME>, except (under MySQL and Postgres) it only stores and
returns the C<YYYY-MM-DD> portion of the value. Note that when using this
type, care must be taken to extract only the desired portion of the output as
databases other than MySQL and Postgres map this to a C<DATETIME> above, which
returns 'YYYY-MM-DD HH:MM:SS' values (with a possible fractional seconds value,
in the case of MSSQL/Postgres). Using a C<DATETIME> or C<INT> field is
generally preferred, but this type may be slightly more effecient and take
slightly less space (4 bytes instead of 8 bytes) on MySQL and Postgres
databases.
Like C<DATETIME>, this handles a C<time_check> field, with the same caveats
described in the the C<DATETIME> C<time_check> description.
=back
The alternate, deprecated date/time types supported are listed in the
L</Deprecated types> section below.
=head2 Deprecated types
=over 4
=item BLOB
Limited C<BLOB> support (C<TINYBLOB>, C<BLOB>, C<MEDIUMBLOB>, and C<LONGBLOB>)
existed in older versions of GT::SQL, however the support, where it existed at
all, was partial and incomplete. Additionally, only certain drivers (MySQL and
Oracle) supported C<BLOB> types at all. As such, the limited C<BLOB> support
present in old GT::SQL versions is still supported under MySQL and Oracle, but
any new development should avoid them. If you really need to store binary
data, it is strongly recommended that you use files, and simply store
fileI<names> in the database.
=item TIMESTAMP
This extremely odd MySQL data type, depending on the version of MySQL, stores
times in either the format described in C<DATETIME> (MySQL 4.1+) or an
extremely MySQL-specific C<YYYYMMDDhhmmss> format. Another MySQL-specific of
this data type is that the first - and ONLY the first - C<TIMESTAMP> column in
a row will be automatically updated to the current local timezone-dependent
date and time. Use a C<DATETIME> (possibly with the C<time_check> option)
instead.
=item TIME
A MySQL and Postgres-specific type that stores only the time-of-day in
C<HH:MM:SS> format. Deprecated due to non-portability and incompatibility on
other databases. If you really want to store just the time of day, either use
an C<INT> to store the minutes or seconds since midnight, or use a C<CHAR>
which you update with the C<HH:MM:SS> value. Causes a fatal error on databases
which don't have an appropriate native type.
=item YEAR
A particularly useless MySQL-specific data type that stores only the year
portion of a date. Use a C<SMALLINT> instead. Causes a fatal error on
anything other than MySQL.
=back
=head1 SEE ALSO
L<GT::SQL>
L<GT::SQL::Creator>
=head1 MAINTAINER
Jason Rhinelander
=head1 COPYRIGHT
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
http://www.gossamer-threads.com/
=head1 VERSION
Revision: $Id: Types.pm,v 1.2 2004/09/07 20:56:59 jagerman Exp $
=cut

276
site/glist/lib/GT/SQL/Upgrade.pm Normal file
View File

@ -0,0 +1,276 @@
# ====================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Upgrade
# Author: Jason Rhinelander
# CVS Info :
# $Id: Upgrade.pm,v 1.3 2005/04/14 00:59:12 brewt Exp $
#
# Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved.
# ====================================================================
#
# Description:
# Various commonly used SQL upgrade functions used by GT product upgrades.
#
package GT::SQL::Upgrade;
use strict;
use vars qw/@ISA @EXPORT $VERSION/;
require Exporter;
# You *must* bump this each time you change or fix any of the code this file or
# it is guaranteed to cause problems:
$VERSION = 1.00;
@ISA = 'Exporter';
@EXPORT = qw/add_column alter_column drop_column add_index drop_index add_table recreate_table/;
# Adds a column. Takes 5 args:
# Output coderef, database object, table name, column name, column definition
# Returns the return of $editor->add_col
sub add_column {
my ($out, $db, $table, $col, $def) = @_;
$out->("Adding column $col to $table table...\n");
my $ret = $db->editor($table)->add_col($col => $def);
$out->($ret ? "\tOkay!\n" : "\tCould not add column $col: $GT::SQL::error\n");
$ret;
}
# Changes a column. Takes 5 args:
# Output coderef, database obj, table name, column name, new column definition
sub alter_column {
my ($out, $db, $table, $col, $def) = @_;
$out->("Updating column definition for $col in $table table...\n");
my $ret = $db->editor($table)->alter_col($col, $def);
$out->($ret ? "\tOkay!\n" : "\tCould not alter column $col: $GT::SQL::error\n");
$ret;
}
# Drops a column. Takes 4 args:
# Output coderef, database object, table name, column name
# Returns the return of $editor->drop_col
sub drop_column {
my ($out, $db, $table, $col) = @_;
$out->("Dropping column '$col' from table '$table'...\n");
my $ret = $db->editor($table)->drop_col($col);
$out->($ret ? "\tOkay!\n" : "\tCould not drop column $col: $GT::SQL::error\n");
$ret;
}
# Adds indexes. Takes 4-5 args
# Output coderef, database object, table name, indexes hash reference, and an
# optional boolean value to make the added indexes unique indexes.
# Returns the return of $editor->add_index
sub add_index {
my ($out, $db, $table, $indexes, $unique) = @_;
my $editor = $db->editor($table);
my $cret = 1;
while (my ($idx, $defn) = each %$indexes) {
my ($meth, $index_display) = $unique ? (add_unique => 'unique index') : (add_index => 'index');
$out->("Adding $index_display '$idx' to '$table' table...\n");
my $ret = $editor->$meth($idx => $indexes->{$idx});
$out->($ret ? "\tOkay!\n" : "\tCould not add $index_display '$idx': $GT::SQL::error\n");
$cret = $ret unless $ret;
}
$cret;
}
# Drops an index. Takes 4-5 args:
# Output coderef, GT::SQL obj, table name, index name, plus an optional boolean
# value to indicate that the index to drop is a unique index.
sub drop_index {
my ($out, $db, $table, $index, $unique) = @_;
$out->("Dropping index '$index' from '$table' table...\n");
my $editor = $db->editor($table);
my $meth = $unique ? 'drop_unique' : 'drop_index';
my $ret = $editor->$meth($index);
$out->($ret ? "\tOkay!\n" : "\tCould not drop index '$index': $GT::SQL::error\n");
$ret;
}
# Adds a table. Takes 3 base, plus unlimited extra arguments:
# Output coderef, GT::SQL obj, table name
# Other arguments are read in pairs - the first is a ::Creator method name, the
# second is the value to pass to the method.
sub add_table {
my ($out, $db, $table) = splice @_, 0, 3;
$out->("Adding table '$table'...\n");
my $c = $db->creator($table);
while (@_) {
my ($meth, $arg) = splice @_, 0, 2;
$c->$meth($arg);
}
my $ret = $c->create;
if ($ret) {
$out->("\tOkay!\n");
}
else {
$out->("\tAn error occured: $GT::SQL::error\n");
$c->set_defaults;
$c->save_schema;
}
$ret;
}
# Used when recreating a table is necessary (used in at least the Links SQL
# 2.1.2 -> 2.2.0 upgrade) It creates a temporary table, copies all the data
# into it, then drops the original table, recreates it, and copies all the data
# back.
# Usage:
# recreate_table($out, $db, $table_name, $condition, ...ARGS...);
# - $out is the code reference to call with output
# - $db is the GT::SQL object for the database
# - $table_name is the name of the table to recreated
# - $condition is a code reference - it will be called with the table as an
# argument. If it returns true, the table is recreated, otherwise (if it
# returns false) recreating the table is skipped.
# - Remaining arguments are specified in pairs - the first of each pair of
# arguments is the function to call, the second is the argument to pass to
# that function. At least a "cols => [ ... ]" pair must be specified.
# Known problems:
# - The code that copies any custom columns breaks if any columns have been
# removed from the new table has fewer columns from the old one - those
# columns will be copied to the new table.
# - A change adding not_null to a column will only work for INT's/FLOAT's,
# for which any previous null values are given a value of 0.
sub recreate_table {
my ($out, $db, $table_name, $condition) = splice @_, 0, 4;
@_ % 2 == 0 or die "Invalid arguments. Usage: recreate_table(INSTALLER_OBJ, GTSQL_OBJ, 'Table', method => val, method => val, ...)";
my @args = @_;
my %args = @args;
my @cols = $args{cols};
my %cols = @cols;
my $table = $db->table($table_name);
my $success;
if ($condition->($table)) {
RECREATE: {
$out->("Performing required $table_name table recreation...\n");
$out->("\t- Creating temporary storage table...\n");
my @create;
my %old_cols = $table->cols;
my %new_cols = @{$args{cols}};
my ($count, @denull) = 0;
for (keys %old_cols) {
if (
!$old_cols{$_}->{not_null} and # Didn't have not_null before
$new_cols{$_} and # Still exists in the new version of the table
$new_cols{$_}->{not_null} and # not_null present in the new version
$new_cols{$_}->{type} =~ /^(?:FLOAT|DOUBLE|DECIMAL|\w*INT)$/ # is a numeric type
) {
push @denull, $count;
}
$count++;
}
# Retain any custom columns:
for (keys %old_cols) {
unless ($cols{$_}) {
push @create, $_ => $old_cols{$_};
push @cols, $_ => $old_cols{$_};
$cols{$_} = $old_cols{$_};
}
}
my $c = $db->creator($table_name . '_tmp');
$c->cols(@create);
# We should probably 'force' the following create, but that is
# potentially dangerous if the main table isn't recreated properly.
my $ret = $c->create;
if ($ret) {
$out->("\t\tOkay!\n");
}
else {
$out->("\t\tAn error occured: $GT::SQL::error\n");
last RECREATE;
}
my $tmp_table = $db->table($table_name . '_tmp');
$out->("\t- Copying existing data to temporary table...\n");
my $sth = $table->select(keys %old_cols);
my @recs;
while () {
my $row = $sth->fetchrow_arrayref;
if ($row) {
my @row = @$row;
for (@denull) {
$row[$_] = 0 if not defined $row[$_];
}
push @recs, \@row;
}
if (!$row or @recs >= 1000) {
$ret = $tmp_table->insert_multiple([keys %old_cols], @recs) if @recs;
$out->("\t\tAn error occured: $GT::SQL::error\n") unless $ret;
@recs = ();
last if !$row;
}
}
$out->("\t\tOkay!\n");
$out->("\t- Dropping $table_name table...\n");
$ret = $db->editor($table_name)->drop_table;
if ($ret) {
$out->("\t\tOkay!\n");
}
else {
$out->("\t\tAn error occured: $GT::SQL::error\n");
}
$out->("\t- Creating new $table_name table...\n");
$c = $db->creator($table_name);
while (@args) {
my ($method, $value) = (shift @args, shift @args);
$c->$method($value);
}
$ret = $c->create('force');
if ($ret) {
$out->("\t\tOkay!\n");
}
else {
$out->("\t\tAn error occured: $GT::SQL::error\n");
last RECREATE;
}
$out->("\t- Copying temporary data back into new table...\n");
$sth = $tmp_table->select(keys %old_cols);
@recs = ();
while () {
my $row = $sth->fetchrow_arrayref;
push @recs, [@$row] if $row;
if (!$row or @recs >= 1000) {
$ret = $table->insert_multiple([keys %old_cols], @recs) if @recs;
$out->("\t\tAn error occured: $GT::SQL::error\n") unless $ret;
@recs = ();
last if !$row;
}
}
$out->("\t\tOkay!\n");
$out->("\t- Dropping ${table_name}_tmp table...\n");
$ret = $db->editor("${table_name}_tmp")->drop_table;
if ($ret) {
$out->("\t\tOkay!\n");
}
else {
$out->("\t\tAn error occured: $GT::SQL::error\n");
}
$success = 1;
}
if (!$success) {
$out->("\tAn error occured while attempting to recreate $table_name. Procedure aborted.\n");
}
}
}
1;