1898 lines
63 KiB
Perl
1898 lines
63 KiB
Perl
# ==================================================================
|
|
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
|
#
|
|
# GT::SQL::Relation
|
|
# Author : Jean-Michel Hiver
|
|
# $Id: Relation.pm,v 1.102 2004/08/28 03:53:43 jagerman Exp $
|
|
#
|
|
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
# ==================================================================
|
|
#
|
|
# Description:
|
|
# Utility modules that makes it possible to treat joins between
|
|
# multiple tables almost as if it was a single table.
|
|
#
|
|
|
|
package GT::SQL::Relation;
|
|
# ==================================================================
|
|
use GT::SQL::Condition;
|
|
use GT::SQL::Base;
|
|
use GT::AutoLoader;
|
|
use strict;
|
|
use vars qw/@ISA $DEBUG $VERSION $ERROR_MESSAGE/;
|
|
|
|
$ERROR_MESSAGE = 'GT::SQL';
|
|
|
|
@ISA = qw/GT::SQL::Base/;
|
|
$DEBUG = 0;
|
|
$VERSION = sprintf "%d.%03d", q$Revision: 1.102 $ =~ /(\d+)\.(\d+)/;
|
|
|
|
sub DESTROY {}
|
|
|
|
sub new {
|
|
# -----------------------------------------------------------
|
|
# new GT::SQL::Relation (
|
|
# tables => { table name => object }
|
|
# debug => debug level,
|
|
# _err_pkg => package name,
|
|
# );
|
|
# -------------------------------------------------
|
|
# Constructs (or returns if it already exists) a
|
|
# new GT::SQL::Relation object with the parameters specified
|
|
# above.
|
|
#
|
|
#
|
|
# new GT::SQL::Relation ( $hashref );
|
|
# ----------------------------------
|
|
# Same thing, $hashref being a reference to a
|
|
# hash which would be similar to what's above.
|
|
#
|
|
#
|
|
# $obj->new(LIST);
|
|
# -----------------
|
|
# Internal use only. Creates a new Relation object from $obj
|
|
# with list being a subset of the tables which are being
|
|
# contained in $obj.
|
|
#
|
|
my $class = shift;
|
|
|
|
if (ref $class) {
|
|
# if the first argument is a reference, then we assume that we
|
|
# are constructing from a Relation object that handles all the
|
|
# data that has to be passed in.
|
|
my $this = $class;
|
|
my $class = ref $class;
|
|
|
|
my @tables = map { (ref $_) ? $_->{name} : $_ } @_;
|
|
|
|
my $opts = {};
|
|
$opts->{_debug} = $this->{_debug} || $DEBUG;
|
|
$opts->{_err_pkg} = $this->{_err_pkg};
|
|
$opts->{connect} = $this->{connect};
|
|
$opts->{tables} = { map { $_ => $this->{tables}->{$_} } @tables };
|
|
$opts->{tables_ord} = \@tables;
|
|
|
|
return $class->new($opts);
|
|
}
|
|
else {
|
|
my $self = bless {}, $class;
|
|
my $opts = {};
|
|
|
|
if (@_ == 1 and ref $_[0] eq 'HASH') { $opts = shift }
|
|
elsif (@_ % 2 == 0) { $opts = { @_ } }
|
|
else {
|
|
$self->error("BADARGS", "FATAL", "new GT::SQL::Relation (HASH or HASHREF)");
|
|
}
|
|
|
|
# same thing for name - must be an array ref
|
|
ref $opts->{tables} eq 'HASH' or
|
|
return $self->error("BADARGS", "FATAL", "$class new(HASH_REF or HASH). name must be a ref to a list of table names.");
|
|
|
|
$self->{_debug} = $opts->{debug} || $DEBUG;
|
|
$self->{_err_pkg} = $opts->{_err_pkg} if exists $opts->{_err_pkg};
|
|
$self->{tables} = $opts->{tables};
|
|
$self->{connect} = $opts->{connect};
|
|
$self->{fk} = {};
|
|
|
|
# if an order was specified for the tables, use it, otherwise
|
|
# sort the tables in lexicographical order.
|
|
my @tables_ord = sort keys %{$self->{tables}};
|
|
if ($opts->{tables_ord}) { @tables_ord = @{$opts->{tables_ord}} }
|
|
|
|
$self->{tables_ord} = \@tables_ord;
|
|
|
|
# this is a hash that has { $table names => $schema object }
|
|
$self->{last_where} = undef;
|
|
$self->{last_hits} = undef;
|
|
$self->debug("OBJECT CREATED") if ($self->{_debug} > 2);
|
|
return $self;
|
|
}
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------------- #
|
|
# INSERT #
|
|
# ------------------------------------------------------------------------------------- #
|
|
|
|
$COMPILE{insert} = __LINE__ . <<'END_OF_SUB';
|
|
sub insert {
|
|
# -----------------------------------------------------------
|
|
# $obj->insert($col1 => $val1,
|
|
# ...,
|
|
# $coln => $valn,
|
|
# );
|
|
# -----------------------------
|
|
# Will fill
|
|
# the tables whenever it can according to the
|
|
# insert parameters.
|
|
#
|
|
# returns TRUE if insert succeeded,
|
|
# FALSE otherwise.
|
|
#
|
|
# $obj->insert($hashref);
|
|
# ------------------------------
|
|
# Same as above.
|
|
#
|
|
my $self = shift;
|
|
my $opts = (ref $_[0] eq 'HASH') ? shift : {@_};
|
|
my $input = {};
|
|
foreach my $key (keys %$opts) {
|
|
$input->{$key} = $opts->{$key};
|
|
}
|
|
my $split = $self->_split_schema($input);
|
|
my $added = $self->_insert($split);
|
|
if (! $added) {
|
|
$self->{_error} ||= [];
|
|
for (values %{$self->{tables}}) {
|
|
if (ref $_->{_error} eq 'ARRAY' and @{$_->{_error}}) {
|
|
push(@{$self->{_error}}, @{$_->{_error}});
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
return $added;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{add} = __LINE__ . <<'END_OF_SUB';
|
|
sub add {
|
|
# -----------------------------------------------------------
|
|
# add() : Adds a record into the current relation object, and
|
|
# returns a hash of primary key => value.
|
|
#
|
|
my $self = shift;
|
|
my $opts = (ref $_[0] eq 'HASH') ? shift : {@_};
|
|
|
|
my $input = {};
|
|
foreach my $key (keys %$opts) {
|
|
$input->{$key} = $opts->{$key};
|
|
}
|
|
my $split = $self->_split_schema($input);
|
|
my $added = $self->_add($split);
|
|
if (!$added) {
|
|
$self->{_error} ||= [];
|
|
for (values %{$self->{tables}}) {
|
|
if (ref $_->{_error} eq 'ARRAY' and @{$_->{_error}}) {
|
|
push(@{$self->{_error}}, @{$_->{_error}});
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
return $added;
|
|
}
|
|
END_OF_SUB
|
|
|
|
# ------------------------------------------------------------------------------------- #
|
|
# SELECT #
|
|
# ------------------------------------------------------------------------------------- #
|
|
|
|
sub select {
|
|
# -----------------------------------------------------------
|
|
# $obj->select;
|
|
# -------------
|
|
# returns all rows from that relation (no where
|
|
# condition).
|
|
#
|
|
# $obj->select($condition, \@select_returns);
|
|
# --------------------------------------------
|
|
# $condition is a Condition or a
|
|
# hash reference.
|
|
#
|
|
# $obj->select(\%columns, \@select_returns);
|
|
# -------------------------------------------
|
|
# $col1 = $val1, $col2 = $val2
|
|
#
|
|
# @select_returns is a list of the fields that
|
|
# you wish returned. If none are specified all
|
|
# fields will be returned.
|
|
#
|
|
my $self = shift;
|
|
$self->connect or return;
|
|
|
|
# Get a list of fields to select.
|
|
my (@fields, @cond, $left_join);
|
|
for (@_) {
|
|
if (ref $_ eq 'ARRAY') { push @fields, @{$_}; }
|
|
elsif (not ref $_) { ($_ eq 'left_join') ? ($left_join = 1) : push @fields, $_; }
|
|
else { push @cond, $self->_build_cond($_); }
|
|
}
|
|
@fields = map { $self->_complete_name($_) } grep { defined and length } @fields;
|
|
@fields or (@fields = ('*'));
|
|
|
|
my $fields = join ',' => @fields;
|
|
my $condition = @cond > 1 ? GT::SQL::Condition->new(@cond) : $cond[0];
|
|
|
|
# building the join condition for this query
|
|
my @relations = values %{$self->{tables}};
|
|
my $join = $self->_join_query(\@relations);
|
|
|
|
# building the select options, if any
|
|
my $sel_opts = '';
|
|
if (defined $self->select_options) { $sel_opts = " " . join " ", $self->select_options }
|
|
$self->{sel_opts} = undef;
|
|
|
|
# Any fk specifics
|
|
$self->{fk} ||= {};
|
|
my $orig_fk = {};
|
|
for my $table (keys %{$self->{fk}}) {
|
|
if (defined $self->{fk}->{$table}) {
|
|
$orig_fk->{$table} = $self->{fk}->{$table};
|
|
$self->{tables}->{$table}->{schema}->{fk}->{$table} = $self->{fk}->{$table};
|
|
}
|
|
}
|
|
|
|
my $sql;
|
|
if ($left_join) {
|
|
my $tables = $self->{tables_ord}->[0] . ' LEFT OUTER JOIN ' . $self->{tables_ord}->[1] . ' ON ' . $join;
|
|
my $cond_sql = '';
|
|
if (defined $condition) {
|
|
my $string = $condition->sql; # may be empty, never be paranoid enough
|
|
$cond_sql = "WHERE ($string)" if $string;
|
|
}
|
|
|
|
$sql = qq!SELECT $fields FROM $tables $cond_sql!;
|
|
$sql .= $sel_opts if $sel_opts;
|
|
}
|
|
else {
|
|
my $tables = join ',' => sort keys %{$self->{tables}};
|
|
my $cond_sql = '';
|
|
if (defined $condition) {
|
|
my $string = $condition->sql; # may be empty, never be paranoid enough
|
|
$cond_sql = "($string)" if $string;
|
|
}
|
|
|
|
my $where = ($cond_sql or $join) ? "WHERE " : "";
|
|
$where .= "$join " if $join;
|
|
$where .= 'AND ' if $join and $cond_sql;
|
|
$where .= "$cond_sql" if $cond_sql;
|
|
$sql = qq!SELECT $fields FROM $tables $where!;
|
|
$sql .= $sel_opts if $sel_opts;
|
|
}
|
|
|
|
my $sth = $self->{driver}->prepare($sql) or return;
|
|
$sth->execute or return;
|
|
|
|
$self->{last_hits} = undef;
|
|
my $rows = $sth->rows;
|
|
|
|
# Attempt to optimize a possible later call to hits(). If there was no limit,
|
|
# it's the number of rows. If there was a limit, and the rows returned was
|
|
# less than the limit (but still greater than 0), we can calculate it now
|
|
# without an additional query.
|
|
if ($sel_opts =~ /\bLIMIT\s+(\d+)(?:\s+OFFSET\s+(\d+)|\s*,\s*(\d+))?|\bOFFSET\s+(\d+)\s+LIMIT\s+(\d+)/i) {
|
|
my ($limit, $offset);
|
|
if (defined($3)) { # MySQL-style, with an offset
|
|
($offset, $limit) = ($1, $3);
|
|
}
|
|
elsif ($1) {
|
|
($limit, $offset) = ($1, $2 || 0);
|
|
}
|
|
else {
|
|
($offset, $limit) = ($4, $5);
|
|
}
|
|
if ($rows > 0 and $rows < $limit) {
|
|
$self->{last_hits} = $offset + $rows;
|
|
}
|
|
}
|
|
else {
|
|
$self->{last_hits} = $rows;
|
|
}
|
|
|
|
$self->{sel_opts} = [];
|
|
|
|
# Save the last query for future use.
|
|
$self->{last_where} = $condition ? $condition->clone : undef;
|
|
|
|
for ( keys %$orig_fk ) {
|
|
$self->{tables}->{$_}->{schema}->{fk}->{$_} = $orig_fk->{$_};
|
|
}
|
|
$self->{fk} = {};
|
|
return $sth;
|
|
}
|
|
|
|
$COMPILE{join_on} = __LINE__ . <<'END_OF_SUB';
|
|
sub join_on {
|
|
# -------------------------------------------------------------------
|
|
# Change how tables join
|
|
my ( $self, $tb, %change ) = @_;
|
|
my $p = $self->prefix;
|
|
$tb = $p . $tb;
|
|
return unless exists $self->{tables}{$tb};
|
|
for my $table ( keys %change ) {
|
|
my $cp = $p . $table;
|
|
next unless exists $self->{tables}{$cp};
|
|
$self->{tables}->{$tb}->{schema}->{fk}->{$cp} = $change{$table};
|
|
}
|
|
}
|
|
END_OF_SUB
|
|
|
|
sub _join_query {
|
|
# -------------------------------------------------------------------
|
|
# Figures out the join clause between tables.
|
|
#
|
|
my $self = shift;
|
|
my $relations = shift;
|
|
my %join;
|
|
foreach my $relation (@$relations) {
|
|
my $relation_name = $relation->{name};
|
|
my @join_tables = keys %{$relation->{schema}->{fk}};
|
|
foreach my $join_table (@join_tables) {
|
|
if ($self->{tables}->{$join_table}) {
|
|
my $fk = $relation->{schema}->{fk}->{$join_table};
|
|
for my $key (keys %$fk) {
|
|
$join{"$relation_name.$key"} = "$join_table.$fk->{$key}" unless $relation_name eq $join_table; # Ignore foreign keys to the same table
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return join " AND ", map "$_ = $join{$_}", keys %join;
|
|
}
|
|
|
|
sub select_options {
|
|
# -----------------------------------------------------------
|
|
# $obj->select_options(@options);
|
|
# --------------------------------
|
|
# @options should be a list of options you want
|
|
# prepended to your search.
|
|
#
|
|
my $self = shift;
|
|
push @{$self->{sel_opts}}, @_ if @_ > 0;
|
|
if (wantarray) { ($self->{sel_opts}) ? @{$self->{sel_opts}} : () }
|
|
else { ($self->{sel_opts}) ? $self->{sel_opts} : [] }
|
|
}
|
|
|
|
$COMPILE{query} = __LINE__ . <<'END_OF_SUB';
|
|
sub query {
|
|
# -----------------------------------------------------------
|
|
# $obj->query($HASH or $CGI);
|
|
# ----------------------------
|
|
# Performs a query based on the options in the hash.
|
|
# $HASH can be a hash ref, hash or CGI object.
|
|
#
|
|
# Returns the result of a query as fetchall_arrayref.
|
|
#
|
|
my $self = shift;
|
|
my $sth = $self->_query(@_) or return;
|
|
return $sth->fetchall_arrayref;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{query_sth} = __LINE__ . <<'END_OF_SUB';
|
|
sub query_sth {
|
|
# -----------------------------------------------------------
|
|
# $obj->query_sth($HASH or $CGI);
|
|
# --------------------------------
|
|
# Same as query but returns the sth object.
|
|
#
|
|
shift->_query(@_)
|
|
}
|
|
END_OF_SUB
|
|
|
|
# ------------------------------------------------------------------------------------- #
|
|
# DELETE #
|
|
# ------------------------------------------------------------------------------------- #
|
|
|
|
$COMPILE{delete} = __LINE__ . <<'END_OF_SUB';
|
|
sub delete {
|
|
# -----------------------------------------------------------
|
|
# $obj->delete($condition, $opt);
|
|
# --------------------------------
|
|
# $condition is a condition on the current
|
|
# join relation,
|
|
#
|
|
# $opt is a string which can be either 'abort',
|
|
# 'ignore', or 'cascade'.
|
|
#
|
|
my $self = shift;
|
|
my $cond = shift;
|
|
my $opt = shift || 'cascade';
|
|
|
|
$cond = $self->_build_cond($cond);
|
|
|
|
$self->{last_where} = $cond ? $cond->clone : undef;
|
|
|
|
my $rows;
|
|
if ($opt eq 'ignore') {
|
|
my $split = $self->_split_fields($cond);
|
|
for (keys %{$split}) {
|
|
$rows += $self->{$_}->delete($split->{$_}, 'ignore') or return;
|
|
}
|
|
}
|
|
elsif ($opt eq 'abort') {
|
|
my @ordered_columns = $self->col_names;
|
|
my $q = $self->select(\@ordered_columns, $cond) or return;
|
|
if (!$q->rows) {
|
|
$rows = "0E0" unless ($q->rows);
|
|
}
|
|
else {
|
|
while (my $array = $q->fetchrow_arrayref) {
|
|
my $h = {};
|
|
for (my $i = 0; $i < @ordered_columns; $i++) {
|
|
$h->{$ordered_columns[$i]} = $array->[$i];
|
|
}
|
|
foreach my $referencing ($self->_referencing_relations) {
|
|
unless ($self->_can_delete($h, $referencing)) {
|
|
return $self->error("DEPENDENCY", "WARN", $referencing);
|
|
}
|
|
}
|
|
}
|
|
$rows = $self->_delete_cascade($cond->new_clean);
|
|
}
|
|
}
|
|
elsif ($opt eq 'cascade') {
|
|
$rows = $self->_delete_cascade($cond) or return;
|
|
}
|
|
return ($rows == 0) ? '0E0' : $rows;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{delete_all} = __LINE__ . <<'END_OF_SUB';
|
|
sub delete_all {
|
|
# -----------------------------------------------------------
|
|
# deletes all the records in this relation
|
|
#
|
|
my $self = shift;
|
|
my $opt = shift || 'abort';
|
|
foreach my $rel ($self->_referencing_relations) { ($rel->delete_all($opt)) ? next : return }
|
|
foreach my $rel ($self->_referenced_relations) { ($rel->delete_all($opt)) ? next : return }
|
|
return 1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
# ------------------------------------------------------------------------------------- #
|
|
# UPDATE #
|
|
# ------------------------------------------------------------------------------------- #
|
|
|
|
$COMPILE{update} = __LINE__ . <<'END_OF_SUB';
|
|
sub update {
|
|
# -----------------------------------------------------------
|
|
# $obj->update($hashref, $hashref);
|
|
# $obj->update($hashref, $condition);
|
|
# ------------------------------------
|
|
# $hashref are the fields to update
|
|
#
|
|
# $condition is a condition on the current
|
|
# join relation.
|
|
#
|
|
# A limitation exists: in a relation one to many,
|
|
# it is not possible to perform an update on the
|
|
# attributes that are in the "one" entity.
|
|
#
|
|
my ($self, $hash, $cond) = @_;
|
|
(ref $self and ref $hash and ref $cond) or $self->error("BADARGS", "FATAL", '$obj->update(HASH, GT::SQL::Condition or HASH)');
|
|
$hash = $self->_split_schema($hash);
|
|
|
|
# removes noise values from _split_schema
|
|
foreach my $rel_name (keys %{$hash}) {
|
|
my $h = $hash->{$rel_name};
|
|
if (defined $h) {
|
|
foreach my $rel_col (keys %{$h}) { delete $h->{$rel_col} unless (defined $h->{$rel_col}) }
|
|
delete $hash->{$rel_name} unless (keys %{$h});
|
|
}
|
|
else {
|
|
delete $hash->{$rel_name};
|
|
}
|
|
}
|
|
|
|
my @ordered_columns = $self->col_names;
|
|
$cond = $self->_build_cond($cond);
|
|
$self->{last_where} = $cond ? $cond->clone : undef;
|
|
|
|
my $q = $self->select(@ordered_columns, $cond) or return;
|
|
my @err = ();
|
|
while (my $array = $q->fetchrow_arrayref) {
|
|
my $h = {};
|
|
for (my $i = 0; $i < @ordered_columns; $i++) {
|
|
$h->{$ordered_columns[$i]} = $array->[$i]
|
|
}
|
|
|
|
for my $rel (values %{$self->{tables}}) {
|
|
next unless defined $hash->{$rel->{name}};
|
|
my ($upd, $rec) = ($hash->{$rel->{name}}, $h);
|
|
my $allrec = $self->_split_schema($rec);
|
|
my $rel_rec = $allrec->{$rel->{name}};
|
|
|
|
# from $rel_rec, a hashref needs to be built that isn't prefixed
|
|
# by the table name because GT::SQL::Table doesn't understand that
|
|
my $rel_rec2 = {};
|
|
my $prefix = $rel->{name} . ".";
|
|
foreach my $col (keys %{$rel_rec}) {
|
|
my $col2 = $col;
|
|
$col2 =~ s/^\Q$prefix\E//;
|
|
$rel_rec2->{$col2} = $rel_rec->{$col};
|
|
}
|
|
|
|
$self->debug("Calling $rel->update") if ($self->{_debug} > 2);
|
|
|
|
unless (defined $rel->update($upd, $rel_rec2)) {
|
|
if ($GT::SQL::errcode eq 'UNIQUE') {
|
|
next;
|
|
}
|
|
push @err, $GT::SQL::error;
|
|
}
|
|
}
|
|
}
|
|
if (@err) {
|
|
$GT::SQL::error = join "\n", @err;
|
|
return;
|
|
}
|
|
else { return 1 }
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{modify} = __LINE__ . <<'END_OF_SUB';
|
|
sub modify {
|
|
# -----------------------------------------------------------
|
|
# modify()
|
|
# IN : hash/hash_ref/cgi/GT::CGI of col => val pairs to change.
|
|
# OUT: 1 on success, undef on failure.
|
|
#
|
|
my $self = shift;
|
|
|
|
my $in = $self->common_param(@_);
|
|
|
|
# first of all complete $in attributes
|
|
my ($hash, $cond);
|
|
for my $col (keys %$in) {
|
|
if (my $completed = $self->_complete_name($col, 1)) {
|
|
$hash->{$completed} = $in->{$col};
|
|
}
|
|
}
|
|
|
|
# let's build the $condition
|
|
my $condition = { map {
|
|
$_ => $hash->{$_}
|
|
} $self->pk };
|
|
|
|
$hash = $self->_split_schema($hash);
|
|
|
|
# removes noise values from _split_schema
|
|
foreach my $rel_name (keys %{$hash}) {
|
|
my $h = $hash->{$rel_name};
|
|
if (defined $h) {
|
|
foreach my $rel_col (keys %{$h}) { delete $h->{$rel_col} unless (defined $h->{$rel_col}) }
|
|
delete $hash->{$rel_name} unless (keys %{$h});
|
|
}
|
|
else {
|
|
delete $hash->{$rel_name};
|
|
}
|
|
}
|
|
|
|
my @ordered_columns = $self->col_names;
|
|
|
|
$cond = $self->_build_cond($condition);
|
|
$self->{last_where} = $cond ? $cond->clone : undef;
|
|
|
|
my $q = $self->select(\@ordered_columns, $cond) or return;
|
|
my @err = ();
|
|
while (my $array = $q->fetchrow_arrayref) {
|
|
my $h = {};
|
|
for (my $i = 0; $i < @ordered_columns; $i++) {
|
|
$h->{$ordered_columns[$i]} = $array->[$i]
|
|
}
|
|
|
|
|
|
for my $rel (values %{$self->{tables}}) {
|
|
next unless defined $hash->{$rel->{name}};
|
|
|
|
# from $rel_rec, a hashref needs to be built that isn't prefixed
|
|
# by the table name because GT::SQL::Table doesn't understand that
|
|
my $rel_rec = {};
|
|
foreach my $col (keys %{$h}) {
|
|
next unless $col =~ /^\Q$rel->{name}\E\./;
|
|
my $col2 = $col;
|
|
$col2 =~ s/^[^.]+\.//;
|
|
$rel_rec->{$col2} = defined($hash->{$rel->{name}}->{$col2}) ? $hash->{$rel->{name}}->{$col2} : defined($hash->{$rel->{name}}->{$col}) ? $hash->{$rel->{name}}->{$col} : $h->{$col};
|
|
}
|
|
|
|
$self->debug("Calling $rel->update") if ($self->{_debug} > 2);
|
|
unless (defined $rel->modify($rel_rec)) {
|
|
if ($GT::SQL::errcode eq 'UNIQUE') {
|
|
next;
|
|
}
|
|
push @err, $GT::SQL::error;
|
|
}
|
|
}
|
|
}
|
|
if (@err) {
|
|
$GT::SQL::error = join "\n", @err;
|
|
return;
|
|
}
|
|
else { return 1 }
|
|
}
|
|
END_OF_SUB
|
|
|
|
# ------------------------------------------------------------------------------------- #
|
|
# COUNT/GET #
|
|
# ------------------------------------------------------------------------------------- #
|
|
|
|
$COMPILE{get} = __LINE__ . <<'END_OF_SUB';
|
|
sub get {
|
|
# -----------------------------------------------------------
|
|
# $obj->get($condition, $opt);
|
|
# -----------------------------
|
|
# $condition is the condition for the row that has to be
|
|
# retrieved. $opt can be 'ARRAY' or 'HASH'. The first row
|
|
# of the query is returned, which makes the get method
|
|
# mostly useful to retrieve rows from the primary key
|
|
# values.
|
|
#
|
|
my $self = shift;
|
|
my $cond = shift;
|
|
if (ref $cond eq 'ARRAY') { $cond = { @{$cond} } }
|
|
my $method = shift || 'HASH';
|
|
$method = (uc $method eq 'ARRAY') ? 'fetchrow_arrayref' : 'fetchrow_hashref';
|
|
my $sth = $self->select($cond) or return;
|
|
return $sth->$method();
|
|
}
|
|
END_OF_SUB
|
|
|
|
# ------------------------------------------------------------------------------------- #
|
|
# ACCESSSORS #
|
|
# ------------------------------------------------------------------------------------- #
|
|
|
|
$COMPILE{cols} = __LINE__ . <<'END_OF_SUB';
|
|
sub cols {
|
|
# -----------------------------------------------------------
|
|
# $obj->cols;
|
|
# -----------
|
|
# Returns the relation columns as a hash which has
|
|
# the columns names as a key and their type as a
|
|
# value.
|
|
#
|
|
my $self = shift;
|
|
my @res;
|
|
if (@_) { $self->error('BADARGS', 'FATAL', '$obj->cols;') }
|
|
|
|
# if the number of table objects that handles the current
|
|
# relation object equals zero, then returns an empty hash.
|
|
my @names = $self->name;
|
|
if (@names == 0) { return {} }
|
|
else {
|
|
my $res = {};
|
|
my @referencing = $self->_referencing_relations;
|
|
my @referenced = $self->_referenced_relations;
|
|
if (@referenced) {
|
|
|
|
# if in the current Relation object there exists some
|
|
# tables which are referenced by other tables within
|
|
# the current relation object, then
|
|
my %referenced_cols = $self->new(@referenced)->cols;
|
|
my @referenced_cols = keys %referenced_cols;
|
|
|
|
# remove columns which are referenced by referencing
|
|
# tables because we don't wanna have these duplicates.
|
|
my @rem_cols;
|
|
foreach my $referencing (@referencing) {
|
|
foreach my $target (keys %{$referencing->{schema}->{fk}}) {
|
|
if (defined $self->{tables}->{$target}) {
|
|
push @rem_cols, map { $target .'.'. $_ } keys %{$referencing->{schema}->{fk}->{$target}};
|
|
}
|
|
}
|
|
}
|
|
my @cols_left = _minus(\@referenced_cols, \@rem_cols);
|
|
map { $res->{$_} = $referenced_cols{$_} } @cols_left;
|
|
}
|
|
|
|
# add then all low level columns, and return.
|
|
foreach my $referencing (@referencing) {
|
|
my %referencing_cols = %{$referencing->{schema}->{cols}};
|
|
map { $res->{$referencing->{name} .'.'. $_} = $referencing_cols{$_} } keys %referencing_cols;
|
|
}
|
|
|
|
return $res unless wantarray;
|
|
|
|
# Wantarray has been set so create a copy of the res whose
|
|
# first and second level references can be clobbered.
|
|
# This assumes that the values side of the res will
|
|
# always been hashrefs
|
|
my %res_copy = %$res;
|
|
foreach my $res_name ( keys %res_copy ) {
|
|
|
|
my %res_data = %{$res_copy{$res_name}};
|
|
$res_copy{$res_name} = \%res_data;
|
|
|
|
foreach ( keys %res_data ) {
|
|
if ( ref $res_data{$_} eq 'HASH' ) {
|
|
$res_data{$_} = {%{$res_data{$_}}};
|
|
}
|
|
elsif ( ref $res_data{$_} eq 'ARRAY' ) {
|
|
$res_data{$_} = [@{$res_data{$_}}];
|
|
}
|
|
}
|
|
}
|
|
|
|
return %res_copy;
|
|
}
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{col_names} = __LINE__ . <<'END_OF_SUB';
|
|
sub col_names {
|
|
# -----------------------------------------------------------
|
|
# Returns the columns names sorted the right order.
|
|
#
|
|
my $self = shift;
|
|
my %cols = $self->cols;
|
|
return sort { my $ret = $self->_col_cmp($a, $b); $ret } keys %cols;
|
|
}
|
|
END_OF_SUB
|
|
|
|
# self explainatory
|
|
$COMPILE{ordered_columns} = __LINE__ . <<'END_OF_SUB';
|
|
sub ordered_columns { return shift->col_names(@_) }
|
|
END_OF_SUB
|
|
|
|
sub name {
|
|
# -----------------------------------------------------------
|
|
# $obj->name;
|
|
# -----------
|
|
# Returns a list of current relation names
|
|
#
|
|
# $obj->name(@names);
|
|
# --------------------
|
|
# Returns a list of objects maching specified name.
|
|
#
|
|
my $self = shift;
|
|
if (@_) {
|
|
return map $self->{tables}->{$_}, @_
|
|
}
|
|
else {
|
|
my @names = keys %{$self->{tables}};
|
|
return wantarray ? @names : \@names;
|
|
}
|
|
}
|
|
|
|
$COMPILE{unique} = __LINE__ . <<'END_OF_SUB';
|
|
sub unique {
|
|
# -----------------------------------------------------------
|
|
# $obj->unique;
|
|
# -------------
|
|
# Returns an array containing all the array refs
|
|
# for all the uniques.
|
|
#
|
|
# $obj->unique($field_name);
|
|
# ---------------------------
|
|
# Returns true if the field is unique. False otherwise.
|
|
#
|
|
my $self = shift;
|
|
my @res = ();
|
|
foreach my $table_name (sort keys %{$self->{tables}}) {
|
|
my $table = $self->{tables}->{$table_name};
|
|
my %unq = %{$table->{schema}->{unique}};
|
|
foreach my $unq (values %unq) { push @res, [ map { $table_name . "." . $_ } @{$unq} ] }
|
|
}
|
|
if (@_ == 1) {
|
|
my $s = shift;
|
|
return scalar grep { $s eq $_ } map { @{$_} } @res;
|
|
}
|
|
return wantarray ? @res : \@res;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{index} = __LINE__ . <<'END_OF_SUB';
|
|
sub index {
|
|
# -----------------------------------------------------------
|
|
# $obj->index;
|
|
# ------------
|
|
# Returns an array containing all the array refs
|
|
# for all the indexes.
|
|
#
|
|
my $self = shift;
|
|
if (@_ == 0) {
|
|
my @res = ();
|
|
foreach my $table_name (sort keys %{$self->{tables}}) {
|
|
my $table = $self->{tables}->{$table_name};
|
|
my @idx = values %{$table->{schema}->{index}};
|
|
foreach my $idx (@idx) { push @res, [ map { $table_name . "." . $_ } @{$idx} ] }
|
|
}
|
|
return wantarray ? @res : \@res;
|
|
}
|
|
else { return $self->error('BADARGS', 'FATAL', '$obj->index;') }
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{pk} = __LINE__ . <<'END_OF_SUB';
|
|
sub pk {
|
|
# -----------------------------------------------------------
|
|
# $obj->pk;
|
|
# ---------
|
|
# This method returns the columns reprensenting what
|
|
# would be the primary key of our JoinRelation if it
|
|
# ever existed.
|
|
#
|
|
# Tables which are referenced by other tables primary
|
|
# key shall not be exported, because they are the 'one'
|
|
# entities in a one-to-many relation.
|
|
#
|
|
# $obj->pk($field_name);
|
|
# -----------------------
|
|
# Returns true if the field is in the primary
|
|
# key list. Returns false otherwise.
|
|
#
|
|
my $self = shift;
|
|
if (@_ == 0) {
|
|
my @result = ();
|
|
my @referencing = $self->_referenced_relations;
|
|
foreach my $referencing (@referencing) { push @result, map { $referencing->{name} .'.'. $_ } @{$referencing->{schema}->{pk}}; }
|
|
return sort { my $ret = $self->_col_cmp($a, $b); $ret; } @result;
|
|
}
|
|
elsif (@_ == 1) {
|
|
my $name = $self->_complete_name(shift);
|
|
return scalar grep { $name eq $_ } @{$self->{schema}->{pk}};
|
|
}
|
|
else { $self->error('BADARGS', 'FATAL', '$obj->pk;') }
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{fk} = __LINE__ . <<'END_OF_SUB';
|
|
sub fk {
|
|
# -----------------------------------------------------------
|
|
# $obj->fk;
|
|
# ---------
|
|
# returns a list of relation names which are referenced
|
|
# by the current relation.
|
|
#
|
|
# $obj->fk(RELATION_NAME);
|
|
# -------------------------
|
|
# returns a hashref for relation RELATION_NAME which
|
|
# keys are the current relation "source" schema and which
|
|
# values are the "target" schema.
|
|
#
|
|
my $self = shift;
|
|
if (@_ > 1) { $self->error('BADARGS', 'FATAL', '$obj->fk; or $obj->fk($table_name)') }
|
|
if (@_ == 1) {
|
|
my $res = {};
|
|
my $target = shift;
|
|
foreach my $rel (values %{$self->{tables}}) {
|
|
foreach my $rel_target (keys %{$rel->{schema}->{fk}}) {
|
|
if ($target eq $rel_target) {
|
|
my $h = $rel->{schema}->{fk}->{$rel_target};
|
|
foreach my $k (keys %{$h}) { $res->{$rel->{name} .'.'. $k} = $h->{$k} }
|
|
}
|
|
}
|
|
}
|
|
return wantarray ? %{$res} : $res;
|
|
}
|
|
else {
|
|
my @res;
|
|
foreach my $rel (values %{$self->{tables}}) {
|
|
foreach my $fk (keys %{$rel->{schema}->{fk}}) {
|
|
push @res, $fk unless ($self->{tables}->{$fk});
|
|
}
|
|
}
|
|
return wantarray ? @res : \@res;
|
|
}
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{fk_tables} = __LINE__ . <<'END_OF_SUB';
|
|
sub fk_tables {
|
|
# -----------------------------------------------------------
|
|
# $obj->fk_tables;
|
|
# ----------------
|
|
# Returns a list of table that reference any
|
|
# of the table that's in the current joinrelation.
|
|
#
|
|
# $obj->fk_tables($table_name);
|
|
# ------------------------------
|
|
# Returns true if $table_name is the name of a
|
|
# table that's referencing any of the tables that's
|
|
# in the current joinrelation.
|
|
#
|
|
my $self = shift;
|
|
my @result = $self->_minus( [ map { @{$_->{schema}->{fk_tables}} } values %{$self->{tables}} ], [ $self->name ] ); # very evil (c)
|
|
if (@_ == 1) {
|
|
my $check = shift;
|
|
return scalar grep { $check eq $_ } @result;
|
|
}
|
|
return wantarray ? @result : \@result;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{all_indexes} = __LINE__ . <<'END_OF_SUB';
|
|
sub all_indexes {
|
|
# -----------------------------------------------------------
|
|
# $obj->all_indexes;
|
|
# ------------------
|
|
# Returns an array reference with all the array refs
|
|
# from the indexes and the uniques.
|
|
#
|
|
my $self = shift;
|
|
return wantarray ? [@{$self->unique}, @{$self->index}] : @{$self->unique}, @{$self->index};
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{ai} = __LINE__ . <<'END_OF_SUB';
|
|
sub ai {
|
|
# -----------------------------------------------------------
|
|
# ai makes no sense in a Relation therefore I return nothing
|
|
#
|
|
my $self = shift;
|
|
my @res;
|
|
foreach my $rel (values %{$self->{tables}}) {
|
|
my $ai = $rel->{schema}->{ai} or next;
|
|
$ai = $rel->{name} . '.' . $ai;
|
|
push @res, $ai;
|
|
}
|
|
return unless @res;
|
|
return wantarray ? @res : \@res;
|
|
|
|
}
|
|
END_OF_SUB
|
|
|
|
# ------------------------------------------------------------------------------------- #
|
|
# INTERNAL METHODS #
|
|
# ------------------------------------------------------------------------------------- #
|
|
|
|
$COMPILE{_build_cond} = __LINE__ . <<'END_OF_SUB';
|
|
sub _build_cond {
|
|
# -----------------------------------------------------------
|
|
# this subroutine is made to build conditions which may not
|
|
# be a Condition object for selects and deletes.
|
|
#
|
|
my ($self, $condition) = @_;
|
|
my $prefix = $self->{connect}->{PREFIX};
|
|
if (! defined $condition) {
|
|
return;
|
|
}
|
|
elsif (ref $condition eq 'HASH') {
|
|
my $tmp = new GT::SQL::Condition;
|
|
while (my ($col, $val) = each %$condition) {
|
|
$col = $self->_complete_name($col);
|
|
$tmp->add($col => '=' => $val);
|
|
}
|
|
return $tmp;
|
|
}
|
|
elsif (ref $condition eq 'ARRAY') {
|
|
my $tmp = new GT::SQL::Condition (@{$condition});
|
|
return $tmp;
|
|
}
|
|
elsif (length $prefix and (ref $condition eq 'GT::SQL::Condition')) {
|
|
$self->_build_prefixed_cond($prefix, $condition);
|
|
return $condition;
|
|
}
|
|
else {
|
|
return $condition;
|
|
}
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_build_prefixed_cond} = __LINE__ . <<'END_OF_SUB';
|
|
sub _build_prefixed_cond {
|
|
# -----------------------------------------------------------
|
|
# $obj->_build_prefixed_cond($prefix, $cond)
|
|
# ---------------------------------
|
|
#
|
|
my ($self, $prefix, $condition) = @_;
|
|
foreach (@{$condition->{cond}}) {
|
|
if (ref $_ eq 'ARRAY') {
|
|
if ($_->[0] =~ /^[\w\.]+$/) {
|
|
$_->[0] = $self->_complete_name($_->[0]);
|
|
}
|
|
}
|
|
elsif (ref $_ eq 'GT::SQL::Condition') {
|
|
$self->_build_prefixed_cond($prefix, $_);
|
|
}
|
|
}
|
|
return $condition;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_complete_name} = __LINE__ . <<'END_OF_SUB';
|
|
sub _complete_name {
|
|
# -----------------------------------------------------------
|
|
# Returns a Table.Attribute name of a column given Attribute, if possible.
|
|
# Takes an optional second argument - if passed and true, seeing 'abc.xyz' will
|
|
# return undef if 'abc' isn't a valid table. Without the true second argument,
|
|
# such a situation causes a fatal error.
|
|
#
|
|
my $self = shift;
|
|
my $col = shift or return $self->error('BADARGS', 'FATAL', "No column name specified.");
|
|
my $ignore_unknown = shift;
|
|
|
|
# if column name is a scalar reference, just throw in the raw colname
|
|
ref $col eq 'SCALAR' and return $$col;
|
|
|
|
# try to handle fully qualified column names
|
|
my ($relname, $colname) = split /\./, $col;
|
|
if ($relname and $colname) {
|
|
if (exists $self->{tables}->{$relname}) {
|
|
return $col;
|
|
}
|
|
else {
|
|
my $prefix = $self->{connect}->{PREFIX};
|
|
if (exists $self->{tables}->{$prefix.$relname}) {
|
|
return $prefix.$relname.".".$colname;
|
|
}
|
|
elsif ($ignore_unknown) {
|
|
return undef;
|
|
}
|
|
else {
|
|
return $self->error('BADCOLS', 'FATAL', $col);
|
|
}
|
|
}
|
|
}
|
|
|
|
# Otherwise, no . in column name.
|
|
my $found = 0;
|
|
my $return = $col;
|
|
foreach my $rel (values %{$self->{tables}}) {
|
|
my %h = %{$rel->{schema}->{cols}};
|
|
if (exists $h{$col}) {
|
|
$found++;
|
|
$return = $rel->{name} . '.' . $col;
|
|
}
|
|
}
|
|
if ($found > 1) {
|
|
return $self->error('BADCOLS', 'FATAL', $col);
|
|
}
|
|
return $return;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_col_cmp} = __LINE__ . <<'END_OF_SUB';
|
|
sub _col_cmp {
|
|
# -----------------------------------------------------------
|
|
# $a is something like TABLE.COL
|
|
# this method is used to sort the columns in the right order.
|
|
#
|
|
my ($self, $a, $b) = @_;
|
|
|
|
$a and !$b and return -1;
|
|
$b and !$a and return 1;
|
|
!$a and !$b and return 0;
|
|
|
|
my $one = $self->_complete_name($a);
|
|
my $two = $self->_complete_name($b);
|
|
my ($one_tab, $one_col) = split /\./, $one;
|
|
my ($two_tab, $two_col) = split /\./, $two;
|
|
|
|
if ($one_tab eq $two_tab) {
|
|
return 0 if (!$one_tab or !$two_tab);
|
|
return ($self->{tables}->{$one_tab}->{schema}->{cols}->{$one_col}->{pos} <=> $self->{tables}->{$one_tab}->{schema}->{cols}->{$two_col}->{pos});
|
|
}
|
|
else {
|
|
my @tables_ord = @{$self->{tables_ord}};
|
|
while (my $table = shift(@tables_ord)) {
|
|
if ($table eq $one_tab) { return -1 }
|
|
if ($table eq $two_tab) { return 1 }
|
|
}
|
|
return 0;
|
|
}
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_insert} = __LINE__ . <<'END_OF_SUB';
|
|
sub _insert {
|
|
# -----------------------------------------------------------
|
|
# $obj->_insert($split);
|
|
# --------------------------------
|
|
# Inserts a record in the current Relation
|
|
# inserting where it's possible to.
|
|
#
|
|
my $self = shift;
|
|
my $split = shift;
|
|
|
|
my @referenced = $self->_referenced_relations;
|
|
my @referencing = $self->_referencing_relations;
|
|
|
|
my (%added, $err);
|
|
foreach my $rel (@referenced) {
|
|
$self->{tables}->{$rel->{name}}->_check_insert($split->{$rel->{name}}) or return;
|
|
my $sth = $rel->insert($split->{$rel->{name}}) or return;
|
|
unless ($sth) {
|
|
my $errcode = $GT::SQL::errcode;
|
|
if ($errcode ne 'UNIQUE') { $err = 1; last }
|
|
else { next }
|
|
}
|
|
if ($rel->{schema}->{ai}) {
|
|
$added{$rel->{name}} = { $rel->{schema}->{ai} => $sth->insert_id };
|
|
}
|
|
else {
|
|
$added{$rel->{name}} = $split->{$rel->{name}};
|
|
}
|
|
}
|
|
if ($err) {
|
|
for my $rel_name (keys %added) {
|
|
my $rel = $self->{tables}->{$rel_name};
|
|
my $id = $added{$rel_name};
|
|
$rel->delete($id);
|
|
}
|
|
return;
|
|
}
|
|
foreach my $rel (@referencing) {
|
|
my %fk = %{$rel->{schema}->{fk}};
|
|
my $name = $rel->{name};
|
|
|
|
for my $ft (keys %fk) {
|
|
if (exists $added{$ft} and $self->{tables}->{$ft}->{schema}->{ai}) {
|
|
my $h = $fk{$ft};
|
|
my $rec = $self->{tables}->{$ft};
|
|
for (keys %{$h}) {
|
|
unless ($split->{$name}->{$_}) {
|
|
if ($h->{$_} eq $rec->{schema}->{ai}) {
|
|
$split->{$name}->{$_} = $added{$ft}->{$h->{$_}};
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
my $sth = $rel->insert(%{$split->{$name}});
|
|
unless ($sth) { $err = 1; last; }
|
|
if ($rel->{schema}->{ai}) {
|
|
$added{$rel->{name}} = { $rel->{schema}->{ai} => $sth->insert_id };
|
|
}
|
|
else {
|
|
$added{$rel->{name}} = $split->{$name};
|
|
}
|
|
}
|
|
if ($err) {
|
|
for my $rel_name (keys %added) {
|
|
my $rel = $self->{tables}->{$rel_name};
|
|
my $id = $added{$rel_name};
|
|
$rel->delete($id);
|
|
}
|
|
return;
|
|
}
|
|
|
|
# Return a hash ref of primary key => value.
|
|
my %ids;
|
|
foreach my $column_hash (values %added) {
|
|
foreach my $col (keys %{$column_hash}) {
|
|
$ids{$col} = $column_hash->{$col};
|
|
}
|
|
}
|
|
return \%ids;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_add} = __LINE__ . <<'END_OF_SUB';
|
|
sub _add {
|
|
# -----------------------------------------------------------
|
|
# $obj->_insert($split);
|
|
# --------------------------------
|
|
# Inserts a record in the current Relation
|
|
# inserting where it's possible to.
|
|
#
|
|
my $self = shift;
|
|
my $split = shift;
|
|
my @referenced = $self->_referenced_relations;
|
|
my @referencing = $self->_referencing_relations;
|
|
|
|
my (%added, $err);
|
|
foreach my $rel (@referenced) {
|
|
$self->{tables}->{$rel->{name}}->_check_insert($split->{$rel->{name}}) or return;
|
|
my $id = $rel->add($split->{$rel->{name}}) or return;
|
|
unless ($id) {
|
|
my $errcode = $GT::SQL::errcode;
|
|
if ($errcode ne 'UNIQUE') { $err = 1; last }
|
|
else { next }
|
|
}
|
|
if ($rel->{schema}->{ai}) {
|
|
$added{$rel->{name}} = { $rel->{schema}->{ai} => $id };
|
|
}
|
|
else {
|
|
$added{$rel->{name}} = $split->{$rel->{name}};
|
|
}
|
|
}
|
|
if ($err) {
|
|
|
|
for my $rel_name (keys %added) {
|
|
my $rel = $self->{tables}->{$rel_name};
|
|
my $id = $added{$rel_name};
|
|
$rel->delete($id);
|
|
}
|
|
return;
|
|
}
|
|
foreach my $rel (@referencing) {
|
|
my %fk = %{$rel->{schema}->{fk}};
|
|
my $name = $rel->{name};
|
|
|
|
for my $ft (keys %fk) {
|
|
if (exists $added{$ft} and $self->{tables}->{$ft}->{schema}->{ai}) {
|
|
my $h = $fk{$ft};
|
|
my $rec = $self->{tables}->{$ft};
|
|
for (keys %{$h}) {
|
|
unless ($split->{$name}->{$_}) {
|
|
if ($h->{$_} eq $rec->{schema}->{ai}) {
|
|
$split->{$name}->{$_} = $added{$ft}->{$h->{$_}};
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
my $id = $rel->add($split->{$name});
|
|
unless ($id) { $err = 1; last; }
|
|
if ($rel->{schema}->{ai}) {
|
|
$added{$rel->{name}} = { $rel->{schema}->{ai} => $id };
|
|
}
|
|
else {
|
|
$added{$rel->{name}} = $split->{$name};
|
|
}
|
|
}
|
|
if ($err) {
|
|
for my $rel_name (keys %added) {
|
|
my $rel = $self->{tables}->{$rel_name};
|
|
my $id = $added{$rel_name};
|
|
$rel->delete($id);
|
|
}
|
|
return;
|
|
}
|
|
|
|
# Return a hash ref of primary key => value.
|
|
my %ids;
|
|
foreach my $table_name ( keys %added ) {
|
|
foreach my $col (keys %{$added{$table_name}}) {
|
|
$ids{"$table_name.".$col} = $added{$table_name}->{$col};
|
|
}
|
|
}
|
|
|
|
return \%ids;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_minus} = __LINE__ . <<'END_OF_SUB';
|
|
sub _minus {
|
|
# -----------------------------------------------------------
|
|
# _minus($ary1, $ary2);
|
|
# ----------------------
|
|
# $ary1 and $ary2 being two array refs,
|
|
# returns a list of all elements in $ary1
|
|
# which are not in $ary2.
|
|
#
|
|
my ($self, $ary1, $ary2);
|
|
if (@_ == 0 || @_ == 1) { return }
|
|
elsif (@_ == 2) { ($ary1, $ary2) = @_ }
|
|
else { ($self, $ary1, $ary2) = @_ }
|
|
my @a1 = @{$ary1};
|
|
my @a2 = @{$ary2};
|
|
my @result;
|
|
foreach my $elt1 (@a1) {
|
|
my $push = 1;
|
|
foreach my $elt2 (@a2) {
|
|
$push = 0 if ($elt1 eq $elt2);
|
|
}
|
|
push @result, $elt1 if ($push == 1);
|
|
}
|
|
return @result;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_query} = __LINE__ . <<'END_OF_SUB';
|
|
sub _query {
|
|
# -----------------------------------------------------------
|
|
# $self->_query;
|
|
# --------------
|
|
# This function takes in special query arguments and turns them
|
|
# into a $opts array before doing the actual select on the
|
|
# database.
|
|
#
|
|
my $self = shift;
|
|
scalar $self->name() or return $self->error("NOTABLE", "FATAL");
|
|
my $opts = $self->common_param(@_) or return $self->error('BADARGS', 'FATAL', '$obj->_query( HASH or HASH_REF or CGI ) only.');
|
|
|
|
|
|
# Strip out values that are empty or blank (as query is generally
|
|
# derived from cgi input).
|
|
my %input = map { $_ => $opts->{$_} } grep { defined $opts->{$_} and $opts->{$_} =~ /\S/ } keys %$opts;
|
|
$opts = \%input;
|
|
|
|
# Prefix column names.
|
|
foreach my $field (keys %$opts) {
|
|
if ($field =~ /^(.*)-(gt|lt|le|ge|opt)$/) {
|
|
my $opt = $2;
|
|
if (my $full = $self->_complete_name("$1", 1)) {
|
|
$opts->{"$full-$opt"} = $opts->{$field};
|
|
}
|
|
}
|
|
else {
|
|
if (my $full = $self->_complete_name($field, 1)) {
|
|
$opts->{$full} = $opts->{$field};
|
|
}
|
|
}
|
|
}
|
|
|
|
# Set search options and get query condition.
|
|
my $in = $self->_get_search_opts($opts);
|
|
my $cond = $self->build_query_cond($opts, scalar $self->cols);
|
|
|
|
my $offset = ($in->{nh} - 1) * $in->{mh};
|
|
$self->select_options("ORDER BY $in->{sb} $in->{so}") if ($in->{sb});
|
|
$self->select_options("LIMIT $in->{mh} OFFSET $offset") unless ($in->{mh} == -1);
|
|
my @sel = ();
|
|
if ($cond) { push @sel, $cond }
|
|
if ($in->{rs} and $cond) { push @sel, $in->{rs} }
|
|
if ($opts->{left_join} and $cond) { push @sel,'left_join' }
|
|
my $sth = $self->select(@sel) or return;
|
|
return $sth;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_split_schema} = __LINE__ . <<'END_OF_SUB';
|
|
sub _split_schema {
|
|
# -----------------------------------------------------------
|
|
# $obj->_split_schema($hashref);
|
|
# -------------------------------
|
|
# Turns { Table1.Attribute1 => value1,
|
|
# Table1.Attribute2 => value2,
|
|
# Table2.Attribute1 => value3 }
|
|
#
|
|
# into { Table1 => { Attribute1 => value1,
|
|
# Attribute2 => value2 }
|
|
# Table2 => { Attribute1 => value1 } }
|
|
#
|
|
# $obj->_split_schema($col1 => $val1,
|
|
# ...,
|
|
# $coln => $valn);
|
|
#
|
|
# it also looks if a field is referencing
|
|
# another, and if so duplicates the field
|
|
# key and value in the target table provided
|
|
# that this target table is in the current
|
|
# relation object.
|
|
#
|
|
my $self = shift;
|
|
my $arg;
|
|
if (ref $_[0] eq 'HASH') { $arg = shift }
|
|
elsif (not @_ % 2 and defined $_[0]) { $arg = {@_} }
|
|
else { return $self->error('BADARGS', 'FATAL', '$self->_split_schema(%hash)') }
|
|
my $result = {};
|
|
|
|
# first of all, some of the fields may not be specifying
|
|
# the table they belong to.
|
|
foreach my $col (keys %{$arg}) {
|
|
if (my $relname = $self->_complete_name($col, 1)) {
|
|
$arg->{$relname} = delete $arg->{$col};
|
|
}
|
|
}
|
|
|
|
# then, we separate fields in function of
|
|
# the table name that they have.
|
|
foreach my $complete_field (keys %{$arg}) {
|
|
next if (CORE::index($complete_field, '.') == -1);
|
|
my ($tablename, $fieldname) = split /\./, $complete_field;
|
|
$result->{$tablename} = {} unless (defined $result->{$tablename});
|
|
$result->{$tablename}->{$fieldname} = $arg->{$complete_field};
|
|
}
|
|
|
|
# then, for each relation in our join object, complete
|
|
# names in $result
|
|
foreach my $relation (values %{$self->{tables}}) {
|
|
my $relation_name = $relation->{name};
|
|
|
|
# for all $relation foreign keys which are in $self
|
|
my %target_relation_names = %{$relation->{schema}->{fk}};
|
|
|
|
foreach my $target_relation_name (keys %target_relation_names) {
|
|
|
|
# if the target relation exists in our join relation
|
|
# object and in our $hash
|
|
if (defined $self->{tables}->{$target_relation_name} and defined $result->{$target_relation_name}) {
|
|
|
|
# then in $hash we set the values of the fields
|
|
# for the target relation depending on the values
|
|
# of the source relation.
|
|
my $fk = $relation->{schema}->{fk}->{$target_relation_name};
|
|
foreach my $key (keys %{$fk}) {
|
|
my $value = $fk->{$key};
|
|
$result->{$target_relation_name} = {} unless defined $result->{$target_relation_name};
|
|
|
|
my $fk_key = $relation->{schema}->{fk}->{$target_relation_name}->{$key};
|
|
$result->{$relation_name}->{$key} = $result->{$target_relation_name}->{$fk_key}
|
|
if defined $result->{$target_relation_name}->{$fk_key};
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return $result;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_referenced_relations} = __LINE__ . <<'END_OF_SUB';
|
|
sub _referenced_relations {
|
|
# -----------------------------------------------------------
|
|
# $obj->_top_level_relations;
|
|
# ---------------------------
|
|
# This method returns the relations in the current
|
|
# which are referenced by other tables in the current join
|
|
# relation.
|
|
#
|
|
my $self = shift;
|
|
my %names = map { $_ => 1 } keys %{$self->{tables}};
|
|
foreach my $rel (values %{$self->{tables}}) {
|
|
foreach my $fk (keys %{$rel->{schema}->{fk}}) {
|
|
delete $names{$fk} unless ($fk eq $rel->{name})
|
|
}
|
|
}
|
|
my @referenced = _minus([ values %{$self->{tables}} ], [ map {$self->{tables}->{$_}} keys %names ]);
|
|
return @referenced;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_referencing_relations} = __LINE__ . <<'END_OF_SUB';
|
|
sub _referencing_relations {
|
|
# -----------------------------------------------------------
|
|
# $obj->_referencing_relations;
|
|
# -----------------------------
|
|
# This method returns the tables in the current
|
|
# relation which are not referenced by any other
|
|
# tables in this relation.
|
|
#
|
|
my $self = shift;
|
|
my %names = map { $_ => 1 } keys %{$self->{tables}};
|
|
foreach my $rel (values %{$self->{tables}}) {
|
|
foreach my $fk (keys %{$rel->{schema}->{fk}}) {
|
|
delete $names{$fk} unless ($fk eq $rel->{name})
|
|
}
|
|
}
|
|
return map {$self->{tables}->{$_}} keys %names;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_delete_cascade} = __LINE__ . <<'END_OF_SUB';
|
|
sub _delete_cascade {
|
|
# -----------------------------------------------------------
|
|
# $obj->_delete_cascade($cond);
|
|
# ------------------------------
|
|
# This method is used internaly to delete all the rows
|
|
# that match $cond for that joinrelation object.
|
|
#
|
|
my $self = shift;
|
|
my $count = 0;
|
|
|
|
my @ordered_columns = $self->col_names;
|
|
my $q = $self->select(\@ordered_columns, @_) or return;
|
|
while (my $array = $q->fetchrow_arrayref) {
|
|
$count++;
|
|
|
|
# for each row that matches the condition
|
|
my $h = {};
|
|
for (my $i = 0; $i < @ordered_columns; $i++) {
|
|
$h->{$ordered_columns[$i]} = $array->[$i];
|
|
}
|
|
|
|
# delete each low-level table rows (i.e. referencing tables)
|
|
foreach my $referencing ($self->_referencing_relations) {
|
|
$self->_delete_row($h, $referencing);
|
|
}
|
|
|
|
# then delete each top-level table rows, if possible
|
|
# this may be broken when using tables with hierarchy
|
|
# level > 2.
|
|
foreach my $referenced ($self->_referenced_relations) {
|
|
if ($self->_can_delete($h, $referenced)) { $self->_delete_row($h, $referenced) }
|
|
}
|
|
}
|
|
return $count == 0 ? "0E0" : $count;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_can_delete} = __LINE__ . <<'END_OF_SUB';
|
|
sub _can_delete {
|
|
# -----------------------------------------------------------
|
|
# $obj->_can_delete($record, $relation);
|
|
# ---------------------------------------
|
|
# Returns true if the record can be deleted
|
|
# from this relation without breaking dependancies
|
|
# or false otherwise.
|
|
#
|
|
my ($self, $rec, $rel) = (@_);
|
|
ref $rel or $rel = $self->{tables}->{$rel};
|
|
|
|
my $allrec = $self->_split_schema($rec);
|
|
my $rel_rec = $allrec->{$rel->{name}};
|
|
|
|
# for all the schemas that exist in the database
|
|
foreach my $schema (keys %GT::SQL::Table::DATABASE) {
|
|
$self->debug("CREATING A NEW TABLE OBJECT") if ($self->{_debug} > 2);
|
|
|
|
my $relation = $self->new_table($schema);
|
|
foreach my $relation_targetname ($relation->{schema}->{fk}) {
|
|
if ($relation_targetname eq $rel->{name}) {
|
|
my $schem = $relation->{schema}->{fk}->{$relation_targetname};
|
|
|
|
# I must make a copy of this because it's a reference from Schema
|
|
# and can potentially be used later, therefore it should not be
|
|
# modified.
|
|
my $schema = { map { $_ => $schem->{$_} } keys %{$schem} };
|
|
foreach my $key (keys %{$schema}) { $schema->{$key} = $rel_rec->{$schema->{$key}} }
|
|
$relation->count($schema) and return 0;
|
|
}
|
|
}
|
|
}
|
|
return 1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_delete_row} = __LINE__ . <<'END_OF_SUB';
|
|
sub _delete_row {
|
|
# -----------------------------------------------------------
|
|
# $obj->_delete_row($record, $relation);
|
|
# ---------------------------------------
|
|
#
|
|
my ($self, $rec, $rel) = (@_);
|
|
my $allrec = $self->_split_schema($rec);
|
|
my $rel_rec = $allrec->{$rel->{name}};
|
|
foreach my $col (keys %{$rel_rec}) { delete $rel_rec->{$col} unless (defined $rel_rec->{$col}) }
|
|
$rel->delete($rel_rec, 'cascade');
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_file_cols} = __LINE__ . <<'END_OF_SUB';
|
|
sub _file_cols {
|
|
#-------------------------------------------------------------------------------
|
|
my $self = shift;
|
|
$_[0] and $self->{_file_cols} = undef;
|
|
$self->{_file_cols} and return %{$self->{_file_cols}};
|
|
my %rec = ();
|
|
for my $table_name ( keys %{$self->{tables} } ) {
|
|
my %trec = $self->{tables}->{$table_name}->_file_cols() or next;
|
|
$rec{$table_name} = \%trec;
|
|
}
|
|
return %rec;
|
|
}
|
|
END_OF_SUB
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
GT::SQL::Relation - manage multiple table joins
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
my $relation = $DB->table('Company', 'Employees');
|
|
my $sth = $relation->select( {
|
|
Company.Name => 'Gossamer Threads',
|
|
Employees.Name => 'Alex Krohn'
|
|
}, ['Employees.Salary', 'Company.City'] );
|
|
my ($salary, $city) = $sth->fetchrow_array;
|
|
print "Alex works in $city and earns $salary!\n";
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This module aims at emulating a set of tables that are related to each other
|
|
via the use of foreign keys just as if it was one big table.
|
|
|
|
The module interface should be as compatible as possible with GT::SQL::Table,
|
|
thus you should be familiar with GT::SQL::Table before even reading this.
|
|
|
|
This documentation explains the differences between GT::SQL::Relation and
|
|
GT::SQL::Table and how the module internally works as well.
|
|
|
|
=head2 How it works
|
|
|
|
GT::SQL supports the concept of foreign keys (also known as external
|
|
references). Basically, two tables that are linked together using external
|
|
references can look like that:
|
|
|
|
.-------------. .---------.
|
|
| EMPLOYEE | | COMPANY |
|
|
`-------------' `---------'
|
|
| ID | .--->ID |
|
|
| COMPANY_ID ----' | NAME |
|
|
| NAME | `---------'
|
|
| SALARY |
|
|
`-------------'
|
|
|
|
In this example, the COMPANY_ID attribute relates the fact that a an EMPLOYEE
|
|
belongs to such or such COMPANY.
|
|
|
|
Utilizing a Relation object can make these tables look like that:
|
|
|
|
.----------------------.
|
|
| EMPLOYEE-COMPANY |
|
|
`----------------------'
|
|
| EMPLOYEE.ID |
|
|
| EMPLOYEE.COMPANY_ID |
|
|
| EMPLOYEE.NAME |
|
|
| EMPLOYEE.SALARY |
|
|
| COMPANY.NAME |
|
|
`----------------------'
|
|
|
|
The first thing that can be seen from there is that COMPANY.ID has disappeared
|
|
from this "Virtual" table.
|
|
|
|
Indeed, as for a given "joined" record this value must be the same in both
|
|
tables, representing the values twice would have been a useless source of
|
|
confusion.
|
|
|
|
=head2 SELECT statements
|
|
|
|
Selecting from a Relation object is pretty simple using the GT::SQL module. As
|
|
the interface is (almost) the same as L<GT::SQL::Table>, the GT::SQL wrapper
|
|
returns Table or Relation objects depending on the arguments that are passed to
|
|
table.
|
|
|
|
# This gives me a GT::SQL::Table object for
|
|
# the EMPLOYEE table.
|
|
my $emp = $sql->table('EMPLOYEE');
|
|
|
|
# This gives me a GT::SQL::Relation object for
|
|
# the relation EMPLOYEE-COMPANY tables
|
|
my $emp_cmp = $sql->table('EMPLOYEE','COMPANY');
|
|
|
|
From there, performing a select is pretty simple:
|
|
|
|
# select all the people from a real cool company
|
|
my $sth = $emp_cmp->select( { COMPANY.NAME => "Gossamer Threads" } )
|
|
|
|
Internally, the generated SQL query would look like:
|
|
|
|
SELECT EMPLOYEE.ID, EMPLOYEE.COMPANY_ID, EMPLOYEE.NAME
|
|
EMPLOYEE.SALARY, COMPANY.NAME
|
|
FROM EMPLOYEE, COMPANY
|
|
WHERE COMPANY.NAME = 'Gossamer Threads' AND
|
|
EMPLOYEE.COMPANY_ID = COMPANY.ID
|
|
|
|
Note that the join condition is computed and automatically appended at the end
|
|
of the query, so you do not have to worry about this.
|
|
|
|
=head2 SELECT options
|
|
|
|
The select options for relation are similar to that of table, you have
|
|
select_options() which will be set for the next query done. Example:
|
|
|
|
$relation->select_options("LIMIT 10");
|
|
|
|
This would append 'LIMIT 10' to your next select query. Another useful thing
|
|
is join_on(). join_on() allows you to specify the FK relation for the nextr
|
|
select. This overrides what is in the def files. It is useful for allowing you
|
|
to have one table which will be join differently depending on what you are
|
|
doing. The argument to this are the same as to fk().
|
|
Example:
|
|
|
|
$relation->join_on( remote_table => { local_column => remote_column } );
|
|
|
|
The FK relation will be changed to this the next time you call select() but
|
|
then it will be cleared.
|
|
|
|
=head2 Listing the relation columns
|
|
|
|
* As previously said, the cols() method when invoked on a GT::SQL::Relation
|
|
object does not return all the columns, removing the duplicate external
|
|
references. So, how does it decides which column to keep and which one to
|
|
return?
|
|
|
|
In the EMPLOYEE-COMPANY example we have the constraint
|
|
EMPLOYEE.COMPANY_ID => COMPANY.ID and it keeps COMPANY_ID, i.e. the foreign key
|
|
instead of the key itself.
|
|
|
|
=head2 Relation primary key
|
|
|
|
* The pk() method has to return the table primary key. The property of a primary
|
|
key is that it is a non-null unique record identifier. When pk() is invoked on
|
|
a Relation object, this base definition is applied to construct the object
|
|
primary key.
|
|
|
|
To find a unique set of fields that makes a good primary key for a Relation
|
|
object, the following, simple algorithm is used:
|
|
|
|
. .
|
|
. for each table .
|
|
. if the table is not referenced by another table that .
|
|
. is in the current relation .
|
|
. do .
|
|
. append the current table's primary key fields to .
|
|
. the Relation primary key fields .
|
|
. end-do .
|
|
. end-if .
|
|
. end-for .
|
|
. .
|
|
|
|
This algorithm selects all the tables that represent the "many" in one-to-many
|
|
relations, and for all these tables add a list of fields which ensure a record
|
|
uniqueness.
|
|
|
|
=head2 Foreign keys management
|
|
|
|
* When invoked on a GT::SQL::Table object, the fk() method returns a hash which
|
|
has the following general structure:
|
|
|
|
{
|
|
target_table_1 => {
|
|
source_col_1 => target_col_1,
|
|
source_col_2 => target_col_2
|
|
},
|
|
target_table_2 => {
|
|
source_col_1 => target_col_1
|
|
}
|
|
}
|
|
|
|
The GT::SQL::Relation module returns a hash which has the same structure. The
|
|
only difference is that it does not returns the external references which are
|
|
managed internally.
|
|
|
|
This is done for two reasons: As one field is removed from a Relation table, it
|
|
would not have been very logical to return a structure that point to
|
|
non-existent fields.
|
|
|
|
Moreover, these internal references from the "Relation" point of view have
|
|
nothing to do with the external world and thus should not be shown.
|
|
|
|
(i.e. EMPLOYEE.COMPANY_ID |===> COMPANY.ID would not count in our example)
|
|
|
|
=head2 Inserting data
|
|
|
|
The interface for inserting data in a Relation is the same as the one that is
|
|
being used for Table. However, because rows are being inserted in a relation
|
|
one-to-many, things internally work a bit differently.
|
|
|
|
The Relation insert() method takes an optional argument, which can be
|
|
'complete' or 'abort' (default being complete).
|
|
|
|
insert() splits the relation columns into separate records that can be inserted
|
|
in a single table. However, some of the records may exist already!
|
|
|
|
for example, if we perform:
|
|
|
|
$sql = shift; # our GT::SQL object
|
|
$rel = $sql->table(qw/EMPLOYEE COMPANY/);
|
|
$rel->insert({
|
|
'EMPLOYEE.NAME' => $your_name,
|
|
'EMPLOYEE.SALARY' => $big_buck,
|
|
'COMPANY.NAME' => "Gossamer Threads"
|
|
});
|
|
|
|
Obviously the company "Gossamer Threads" already exists, but you were not in
|
|
the "EMPLOYEE" table. Thus, when 'complete' is specified (it is the default
|
|
option), the program will not complain if a record to insert already exists but
|
|
just warns and continue the insertion work.
|
|
|
|
In other words, Gossamer Threads exists already and it will not be inserted
|
|
twice, but the employee will still be inserted and will belong to this company.
|
|
|
|
On the other hand, if you specify "abort", then no data is inserted if a
|
|
record that has to be inserted would trigger an error in GT::SQL::Table.
|
|
|
|
This feature can be useful if you want to insert a relation record assuming
|
|
that none of the entities that you specify should exist.
|
|
|
|
=head2 Deleting data
|
|
|
|
Deleting data from a Relation object works using the following pattern:
|
|
|
|
. .
|
|
. for each row that matches the delete condition .
|
|
. do .
|
|
. split the row in table-based records .
|
|
. for each table that contains foreing keys from the .
|
|
. current relation object .
|
|
. do .
|
|
. delete the record .
|
|
. end-do .
|
|
. .
|
|
. for each table that is being referenced by another .
|
|
. table in the current relation object .
|
|
. do .
|
|
. delete the record unless there exists .
|
|
. some "referencing" data. .
|
|
. end-do .
|
|
. .
|
|
|
|
As I feel that this explanation is probably very confusing, let us see how it
|
|
works using our classical example (The salary column has been removed).
|
|
|
|
.-------------------------------------------------------------.
|
|
| EMPLOYEE.ID | COMPANY_ID | EMPLOYEE.NAME | COMPANY.NAME |
|
|
`-------------------------------------------------------------'
|
|
| 1 | 1 | Alex | Gossamer Threads |
|
|
|-------------|------------|---------------|------------------|
|
|
| 2 | 1 | Scott | Gossamer Threads |
|
|
|-------------|------------|---------------|------------------|
|
|
| 3 | 1 | Aki | Gossamer Threads |
|
|
`-------------------------------------------------------------'
|
|
|
|
Now let us say that we do the following:
|
|
|
|
# remove all the crazy geeks
|
|
$relation->delete({ 'EMPLOYEE.NAME' => 'Scott' });
|
|
|
|
This will remove "Scott" from the EMPLOYEE table, but of course
|
|
Gossamer Threads will not be deleted because there still exists Alex and Aki
|
|
that would reference it.
|
|
|
|
Now if we do:
|
|
|
|
$relation->delete({ 'COMPANY.NAME' => 'Gossamer Threads' });
|
|
|
|
or even
|
|
|
|
my $condition = new GT::SQL::Condition;
|
|
$condition->add(qw/EMPLOYEE.NAME LIKE %/);
|
|
$relation->delete($condition);
|
|
|
|
Then we have generated a condition that matches all the employees, this means
|
|
that when the last record will be deleted, then the company Gossamer Threads
|
|
will have no more employees and therefore will be deleted.
|
|
|
|
(Yeah, well, this is for the purpose of this example, of course this will never
|
|
happen in real life :) )
|
|
|
|
=head2 Updating records
|
|
|
|
Currently, there exists a limitation on updating records in a Relation, which
|
|
is that only the records that represent the "many" part of the Relation are
|
|
updated.
|
|
|
|
The way it proceeds to perform the update is pretty simple:
|
|
|
|
. .
|
|
. for each row that matches the update condition .
|
|
. do .
|
|
. split the row in table-based records .
|
|
. for each table that contains foreing keys from the .
|
|
. current relation object .
|
|
. do .
|
|
. update the record .
|
|
. end-do .
|
|
. .
|
|
|
|
That means that this will work:
|
|
|
|
# SALARY being a property of EMPLOYEE, it will be updated
|
|
# because EMPLOYEE references COMPANY and therefore is a
|
|
# "many"
|
|
$relation->update({ SALARY => $big_bill },
|
|
{ 'COMPANY.NAME' => 'Gossamer Threads' });
|
|
|
|
# nope, you cannot use Relation to update the COMPANY table that
|
|
# way, this will not do anything.
|
|
$relation->update({ 'COMPANY.NAME' => 'New_Name' },
|
|
{ 'COMPANY.NAME' => 'Gossamer Threads' });
|
|
|
|
Who would like to change such a great name anyway ?
|
|
|
|
=head2 Selecting Records
|
|
|
|
Select behaves exactly like L<GT::SQL::Table> select. The only difference is
|
|
the ability to specify LEFT JOINs. For instance, if you want to see a list of
|
|
Employees who don't belong to a company, you can do:
|
|
|
|
my $relation = $DB->table('Employees', 'Company');
|
|
my $cond = GT::SQL::Condition->new('Company.ID', 'IS', \'NULL');
|
|
my $sth = $relation->select('left_join', $cond);
|
|
|
|
The order of tables specified in the relation constructor is important!
|
|
|
|
In selecting columns, calling functions utilizing fully qualified column names
|
|
will cause GT::SQL::Relation to fail. Simply turn the values into references
|
|
like below.
|
|
|
|
my $sth = $relation->select("MIN(Company.ID)"); # will fail
|
|
|
|
my $sth = $relation->select(\"MIN(Company.ID)"); # will work
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
http://www.gossamer-threads.com/
|
|
|
|
=head1 VERSION
|
|
|
|
Revision: $Id: Relation.pm,v 1.102 2004/08/28 03:53:43 jagerman Exp $
|
|
|
|
=cut
|