discourse-legacysite-perl/site/glist/lib/GT/SQL.pm

# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::SQL
#   CVS Info :                          
#   $Id: SQL.pm,v 1.111 2005/04/14 20:22:37 alex Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
# ==================================================================
#
# Description: A general purpose perl interface to a RDBMS.
#

package GT::SQL;
# ==================================================================
use GT::Base;
use GT::AutoLoader;
use GT::Config;
use GT::SQL::Base;
use GT::SQL::Table;
use GT::SQL::Driver;
use strict;
use vars qw(@ISA $DEBUG $ERRORS $VERSION %OBJ_CACHE $error $errcode);

@ISA = qw(GT::SQL::Base);
$DEBUG              = 0;
$VERSION            = sprintf "%d.%03d", q$Revision: 1.111 $ =~ /(\d+)\.(\d+)/;
$ERRORS = {
    # Common Errors
    UNIQUE       => "The column '%s' must be unique, and already has an entry '%s'",
    NOTABLE      => 'No table defined -- call $db->table($table) before accessing',
    CANTOPEN     => "Cannot open file '%s': %s",
    CANTOPENDIR  => "Cannot read directory '%s': %s",
    FILENOEXISTS => "File '%s' does not exist or the permissions are set incorrectly",
    # GT::SQL Errors
    NODRIVER     => "Database driver %s is not installed. Available drivers: %s",
    CANTLOAD     => "Unable to load driver '%s': %s",
    BADPREFIX    => "Invalid prefix: '%s'",
    NODATABASE   => 'No database def file -- create def file with ->set_connect before calling $obj->%s',
    CANTCONNECT  => "Could not connect to database: %s",
    CANTPREPARE  => "Failed to prepare query: '%s': %s",
    CANTEXECUTE  => "Failed to execute query: '%s': %s",
    BADSUBCLASS  => "Unable to load subclass: '%s': %s",
    NEEDDEBUG    => "You must turn on debug in order to access query logs",
    NOORACLEHOME => "The environment variable ORACLE_HOME is not defined.  It must be defined for the script to connect properly",
    NONLSDATE    => "Unable to set NLS_DATE_FORMAT: %s",
    # Table Errors
    BADNAME        => "Invalid table name '%s'",
    NOTNULL        => "Column %s cannot be left blank",
    NORECMOD       => "The record you are attempting to modify no longer exists in the current table",
    NOVALUES       => "You did not pass any valid column names to %s",
    BADMULTVALUES  => "One or more of the value groups passed to %s contained an incorrect number of values",
    NOPKTOMOD      => "Cannot modify record, no primary key specified",
    DEPENDENCY     => "Table %s has dependencies. Aborting",
    ILLEGALVAL     => "%s cannot contain the value '%s'",
    ALREADYCHANGED => "The record you are attempting to modify has changed since you last accessed it",
    REGEXFAIL      => "The regular expressions %s for this column is not properly formed",
    FKNOTABLE      => "A foreign key is referencing a non existant table: %s. GT::SQL load error: %s",
    FKNOEXISTS     => "You attempted to remove non-existent foreign key '%s' from table '%s'",
    CIRCULAR       => "Circular reference detected in the foreign key schema. Already seen column: %s",
    CIRCULARLIMIT  => "Loop detected in circular reference check, hit maximum recursion depth of 100",
    # Relation Errors
    BADCOLS => "Bad columns / column clash: columns named '%s' have been found in current relation, please qualify your expression",
    # Creator Errors
    BADTYPE     => "%s is not a supported type",
    AINOTPK     => "Column %s defined as auto_increment but is not an INT",
    TBLEXISTS   => "Could not create table '%s': It already exists",
    NOTABLEDEFS => "You must define your table before creating it",
    NOPOS       => "No position column was found in definition for column: %s",
    # Editor Errors
    NOCOL          => "There is no column %s in this table",
    REFCOL         => "You cannot alter column %s, as table %s still has references to it. Remove those references first",
    NOPK           => "There is no primary key for this table",
    COLREF         => "You cannot alter column %s, as it is a foreign key. Remove the foreign key first",
    NOINDEX        => "You are trying to modify an index that does not exist",
    NOUNIQUE       => "You are trying to drop a unique column '%s', but it is not unique",
    INDXQTEXT      => "Cannot create index on '%s' as it is a text/blob field",
    COLEXISTS      => "Unable to add column '%s' - already exists",
    NOTUNIQUE      => "Cannot create unique index on '%s', data is not unique",
    INDXEXISTS     => "Unable to add index '%s' - already exists",
    PKTEXT         => "Column %s specified as a primary key but is a text or a blob type",
    UNIQTEXT       => "Column %s specified as a unique but is a text or blob column type",
    TABLEREFD      => "%s cannot be dropped as table still has references to it",
    NOFILESAVEIN   => "Column %s must have file_save_in set if is to be File type",
    NODIRPRIV      => "Privileges on directory %s do not allow write or directory does not exist",
    SAMEDRIVER     => "Search Driver '%s' is unchanged",
    NOTNULLDEFAULT => "Column %s was specified as not null, but has no default value",
    # Admin Error
    NOACTION => "The CGI object passed in did not contain a valid action. %s",
    # Tree errors
    NOTREE      => "No tree object exists for table '%s'. Create a tree first with \$editor->add_tree",
    NOTREEOBJ   => "You attempted to call '%s' without a valid tree object. Call \$table->tree() first",
    TREEEXISTS  => "A tree already exists for table '%s'",
    TREENOCANDO => "You attempted to call '%s' on table '%s', but that table has a tree attached and does not support the command",
    TREENOIDS   => "You did not pass any ID's to %s",
    TREEBADPK   => "You tried to create a tree on table '%s', but that table doesn't have a primary key, or has multiple primary keys",
    TREEBADJOIN => "Joining more than 2 tables with a tree is not supported. You attempted to join: %s",
    TREEFATHER  => "Unable to update a tree record to a descendant of itself",
    # Driver errors
    DRIVERPROTOCOL => "Driver implements wrong protocol: protocol v%d required, driver is v%d",
};

