977 lines
16 KiB
Perl
977 lines
16 KiB
Perl
#! /usr/bin/perl
|
|
# $OpenBSD: Sql.pm,v 1.37 2023/08/14 09:21:36 espie Exp $
|
|
#
|
|
# Copyright (c) 2018 Marc Espie <espie@openbsd.org>
|
|
#
|
|
# Permission to use, copy, modify, and distribute this software for any
|
|
# purpose with or without fee is hereby granted, provided that the above
|
|
# copyright notice and this permission notice appear in all copies.
|
|
#
|
|
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
|
|
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
|
|
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
|
|
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
|
|
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
|
|
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
|
|
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
|
|
# This does implement objects for an Sql Tree.
|
|
|
|
use v5.36;
|
|
|
|
package Sql::Object;
|
|
sub new($class, $name, %rest)
|
|
{
|
|
my $o = \%rest;
|
|
$o->{name} = $name;
|
|
bless $o, $class;
|
|
}
|
|
|
|
sub indent($self, $string, $plus)
|
|
{
|
|
$self->{level} //= 0;
|
|
return ' 'x(($self->{level}+$plus)).$string;
|
|
}
|
|
|
|
sub name($self)
|
|
{
|
|
return $self->{name};
|
|
}
|
|
|
|
sub drop($self)
|
|
{
|
|
return "DROP ".$self->type." IF EXISTS ".$self->name;
|
|
}
|
|
|
|
sub dump($self)
|
|
{
|
|
say $self->stringize;
|
|
}
|
|
|
|
sub add($self, @p)
|
|
{
|
|
for my $o (@p) {
|
|
$o->add_to($self);
|
|
}
|
|
return $self;
|
|
}
|
|
|
|
sub add_to($o, $c)
|
|
{
|
|
$o->{parent} = $c;
|
|
push(@{$c->{$o->category}}, $o);
|
|
}
|
|
|
|
sub prepend($self, @p)
|
|
{
|
|
for my $o (reverse @p) {
|
|
$o->prepend_to($self);
|
|
}
|
|
return $self;
|
|
}
|
|
|
|
sub prepend_to($o, $c)
|
|
{
|
|
$o->{parent} = $c;
|
|
unshift(@{$c->{$o->category}}, $o);
|
|
}
|
|
|
|
sub is_table($)
|
|
{
|
|
0
|
|
}
|
|
|
|
sub origin($self)
|
|
{
|
|
return $self->{origin};
|
|
}
|
|
|
|
sub normalize($self, $v)
|
|
{
|
|
$v =~ tr/A-Z/a-z/;
|
|
return $v;
|
|
}
|
|
|
|
sub identify($self)
|
|
{
|
|
my $string = "object ".ref($self)." named ".$self->name;
|
|
if (exists $self->{origin}) {
|
|
$string .= " (from $self->{origin})";
|
|
}
|
|
if (defined $self->{parent}) {
|
|
$string .= "(parent ".$self->{parent}->identify.")";
|
|
}
|
|
return $string;
|
|
}
|
|
|
|
sub is_view($)
|
|
{
|
|
0
|
|
}
|
|
|
|
sub is_index($)
|
|
{
|
|
0
|
|
}
|
|
|
|
package Sql::Create;
|
|
our @ISA = qw(Sql::Object);
|
|
|
|
my $register;
|
|
|
|
sub stringize($self)
|
|
{
|
|
return "CREATE ".($self->{temp} ? "TEMP ": "").$self->type.
|
|
" ".$self->name." ".join("\n", $self->contents);
|
|
}
|
|
|
|
sub sort($self)
|
|
{
|
|
$self->{columns} = [ sort {$a->name cmp $b->name} @{$self->{columns}}];
|
|
return $self;
|
|
}
|
|
|
|
sub all_tables($class)
|
|
{
|
|
return grep {$_->is_table} (sort {$a->name cmp $b->name} values %$register);
|
|
}
|
|
|
|
sub all_views($class)
|
|
{
|
|
return grep {$_->is_view} (sort {$a->name cmp $b->name} values %$register);
|
|
}
|
|
|
|
sub all_indices($class)
|
|
{
|
|
return grep {$_->is_index} (sort {$a->name cmp $b->name} values %$register);
|
|
}
|
|
|
|
sub key($class, $name)
|
|
{
|
|
return $class->find($name)->{key};
|
|
}
|
|
|
|
sub find($class, $name)
|
|
{
|
|
return $register->{$class->normalize($name)};
|
|
}
|
|
|
|
sub dump_all($class)
|
|
{
|
|
for my $v (values %$register) {
|
|
$v->dump;
|
|
}
|
|
}
|
|
|
|
sub register($self)
|
|
{
|
|
$register->{$self->normalize($self->name)} = $self;
|
|
return $self;
|
|
}
|
|
|
|
sub add_column_names($self, $name)
|
|
{
|
|
my $o = $self->find($name);
|
|
if (!defined $o) {
|
|
# print STDERR $name, "\n";
|
|
return;
|
|
}
|
|
$self->add_column_names_from($o);
|
|
}
|
|
|
|
sub add_column_names_from($self, $o)
|
|
{
|
|
for my $c ($o->columns) {
|
|
$self->{column_names}{$self->normalize($c->name)}++;
|
|
}
|
|
}
|
|
|
|
sub known_column($self, $name)
|
|
{
|
|
$name = $self->normalize($name);
|
|
for my $c ($self->columns) {
|
|
if ($self->normalize($c->name) eq $name) {
|
|
return 1;
|
|
}
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
sub is_table_column($self, $table, $name)
|
|
{
|
|
my $t = $self->find($table);
|
|
if (defined $t) {
|
|
return $t->known_column($name);
|
|
} else {
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
sub columns($self)
|
|
{
|
|
return @{$self->{columns}};
|
|
}
|
|
|
|
sub column_names($self)
|
|
{
|
|
my @names;
|
|
for my $c ($self->columns) {
|
|
next if $c->is_key;
|
|
push(@names, $c->name);
|
|
}
|
|
return @names;
|
|
}
|
|
|
|
sub temp($self)
|
|
{
|
|
$self->{temp} = 1;
|
|
return $self;
|
|
}
|
|
|
|
package Sql::Create::Table;
|
|
our @ISA = qw(Sql::Create);
|
|
|
|
sub type($)
|
|
{
|
|
"TABLE"
|
|
}
|
|
|
|
sub is_table($)
|
|
{
|
|
1
|
|
}
|
|
|
|
sub contents($self)
|
|
{
|
|
my @c;
|
|
my @d;
|
|
for my $col (@{$self->{columns}}) {
|
|
if ($col->{want_index}) {
|
|
Sql::Create::Index->new($self, $col);
|
|
}
|
|
push(@c, $col->stringize);
|
|
if ($col->{is_constraint}) {
|
|
push(@d, $col->name);
|
|
}
|
|
}
|
|
if (@d > 0) {
|
|
push(@c, "UNIQUE(".join(", ", @d). ")");
|
|
}
|
|
return "(". join(', ', @c).")";
|
|
}
|
|
|
|
sub inserter($self)
|
|
{
|
|
my (@names, @placeholders);
|
|
my $alt = $self->{ignore} ? " OR IGNORE" :
|
|
($self->{noreplace} ? "" : " OR REPLACE");
|
|
for my $c ($self->columns) {
|
|
next if $c->is_key;
|
|
push @names, $c->name;
|
|
push @placeholders, $c->placeholder;
|
|
}
|
|
return "INSERT$alt INTO ".$self->name." (".
|
|
join(', ', @names).") VALUES (".join(', ', @placeholders).")";
|
|
}
|
|
|
|
sub noreplace($self)
|
|
{
|
|
$self->{noreplace} = 1;
|
|
return $self;
|
|
}
|
|
|
|
sub ignore($self)
|
|
{
|
|
$self->{ignore} = 1;
|
|
return $self;
|
|
}
|
|
|
|
sub new($class, @p)
|
|
{
|
|
$class->SUPER::new(@p)->register;
|
|
}
|
|
|
|
package Sql::Create::View;
|
|
our @ISA = qw(Sql::Create);
|
|
sub type($)
|
|
{
|
|
"VIEW"
|
|
}
|
|
|
|
sub is_view($)
|
|
{
|
|
1
|
|
}
|
|
|
|
sub new($class, @p)
|
|
{
|
|
my $o = $class->SUPER::new(@p);
|
|
my $a = "T0001";
|
|
$o->{alias} = \$a;
|
|
$o->{select} = Sql::Select->new(@p);
|
|
$o->register;
|
|
}
|
|
|
|
sub cache($self, $name = $self->name."_Cache")
|
|
{
|
|
return "CREATE TABLE $name (". $self->{select}->cache. ")";
|
|
}
|
|
|
|
sub contents($self)
|
|
{
|
|
my @parts = ();
|
|
|
|
$self->{select}{level} = ($self->{level}//0)+4;
|
|
$self->{select}{alias} = $self->{alias};
|
|
|
|
return ("AS", $self->{select}->contents);
|
|
}
|
|
|
|
sub columns($self)
|
|
{
|
|
if (!defined $self->{select}{columns}) {
|
|
die $self->identify, " has no columns";
|
|
}
|
|
return @{$self->{select}{columns}};
|
|
}
|
|
|
|
sub add($self, @p)
|
|
{
|
|
$self->{select}->add(@p);
|
|
return $self;
|
|
}
|
|
|
|
sub prepend($self, @p)
|
|
{
|
|
$self->{select}->prepend(@p);
|
|
return $self;
|
|
}
|
|
sub sort($self)
|
|
{
|
|
$self->{select}->sort;
|
|
return $self;
|
|
}
|
|
|
|
package Sql::Select;
|
|
our @ISA = qw(Sql::Create);
|
|
|
|
|
|
sub contents($self)
|
|
{
|
|
my @parts = ();
|
|
# compute the joins
|
|
my $joins = {};
|
|
my @joins = ();
|
|
|
|
# figure out used tables
|
|
my $tables = {};
|
|
|
|
if (!defined $self->{origin}) {
|
|
die "Missing origin in ", $self->identify;
|
|
}
|
|
# and column names
|
|
$self->{column_names} = {};
|
|
|
|
for my $w (@{$self->{with}}) {
|
|
$w->{alias} = $self->{alias};
|
|
# this stuff should use double dispatch
|
|
$self->add_column_names_from($w);
|
|
push(@parts, $self->indent("WITH ".$w->name." AS", 0));
|
|
my @c = $w->contents;
|
|
my $one = shift @c;
|
|
my $last = pop @c;
|
|
push(@parts, $self->indent("($one", 4));
|
|
for my $c (@c) {
|
|
push(@parts, $self->indent($c, 5));
|
|
}
|
|
push(@parts, $self->indent("$last)", 5));
|
|
}
|
|
|
|
# this stuff should use double dispatch
|
|
$self->add_column_names($self->origin);
|
|
|
|
$tables->{$self->normalize($self->origin)}++;
|
|
|
|
for my $c (@{$self->{columns}}) {
|
|
my $j = $c->{join};
|
|
while (defined $j) {
|
|
if (!defined $joins->{$j}) {
|
|
# this stuff should use double dispatch
|
|
$self->add_column_names($j->name);
|
|
push(@joins, $j);
|
|
$joins->{$j} = $j;
|
|
if (++$tables->{$self->normalize($j->name)} == 1) {
|
|
delete $j->{alias};
|
|
} else {
|
|
$j->{alias} = ${$self->{alias}}++;
|
|
}
|
|
}
|
|
$j = $j->{join};
|
|
}
|
|
}
|
|
|
|
push(@parts, $self->indent("SELECT", 0));
|
|
my @c = @{$self->{columns}};
|
|
while (@c != 0) {
|
|
my $c = shift @c;
|
|
my $sep = @c == 0 ? '' : ',';
|
|
my @lines = split /\n/, $c->stringize;
|
|
while (@lines > 1) {
|
|
push(@parts, $self->indent(shift @lines, 4));
|
|
}
|
|
push(@parts, $self->indent(shift @lines, 4).$sep);
|
|
}
|
|
|
|
push(@parts, $self->indent("FROM ".$self->origin, 0));
|
|
for my $j (@joins) {
|
|
push(@parts, $self->indent($j->join_part, 4));
|
|
# next if $j->is_natural;
|
|
my @p = $j->on_part($self);
|
|
if (@p > 0) {
|
|
push(@parts, $self->indent("ON ".join(" AND ", @p), 8));
|
|
}
|
|
}
|
|
if (defined $self->{group}) {
|
|
push(@parts, $self->indent("GROUP BY ".
|
|
join(", ", map {$_->name} @{$self->{group}}), 4));
|
|
}
|
|
if (defined $self->{order}) {
|
|
push(@parts, $self->indent("ORDER BY ".
|
|
join(", ", map {$_->name} @{$self->{order}}), 4));
|
|
}
|
|
return @parts;
|
|
}
|
|
|
|
sub is_unique_name($self, $name)
|
|
{
|
|
my $c = $self->{column_names}{$self->normalize($name)};
|
|
if (!defined $c) {
|
|
die "$name not registered in ", $self->identify;
|
|
}
|
|
return $c == 1;
|
|
}
|
|
|
|
sub cache($self)
|
|
{
|
|
my @c;
|
|
my $base = Sql::Create->find($self->origin);
|
|
for my $c (@{$self->{columns}}) {
|
|
my $type = "TEXT";
|
|
if (defined $c->{join}) {
|
|
my $t = Sql::Create->find($c->{join}->name);
|
|
for my $c2 (@{$t->{columns}}) {
|
|
if ($c2->name eq $c->origin) {
|
|
$type = $c2->type;
|
|
last;
|
|
}
|
|
}
|
|
} else {
|
|
for my $c2 (@{$base->{columns}}) {
|
|
if ($c2->name eq $c->origin) {
|
|
$type = $c2->type;
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
push @c, $c->name." ".$type;
|
|
}
|
|
return join(', ', @c);
|
|
}
|
|
|
|
package Sql::With;
|
|
our @ISA = qw(Sql::Object);
|
|
sub category($)
|
|
{
|
|
"with"
|
|
}
|
|
|
|
sub new($class, @p)
|
|
{
|
|
my $o = $class->SUPER::new(@p);
|
|
$o->{select} = Sql::Select->new(@p);
|
|
return $o;
|
|
}
|
|
|
|
sub contents($self)
|
|
{
|
|
return $self->{select}->contents;
|
|
}
|
|
|
|
sub add($self, @p)
|
|
{
|
|
$self->{select}->add(@p);
|
|
return $self;
|
|
}
|
|
|
|
sub prepend($self, @p)
|
|
{
|
|
$self->{select}->prepend(@p);
|
|
return $self;
|
|
}
|
|
|
|
sub columns($self)
|
|
{
|
|
return $self->{select}->columns;
|
|
}
|
|
|
|
package Sql::Order;
|
|
our @ISA = qw(Sql::Object);
|
|
sub category($)
|
|
{
|
|
"order"
|
|
}
|
|
|
|
package Sql::Group;
|
|
our @ISA = qw(Sql::Object);
|
|
sub category($)
|
|
{
|
|
"group"
|
|
}
|
|
|
|
package Sql::Column;
|
|
our @ISA = qw(Sql::Object);
|
|
sub category($)
|
|
{
|
|
"columns"
|
|
}
|
|
|
|
sub notnull($self)
|
|
{
|
|
$self->{notnull} = 1;
|
|
return $self;
|
|
}
|
|
|
|
sub null($self)
|
|
{
|
|
delete $self->{notnull};
|
|
return $self;
|
|
}
|
|
|
|
sub unique($self)
|
|
{
|
|
$self->{unique} = 1;
|
|
return $self;
|
|
}
|
|
|
|
sub indexed($self)
|
|
{
|
|
$self->{want_index} = 1;
|
|
return $self;
|
|
}
|
|
|
|
sub stringize($self)
|
|
{
|
|
my @c = ($self->name, $self->type);
|
|
if ($self->{notnull}) {
|
|
push(@c, "NOT NULL");
|
|
}
|
|
if ($self->{unique}) {
|
|
push(@c, "UNIQUE");
|
|
}
|
|
if ($self->{references}) {
|
|
push(@c, "REFERENCES $self->{references}{table}(".
|
|
$self->reference_field.")");
|
|
}
|
|
return join(" ", @c);
|
|
}
|
|
|
|
sub placeholder($)
|
|
{
|
|
'?';
|
|
}
|
|
|
|
sub is_key($)
|
|
{
|
|
0
|
|
}
|
|
|
|
sub constraint($self)
|
|
{
|
|
$self->{is_constraint} = 1;
|
|
return $self;
|
|
}
|
|
package Sql::Column::Integer;
|
|
our @ISA = qw(Sql::Column);
|
|
|
|
sub type($)
|
|
{
|
|
"INTEGER"
|
|
}
|
|
|
|
sub reference_field($self)
|
|
{
|
|
if (defined $self->{references}{field}) {
|
|
return $self->{references}{field};
|
|
} else {
|
|
my $table = $self->{references}{table};
|
|
my $k = Sql::Create::Table->key($table);
|
|
if (defined $k) {
|
|
return $k->name;
|
|
} else {
|
|
my $parent = "???";
|
|
if (defined $self->{parent}) {
|
|
$parent = $self->{parent}->name;
|
|
}
|
|
die "Can't reference $table from field ",$self->name,
|
|
" in $parent";
|
|
}
|
|
}
|
|
}
|
|
|
|
sub may_reference($self, $table, $field = undef)
|
|
{
|
|
$self->{references}{table} = $table;
|
|
$self->{references}{field} = $field if defined $field;
|
|
return $self;
|
|
}
|
|
|
|
sub references($self, $table, $field = undef)
|
|
{
|
|
return $self->may_reference($table, $field)->notnull;
|
|
}
|
|
|
|
sub placeholder($self)
|
|
{
|
|
if (!defined $self->{references}) {
|
|
return '?';
|
|
}
|
|
my $table = $self->{references}{table};
|
|
|
|
my ($key, $value);
|
|
for my $c (Sql::Create->find($table)->columns) {
|
|
if ($c->is_key) {
|
|
$key = $c->name;
|
|
} elsif (defined $value) {
|
|
return '?'; # can't match multiple fields
|
|
} else {
|
|
$value = $c->name;
|
|
}
|
|
}
|
|
if (defined $key && defined $value) {
|
|
return "(SELECT $key FROM $table WHERE $value=?)";
|
|
} else {
|
|
return '?';
|
|
}
|
|
}
|
|
|
|
|
|
package Sql::Column::View;
|
|
our @ISA = qw(Sql::Column);
|
|
|
|
# this is the code I need to rewrite to provide column names based on the
|
|
# container or the join
|
|
sub stringize($self)
|
|
{
|
|
if ($self->{parent}->is_unique_name($self->origin)) {
|
|
if ($self->origin eq $self->name) {
|
|
return $self->name;
|
|
} else {
|
|
return $self->origin." AS ".$self->name;
|
|
}
|
|
} else {
|
|
return $self->stringize_with_alias;
|
|
}
|
|
}
|
|
|
|
sub stringize_with_alias($self)
|
|
{
|
|
return $self->expr." AS ".$self->name;
|
|
}
|
|
|
|
sub expr($self, @p)
|
|
{
|
|
return $self->column(@p);
|
|
}
|
|
|
|
|
|
sub column($self, $name = $self->origin)
|
|
{
|
|
if ($self->{parent}->is_unique_name($name)) {
|
|
return $name;
|
|
}
|
|
if (defined $self->{join} &&
|
|
Sql::Create->is_table_column($self->{join}->name, $name)) {
|
|
return $self->{join}->join_table.".".$name;
|
|
} else {
|
|
return $self->{parent}->origin.".".$name;
|
|
}
|
|
}
|
|
|
|
sub group_by($self)
|
|
{
|
|
$self->{group_by} = 1;
|
|
return $self;
|
|
}
|
|
|
|
sub join_table($self)
|
|
{
|
|
return $self->{parent}->origin;
|
|
}
|
|
|
|
sub join($self, @j)
|
|
{
|
|
my $subject = $self;
|
|
for my $j (@j) {
|
|
$subject->{join} = $j;
|
|
$j->{previous} = $subject;
|
|
$subject = $j;
|
|
}
|
|
return $self;
|
|
}
|
|
|
|
sub left($self)
|
|
{
|
|
if (defined $self->{join}) {
|
|
$self->{join}->left;
|
|
}
|
|
return $self;
|
|
}
|
|
|
|
sub new($class, @p)
|
|
{
|
|
my $o = $class->SUPER::new(@p);
|
|
$o->{origin} //= $o->name;
|
|
return $o;
|
|
}
|
|
|
|
sub add_to($self, $container)
|
|
{
|
|
$self->SUPER::add_to($container);
|
|
if ($self->{group_by}) {
|
|
push(@{$container->{group}}, $self);
|
|
}
|
|
}
|
|
|
|
sub prepend_to($self, $container)
|
|
{
|
|
$self->SUPER::prepend_to($container);
|
|
if ($self->{group_by}) {
|
|
unshift(@{$container->{group}}, $self);
|
|
}
|
|
}
|
|
|
|
package Sql::Column::View::Expr;
|
|
our @ISA = qw(Sql::Column::View);
|
|
|
|
sub stringize($self)
|
|
{
|
|
return $self->stringize_with_alias;
|
|
}
|
|
|
|
package Sql::Column::View::Concat;
|
|
our @ISA = qw(Sql::Column::View::Expr);
|
|
|
|
sub new($class, @p)
|
|
{
|
|
my $o = $class->SUPER::new(@p);
|
|
$o->{separator} //= ' ';
|
|
return $o;
|
|
}
|
|
|
|
sub expr($self)
|
|
{
|
|
return "group_concat(".$self->column.", '".$self->{separator}."')";
|
|
}
|
|
|
|
package Sql::Column::Text;
|
|
our @ISA = qw(Sql::Column);
|
|
sub type($)
|
|
{
|
|
"TEXT";
|
|
}
|
|
|
|
package Sql::Column::CurrentDate;
|
|
our @ISA = qw(Sql::Column::Text);
|
|
sub placeholder($)
|
|
{
|
|
"CURRENT_DATE";
|
|
}
|
|
|
|
package Sql::Column::Key;
|
|
our @ISA = qw(Sql::Column::Integer);
|
|
sub new($class, @p)
|
|
{
|
|
my $o = $class->SUPER::new(@p);
|
|
$o->{autoincrement} = 1;
|
|
return $o;
|
|
}
|
|
|
|
sub is_key($self)
|
|
{
|
|
return $self->{autoincrement};
|
|
}
|
|
|
|
sub add_to($self, $c)
|
|
{
|
|
$c->{key} = $self;
|
|
$self->SUPER::add_to($c);
|
|
}
|
|
|
|
|
|
sub prepend_to($self, $c)
|
|
{
|
|
$c->{key} = $self;
|
|
$self->SUPER::prepend_to($c);
|
|
}
|
|
|
|
sub noautoincrement($self)
|
|
{
|
|
$self->{autoincrement} = 0;
|
|
return $self;
|
|
}
|
|
|
|
sub type($self)
|
|
{
|
|
if ($self->{autoincrement}) {
|
|
return "INTEGER PRIMARY KEY AUTOINCREMENT";
|
|
} else {
|
|
return "INTEGER PRIMARY KEY";
|
|
}
|
|
}
|
|
|
|
package Sql::Join;
|
|
our @ISA = qw(Sql::Object);
|
|
sub category($)
|
|
{
|
|
"joins"
|
|
}
|
|
|
|
sub join_part($self)
|
|
{
|
|
my $s = "JOIN ".$self->name;
|
|
if (defined $self->{alias}) {
|
|
$s .= " ".$self->{alias};
|
|
}
|
|
if ($self->{left}) {
|
|
$s = "LEFT ".$s;
|
|
}
|
|
# if ($self->is_natural) {
|
|
# $s = "NATURAL ".$s;
|
|
# }
|
|
return $s;
|
|
}
|
|
|
|
sub join_table($self)
|
|
{
|
|
return $self->{alias} // $self->name;
|
|
}
|
|
|
|
sub on_part($self, $view)
|
|
{
|
|
return map {$_->equation($self, $view)} @{$self->{equals}};
|
|
|
|
}
|
|
|
|
sub is_natural($self)
|
|
{
|
|
for my $e (@{$self->{equals}}) {
|
|
return 0 if !$e->is_natural;
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
sub left($self)
|
|
{
|
|
$self->{left} = 1;
|
|
return $self;
|
|
}
|
|
|
|
package Sql::Equal;
|
|
our @ISA = qw(Sql::Object);
|
|
|
|
sub new($class, $a, $b)
|
|
{
|
|
bless {a => $a, b => $b}, $class;
|
|
}
|
|
|
|
sub category($)
|
|
{
|
|
"equals"
|
|
}
|
|
|
|
sub equation($self, $join, $view)
|
|
{
|
|
my $a = $self->{a};
|
|
my $b = $self->{b};
|
|
if (!$view->is_unique_name($a)) {
|
|
$a = $join->join_table.".".$a;
|
|
}
|
|
if (!$view->is_unique_name($b)) {
|
|
$b = $join->{previous}->join_table.".".$b;
|
|
}
|
|
return "$a=$b";
|
|
}
|
|
|
|
sub is_natural($self)
|
|
{
|
|
return $self->{a} eq $self->{b};
|
|
}
|
|
|
|
package Sql::EqualConstant;
|
|
our @ISA = qw(Sql::Equal);
|
|
sub equation($self, $join, $view)
|
|
{
|
|
my $a = $self->{a};
|
|
if (!$view->is_unique_name($a)) {
|
|
$a = $join->join_table.".".$a;
|
|
}
|
|
|
|
return "$a=$self->{b}";
|
|
}
|
|
|
|
sub is_natural($)
|
|
{
|
|
0
|
|
}
|
|
|
|
package Sql::IsNull;
|
|
our @ISA = qw(Sql::Equal);
|
|
|
|
# :IsNull is a "kind of" equal but it has only one single value
|
|
# it's okay because everything referencing b is overriden.
|
|
sub new($class, $a)
|
|
{
|
|
bless {a => $a}, $class;
|
|
}
|
|
|
|
sub equation($self, $join, $view)
|
|
{
|
|
my $a = $self->{a};
|
|
if (!$view->is_unique_name($a)) {
|
|
$a = $join->join_table.".".$a;
|
|
}
|
|
|
|
return "$a IS NULL";
|
|
}
|
|
|
|
sub is_natural($)
|
|
{
|
|
0
|
|
}
|
|
|
|
package Sql::Create::Index;
|
|
our @ISA = qw(Sql::Create);
|
|
|
|
sub type($)
|
|
{
|
|
"INDEX"
|
|
}
|
|
|
|
sub is_index($)
|
|
{
|
|
1
|
|
}
|
|
|
|
sub new($class, $table, $col)
|
|
{
|
|
my $name = $table->name."_".$col->name;
|
|
my $o = bless { name => $name, table => $table, col => $col}, $class;
|
|
$o->register;
|
|
}
|
|
|
|
sub contents($self)
|
|
{
|
|
return "ON ". $self->{table}->name."(".$self->{col}->name.")";
|
|
}
|
|
|
|
1;
|