First pass at adding key files
This commit is contained in:
dsainty
2994
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Admin.pm
Normal file
2994
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Admin.pm
Normal file
File diff suppressed because it is too large
Load Diff
607
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Base.pm
Normal file
607
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Base.pm
Normal file
@@ -0,0 +1,607 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Table
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Base.pm,v 1.72 2011/05/13 23:56:51 brewt 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.72 $ =~ /(\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} and $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} and $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} and $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 "")) {
|
||||
push @ins, [$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 %{$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/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Condition.pm
Normal file
404
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Condition.pm
Normal file
@@ -0,0 +1,404 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Base
|
||||
# Author: Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Condition.pm,v 1.45 2006/02/16 20:26:14 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.45 $ =~ /(\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 $_[-1] and (uc $_[-1] eq 'AND' or uc $_[-1] eq 'OR' or $_[-1] 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.45 2006/02/16 20:26:14 jagerman Exp $
|
||||
|
||||
=cut
|
||||
1216
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Creator.pm
Normal file
1216
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Creator.pm
Normal file
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,893 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Display::HTML
|
||||
# Author: Scott & Alex
|
||||
# $Id: HTML.pm,v 1.98 2009/03/23 22:55:53 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# HTML module that provides a set of method to control your
|
||||
# user display in order to get rid of HTML coding inside CGI script.
|
||||
#
|
||||
|
||||
package GT::SQL::Display::HTML;
|
||||
# ===============================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $AUTOLOAD $VERSION $ERROR_MESSAGE $ATTRIBS $DEBUG $FONT %SIZE_FORMS $INPUT_SEPARATOR/;
|
||||
use GT::Base;
|
||||
|
||||
@ISA = qw/GT::Base/;
|
||||
$FONT = 'face="Tahoma,Arial,Helvetica" size="2"';
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.98 $ =~ /(\d+)\.(\d+)/;
|
||||
$DEBUG = 0;
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
$INPUT_SEPARATOR = "\n";
|
||||
|
||||
$ATTRIBS = {
|
||||
db => undef,
|
||||
input => undef,
|
||||
mode => '',
|
||||
code => {},
|
||||
font => $FONT,
|
||||
hide_timestamp => 0,
|
||||
hide_download => 0,
|
||||
file_field => 0,
|
||||
file_delete => 0,
|
||||
file_use_path => 0,
|
||||
view_key => 0,
|
||||
defaults => 0,
|
||||
search_opts => 0,
|
||||
values => {},
|
||||
multiple => 0,
|
||||
table => 'border="0" width="500"',
|
||||
tr => '',
|
||||
td => 'valign="top" align="left"',
|
||||
extra_table => 1,
|
||||
col_font => $FONT,
|
||||
val_font => $FONT,
|
||||
hide => [],
|
||||
skip => [],
|
||||
view => [],
|
||||
disp_form => 1,
|
||||
disp_html => 0,
|
||||
url => $ENV{REQUEST_URI},
|
||||
};
|
||||
|
||||
sub init {
|
||||
# ---------------------------------------------------------------
|
||||
# new() comes from GT::Base.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# Set any passed in options.
|
||||
$self->set (@_);
|
||||
|
||||
# Try to set the URL
|
||||
$self->{url} or eval { require GT::CGI; $self->{url} = GT::CGI->url(); };
|
||||
$self->{url} ||= '';
|
||||
|
||||
# Make sure we have a database object.
|
||||
# exists ($self->{db}) and (ref $self->{db}) or return $self->error ("BADARGS", "FATAL", "You must pass in a GT::SQL::Table object");
|
||||
|
||||
my $input = ref $self->{input};
|
||||
if ($input and ($input eq 'GT::CGI')) {
|
||||
$self->{input} = $self->{input}->get_hash;
|
||||
}
|
||||
elsif ($input and ($input eq 'CGI')) {
|
||||
my $h = {};
|
||||
foreach my $key ($self->{input}->param) {
|
||||
$h->{$key} = $self->{input}->param($key);
|
||||
}
|
||||
$self->{input} = $h;
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub reset_opts {
|
||||
# ---------------------------------------------------------------
|
||||
# Resets the display options.
|
||||
#
|
||||
my $self = shift;
|
||||
while (my ($k, $v) = each %$ATTRIBS) {
|
||||
next if $k eq 'db';
|
||||
next if $k eq 'disp_form';
|
||||
next if $k eq 'disp_html';
|
||||
next if $k eq 'input';
|
||||
if (! ref $v) {
|
||||
$self->{$k} = $v;
|
||||
}
|
||||
elsif (ref $v eq 'HASH') {
|
||||
$self->{$k} = {};
|
||||
foreach my $k1 (keys %{$ATTRIBS->{$k}}) { $self->{$k}->{$k1} = $ATTRIBS->{$k}->{$k1}; }
|
||||
}
|
||||
elsif (ref $v eq 'ARRAY') {
|
||||
$self->{$k} = [];
|
||||
foreach my $v1 (@{$ATTRIBS->{$k}}) { push @{$self->{$k}}, $v1; }
|
||||
}
|
||||
else { $self->{$k} = $v; }
|
||||
}
|
||||
}
|
||||
|
||||
sub form {
|
||||
# ---------------------------------------------------------------
|
||||
# Display a record as an html form.
|
||||
#
|
||||
my $self = shift;
|
||||
$_[0]->{disp_form} = 1;
|
||||
$_[0]->{disp_html} = 0;
|
||||
return $self->_display (@_);
|
||||
}
|
||||
|
||||
sub display {
|
||||
# ---------------------------------------------------------------
|
||||
# Display a record as html.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->error ("NEEDSUBCLASS", "FATAL")
|
||||
}
|
||||
|
||||
sub _get_defaults {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns default values for fields. Bases it on what's passed in,
|
||||
# cgi input, def file defaults, otherwise blank.
|
||||
#
|
||||
my $self = shift;
|
||||
my @cols = $self->{db}->ordered_columns;
|
||||
my $c = $self->{cols} || $self->{db}->cols;
|
||||
my $values = {};
|
||||
foreach my $col (@cols) {
|
||||
my $value = '';
|
||||
if (exists $self->{values}->{$col}) { $value = $self->{values}->{$col} }
|
||||
elsif (exists $self->{input}->{$col}) { $value = $self->{input}->{$col} }
|
||||
elsif ($self->{defaults} and exists $c->{$col}->{default}) {
|
||||
if ($c->{$col}->{type} =~ /DATE|TIME|YEAR/) {
|
||||
($c->{$col}->{default} =~ /0000/)
|
||||
? ($value = $self->_get_time($c->{$col}))
|
||||
: ($value = $c->{$col}->{default});
|
||||
}
|
||||
else {
|
||||
$value = $c->{$col}->{default};
|
||||
}
|
||||
}
|
||||
elsif ($self->{defaults} and $c->{$col}->{type} =~ /DATE|TIME|YEAR/) {
|
||||
$value = $self->_get_time($c->{$col});
|
||||
}
|
||||
if ($c->{$col}->{form_type} and uc $c->{$col}->{form_type} eq 'FILE' ) {
|
||||
for (qw/_filename _del/) {
|
||||
$values->{$col.$_} = $self->{values}->{$col.$_} if exists $self->{values}->{$col.$_};
|
||||
}
|
||||
}
|
||||
$values->{$col} = $value;
|
||||
}
|
||||
return $values;
|
||||
}
|
||||
|
||||
sub _skip {
|
||||
# -------------------------------------------------------------------
|
||||
my ($self, $col) = @_;
|
||||
|
||||
# Skip timestamps, any fields requested to be skipped or any hidden fields (hidden forms appended at bottom).
|
||||
return 1 if ($self->{hide_timestamp} and $self->{cols}->{$col}->{time_check});
|
||||
return 1 if ($self->{skip} and (grep /^$col$/, @{$self->{skip}}));
|
||||
return 1 if ($self->{hide} and (grep /^$col$/, @{$self->{hide}}));
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub _get_form_display {
|
||||
my ($self, $col) = @_;
|
||||
|
||||
if (
|
||||
($self->{view_key} and
|
||||
exists $self->{cols}->{$col}->{time_check} and
|
||||
$self->{cols}->{$col}->{time_check})
|
||||
||
|
||||
($self->{view} and (grep /^$col$/, @{$self->{view}}))
|
||||
)
|
||||
{
|
||||
return 'hidden_text';
|
||||
}
|
||||
|
||||
my $form_type = lc $self->{cols}->{$col}->{form_type} or return 'default';
|
||||
|
||||
if ( $form_type eq 'password' and index( $self->{mode}, 'search_form' ) + 1 ) {
|
||||
return 'default'
|
||||
}
|
||||
|
||||
elsif ( $form_type and $self->can( $form_type ) ) {
|
||||
return $form_type;
|
||||
}
|
||||
|
||||
return 'default';
|
||||
}
|
||||
|
||||
sub _get_html_display {
|
||||
my $self = shift;
|
||||
my $col = shift;
|
||||
return 'display_text';
|
||||
}
|
||||
|
||||
# Form types
|
||||
sub default {
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to form creator _mk_char_form");
|
||||
my $def = exists $opts->{def} ? $opts->{def} : return $self->error ("BADARGS", "FATAL", "No type hash passed to form creator _mk_char_form");
|
||||
my $val = exists $opts->{value} ? $opts->{value} : (exists $def->{default} ? $def->{default} : '');
|
||||
my $size = exists $opts->{form_size} ? $opts->{form_size} : (exists $def->{form_size} ? ($def->{form_size} || 30) : 30);
|
||||
my $max = exists $opts->{size} ? $opts->{def}->{size} : (exists $def->{size} ? $def->{size} : 255);
|
||||
|
||||
defined ($val) or $val = '';
|
||||
_escape(\$val);
|
||||
return qq~<input type="text" name="$name" value="$val" maxlength="$max" size="$size" />~;
|
||||
}
|
||||
|
||||
sub date {
|
||||
my ($self, $opts) = @_;
|
||||
$opts->{form_size} ||= 20;
|
||||
return $self->text ($opts);
|
||||
}
|
||||
|
||||
sub multiple { shift->select (@_) }
|
||||
|
||||
sub select {
|
||||
# ---------------------------------------------------------------
|
||||
# Make a select list. Valid options are:
|
||||
# name => FORM_NAME
|
||||
# values => { form_value => displayed_value }
|
||||
# value => selected_value
|
||||
# or
|
||||
# value => [selected_value1, selected_value2]
|
||||
# multiple => n - adds MULTIPLE SIZE=n to select list
|
||||
# sort => coderef called to sort the list or array ref specifying the order in
|
||||
# which the fields should be display. A code ref, when called, will be
|
||||
# passed the following arguments: ($value{$a}, $value{$b}, $a, $b)
|
||||
# blank => 1 or 0. If true, a blank first option will be printed, if false
|
||||
# the blank first element will not be printed. Defaults to true.
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS1", "FATAL", "No form name passed to select");
|
||||
my ($names, $values) = $self->_get_multi ($opts);
|
||||
|
||||
# Get the default value to display if nothing is selected.
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
else { $def = '' }
|
||||
|
||||
my %hash;
|
||||
# Build key value pairs we can keep sorted
|
||||
for (0 .. $#{$names}) {
|
||||
$hash{$names->[$_]} = $values->[$_];
|
||||
}
|
||||
|
||||
my ($sort_f, $sort_o);
|
||||
if (ref $opts->{sort} eq 'CODE') {
|
||||
$sort_f = $opts->{sort};
|
||||
}
|
||||
elsif (ref $opts->{sort} eq 'ARRAY') {
|
||||
$sort_o = $opts->{sort};
|
||||
}
|
||||
# sort_order => [...] has been replaced with sort => [...] and so it
|
||||
# is NOT mentioned in the subroutine comments.
|
||||
elsif (ref $opts->{sort_order} eq 'ARRAY') {
|
||||
$sort_o = $opts->{sort_order};
|
||||
}
|
||||
my $blank = exists $opts->{blank} ? $opts->{blank} : 1;
|
||||
|
||||
# Multiple was passed in
|
||||
my $mult;
|
||||
my $clean_name = $name;
|
||||
if ($name =~ /^\d\-(.+)$/) {
|
||||
$clean_name = $1;
|
||||
}
|
||||
if (exists $self->{cols}->{$clean_name} and $self->{cols}->{$clean_name}->{form_type} and $self->{cols}->{$clean_name}->{form_type} eq 'MULTIPLE') {
|
||||
$mult = qq! multiple="multiple" size="$self->{cols}->{$clean_name}->{form_size}"!;
|
||||
}
|
||||
elsif (exists $opts->{multiple} and $opts->{multiple} > 1) {
|
||||
$mult = qq! multiple="multiple" size="$opts->{multiple}"!;
|
||||
}
|
||||
elsif (exists $self->{cols}->{$clean_name} and $self->{cols}->{$clean_name}->{form_size}) {
|
||||
$mult = qq! size="$self->{cols}->{$clean_name}->{form_size}"!;
|
||||
}
|
||||
else {
|
||||
$mult = '';
|
||||
}
|
||||
my $class = ($opts->{def}->{class}) ? qq| class="$opts->{def}->{class}"| : "";
|
||||
my $out = qq~<select$mult name="$name"$class>~;
|
||||
$blank and ($out .= qq~<option value="">---</option>~);
|
||||
|
||||
# Figure out how to order this select list.
|
||||
my @keys;
|
||||
if ($sort_o) { @keys = @$sort_o }
|
||||
elsif ($sort_f) { @keys = sort { $sort_f->($hash{$a}, $hash{$b}, $a, $b) } keys %hash }
|
||||
else { @keys = @$names; }
|
||||
|
||||
if (! ref $def) {
|
||||
$def = { map { ($_ => 1) } split (/\Q$INPUT_SEPARATOR\E%?/o, $def) };
|
||||
}
|
||||
else { # Array ref
|
||||
$def = { map { ($_ => 1) } @$def };
|
||||
}
|
||||
for my $key (@keys) {
|
||||
my $val = $hash{$key};
|
||||
_escape(\$val);
|
||||
$out .= qq~<option value="$key"~;
|
||||
$out .= ' selected="selected"' if $def->{$key};
|
||||
$out .= ">$val</option>";
|
||||
}
|
||||
$out .= "</select>\n";
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub radio {
|
||||
# ---------------------------------------------------------------
|
||||
# Create a radio series.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No name for field passed to radio");
|
||||
my ($names, $values) = $self->_get_multi ($opts);
|
||||
|
||||
# Make sure we have something.
|
||||
if (! @{$names} or ! @{$values}) {
|
||||
return $self->error ("BADARGS", "FATAL", "No value hash passed to checkbox");
|
||||
}
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
else { $def = '' }
|
||||
|
||||
my %hash;
|
||||
# Build key value pairs we can keep sorted
|
||||
for (0 .. $#{$names}) {
|
||||
$hash{$names->[$_]} = $values->[$_];
|
||||
}
|
||||
|
||||
my $sort_f = exists $opts->{sort} ? $opts->{sort} : sub { lc $hash{$a} cmp lc $hash{$b} };
|
||||
my $sort_o = exists $opts->{sort_order} ? $opts->{sort_order} : '';
|
||||
my $out;
|
||||
|
||||
# Figure out how to order this select list.
|
||||
my @keys;
|
||||
if ($sort_o) { @keys = @$sort_o; }
|
||||
elsif ($sort_f) { @keys = sort { $sort_f->() } keys %hash; }
|
||||
else { @keys = keys %hash; }
|
||||
|
||||
(ref $def eq 'ARRAY') or ($def = [$def]);
|
||||
|
||||
my $class = ($opts->{def}->{class}) ? qq| class="$opts->{def}->{class}"| : "";
|
||||
KEY: foreach my $key (@keys) {
|
||||
my $val = $hash{$key};
|
||||
_escape(\$val);
|
||||
VAL: foreach my $sel (@$def) {
|
||||
($key eq $sel) and ($out .= qq~$val<input type="radio" value="$key"$class name="$name" checked="checked" /> ~) and next KEY;
|
||||
}
|
||||
$out .= qq~$val<input name="$name" type="radio" value="$key"$class /> ~;
|
||||
}
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub checkbox {
|
||||
# ---------------------------------------------------------------
|
||||
# Create a checkbox set.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to select");
|
||||
my ($names, $values) = $self->_get_multi ($opts);
|
||||
|
||||
# Make sure we have something.
|
||||
if (! @{$names} or ! @{$values}) {
|
||||
return $self->error ("BADARGS", "FATAL", "No value hash passed to checkbox");
|
||||
}
|
||||
my %hash;
|
||||
# Build key value pairs we can keep sorted
|
||||
for (0 .. $#{$names}) {
|
||||
$hash{$names->[$_]} = $values->[$_];
|
||||
}
|
||||
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
else { $def = '' }
|
||||
my $sort_f = exists $opts->{sort} ? $opts->{sort} : sub { lc $hash{$a} cmp lc $hash{$b} };
|
||||
my $sort_o = exists $opts->{sort_order} ? $opts->{sort_order} : '';
|
||||
my $out;
|
||||
|
||||
# Figure out how to order this select list.
|
||||
my @keys;
|
||||
if ($sort_o) { @keys = @$sort_o; }
|
||||
elsif ($sort_f) { @keys = sort { $sort_f->() } keys %hash }
|
||||
else { @keys = keys %hash }
|
||||
|
||||
if (! ref $def) {
|
||||
$def = [sort split (/\Q$INPUT_SEPARATOR\E%?/o, $def)];
|
||||
}
|
||||
my $class = ($opts->{def}->{class}) ? qq| class="$opts->{def}->{class}"| : "";
|
||||
KEY: foreach my $key (@keys) {
|
||||
my $val = $hash{$key};
|
||||
_escape(\$val);
|
||||
VAL: foreach my $sel (@$def) {
|
||||
($key eq $sel) and ($out .= qq~ <input name="$name" type="checkbox" value="$key" checked="checked"$class />$val~) and next KEY;
|
||||
}
|
||||
$out .= qq~ <input name="$name" type="checkbox" value="$key"$class />$val~;
|
||||
}
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub hidden {
|
||||
# ---------------------------------------------------------------
|
||||
# Create a hidden field.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to select");
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
else { $def = '' }
|
||||
_escape(\$def);
|
||||
return qq~<input type="hidden" name="$name" value="$def" />~;
|
||||
}
|
||||
|
||||
sub hidden_text {
|
||||
my ($self, $opts) = @_;
|
||||
my $out;
|
||||
my $html = $self->_get_html_display;
|
||||
$out .= "<font $self->{val_font}>";
|
||||
$out .= $self->$html($opts);
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
elsif (exists $opts->{def}->{time_check}) { $def = $self->_get_time ($opts->{def}) }
|
||||
else { $def = '' }
|
||||
_escape(\$def);
|
||||
$out .= qq~<input type="hidden" name="$opts->{name}" value="$def" /></font>~;
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub file {
|
||||
# ---------------------------------------------------------------
|
||||
# creates a file field
|
||||
#
|
||||
# function is a bit large since it has to do a fair bit, with multiple options.
|
||||
#
|
||||
my ($self, $opts, $values, $display ) = @_;
|
||||
|
||||
$values ||= {};
|
||||
$self->{file_field} or return $self->text($opts);
|
||||
|
||||
my @parts = split /\./, $opts->{name};
|
||||
my $name = pop @parts;
|
||||
my $dbname = shift @parts || $self->{db}->name;
|
||||
my $prefix = $self->{db}->prefix;
|
||||
$dbname =~ s,^$prefix,, if ($prefix);
|
||||
|
||||
my $def = $opts->{def};
|
||||
my $out;
|
||||
my $colname = $opts->{name}; $colname =~ s,^\d*-,,;
|
||||
my $fname = $opts->{value};
|
||||
_escape(\$fname);
|
||||
|
||||
# Find out if the file exists
|
||||
my $tbl = $display->{db}->new_table( $dbname . "_Files" ) or return 'Associated _File table is missing';
|
||||
my @pk = $self->{db}->pk; @pk == 1 or return 'File handling requires one primary key';
|
||||
|
||||
my $href = $tbl->get({ ForeignColName => $colname, ForeignColKey => $values->{$pk[0]} });
|
||||
|
||||
my $use_path = $self->{file_use_path} && -e $opts->{value};
|
||||
if ($use_path or $href) {
|
||||
|
||||
require GT::SQL::File;
|
||||
my $sfname = $values->{$colname."_filename"};
|
||||
$out = $sfname || GT::SQL::File->get_filename($fname ||= $href->{File_Name});
|
||||
$use_path and $out .= qq!<input name="$opts->{name}_path" type="hidden" value="$fname" />!;
|
||||
$sfname and $out .= qq!<input type="hidden" name="$opts->{name}_filename" value="$sfname" />!;
|
||||
|
||||
if ( $fname and $self->{file_delete} ) {
|
||||
|
||||
if ( $def->{form_type} =~ /^file$/i and not $self->{hide_downloads} and $self->{url} ) {
|
||||
my $url = _reparam_url(
|
||||
$self->{url},
|
||||
{
|
||||
do => 'download_file',
|
||||
id => $values->{$pk[0]},
|
||||
cn => $colname,
|
||||
db => $dbname,
|
||||
src => $use_path ? 'path' : 'db',
|
||||
fname => $fname
|
||||
},
|
||||
[qw( do id cn db src )]
|
||||
);
|
||||
$out .= qq! <font $self->{font}><font size="1"><i><a href="$url">download</a></i></font></font>!;
|
||||
$url = _reparam_url(
|
||||
$self->{url},
|
||||
{
|
||||
do => 'view_file',
|
||||
id => $values->{$pk[0]},
|
||||
cn => $colname,
|
||||
db => $dbname,
|
||||
src => $use_path ? 'path' : 'db',
|
||||
fname => $fname
|
||||
},
|
||||
[qw( do id cn db src )]
|
||||
);
|
||||
$out .= qq! <font $self->{font}><font size="1"><i><a href="$url" target="_blank">view</a></i></font></font>!;
|
||||
}
|
||||
my $checked = $values->{"${colname}_del"} ? ' checked="checked" ' : '';
|
||||
$out .= qq~ <input type="checkbox" name="$opts->{name}_del" value="delete"$checked /> Delete~;
|
||||
}
|
||||
}
|
||||
my $class = ($opts->{def}->{class}) ? qq| class="$opts->{def}->{class}"| : "";
|
||||
$out .= qq~<input type="file" name="$opts->{name}"$class />~;
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub text {
|
||||
# ---------------------------------------------------------------
|
||||
# Create a text field.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to select");
|
||||
my $size = $opts->{def}->{form_size} ? $opts->{def}->{form_size} : $SIZE_FORMS{uc $opts->{def}->{type}};
|
||||
$size ||= 20;
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
else { $def = '' }
|
||||
_escape(\$def);
|
||||
my $class = ($opts->{def}->{class}) ? qq| class="$opts->{def}->{class}"| : "";
|
||||
return qq~<input type="text" name="$name" value="$def" size="$size"$class />~;
|
||||
}
|
||||
|
||||
sub password {
|
||||
# ---------------------------------------------------------------
|
||||
# Create a password field.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to select");
|
||||
my $size = $opts->{def}->{form_size} ? $opts->{def}->{form_size} : $SIZE_FORMS{uc $opts->{def}->{type}};
|
||||
$size ||= 20;
|
||||
my $def;
|
||||
if ( $opts->{blank} ) { $def = '' } # keep the password element blank
|
||||
elsif (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
else { $def = '' }
|
||||
_escape(\$def);
|
||||
my $class = ($opts->{def}->{class}) ? qq| class="$opts->{def}->{class}"| : "";
|
||||
return qq~<input type="password" name="$name" value="$def" size="$size"$class />~;
|
||||
}
|
||||
|
||||
sub textarea {
|
||||
# ---------------------------------------------------------------
|
||||
# Create a textarea.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to select");
|
||||
my $size = $opts->{def}->{form_size} ? $opts->{def}->{form_size} : $SIZE_FORMS{uc $opts->{def}->{type}};
|
||||
$size ||= 20;
|
||||
my ($cols, $rows) = (ref $size) ? (@{$size}) : ($size, 4);
|
||||
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
else { $def = '' }
|
||||
_escape(\$def);
|
||||
my $class = ($opts->{def}->{class}) ? qq| class="$opts->{def}->{class}"| : "";
|
||||
return qq~<textarea rows="$rows" cols="$cols" name="$name"$class>\n$def</textarea>~;
|
||||
}
|
||||
|
||||
sub display_text {
|
||||
# ---------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $opts = shift or return $self->error ("BADARGS", "FATAL", "No hash ref passed to form creator display_text");
|
||||
my $values = shift;
|
||||
my $def = exists $opts->{def} ? $opts->{def} : return $self->error ("BADARGS", "FATAL", "No type hash passed to view creator display_text (" . (caller())[2] . ")" );
|
||||
my $val = exists $opts->{value} ? $opts->{value} : (exists $def->{default} ? $def->{default} : '');
|
||||
my $pval = $val;
|
||||
defined $val or ($val = '');
|
||||
_escape(\$val);
|
||||
|
||||
# If they are using checkbox/radio/selects then we map form_names => form_values.
|
||||
if (ref $def->{form_names} and ref $def->{form_values}) {
|
||||
if (@{$def->{form_names}} and @{$def->{form_values}}) {
|
||||
my %map = map { $def->{form_names}->[$_] => $def->{form_values}->[$_] } (0 .. $#{$def->{form_names}});
|
||||
my @keys = split /\Q$INPUT_SEPARATOR\E|\n/, $val;
|
||||
$val = '';
|
||||
|
||||
foreach (@keys) {
|
||||
$val .= $map{$_} ? $map{$_} : $_;
|
||||
$val .= "<br />";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if ($def->{form_type} and uc $def->{form_type} eq 'FILE' and not $self->{hide_downloads} and $self->{url}) {
|
||||
$pval or return $val;
|
||||
|
||||
my @parts = split /\./, $opts->{name};
|
||||
my $name = pop @parts;
|
||||
my $dbname = shift @parts || $self->{db}->name;
|
||||
my $prefix = $self->{db}->prefix;
|
||||
$dbname =~ s,^$prefix,, if ($prefix);
|
||||
my $colname = $opts->{name}; $colname =~ s,^$dbname\.,,g;
|
||||
|
||||
my @pk = $self->{db}->pk; @pk == 1 or return;
|
||||
my $url = _reparam_url( $self->{url}, { do => 'download_file', id => $values->{$pk[0]}, cn => $colname, db => $dbname }, [qw( do id cn db )] );
|
||||
$val .= qq! <font $self->{font}><font size="1"><i><a href="$url">download</a></i></font></font>!;
|
||||
|
||||
$url = _reparam_url( $self->{url}, { do => 'view_file', id => $values->{$pk[0]}, cn => $colname, db => $dbname }, [qw( do id cn db )] );
|
||||
$val .= qq! <font $self->{font}><font size="1"><i><a href="$url" target="_blank">view</a></i></font></font>!;
|
||||
}
|
||||
|
||||
return $val;
|
||||
}
|
||||
|
||||
sub _reparam_url {
|
||||
# ---------------------------------------------------------------
|
||||
my $orig_url = shift;
|
||||
my $add = shift || {};
|
||||
my $remove = shift || [];
|
||||
my %params = ();
|
||||
my $new_url = $orig_url;
|
||||
|
||||
# get the original parameters
|
||||
my $qloc = index( $orig_url, '?');
|
||||
if ( $qloc > 0 ) {
|
||||
require GT::CGI;
|
||||
$new_url = substr( $orig_url, 0, $qloc );
|
||||
my $base_parms = substr( $orig_url, $qloc+1 );
|
||||
$base_parms = GT::CGI::unescape($base_parms);
|
||||
|
||||
# now parse the parameters
|
||||
foreach my $param ( grep $_, split /[&;]/, $base_parms ) {
|
||||
my $eloc = index( $param, '=' );
|
||||
$eloc < 0 and push( @{$params{$param} ||= []}, undef ), next;
|
||||
my $key = substr( $param, 0, $eloc );
|
||||
my $value = substr( $param, $eloc+1 );
|
||||
push( @{$params{$key} ||= []}, $value);
|
||||
}
|
||||
}
|
||||
|
||||
# delete a few parameters
|
||||
foreach my $param ( @$remove ) { delete $params{$param}; }
|
||||
|
||||
# add a few parameters
|
||||
foreach my $key ( keys %$add ) {
|
||||
push( @{$params{$key} ||= []}, $add->{$key});
|
||||
}
|
||||
|
||||
# put everything together
|
||||
require GT::CGI;
|
||||
my @params;
|
||||
foreach my $key ( keys %params ) {
|
||||
foreach my $value ( @{$params{$key}} ) {
|
||||
push @params, GT::CGI::escape($key).'='.GT::CGI::escape($value);
|
||||
}
|
||||
}
|
||||
$new_url .= "?" . join( '&', @params );
|
||||
return $new_url;
|
||||
}
|
||||
|
||||
sub toolbar {
|
||||
# ---------------------------------------------------------------
|
||||
# Display/calculate a "next hits" toolbar.
|
||||
#
|
||||
my $class = shift;
|
||||
my ($nh, $maxhits, $numhits, $script) = @_;
|
||||
my ($next_url, $max_page, $next_hit, $prev_hit, $left, $right, $upper, $lower, $first, $url, $last, $i);
|
||||
|
||||
# Return if there shouldn't be a speedbar.
|
||||
return unless ($numhits > $maxhits);
|
||||
|
||||
# Strip nh=\d out of the query string, as we need to append it on. Try and keep
|
||||
# the url looking nice (i.e. no double ;&, or extra ?.
|
||||
$script =~ s/[&;]nh=\d+([&;]?)/$1/;
|
||||
$script =~ s/\?nh=\d+[&;]?/\?/;
|
||||
($script =~ /\?/) or ($script .= "?");
|
||||
$script =~ s/&/&/g;
|
||||
$next_hit = $nh + 1;
|
||||
$prev_hit = $nh - 1;
|
||||
$maxhits ||= 25;
|
||||
$max_page = int ($numhits / $maxhits) + (($numhits % $maxhits) ? 1 : 0);
|
||||
|
||||
# First, set how many pages we have on the left and the right.
|
||||
$left = $nh; $right = int($numhits/$maxhits) - $nh;
|
||||
# Then work out what page number we can go above and below.
|
||||
($left > 7) ? ($lower = $left - 7) : ($lower = 1);
|
||||
($right > 7) ? ($upper = $nh + 7) : ($upper = int($numhits/$maxhits) + 1);
|
||||
# Finally, adjust those page numbers if we are near an endpoint.
|
||||
(7 - $nh >= 0) and ($upper = $upper + (8 - $nh));
|
||||
($nh > ($numhits/$maxhits - 7)) and ($lower = $lower - ($nh - int($numhits/$maxhits - 7) - 1));
|
||||
$url = "";
|
||||
# Then let's go through the pages and build the HTML.
|
||||
($nh > 1) and ($url .= qq~<a href="$script;nh=1">[<<]</a> ~);
|
||||
($nh > 1) and ($url .= qq~<a href="$script;nh=$prev_hit">[<]</a> ~);
|
||||
for ($i = 1; $i <= int($numhits/$maxhits) + 1; $i++) {
|
||||
if ($i < $lower) { $url .= " ... "; $i = ($lower-1); next; }
|
||||
if ($i > $upper) { $url .= " ... "; last; }
|
||||
($i == $nh) ?
|
||||
($url .= qq~$i ~) :
|
||||
($url .= qq~<a href="$script&nh=$i">$i</a> ~);
|
||||
if ($i * $maxhits == $numhits) { $nh == $i and $next_hit = $i; last; }
|
||||
}
|
||||
$url .= qq~<a href="$script;nh=$next_hit">[>]</a> ~ unless ($next_hit == $nh or ($nh * $maxhits > $numhits));
|
||||
$url .= qq~<a href="$script;nh=$max_page">[>>]</a> ~ unless ($next_hit == $nh or ($nh * $maxhits > $numhits));
|
||||
return $url;
|
||||
}
|
||||
|
||||
sub escape {
|
||||
# ---------------------------------------------------------------
|
||||
# Public wrapper to private method.
|
||||
#
|
||||
return _escape ($_[1]);
|
||||
}
|
||||
|
||||
# ================================================================================ #
|
||||
# SEARCH WIDGETS #
|
||||
# ================================================================================ #
|
||||
|
||||
sub _mk_search_opts {
|
||||
# ---------------------------------------------------------------
|
||||
# Create the search options boxes based on type.
|
||||
#
|
||||
my $self = shift;
|
||||
my $opts = shift or return $self->error ("BADARGS", "FATAL", "No hash ref passed to form creator _mk_search_opts");
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to form creator _mk_search_opts");
|
||||
my $def = exists $opts->{def} ? $opts->{def} : return $self->error ("BADARGS", "FATAL", "No type hash passed to form creator _mk_search_opts");
|
||||
my $val = '';
|
||||
CASE: {
|
||||
exists $opts->{value} and $val = $opts->{value}, last CASE;
|
||||
exists $self->{input}->{"$name-opt"} and $val = $self->{input}->{"$name-opt"}, last CASE;
|
||||
$opts->{pk} and $val = '=', last CASE;
|
||||
$opts->{unique} and $val = '=', last CASE;
|
||||
}
|
||||
$val = '>' if $val eq '>';
|
||||
$val = '<' if $val eq '<';
|
||||
|
||||
my $type = $def->{type};
|
||||
|
||||
my ($hash, $so);
|
||||
CASE: {
|
||||
($type =~ /INT|FLOAT|DOUBLE|DECIMAL/i)
|
||||
and $hash = { 'LIKE' => 'Like', '=' => 'Exact Match', '<>' => 'Not Equal', '>' => 'Greater Than', '<' => 'Less Than' },
|
||||
$so = [ 'LIKE', '=', '<>', '>', '<' ],
|
||||
$val ||= '=', last CASE;
|
||||
($type =~ /CHAR/i)
|
||||
and $hash = { 'LIKE' => 'Like', '=' => 'Exact Match', '<>' => 'Not Equal', },
|
||||
$so = [ 'LIKE', '=', '<>' ], last CASE;
|
||||
($type =~ /DATE|TIME/i)
|
||||
and $hash = { '=' => 'Exact Match', '<>' => 'Not Equal', '>' => 'Greater Than', '<' => 'Less Than' },
|
||||
$so = [ '=', '>', '<', '<>' ], last CASE;
|
||||
}
|
||||
|
||||
if ($hash) {
|
||||
return $self->select( { name => "$name-opt", values => $hash, sort_order => $so, value => $val, def => $def, blank => 0 } );
|
||||
}
|
||||
else {
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
# ================================================================================ #
|
||||
# UTILS #
|
||||
# ================================================================================ #
|
||||
|
||||
sub _escape {
|
||||
# ---------------------------------------------------------------
|
||||
# Escape HTML quotes and < and >.
|
||||
#
|
||||
my $t = shift;
|
||||
return unless $$t;
|
||||
$$t =~ s/&/&/g;
|
||||
$$t =~ s/"/"/g;
|
||||
$$t =~ s/</</g;
|
||||
$$t =~ s/>/>/g;
|
||||
}
|
||||
|
||||
sub _get_time {
|
||||
# ---------------------------------------------------------------
|
||||
# Return current time for timestamp field.
|
||||
#
|
||||
my ($self, $col) = @_;
|
||||
my ($sec,$min,$hr,$day,$mon,$yr) = (localtime())[0..5];
|
||||
my $val;
|
||||
$mon++; $yr = $yr + 1900;
|
||||
($sec < 10) and ($sec = "0$sec"); ($min < 10) and ($min = "0$min"); ($hr < 10) and ($hr = "0$hr");
|
||||
($day < 10) and ($day = "0$day"); ($mon < 10) and ($mon = "0$mon");
|
||||
CASE: {
|
||||
($col->{type} =~ /DATETIME|TIMESTAMP/) and ($val = "$yr-$mon-$day $hr:$min:$sec"), last CASE;
|
||||
($col->{type} =~ /DATE/) and ($val = "$yr-$mon-$day"), last CASE;
|
||||
($col->{type} =~ /YEAR/) and ($val = "$yr"), last CASE;
|
||||
}
|
||||
return $val;
|
||||
}
|
||||
|
||||
sub _get_multi {
|
||||
my ($self, $opts) = @_;
|
||||
my ($names, $values) = ([], []);
|
||||
$opts->{def} ||= $self->{db}->{schema}->{cols}->{$opts->{name}};
|
||||
|
||||
# Deep copy $opts->{def} => $def
|
||||
my $def = {};
|
||||
while (my ($k, $v) = each %{$opts->{def}}) {
|
||||
if (! ref $v) {
|
||||
$def->{$k} = $v;
|
||||
}
|
||||
elsif (ref $v eq 'HASH') {
|
||||
$def->{$k} = {};
|
||||
foreach my $k1 (keys %{$opts->{def}->{$k}}) { $def->{$k}->{$k1} = $opts->{def}->{$k}->{$k1}; }
|
||||
}
|
||||
elsif (ref $v eq 'ARRAY') {
|
||||
$def->{$k} = [];
|
||||
foreach my $v1 (@{$opts->{def}->{$k}}) { push @{$def->{$k}}, $v1; }
|
||||
}
|
||||
else { $def->{$k} = $v; }
|
||||
}
|
||||
if (
|
||||
(exists $def->{form_names}) and
|
||||
(ref ($def->{form_names}) eq 'ARRAY') and
|
||||
(@{$def->{form_names}})
|
||||
)
|
||||
{
|
||||
$names = $def->{form_names};
|
||||
}
|
||||
elsif (
|
||||
(exists $def->{values}) and
|
||||
(ref ($def->{values}) eq 'ARRAY') and
|
||||
(@{$def->{values}})
|
||||
)
|
||||
{
|
||||
$names = $def->{values};
|
||||
}
|
||||
|
||||
# Get the values.
|
||||
if (
|
||||
(exists $def->{form_values}) and
|
||||
(ref ($def->{form_values}) eq 'ARRAY') and
|
||||
(@{$def->{form_values}})
|
||||
)
|
||||
{
|
||||
$values = $def->{form_values};
|
||||
}
|
||||
elsif (
|
||||
(exists $def->{values}) and
|
||||
(ref ($def->{values}) eq 'ARRAY') and
|
||||
(@{$def->{values}})
|
||||
)
|
||||
{
|
||||
$values = $def->{values};
|
||||
}
|
||||
|
||||
# Can pass in a hash here.
|
||||
if (
|
||||
(exists $opts->{values}) and
|
||||
(ref ($opts->{values}) eq 'HASH') and
|
||||
(keys %{$opts->{values}})
|
||||
)
|
||||
{
|
||||
@{$names} = keys %{$opts->{values}};
|
||||
@{$values} = values %{$opts->{values}};
|
||||
}
|
||||
|
||||
@{$names} or @{$names} = @{$values};
|
||||
@{$values} or @{$values} = @{$names};
|
||||
|
||||
return ($names, $values);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# Options for display forms/views:
|
||||
# hide_timestamp => 1 # Do not display timestamp fields
|
||||
# search_opts => 1 # Add search options boxes.
|
||||
# multiple => 1 # Prepend $multiple- to column names.
|
||||
# defaults => 1 # Use .def defaults.
|
||||
# values => {} # hash ref of values to use (overrides input)
|
||||
# table => 'string' # table properties, defaults to 0 border.
|
||||
# tr => 'string' # table row properties, defaults to none.
|
||||
# td => 'string' # table cell properties, defaults to just aligns.
|
||||
# extra_table => 0 # disable wrap form in extra table for looks.
|
||||
# col_font => 'string' # font to use for columns, defaults to $FONT.
|
||||
# val_font => 'string' # font to use for values, defaults to $FONT.
|
||||
# hide => [] # display fields as hidden tags.
|
||||
# view => [] # display fields as html with hidden tags as well.
|
||||
# skip => [] # don't display array of column names.
|
||||
@@ -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
|
||||
}) || ' ';
|
||||
$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
|
||||
@@ -0,0 +1,299 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Display::HTML
|
||||
# Author: Scott & Alex
|
||||
# $Id: Table.pm,v 1.29 2009/05/11 23:09:59 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# HTML module that provides a set of method to control your
|
||||
# user display in order to get rid of HTML coding inside CGI script.
|
||||
#
|
||||
|
||||
package GT::SQL::Display::HTML::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.29 $ =~ /(\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, $col);
|
||||
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 (ref $self->{code}->{$col} eq 'CODE') {
|
||||
$out .= $self->{code}->{$col}->($self, $self->{cols}->{$col}, $values, $col);
|
||||
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 => $field_name,
|
||||
def => $self->{cols}->{$col},
|
||||
value => (defined $value ? $value : '')
|
||||
},
|
||||
($values || {}),
|
||||
$self
|
||||
);
|
||||
$out .= $o if defined $o;
|
||||
|
||||
# Add edit/delete links next to the primary key in search results.
|
||||
if ($self->{mode} eq 'search_results' and @{$self->{pk}} == 1 and $col eq $self->{pk}->[0]) {
|
||||
my $url = GT::CGI->url({ query_string => 0 }) . '?';
|
||||
my @vals = GT::CGI->param('db');
|
||||
for my $val (@vals) {
|
||||
$url .= 'db=' . GT::CGI->escape($val) . ';';
|
||||
}
|
||||
chop $url;
|
||||
$out .= qq| <small><a href="$url;do=modify_form;modify=1;1-$col=$value">edit</a> <a href="$url;do=delete_search_results;$col-opt=%3D;$col=$value">delete</a></small>|;
|
||||
}
|
||||
$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)
|
||||
}) || ' ';
|
||||
$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
|
||||
904
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver.pm
Normal file
904
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver.pm
Normal file
@@ -0,0 +1,904 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Driver.pm,v 2.6 2005/11/03 01:38:30 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.6 $ =~ /(\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, '?';
|
||||
|
||||
# If the column is numeric, make sure a '' becomes a null, due to
|
||||
# problems where old libraries or the table editor could have set the
|
||||
# default to '':
|
||||
if (defined $val and $val eq '' and $cols->{$col}->{type} =~ /^(?:INTEGER|REAL|FLOAT|DOUBLE|DECIMAL)$|INT$/) {
|
||||
$val = undef;
|
||||
}
|
||||
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;
|
||||
@@ -0,0 +1,522 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::MSSQL
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: MSSQL.pm,v 2.7 2005/12/03 00:54:11 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. Actually, we look for 4000 because that's
|
||||
# the worst-case scenario for escaping being able to increase to 8000 characters.
|
||||
for (my $i = 0; $i < @_; $i++) {
|
||||
if (defined $_[$i] and length $_[$i] > 4000) {
|
||||
$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/ / /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;
|
||||
@@ -0,0 +1,226 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::MYSQL
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $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;
|
||||
@@ -0,0 +1,590 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::ORACLE
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: ORACLE.pm,v 2.2 2008/03/13 23:12:16 bao 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;
|
||||
# using ROWNUM to limit rows instead.
|
||||
my $max_rows = $offset + $limit;
|
||||
$query = "SELECT * from (SELECT a.*, rownum rnum from ($query) a WHERE rownum <= $max_rows) where rnum > $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/ / /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}) {
|
||||
while (my $rec = $self->{sth}->fetchrow_arrayref) {
|
||||
my @tmp = @$rec;
|
||||
pop @tmp; # get rid of the RNUM extra column
|
||||
push @{$self->{_results}}, [@tmp]; # 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;
|
||||
}
|
||||
|
||||
$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) {
|
||||
next if $lc_col eq 'rnum';
|
||||
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
|
||||
|
||||
# -----------------------------------------------------------------------------
|
||||
# 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;
|
||||
661
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver/PG.pm
Normal file
661
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver/PG.pm
Normal file
@@ -0,0 +1,661 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::PG
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: PG.pm,v 2.3 2005/10/06 00:05:51 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 connect {
|
||||
my $self = shift;
|
||||
my $dbh = $self->SUPER::connect(@_) or return;
|
||||
|
||||
# This is really a hack to get things working somewhat accurately - ideally
|
||||
# all data should be in UTF8, but GT::SQL and our products do not yet have
|
||||
# any provision for such, and inserting iso8859-1 data into a unicode table
|
||||
# causes fatal errors about invalid utf8 sequences. So, we set it to
|
||||
# latin1 here in the hopes that it won't break too much, and let the
|
||||
# application deal with it. There are still inherent problems here,
|
||||
# however - if the database is latin5, for example, setting this to latin1
|
||||
# would make postgresql attempt to convert from latin1 -> latin5 on input
|
||||
# and convert back on output, which is a potentially lossy conversion.
|
||||
$dbh->do("SET NAMES 'LATIN1'");
|
||||
|
||||
return $dbh;
|
||||
}
|
||||
|
||||
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;
|
||||
@@ -0,0 +1,191 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::Types
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $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;
|
||||
@@ -0,0 +1,189 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::debug
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: debug.pm,v 2.1 2007/12/18 23:13:41 brewt 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} ? ' ' : ' ';
|
||||
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> ";
|
||||
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;
|
||||
# Keep track of where we are in each of the @vals strings so that strings with
|
||||
# '?'s in them that aren't placeholders don't incorrectly get replaced with
|
||||
# values.
|
||||
my @vals_idx;
|
||||
VALUE: for my $val (@args) {
|
||||
SUBSTRING: for my $i (0 .. $#vals) {
|
||||
next SUBSTRING if $i % 2;
|
||||
$vals_idx[$i] ||= 0;
|
||||
$vals_idx[$i] = index($vals[$i], '?', $vals_idx[$i]);
|
||||
if ($vals_idx[$i] >= 0) {
|
||||
$val = defined $val ? ($val =~ /\D/ ? "'" . quick_quote($val) . "'" : $val) : 'NULL';
|
||||
substr($vals[$i], $vals_idx[$i], 1, $val);
|
||||
$vals_idx[$i] += length $val;
|
||||
next VALUE;
|
||||
}
|
||||
else {
|
||||
$vals_idx[$i] = 0;
|
||||
}
|
||||
}
|
||||
}
|
||||
$query = join '', @vals;
|
||||
}
|
||||
return $query;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
1;
|
||||
296
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver/sth.pm
Normal file
296
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Driver/sth.pm
Normal file
@@ -0,0 +1,296 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::sth
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: sth.pm,v 2.4 2007/03/21 21:28:47 brewt 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/ / /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 >::SQL::Driver::debug::AUTOLOAD;
|
||||
}
|
||||
|
||||
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;
|
||||
}
|
||||
my $msg = $_[0];
|
||||
$msg .= " from $sub" if $sub;
|
||||
$msg .= " at $file" if $file;
|
||||
$msg .= " line $line" if $line;
|
||||
$msg .= "\n";
|
||||
return $self->SUPER::debug($msg);
|
||||
}
|
||||
|
||||
1;
|
||||
1082
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Editor.pm
Normal file
1082
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Editor.pm
Normal file
File diff suppressed because it is too large
Load Diff
1132
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/File.pm
Normal file
1132
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/File.pm
Normal file
File diff suppressed because it is too large
Load Diff
149
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Monitor.pm
Normal file
149
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Monitor.pm
Normal file
@@ -0,0 +1,149 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Monitor
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Monitor.pm,v 1.7 2008/12/05 01:28:49 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 HTML escaped and the whole thing surrounded 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 occurred
|
||||
# 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},
|
||||
style => $opts{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|EXPLAIN|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) {
|
||||
my @foo = map html_escape($_), @$_;
|
||||
$table .= join("\t", $opts{html} ? (map defined $_ ? html_escape($_) : '', @$_) : @$_) . "\n";
|
||||
}
|
||||
$table .= "</pre>" if $opts{html};
|
||||
}
|
||||
else { # style = 'text'
|
||||
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 = join('+', '', map("-" x ($_ + 2), @max_width), '') . "\n";
|
||||
$table .= '|';
|
||||
for my $i (0 .. $#$names) {
|
||||
$table .= sprintf " %-$max_width[$i]s |", $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 |", $_->[$i];
|
||||
}
|
||||
$table .= "\n";
|
||||
}
|
||||
$table .= join('+', '', map("-" x ($_ + 2), @max_width), '') . "\n";
|
||||
$table = "<pre>" . html_escape($table) . "</pre>" if $opts{html};
|
||||
}
|
||||
$ret{results} = \$table;
|
||||
}
|
||||
else {
|
||||
$ret{results} = "Rows affected: $ret{rows}";
|
||||
}
|
||||
|
||||
return \%ret;
|
||||
}
|
||||
|
||||
1897
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Relation.pm
Normal file
1897
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Relation.pm
Normal file
File diff suppressed because it is too large
Load Diff
585
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search.pm
Normal file
585
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Search.pm
Normal file
@@ -0,0 +1,585 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Search
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Search.pm,v 1.62 2008/09/23 23:55:26 brewt 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.62 $ =~ /(\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//;
|
||||
next if $driver_name eq 'LUCENE';
|
||||
-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 occurred). 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.62 2008/09/23 23:55:26 brewt Exp $
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,82 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Search::Base::Common
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $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 & > < 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;
|
||||
@@ -0,0 +1,78 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Search::Base::Indexer
|
||||
# Author: Aki Mimoto
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $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;
|
||||
@@ -0,0 +1,287 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Search::STH
|
||||
# Author: Aki Mimoto
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $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;
|
||||
@@ -0,0 +1,572 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Search::Base
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $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;
|
||||
@@ -0,0 +1,411 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Search::INTERNAL::Indexer
|
||||
# Author: Aki Mimoto
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $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;
|
||||
@@ -0,0 +1,604 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Indexer
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $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;
|
||||
@@ -0,0 +1,239 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Search::LUCENE::Indexer
|
||||
# Author: Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Indexer.pm,v 1.2 2006/12/07 22:42:16 aki Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
|
||||
package GT::SQL::Search::LUCENE::Indexer;
|
||||
|
||||
# ------------------------------------------------------------------------------
|
||||
# Preamble information related to the object
|
||||
use strict;
|
||||
use vars qw/@ISA $ATTRIBS $VERSION $DEBUG $ERRORS $ERROR_MESSAGE/;
|
||||
use Lucene;
|
||||
use GT::SQL::Search::Base::Indexer;
|
||||
use GT::TempFile;
|
||||
@ISA = qw/ GT::SQL::Search::Base::Indexer /;
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/;
|
||||
$ERRORS = {
|
||||
INDEX_CORRUPT => 'Could not create an Indexer, this probably means your index is corrupted and you should rebuild it. The error was: %s',
|
||||
DELETE_FAILED => 'Could not delete some records: %s'
|
||||
};
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
|
||||
sub load {
|
||||
my $class = shift;
|
||||
return $class->new(@_)
|
||||
}
|
||||
|
||||
sub _get_path {
|
||||
my $self = shift;
|
||||
my $name = $self->{table}->name;
|
||||
my $tmpdir = GT::TempFile::find_tmpdir();
|
||||
my $path = $tmpdir . '/' . $name;
|
||||
$path = $1 if $path =~ /(.*)/; # XXX untaint
|
||||
return $path;
|
||||
}
|
||||
|
||||
sub _get_store {
|
||||
my ($self, $create) = @_;
|
||||
my $path = $self->_get_path;
|
||||
return Lucene::Store::FSDirectory->getDirectory($path, $create);
|
||||
}
|
||||
|
||||
sub _get_indexer {
|
||||
my ($self, $create) = @_;
|
||||
my %weights = $self->{table}->_weight_cols() or return $self->error(NOWEIGHTS => 'WARN');
|
||||
|
||||
my ($pk) = $self->{table}->pk;
|
||||
if (!$pk) {
|
||||
return $self->error('NOPRIMARYKEY','WARN');
|
||||
}
|
||||
my $analyzer = new Lucene::Analysis::Standard::StandardAnalyzer;
|
||||
my $store = $self->_get_store($create);
|
||||
|
||||
my $iw;
|
||||
eval { $iw = new Lucene::Index::IndexWriter($store, $analyzer, $create); };
|
||||
if ($@) {
|
||||
return $self->error('INDEX_CORRUPT', 'WARN', "$@");
|
||||
}
|
||||
return $iw;
|
||||
}
|
||||
|
||||
sub drop_search_driver {
|
||||
# ------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $path = $self->_get_path;
|
||||
require File::Tools;
|
||||
File::Tools::deldir($path);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub add_search_driver {
|
||||
# ------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->_get_indexer(1) 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 post_add_record {
|
||||
# -------------------------------------------------------
|
||||
# indexes a single record
|
||||
my ($self, $rec, $insert_sth, $no_optimize) = @_;
|
||||
|
||||
my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' );
|
||||
my %weights = $tbl->_weight_cols() or return;
|
||||
|
||||
my $indexer = $self->_get_indexer(0) or return $self->{_debug} ? () : 1;
|
||||
my $doc = new Lucene::Document;
|
||||
my ($pk) = $self->{table}->pk;
|
||||
delete $weights{$pk};
|
||||
for my $column_name (keys %weights) {
|
||||
my $field = Lucene::Document::Field->UnStored($column_name, $rec->{$column_name});
|
||||
$field->setBoost($weights{$column_name});
|
||||
$doc->add($field);
|
||||
}
|
||||
$doc->add(Lucene::Document::Field->Keyword($pk, ($tbl->ai && $insert_sth ? $insert_sth->insert_id : $rec->{$pk})));
|
||||
$indexer->addDocument($doc);
|
||||
$indexer->optimize if !$no_optimize;
|
||||
$indexer->close;
|
||||
undef $indexer;
|
||||
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 $indexer = $self->_get_indexer(1) or return $self->{_debug} ? () : 1; # clobbers the old one
|
||||
$indexer->close;
|
||||
undef $indexer;
|
||||
|
||||
my %weights = $self->{table}->_weight_cols() or return;
|
||||
my @weight_list = keys %weights;
|
||||
my ($pk) = $self->{table}->pk();
|
||||
|
||||
# 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 $rec = $sth->fetchrow_hashref() ) {
|
||||
$self->post_add_record($rec, undef, 1);
|
||||
$done = 0;
|
||||
if ($tick) {
|
||||
$count++;
|
||||
$count % $tick or (print "$count ");
|
||||
$count % ($tick*10) or (print "\n");
|
||||
}
|
||||
}
|
||||
last if $done;
|
||||
$iterations++;
|
||||
last if !$max;
|
||||
}
|
||||
$indexer = $self->_get_indexer(0) or return;
|
||||
$indexer->optimize;
|
||||
$indexer->close;
|
||||
undef $indexer;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub pre_delete_record {
|
||||
# -------------------------------------------------------
|
||||
# Delete a records index values.
|
||||
#
|
||||
my ($self, $where) = @_;
|
||||
|
||||
my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' );
|
||||
my ($pk) = $tbl->pk();
|
||||
my $q = $tbl->select($where, [$pk]);
|
||||
|
||||
my $reader = eval { Lucene::Index::IndexReader->open($self->_get_store(0)); };
|
||||
if ($@) {
|
||||
return $self->{_debug} ? $self->error('INDEX_CORRUPT', 'WARN', "$@") : 1;
|
||||
}
|
||||
|
||||
my @errors;
|
||||
while (my ($item_id) = $q->fetchrow) {
|
||||
my $t = new Lucene::Index::Term($pk => $item_id);
|
||||
eval { $reader->deleteDocuments($t); };
|
||||
if ($@) {
|
||||
push @errors, "$@";
|
||||
}
|
||||
}
|
||||
$reader->close;
|
||||
undef $reader;
|
||||
if (@errors) {
|
||||
return $self->{_debug} ? $self->error('DELETE_FAILED', 'WARN', join(", ", @errors)) : 1;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub post_update_record {
|
||||
# -------------------------------------------------------
|
||||
my ( $self, $set_cond, $where_cond, $tmp ) = @_;
|
||||
|
||||
# delete the previous record
|
||||
eval {
|
||||
$self->pre_delete_record($where_cond) or return $self->{_debug} ? () : 1;
|
||||
};
|
||||
#
|
||||
# the new record
|
||||
my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' );
|
||||
my ($pk) = $tbl->pk();
|
||||
my %weights = $self->{table}->_weight_cols();
|
||||
my @weight_list = keys %weights;
|
||||
my $q = $tbl->select($where_cond, [$pk, @weight_list]);
|
||||
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, $rec) = @_;
|
||||
|
||||
$self->delete_record($rec);
|
||||
$self->index_record($rec);
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,206 @@
|
||||
NAME
|
||||
Lucene -- API to the C++ port of the Lucene search engine
|
||||
|
||||
SYNOPSIS
|
||||
Initialize/Empty Lucene index
|
||||
my $analyzer = new Lucene::Analysis::Standard::StandardAnalyzer();
|
||||
my $store = Lucene::Store::FSDirectory->getDirectory("/home/lucene", 1);
|
||||
|
||||
my $tmp_writer = new Lucene::Index::IndexWriter($store, $analyzer, 1);
|
||||
$tmp_writer->close;
|
||||
undef $tmp_writer;
|
||||
|
||||
Choose your Analyzer (string tokenizer)
|
||||
# lowercases text and splits it at non-letter characters
|
||||
my $analyzer = Lucene::Analysis::SimpleAnalyzer();
|
||||
# same as before and removes stop words
|
||||
my $analyzer = Lucene::Analysis::StopAnalyzer();
|
||||
# splits text at whitespace characters
|
||||
my $analyzer = Lucene::Analysis::WhitespaceAnalyzer();
|
||||
# lowercases text, tokenized it based on a grammer that
|
||||
# leaves named authorities intact (e-mails, company names,
|
||||
# web hostnames, IP addresses, etc) and removed stop words
|
||||
my $analyzer = Lucene::Analysis::Standard::StandardAnalyzer();
|
||||
|
||||
Choose your Store (storage engine)
|
||||
# in-memory storage
|
||||
my $store = new Lucene::Store::RAMDirectory();
|
||||
# disk-based storage
|
||||
my $store = Lucene::Store::FSDirectory->getDirectory("/home/lucene", 0);
|
||||
|
||||
Open and configure an IndexWriter
|
||||
my $writer = new Lucene::Index::IndexWriter($store, $analyzer, 0);
|
||||
# optional settings for power users
|
||||
$writer->setMergeFactor(100);
|
||||
$writer->setUseCompoundFile(0);
|
||||
$writer->setMaxFieldLength(255);
|
||||
$writer->setMinMergeDocs(10);
|
||||
$writer->setMaxMergeDocs(100);
|
||||
|
||||
Create Documents and add Fields
|
||||
my $doc = new Lucene::Document;
|
||||
# field gets analyzed, indexed and stored
|
||||
$doc->add(Lucene::Document::Field->Text("content", $content));
|
||||
# field gets indexed and stored
|
||||
$doc->add(Lucene::Document::Field->Keyword("isbn", $isbn));
|
||||
# field gets just stored
|
||||
$doc->add(Lucene::Document::Field->UnIndexed("sales_rank", $sales_rank));
|
||||
# field gets analyzed and indexed
|
||||
$doc->add(Lucene::Document::Field->UnStored("categories", $categories));
|
||||
|
||||
Add Documents to an IndexWriter
|
||||
$writer->addDocument($doc);
|
||||
|
||||
Optimize your index and close the IndexWriter
|
||||
$writer->optimize();
|
||||
$writer->close();
|
||||
undef $writer;
|
||||
|
||||
Delete Documents
|
||||
my $reader = Lucene::Index::IndexReader->open($store);
|
||||
my $term = new Lucene::Index::Term("isbn", $isbn);
|
||||
$reader->deleteDocuments($term);
|
||||
$reader->close();
|
||||
undef $reader;
|
||||
|
||||
Query index
|
||||
# initalize searcher and parser
|
||||
my $analyzer = Lucene::Analysis::SimpleAnalyzer();
|
||||
my $store = Lucene::Store::FSDirectory->getDirectory("/home/lucene", 0);
|
||||
my $searcher = new Lucene::Search::IndexSearcher($store);
|
||||
my $parser = new Lucene::QueryParser("default_field", $analyzer);
|
||||
|
||||
# build a query on the default field
|
||||
my $query = $parser->parse("perl");
|
||||
|
||||
# build a query on another field
|
||||
my $query = $parser->parse("title:cookbook");
|
||||
|
||||
# define a sort on one field
|
||||
my $sortfield = new Lucene::Search::SortField("unixtime");
|
||||
my $reversed_sortfield = new Lucene::Search::SortField("unixtime", 1);
|
||||
my $sort = new Lucene::Search::Sort($sortfield);
|
||||
|
||||
# define a sort on two fields
|
||||
my $sort = new Lucene::Search::Sort($sortfield1, $sortfield2);
|
||||
|
||||
# use Lucene's INDEXORDER or RELEVANCE sort
|
||||
my $sort = Lucene::Search::Sort->INDEXORDER;
|
||||
my $sort = Lucene::Search::Sort->RELEVANCE;
|
||||
|
||||
# query index and get results
|
||||
my $hits = $searcher->search($query);
|
||||
my $sorted_hits = $searcher->search($query, $sort);
|
||||
|
||||
# get number of results
|
||||
my $num_hits = $hits->length();
|
||||
|
||||
# get fields and ranking score for each hit
|
||||
for (my $i = 0; $i < $num_hits; $i++) {
|
||||
my $doc = $hits->doc($i);
|
||||
my $score = $hits->score($i);
|
||||
my $title = $doc->get("title");
|
||||
my $isbn = $doc->get("isbn");
|
||||
}
|
||||
|
||||
# free memory and close searcher
|
||||
undef $hits;
|
||||
undef $query;
|
||||
undef $parser;
|
||||
undef $analyzer;
|
||||
$searcher->close();
|
||||
undef $fsdir;
|
||||
undef $searcher;
|
||||
}
|
||||
|
||||
Close your Store
|
||||
$store->close;
|
||||
undef $store;
|
||||
|
||||
DESCRIPTION
|
||||
Like it or not Apache Lucene has become the de-facto standard for
|
||||
open-source high-performance search. It has a large user-base, is well
|
||||
documented and has plenty of committers. Unfortunately Apache Lucene is
|
||||
entirely written in Java and therefore of relatively little use for perl
|
||||
programmers. Fortunately in the recent years a group of C++ programmers
|
||||
led by Ben van Klinken decided to port Java Lucene to C++.
|
||||
|
||||
The purpose of the module is to export the C++ Lucene API to perl and at
|
||||
the same time be as close as possible to the original Java API. This has
|
||||
the combined advantage of providing perl programmers with a
|
||||
well-documented API and giving them access to a C++ search engine
|
||||
library that is supposedly faster than the original.
|
||||
|
||||
CHARACTER SUPPORT
|
||||
Currently only ISO 8859-1 (Latin-1) characters are supported. Obviously
|
||||
this included all ASCII characters.
|
||||
|
||||
INDEX COMPATIBLITY
|
||||
For the moment indices produced by this module are not compatible with
|
||||
those from Apache Lucene. The reason for this is that this module uses
|
||||
1-byte character encoding as opposed to 2-byte (widechar) encoding with
|
||||
Apache Lucene.
|
||||
|
||||
INSTALLATION
|
||||
This module requires the clucene library to be installed. The best way
|
||||
to get it is to go to the following page
|
||||
|
||||
http://sourceforge.net/projects/clucene/
|
||||
|
||||
and download the latest STABLE clucene-core version. Currently it is
|
||||
clucene-core-0.9.15. Make sure you compile it in ASCII mode and install
|
||||
it in your standard library path.
|
||||
|
||||
On a Linux platform this goes as follows:
|
||||
|
||||
wget http://kent.dl.sourceforge.net/sourceforge/clucene/clucene-core-0.9.15.tar.gz
|
||||
cd clucene-core-0.9.15
|
||||
./autogen.sh
|
||||
./configure --disable-debug --prefix=/usr --exec-prefix=/usr --enable-ascii
|
||||
make
|
||||
make check
|
||||
(as root) make install
|
||||
|
||||
To install the perl module itself, run the following commands:
|
||||
|
||||
perl Makefile.PL
|
||||
make
|
||||
make test
|
||||
(as root) make install
|
||||
|
||||
AUTHOR
|
||||
Thomas Busch <tbusch at cpan dot org>
|
||||
|
||||
COPYRIGHT AND LICENSE
|
||||
Copyright (c) 2006 Thomas Busch
|
||||
|
||||
This library is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
SEE ALSO
|
||||
Plucene - a pure-Perl implementation of Lucene
|
||||
|
||||
KinoSearch - a search engine library inspired by Lucene
|
||||
|
||||
DISCLAIMER OF WARRANTY
|
||||
BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
|
||||
FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
|
||||
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
|
||||
PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
|
||||
EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||||
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
|
||||
ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
|
||||
YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
|
||||
NECESSARY SERVICING, REPAIR, OR CORRECTION.
|
||||
|
||||
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
|
||||
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
|
||||
REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE
|
||||
TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR
|
||||
CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
|
||||
SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
|
||||
RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
|
||||
FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
|
||||
SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
|
||||
DAMAGES.
|
||||
|
||||
@@ -0,0 +1,115 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Search::STH
|
||||
# Author: Aki Mimoto
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: STH.pm,v 1.1 2006/12/07 07:04:51 aki Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
|
||||
package GT::SQL::Search::LUCENE::STH;
|
||||
#--------------------------------------------------------------------------------
|
||||
use strict;
|
||||
use vars qw/@ISA $ATTRIBS $VERSION $DEBUG $ERRORS $ERROR_MESSAGE /;
|
||||
require GT::SQL::Search::Base::STH;
|
||||
|
||||
@ISA = ('GT::SQL::Search::STH');
|
||||
$ATTRIBS = {
|
||||
'db_sort' => 1,
|
||||
'hits' => undef
|
||||
};
|
||||
$ERROR_MESSAGE = 'GT::SQL::Search::STH';
|
||||
|
||||
|
||||
|
||||
sub init {
|
||||
#--------------------------------------------------------------------------------
|
||||
# GT::SQL::Search::STH expects a full set of results in $self->{results}. For
|
||||
# Lucene the only time a full set of results is there is when we are sorting
|
||||
# on a field that is not weighted, otherwise the results in $self->{results} is
|
||||
# the proper page and number of results.
|
||||
my $self = shift;
|
||||
|
||||
$self->set(@_);
|
||||
|
||||
--$self->{nh} if $self->{nh};
|
||||
|
||||
# Here we allow hits to override our concept of rows. This is only useful
|
||||
# when !$self->{db_sort}
|
||||
$self->{rows} = $self->{hits}
|
||||
? $self->{hits}
|
||||
: $self->{results}
|
||||
? scalar(keys %{$self->{results}})
|
||||
: 0;
|
||||
|
||||
if ($self->{db_sort}) {
|
||||
$self->get_db_sorted_results;
|
||||
}
|
||||
else {
|
||||
$self->get_sorted_results;
|
||||
}
|
||||
}
|
||||
|
||||
sub get_sorted_results {
|
||||
# Just sorts the results out of $self->{results} which should have been setup
|
||||
# by a search driver
|
||||
my ($self) = @_;
|
||||
my $results = $self->{results};
|
||||
$self->{index} = 0;
|
||||
$self->{max_index} = $self->{mh} - 1;
|
||||
$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 get_db_sorted_results {
|
||||
# This assumes $self->{results} has a full result set, i.e. without any LIMIT
|
||||
# It then selects the result set using the SQL driver to do the sorting. This
|
||||
# is for Search modules which can not handle their own sorting
|
||||
my ($self) = @_;
|
||||
|
||||
my $sb = GT::SQL::Search::Base::Search->clean_sb($self->{sb}, $self->{so});
|
||||
$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};
|
||||
}
|
||||
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});
|
||||
my $sth = $self->{table}->{driver}->prepare( $query );
|
||||
$sth->execute();
|
||||
|
||||
$self->{index} = 0;
|
||||
$self->{max_hits} = $self->{rows};
|
||||
|
||||
# Fetch the results in sorted order
|
||||
my $order = $sth->fetchall_arrayref();
|
||||
$sth->finish();
|
||||
|
||||
$self->{'order'} = [ map { $_->[0] } @{$order} ];
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
@@ -0,0 +1,260 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Search::LUCENE::Search
|
||||
# Author : Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Search.pm,v 1.2 2006/12/07 22:42:16 aki Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Class used to search indexed tables.
|
||||
#
|
||||
|
||||
package GT::SQL::Search::LUCENE::Search;
|
||||
# ------------------------------------------------------------------------------
|
||||
use strict;
|
||||
use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD $STOPWORDS $ERRORS $ERROR_MESSAGE /;
|
||||
use Lucene;
|
||||
use GT::TempFile;
|
||||
use GT::SQL::Search::LUCENE::STH;
|
||||
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.2 $ =~ /(\d+)\.(\d+)/;
|
||||
$ERRORS = {
|
||||
SEARCH_ERROR => "Error searching: %s",
|
||||
QUERY_ERROR => "Query error: %s"
|
||||
};
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
|
||||
sub load {
|
||||
shift;
|
||||
return GT::SQL::Search::LUCENE::Search->new(@_)
|
||||
}
|
||||
|
||||
sub _get_path {
|
||||
my $self = shift;
|
||||
my $name = $self->{table}->name;
|
||||
my $tmpdir = GT::TempFile::find_tmpdir();
|
||||
my $path = $tmpdir . '/' . $name;
|
||||
$path = $1 if $path =~ /(.*)/; # XXX untaint
|
||||
return $path;
|
||||
}
|
||||
|
||||
sub _get_store {
|
||||
my ($self, $create) = @_;
|
||||
my $path = $self->_get_path;
|
||||
return Lucene::Store::FSDirectory->getDirectory($path, $create);
|
||||
}
|
||||
|
||||
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(@_);
|
||||
my $tbl = $self->{table};
|
||||
|
||||
# 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 Lucene 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;
|
||||
$token =~ s/(["()])/\\$1/g;
|
||||
$token =~ s/\b(or|and)\b/ /g;
|
||||
|
||||
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 .= '"' . $token . '"' unless $token =~ /^"|"$/;
|
||||
}
|
||||
else {
|
||||
$e .= $token;
|
||||
|
||||
# substring match
|
||||
if ($properties->{mode} ne 'substring') {
|
||||
$e .= '*' if $properties->{substring};
|
||||
}
|
||||
}
|
||||
|
||||
$query_string .= $e;
|
||||
}
|
||||
}
|
||||
|
||||
# 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';
|
||||
|
||||
# Score is the default
|
||||
$args->{so} = (defined $args->{so} and $args->{so} =~ /^(asc|desc)(?:end)?$/i) ? lc($1) : 'asc';
|
||||
|
||||
my %weights = $tbl->_weight_cols();
|
||||
my @sortfields;
|
||||
my $do_mysql_sort = 0;
|
||||
for (ref($args->{sb}) eq 'ARRAY' ? @{$args->{sb}} : $args->{sb}) {
|
||||
if (!exists $weights{$_}) {
|
||||
$do_mysql_sort = 1 if $_ ne 'score';
|
||||
next;
|
||||
}
|
||||
push @sortfields, new Lucene::Search::SortField($_, $args->{so} ne 'asc');
|
||||
}
|
||||
my $sort = @sortfields ? new Lucene::Search::Sort(@sortfields) : Lucene::Search::Sort->RELEVANCE;
|
||||
my $store = $self->_get_store(0);
|
||||
my $analyzer = new Lucene::Analysis::Standard::StandardAnalyzer;
|
||||
my $searcher = eval { new Lucene::Search::IndexSearcher($store); };
|
||||
if ($@) {
|
||||
$self->{_debug} and $self->error('SEARCH_ERROR', 'WARN', "$@");
|
||||
return $self->sth({}, 0); # no hits
|
||||
}
|
||||
# Random default field, it's not used
|
||||
my $parser = new Lucene::MultiFieldQueryParser((keys %weights)[0], $analyzer);
|
||||
my $pquery = eval { $parser->parse($query_string, [keys %weights], $analyzer); };
|
||||
if ($@) {
|
||||
$self->{_debug} and $self->error('QUERY_ERROR', 'WARN', "$@");
|
||||
return $self->sth({}, 0); # no hits
|
||||
}
|
||||
my $hits = $searcher->search($pquery, $sort);
|
||||
my $num_hits = $hits->length;
|
||||
|
||||
## Setup a limit only if there is no callback. The callback argument requires a full results list
|
||||
my ($offset, $max_hits) = (0, $num_hits);
|
||||
unless ($self->{callback} or $do_mysql_sort) {
|
||||
$offset = ( $args->{nh} - 1 ) * $args->{mh};
|
||||
$max_hits = $offset + $args->{mh};
|
||||
}
|
||||
$max_hits = $num_hits if $max_hits > $num_hits;
|
||||
my ($pk) = $self->{table}->pk;
|
||||
my @indexes;
|
||||
my $results = {};
|
||||
for (my $i= $offset; $i < $max_hits; ++$i) {
|
||||
my $doc = $hits->doc($i);
|
||||
my $value = $doc->get($pk);
|
||||
my $score = $hits->score($i);
|
||||
$results->{$value} = $score;
|
||||
}
|
||||
|
||||
# now handle filters
|
||||
my $cols = $self->{'table'}->cols();
|
||||
my %filters = map {
|
||||
(my $tmp = $_) =~ s/-[lg]t$//;
|
||||
$cols->{$tmp} ? ($_ => $args->{$_}) : ()
|
||||
} keys %{$args};
|
||||
|
||||
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') {
|
||||
$self->{_debug} and $self->error ('BADARGS', 'FATAL', "callback '$self->{callback}' must be a code ref!");
|
||||
return $self->sth({}, 0); # no hits
|
||||
}
|
||||
$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} = $num_hits;
|
||||
|
||||
return $self->sth($results, $do_mysql_sort);
|
||||
}
|
||||
|
||||
sub sth {
|
||||
#--------------------------------------------------------------------------------
|
||||
my ($self, $results, $db_sort) = @_;
|
||||
|
||||
my $sth = GT::SQL::Search::LUCENE::STH->new(
|
||||
'results' => $results,
|
||||
'hits' => $self->{rows},
|
||||
'db' => $self->{table}->{driver},
|
||||
'db_sort' => $db_sort,
|
||||
# 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;
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,98 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Search::MSSQL::Indexer
|
||||
# Author: Alex Krohn
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $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;
|
||||
@@ -0,0 +1,179 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Search::MSSQL::Search
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $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;
|
||||
@@ -0,0 +1,187 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Search::MYSQL::Indexer
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $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;
|
||||
@@ -0,0 +1,51 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Search::MYSQL::Search
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $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;
|
||||
@@ -0,0 +1,178 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Search::MYSQL::VER3
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $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;
|
||||
@@ -0,0 +1,355 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Search::MYSQL::VER4
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $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;
|
||||
@@ -0,0 +1,25 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Search::NONINDEXED::Indexer
|
||||
# Author: Aki Mimoto
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $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;
|
||||
@@ -0,0 +1,257 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Search::NONINDEXED::Search
|
||||
# Author : Alex Krohn
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Search.pm,v 1.30 2006/08/09 06:58:39 brewt 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.30 $ =~ /(\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 '');
|
||||
if ($i < $#terms) {
|
||||
($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,
|
||||
};
|
||||
}
|
||||
elsif ($word) {
|
||||
$words->{$word} = {
|
||||
mode => $mode,
|
||||
phrase => 0,
|
||||
substring => $substring,
|
||||
keyword => 1,
|
||||
};
|
||||
}
|
||||
}
|
||||
return $words;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
3006
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Table.pm
Normal file
3006
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Table.pm
Normal file
File diff suppressed because it is too large
Load Diff
1269
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Tree.pm
Normal file
1269
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Tree.pm
Normal file
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,237 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Table
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $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
|
||||
384
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Types.pm
Normal file
384
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Types.pm
Normal file
@@ -0,0 +1,384 @@
|
||||
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>.
|
||||
|
||||
=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.3 2006/05/26 21:56:31 brewt Exp $
|
||||
|
||||
=cut
|
||||
282
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Upgrade.pm
Normal file
282
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Upgrade.pm
Normal file
@@ -0,0 +1,282 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Upgrade
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Upgrade.pm,v 1.7 2008/09/23 23:55:26 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.01;
|
||||
|
||||
@ISA = 'Exporter';
|
||||
@EXPORT = qw/add_column alter_column drop_column add_index add_unique 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;
|
||||
}
|
||||
|
||||
# A simple alias for add_index(..., 1);
|
||||
sub add_unique {
|
||||
push @_, 1;
|
||||
goto &add_index;
|
||||
}
|
||||
|
||||
# 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 occurred: $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 occurred: $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 occurred: $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 occurred: $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 occurred: $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 occurred: $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 occurred: $GT::SQL::error\n");
|
||||
}
|
||||
|
||||
$success = 1;
|
||||
}
|
||||
|
||||
if (!$success) {
|
||||
$out->("\tAn error occurred while attempting to recreate $table_name. Procedure aborted.\n");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user