use constant DEF_HEADER => <<'HEADER';
# Database access & configuration file
# Last updated: [localtime]
# Created by GT::SQL $Revision: 1.111 $
HEADER

sub new {
# -------------------------------------------------------------------
# GT::SQL constructor. Takes:
#       my $db = new GT::SQL '/path/to/def';
#       my $db = new GT::SQL { def_path => '/defpath', debug => 1 };
#
    my $this    = shift;
    my $class   = ref $this || $this;
    my $self    = bless { _err_pkg => __PACKAGE__, _debug => $DEBUG }, $class;

# Get our arguments into a hash ref
    my $opts = {};
    if    (@_ == 0)                         { $opts = {};    }
    elsif (@_ == 1 and ref $_[0] eq 'HASH') { $opts = shift; }
    elsif (@_ > 1 and !(@_ % 2))            { $opts = {@_};  }
    else {
        $opts->{def_path} = shift;
    }

# Set debugging level, caching options and whether to allow subclassing.
    $self->{_debug}   = exists $opts->{debug} ? $opts->{debug} : $DEBUG;
    $self->{cache}    = exists $opts->{cache} ? $opts->{cache} : 1;
    $self->{subclass} = exists $opts->{subclass} ? $opts->{subclass} : 1;

# Def path must exist and be a directory
    exists $opts->{def_path}    or return $self->fatal(BADARGS => "$class->new(HASH_REF). def_path must be defined and a directory path in the hash");
    -d $opts->{def_path}        or return $self->fatal(BADARGS => "The defs directory '$opts->{def_path}' does not exist, or is not a directory");

# Load the database def file if it exists

# Some old programs would sometimes erroneously leave an invalid blank
# database.def file in the def_path; if such a file exists, make GT::Config
# ignore it.
    my $empty = (-f "$opts->{def_path}/database.def" and !-s _);

    $self->{connect} = GT::Config->load(
        "$opts->{def_path}/database.def" => {
            create_ok => 1,
            chmod => 0666,
            debug => $self->{_debug},
            header => DEF_HEADER,
            ($empty ? (empty => 1) : ()),
        }
    );

    $self->{connect}->{PREFIX} = '' unless defined $self->{connect}->{PREFIX};
# Heavily deprecated.  Not guaranteed to always be correct:
    $GT::SQL::PREFIX = $self->{connect}->{PREFIX};
    $self->{connect}->{def_path} = $opts->{def_path};
    $self->{connect}->{obj_cache} = $self->{cache};

    $self->debug("OBJECT CREATED") if $self->{_debug} and $self->{_debug} > 2;
    return $self;
}

$COMPILE{set_connect} = __LINE__ . <<'END_OF_SUB';
sub set_connect {
# -------------------------------------------------------------------
# Sets the connection info, only needed to setup the database.def file.
#     $db->set_connect({
#         driver => 'mysql',
#         host   => 'localhost',
#         port   => 2323,
#         database => 'mydatabase',
#         login    => 'user',
#         password => 'foo',
#     }) or die "Can't connect: $GT::SQL::error";
#
    my $self = shift;
    my $connect = $self->{connect};
    my %old_connect = %$connect;
# Parse our arguments.
    if (!@_) { return $self->fatal(BADARGS => '$obj->set_connect(HASH_REF)') }
    elsif (@_ == 1 and ref $_[0] eq 'HASH') { %$connect = %{+shift} }
    elsif (@_ % 2 == 0) { %$connect = @_ }
    else { return $self->fatal(BADARGS => '$obj->set_connect(HASH_REF)') }

    if (keys %old_connect) {
        for (keys %old_connect) {
            $connect->{$_} = $old_connect{$_} unless exists $connect->{$_};
        }
    }
    $connect->{PREFIX} = '' unless defined $connect->{PREFIX};

# Fix the connect string for test connecting
    $connect->{driver} ||= 'mysql';

# Make sure DBI has been loaded
    eval { require DBI };
    $@ and 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 the requested driver exists
    my @drivers = GT::SQL::Driver->available_drivers;
    unless (grep $_ eq uc $connect->{driver}, @drivers, 'ODBC') {
        return $self->warn(NODRIVER => $connect->{driver}, join ", ", @drivers);
    }

    my $raiseerror = delete $connect->{RaiseError};
    my $printerror = delete $connect->{PrintError};
    $connect->{RaiseError} = 0;
    $connect->{PrintError} = 0;

# Get our driver.
    my $table = GT::SQL::Table->new(connect => $connect, debug => $self->{_debug});
    $table->connect or return;

# Put things back the way they were.
    $connect->{RaiseError} = defined $raiseerror ? $raiseerror : 1;
    $connect->{PrintError} = defined $printerror ? $printerror : 0;

    $self->{connect} = $connect;

# Use this connect string from now on.
    $self->write_db_config;

    return 1;
}
END_OF_SUB

$COMPILE{write_db_config} = __LINE__ . <<'END_OF_SUB';
sub write_db_config {
# -------------------------------------------------------------------
# Saves the database.def file. Takes no arguments.
#
    my $self = shift;
    $self->{connect}->save;
}
END_OF_SUB

# ============================================================================ #
#  DATABASE INFO ACCESSORS                                                     #
# ============================================================================ #
$COMPILE{driver} = __LINE__ . <<'END_OF_SUB';
sub driver {
# -------------------------------------------------------------------
# Returns the name of the driver being used.
#
    my $self = shift;
    return $self->{connect}->{driver};
}
END_OF_SUB

$COMPILE{host} = __LINE__ . <<'END_OF_SUB';
sub host {
# -------------------------------------------------------------------
# Returns the name of the host being used.
#
    my $self = shift;
    return $self->{connect}->{host};
}
END_OF_SUB

$COMPILE{port} = __LINE__ . <<'END_OF_SUB';
sub port {
# -------------------------------------------------------------------
# Returns the port currently being used, undef if default.
#
    my $self = shift;
    return $self->{connect}->{port};
}
END_OF_SUB

$COMPILE{database} = __LINE__ . <<'END_OF_SUB';
sub database {
# -------------------------------------------------------------------
# Returns the name of the database being used.
#
    my $self = shift;
    return $self->{connect}->{database};
}
END_OF_SUB

$COMPILE{login} = __LINE__ . <<'END_OF_SUB';
sub login {
# -------------------------------------------------------------------
# Returns the login username for the current connection.
#
    my $self = shift;
    return $self->{connect}->{login};
}
END_OF_SUB

$COMPILE{password} = __LINE__ . <<'END_OF_SUB';
sub password {
# -------------------------------------------------------------------
# Returns the login password for the current connection.
#
    my $self = shift;
    return $self->{connect}->{password};
}
END_OF_SUB

# ============================================================================ #
#  HTML ACCESSSOR                                                              #
# ============================================================================ #

$COMPILE{html} = __LINE__ . <<'END_OF_SUB';
sub html {
# -------------------------------------------------------------------
# Return an html object. Takes an array ref of table names, or a, and a cgi
# object.
#       my $html = $db->html(['Links'], $in);
#           or
#       my $html = $db->html($table_obj, $in);
#
    my ($self, $tables, $cgi) = @_;
    ref $tables or return $self->fatal(BADARGS => 'Error: no table array ref passed to html');
    ref $cgi    or return $self->fatal(BADARGS => 'Error: no cgi object/hash ref passed to html');

# If already passed a table object, use it, otherwise create a new one
    my ($table);
    if (ref $tables eq 'ARRAY') {
        $table = $self->table(@$tables);
    }
    elsif (UNIVERSAL::isa($tables, 'GT::SQL::Table') or UNIVERSAL::isa($tables, 'GT::SQL::Relation')) {
        $table = $tables;
    }
    else {
        return $self->fatal(BADARGS => "Error: '$tables' must be either an array ref or a table object");
    }

    my $meth = @{[$table->name]} > 1 ? "_html_relation" : "_html_table";
    $self->$meth($table, $cgi);
}
END_OF_SUB

$COMPILE{_html_relation} = __LINE__ . <<'END_OF_SUB';
sub _html_relation {
    my ($self, $rel, $cgi) = @_;

    my $class;
    my $key = join "\0", map { s/^$self->{connect}->{PREFIX}//; $_ } sort keys %{$rel->{tables}};
    foreach my $table (values %{$rel->{tables}}) {
        my $subclass = $table->subclass;
        if ($self->{subclass} and exists $subclass->{html}->{$self->{connect}->{PREFIX} . $key}) {
            $class = $subclass->{html}->{$self->{connect}->{PREFIX} . $key};
            $self->_load_module($class) or return;
            last;
        }
    }

    if (!$class) {
        require GT::SQL::Display::HTML::Relation;
        $class = 'GT::SQL::Display::HTML::Relation';
    }
    return $class->new(
        db    => $rel,
        input => $cgi
    );
}
END_OF_SUB

$COMPILE{_html_table} = __LINE__ . <<'END_OF_SUB';
sub _html_table {
    my ($self, $table, $cgi) = @_;
    my $class;
    if ($self->{subclass} and $table->{schema}->{subclass}->{html}->{$table->name}) {
        $class = $table->{schema}->{subclass}->{html}->{$table->name};
        $self->_load_module($class) or return;
    }
    if (!$class) {
        require GT::SQL::Display::HTML::Table;
        $class = 'GT::SQL::Display::HTML::Table';
    }
    return $class->new(
        db    => $table,
        input => $cgi
    );
}
END_OF_SUB

sub query_stack {
# -------------------------------------------------------------------
# Returns raw query stack (as array/array ref).
#
    return wantarray ? @GT::SQL::Driver::debug::QUERY_STACK : \@GT::SQL::Driver::debug::QUERY_STACK;
}

sub query_stack_disp {
# -------------------------------------------------------------------
# Returns formatted query stack (handled in Driver.pm).
#
    my ($out, $i) = ('', 0);
    foreach (reverse 0 .. $#GT::SQL::Driver::debug::QUERY_STACK) {
        my $query = $GT::SQL::Driver::debug::QUERY_STACK[$_];
        my $stack = $GT::SQL::Driver::debug::STACK_TRACE[$_] || '';
        $i++;
        chomp $query;
        $query =~ s/^[\s]*(.*?)[\s]*$/$1/mg;
        $query =~ s/\n/\n        /mg;
        $out .= "$i: $query\n$stack";
    }
    return $out;
}


$COMPILE{prefix} = __LINE__ . <<'END_OF_SUB';
sub prefix {
# -------------------------------------------------------------------
# Set/Get the database prefix to be attached to all tables.  Calling this as a
# class accessor method is extremely deprecated (it returns $GT::SQL::PREFIX,
# which is itself extremely deprecated); calling this to *set* a prefix is not
# permitted.
#

    my $self = shift;

    if (@_) {
        ref $self or $self->fatal(BADARGS => 'Usage: $obj->prefix(...) not CLASS->prefix(...)');
        my $prefix = shift;
        if ($prefix =~ /\W/) {
            return $self->fatal(BADPREFIX => $prefix);
        }
        $self->{connect}->{PREFIX} = $prefix;
    }
    else {
        return ref $self ? $self->{connect}->{PREFIX} : $GT::SQL::PREFIX;
    }
    return 1;
}
END_OF_SUB

$COMPILE{reset_env} = __LINE__ . <<'END_OF_SUB';
sub reset_env {
# -------------------------------------------------------------------
# Reset globals.
#
    GT::SQL::Driver->reset_env(); # Shut down database connections.
    %OBJ_CACHE = ();
    $error     = '';
    $errcode   = '';
}
END_OF_SUB

1;

__END__

=head1 NAME

GT::SQL - A database independent perl interface

=head1 SYNOPSIS

    use GT::SQL;

    my $db      = GT::SQL->new('/path/to/def');
    my $table   = $db->table('Links');
    my $editor  = $db->editor('Links');
    my $creator = $db->creator('NewTable');
    my $html    = $db->html('Links', new CGI);

=head1 DESCRIPTION

GT::SQL is a perl database abstraction layer to relational databases, providing
a native Perl interface rather than a query-based interface.

A GT::SQL object provides the interface to the entire database by providing
objects that are able to perform the work needed.

=head2 Creating a new GT::SQL object

There are two ways to get a GT::SQL object. First, you can simply provide the
path to the def file directory where GT::SQL stores all it's information:

    $db = GT::SQL->new('/path/to/def');

or you can pass in a hash or hash ref and specify options:

    $db = GT::SQL->new(
        def_path => '/path/to/def',
        cache    => 1,
        debug    => 1,
        subclass => 1
    );

You must specify def_path. Setting C<cache =E<gt> 1> will result in all table
and relation objects being cached, which provides a performance improvement in
any situation where the same table or relation is used again.

Specifying C<subclass =E<gt> 0> or C<subclass =E<gt> 1> will enable or disable
the ability to subclass any of the objects GT::SQL creates. The default
value is C<1>, and should not normally be changed.

GT::SQL has significant amounts of debugging output that can be enabled by
specifying a value of C<1> to the C<debug> option.  Larger values can be
specified for more detailed debugging output, however a level of C<1> is almost
always more than sufficient.  The accepted values are as follows:

=over 4

=item Level 0

This is the default, no debugging information is printed to stderr. All errors
can be obtained in $GT::SQL::error.

=item Level 1

All queries will be displayed to stderr.  This is the recommended value if
query debugging is desired.

=item Level 2

Same as level 1, but includes more detailed information.  Also, when calling
query_stack you get a stack trace on what generated each query.  Not
recommended except when working directly on GT::SQL.

=item Level 3

Very detailed debug logs including creation and destruction of objects.
query_stack generates a javascript page with query, stack trace, and data dump
of arguments, but can be extremely large.  Not recommended except for debugging
GT::SQL internals.

=back

B<Pass in a def path>

    $obj = GT::SQL->new('/path/to/def/directory');

This method of calling new is also supported, however has the drawback that
none of the above options can be provided.

=head2 Getting Connected

GT::SQL loads the database connection info from database.def which is located
in the defs directory.

To create this file, you call set_connect() as follows:

    $obj->set_connect({
        driver     => 'mysql',
        host       => 'localhost',
        port       => 3243,
        database   => 'databasename',
        login      => 'username',
        password   => 'password',
        PREFIX     => 'prefix_'
    });

This will test the database information, and save it to the def file. All
future connections will automatically use this connection information.

Not all of the arguments in this hash are necessary; some have reasonable
defaults for the connection.

=over 4

=item driver

This needs to be the driver that is being used for the connection. The default
for this is C<mysql>.  Driver names are case-insensitive.  Available drivers
are:

=over 4

=item MySQL

Driver for MySQL databases.  Requires that the DBD::mysql module be installed.

=item Pg

Driver for PostgreSQL databases.  Requires that the DBD::Pg module be
installed.

=item MSSQL

Driver for MSSQL 7.0 and above.  Requires that the DBD::ODBC module be
installed.

=item Oracle

Driver for Oracle 8 and above.  Requires the DBD::Oracle module.

=back

=item host

This will specify the host to connect to. The default, which is acceptable for
most installations, is C<localhost>.

=item port

This is the port on which to connect to the SQL server.  The default for this
is to allow the DBI driver to choose the default, which is almost always the
appropriate choice.

=item database

This is the database name to use on the SQL server.  This is required to
connect.  For MSSQL, this is the I<Data Source> name.

=item PREFIX

This specifies a prefix to use for table names.  See the L</"Table Prefixes">
section below for more information.

=back

=head2 Supported Objects

The following objects can be obtained through a GT::SQL object:

=over 4

=item Table/Relation

To get a table or relation object for working with SQL tables, you should call:

    my $table = $db->table('table_name');

or for a table join:

    my $relation = $db->table('table_name', 'other_table');

See L<GT::SQL::Table> for more information on how to use a table object.

=item Creator

To create new tables, you need to use a creator. You can get one by calling:

    my $creator = $db->creator('new_table');

where C<new_table> is the name of the table you wish to create.  See
L<GT::SQL::Creator> for more information on how to use a creator object.

=item Editor

To edit existing tables (i.e. add/drop/change columns, add/drop indexes, etc.)
you need an editor object:

    my $editor = $db->editor('existing_table');

where C<existing_table> is the name of the table you wish the modify.  See
L<GT::SQL::Editor> for more information on how to use an editor object.

=item HTML

To get an html object for generating forms and html output, you need to pass in
the table/relation object you want to work with, and a cgi object:

    my $html = $db->html($table, $cgi);

The html object uses information found in CGI to set values, etc.  See
L<GT::SQL::Display::HTML> for more information on how to use a html object.

=back

=head2 Table Prefixes

GT::SQL supports the concept of table prefixes. If you specify a prefix using
the accessor, it is saved in the database.def file and will be used in all
future calls to table(), editor() and creator().

To set a prefix:

    $db->prefix("foo");

to get the current prefix:

    my $prefix = $db->prefix;

What this will do is transparently prepend C<foo> to the beginning of every
table name.  This means anywhere you access the table C<bar>, the actual table
stored on the SQL server will be C<foobar>.  Note that the prefix should B<not>
be included when getting table/creator/editor/etc. objects - the prefix is
handled completely transparently to all public GT::SQL functionality.

=head2 Query Stack

To display a list of all raw SQL queries sent to the database you can use:

    my @queries = $db->query_stack;

or to have them formatted try

    print $db->query_stack_disp;

which will join them up, displayed nicely. This is also available as a class
method:

    print GT::SQL->query_stack_disp;

=head1 SEE ALSO

L<GT::SQL::Table>

L<GT::SQL::Editor>

L<GT::SQL::Creator>

L<GT::SQL::Types>

L<GT::SQL::Admin>

L<GT::SQL::Display::HTML>

=head1 COPYRIGHT

Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
http://www.gossamer-threads.com/

=head1 VERSION

Revision: $Id: SQL.pm,v 1.111 2005/04/14 20:22:37 alex Exp $

=cut