# -*- perl -*- require 5.004; use strict; require DynaLoader; package SQL::Statement; use vars qw($VERSION @ISA); $VERSION = '0.1017'; @ISA = qw(DynaLoader); bootstrap SQL::Statement $VERSION; sub execute ($$;$) { my($self, $data, $params) = @_; my($table, $msg); my($command) = $self->command(); ($self->{'NUM_OF_ROWS'}, $self->{'NUM_OF_FIELDS'}, $self->{'data'}) = $self->$command($data, $params); delete $self->{'tables'}; # Force closing the tables $self->{'NUM_OF_ROWS'} || '0E0'; } sub open_tables ($$$$) { my($self, $data, $createMode, $lockMode) = @_; my($tables) = {}; my($table); foreach $table ($self->tables()) { my($tname) = $table->name(); if (!($tables->{$tname} = $self->open_table($data, $tname, $createMode, $lockMode))) { return undef; } } SQL::Eval->new({'tables' => $tables}); } sub verify_columns ($$$) { my($self, $eval, $data) = @_; my($column, $tbl, $col); foreach $column ($self->val()) { if (ref($column) && $column->isa("SQL::Statement::Column")) { ($tbl, $col) = ($column->table(), $column->name()); if ($col ne '*' && !defined($eval->table($tbl)->column_num($col))) { die "Unknown column: $tbl.$col"; } } } } sub CREATE ($$$) { my($self, $data, $params) = @_; my($eval) = $self->open_tables($data, 1, 1); $eval->params($params); my($row) = []; my($col); my($table) = $eval->table($self->tables(0)->name()); foreach $col ($self->columns()) { push(@$row, $col->name()); } $table->push_names($data, $row); (0, 0); } sub DROP ($$$) { my($self, $data, $params) = @_; my($eval) = $self->open_tables($data, 0, 1); $eval->params($params); my($table) = $eval->table($self->tables(0)->name()); $table->drop($data); (-1, 0); } sub INSERT ($$$) { my($self, $data, $params) = @_; my($eval) = $self->open_tables($data, 0, 1); $eval->params($params); $self->verify_columns($eval, $data); my($table) = $eval->table($self->tables(0)->name()); $table->seek($data, 0, 2); my($array) = []; my($val, $col, $i); my($columns) = $table->{'colNums'}; my($cNum) = scalar($self->columns()); if ($cNum) { # INSERT INTO $table (row, ...) VALUES (value, ...) for ($i = 0; $i < $cNum; $i++) { $col = $self->columns($i); $val = $self->row_values($i); if (ref($val) eq 'SQL::Statement::Param') { $val = $eval->param($val->num()); } $array->[$table->column_num($col->name())] = $val; } } else { # INSERT INTO $table VALUES (value, ...) $cNum = scalar($self->row_values()); for ($i = 0; $i < $cNum; $i++) { $val = $self->row_values($i); if (ref($val) eq 'SQL::Statement::Param') { $val = $eval->param($val->num()); } $array->[$i] = $val; } } $table->push_row($data, $array); (1, 0); } sub UPDATE ($$$) { my($self, $data, $params) = @_; my($eval) = $self->open_tables($data, 0, 1); $eval->params($params); $self->verify_columns($eval, $data); my($table) = $eval->table($self->tables(0)->name()); my($affected) = 0; my(@rows, $array, $val, $col, $i); while ($array = $table->fetch_row($data)) { if ($self->eval_where($eval)) { for ($i = 0; $i < $self->columns(); $i++) { $col = $self->columns($i); $val = $self->row_values($i); if (ref($val) eq 'SQL::Statement::Param') { $val = $eval->param($val->num()); } $array->[$table->column_num($col->name())] = $val; } ++$affected; } push(@rows, $array); } $table->seek($data, 0, 0); foreach $array (@rows) { $table->push_row($data, $array); } $table->truncate($data); ($affected, 0); } sub DELETE ($$$) { my($self, $data, $params) = @_; my($eval) = $self->open_tables($data, 0, 1); $eval->params($params); $self->verify_columns($eval, $data); my($table) = $eval->table($self->tables(0)->name()); my($affected) = 0; my(@rows, $array); while ($array = $table->fetch_row($data)) { if ($self->eval_where($eval)) { ++$affected; } else { push(@rows, $array); } } $table->seek($data, 0, 0); foreach $array (@rows) { $table->push_row($data, $array); } $table->truncate($data); ($affected, 0); } sub SELECT ($$) { my($self, $data, $params) = @_; my($eval) = $self->open_tables($data, 0, 0); $eval->params($params); $self->verify_columns($eval, $data); my $tableName = $self->tables(0)->name(); my $table = $eval->table($tableName); my $rows = []; # In a loop, build the list of columns to retrieve; this will be # used both for fetching data and ordering. my($cList, $col, $tbl, $ar, $i, $c); my $numFields = 0; my %columns; my @names; foreach my $column ($self->columns()) { if (ref($column) eq 'SQL::Statement::Param') { my $val = $eval->param($column->num()); if ($val =~ /(.*)\.(.*)/) { $col = $1; $tbl = $2; } else { $col = $val; $tbl = $tableName; } } else { ($col, $tbl) = ($column->name(), $column->table()); } if ($col eq '*') { $ar = $table->col_names(); for ($i = 0; $i < @$ar; $i++) { my $cName = $ar->[$i]; $columns{$tbl}->{$cName} = $numFields++; $c = SQL::Statement::Column->new({'table' => $tableName, 'column' => $cName}); push(@$cList, $i); push(@names, $cName); } } else { $columns{$tbl}->{$col} = $numFields++; push(@$cList, $table->column_num($col)); push(@names, $col); } } $self->{'NAME'} = \@names; my @order_by = $self->order(); my @extraSortCols; my $distinct = $self->distinct(); if ($distinct) { # Silently extend the ORDER BY clause to the full list of # columns. my %ordered_cols; foreach my $column (@order_by) { ($col, $tbl) = ($column->column(), $column->table()); $ordered_cols{$tbl}->{$col} = 1; } while (my($tbl, $cref) = each %columns) { foreach my $col (keys %$cref) { if (!$ordered_cols{$tbl}->{$col}) { $ordered_cols{$tbl}->{$col} = 1; push(@order_by, SQL::Statement::Order->new ('col' => SQL::Statement::Column->new ({'table' => $tbl, 'column' => $col}), 'desc' => 0)); } } } } if (@order_by) { my $nFields = $numFields; # It is possible that the user gave an ORDER BY clause with columns # that are not part of $cList yet. These columns will need to be # present in the array of arrays for sorting, but will be stripped # off later. foreach my $column (@order_by) { ($col, $tbl) = ($column->column(), $column->table()); next if exists($columns{$tbl}->{$col}); push(@extraSortCols, $table->column_num($col)); $columns{$tbl}->{$col} = $nFields++; } } while (my $array = $table->fetch_row($data)) { if ($self->eval_where($eval)) { # Note we also include the columns from @extraSortCols that # have to be ripped off later! my @row = map { $array->[$_] } (@$cList, @extraSortCols); push(@$rows, \@row); } } if (@order_by) { my @sortCols = map { ($columns{$_->table()}->{$_->column()}, $_->desc()) } @order_by; my($c, $d, $colNum, $desc); my $sortFunc = sub { my $result; $i = 0; do { $colNum = $sortCols[$i++]; $desc = $sortCols[$i++]; $c = $a->[$colNum]; $d = $b->[$colNum]; if (!defined($c)) { $result = defined $d ? -1 : 0; } elsif (!defined($d)) { $result = 1; } elsif ($c =~ /^\s*[+-]?\s*\.?\s*\d/ && $d =~ /^\s*[+-]?\s*\.?\s*\d/) { $result = ($c <=> $d); } else { $result = $c cmp $d; } if ($desc) { $result = -$result; } } while (!$result && $i < @sortCols); $result; }; if ($distinct) { my $prev; @$rows = map { if ($prev) { $a = $_; $b = $prev; if (&$sortFunc() == 0) { (); } else { $prev = $_; } } else { $prev = $_; } } ($] > 5.00504 ? sort $sortFunc @$rows : sort { &$sortFunc } @$rows); } else { @$rows = $] > 5.00504 ? (sort $sortFunc @$rows) : (sort { &$sortFunc } @$rows) } # Rip off columns that have been added for @extraSortCols only if (@extraSortCols) { foreach my $row (@$rows) { splice(@$row, $numFields, scalar(@extraSortCols)); } } } (scalar(@$rows), $numFields, $rows); } package SQL::Statement::Column; sub new ($$) { my($class, $attr) = @_; bless($attr, (ref($class) || $class)); $attr; } sub table ($) { shift->{'table'}; } sub name ($) { shift->{'column'}; } package SQL::Statement::Table; sub name ($) { shift->{'table'}; } package SQL::Statement::Ident; sub id ($) { shift->{'id'}; } package SQL::Statement::Op; sub neg ($) { shift->{'neg'}; } sub op ($) { SQL::Statement->op(shift->{'op'}); } sub arg1 ($) { my($self) = shift; $self->{'stmt'}->val($self->{'arg1'}); } sub arg2 ($) { my($self) = shift; $self->{'stmt'}->val($self->{'arg2'}); } package SQL::Statement::Param; sub num ($) { shift->{'num'}; } package SQL::Statement::Order; sub new ($$) { my $proto = shift; my $self = {@_}; bless($self, (ref($proto) || $proto)); } sub table ($) { shift->{'col'}->table(); } sub column ($) { shift->{'col'}->name(); } sub desc ($) { shift->{'desc'}; } package SQL::Parser; sub new ($;$$) { my($class, $name, $attr) = @_; my($self) = $class->dup($name); if ($self && $attr) { my($set, $setVal, $feature, $featureVal); while (($set, $setVal) = each %$attr) { while (($feature, $featureVal) = each %$setVal) { $self->feature($set, $feature, $featureVal); } } } $self; } 1; __END__ =head1 NAME SQL::Statement - SQL parsing and processing engine =head1 SYNOPSIS require SQL::Statement; # Create a parser my($parser) = SQL::Statement->new('Ansi'); # Parse an SQL statement $@ = ''; my ($stmt) = eval { SQL::Statement->new("SELECT id, name FROM foo WHERE id > 1", $parser); }; if ($@) { die "Cannot parse statement: $@"; } # Query the list of result columns; my $numColums = $stmt->columns(); # Scalar context my @columns = $stmt->columns(); # Array context # @columns now contains SQL::Statement::Column instances # Likewise, query the tables being used in the statement: my $numTables = $stmt->tables(); # Scalar context my @tables = $stmt->tables(); # Array context # @tables now contains SQL::Statement::Table instances # Query the WHERE clause; this will retrieve an # SQL::Statement::Op instance my $where = $stmt->where(); # Evaluate the WHERE clause with concrete data, represented # by an SQL::Eval object my $result = $stmt->eval_where($eval); # Execute a statement: $stmt->execute($data, $params); =head1 DESCRIPTION For installing the module, see L<"INSTALLATION"> below. The SQL::Statement module implements a small, abstract SQL engine. This module is not usefull itself, but as a base class for deriving concrete SQL engines. The implementation is designed to work fine with the DBI driver DBD::CSV, thus probably not so well suited for a larger environment, but I'd hope it is extendable without too much problems. By parsing an SQL query you create an SQL::Statement instance. This instance offers methods for retrieving syntax, for WHERE clause and statement evaluation. =head2 Creating a parser object What's accepted as valid SQL, depends on the parser object. There is a set of so-called features that the parsers may have or not. Usually you start with a builtin parser: my $parser = SQL::Parser->new($name, [ \%attr ]); Currently two parsers are builtin: The I parser implements a proper subset of ANSI SQL. (At least I hope so. :-) The I parser is used by the DBD:CSV driver. You can query or set individual features. Currently available are: =over 8 =item create.type_blob =item create.type_real =item create.type_text These enable the respective column types in a I clause. They are all disabled in the I parser, but enabled in the I parser. Example: =item select.join This enables the use of multiple tables in a SELECT statement, for example SELECT a.id, b.name FROM a, b WHERE a.id = b.id AND a.id = 2 =back To enable or disable a feature, for example I, use the following: # Enable feature $parser->feature("select", "join", 1); # Disable feature $parser->feature("select", "join", 0); Of course you can query features: # Query feature my $haveSelectJoin = $parser->feature("select", "join"); The C method allows a shorthand for setting features. For example, the following is equivalent to the I parser: $parser = SQL::Statement->new('Ansi', { 'create' => { 'type_text' => 1, 'type_real' => 1, 'type_blob' => 1 }, 'select' => { 'join' => 0 }}); =head2 Parsing a query A statement can be parsed with my $stmt = SQL::Statement->new($query, $parser); In case of syntax errors or other problems, the method throws a Perl exception. Thus, if you want to catch exceptions, the above becomes $@ = ''; my $stmt = eval { SQL::Statement->new($query, $parser) }; if ($@) { print "An error occurred: $@"; } The accepted SQL syntax is restricted, though easily extendable. See L below. See L above. =head2 Retrieving query information The following methods can be used to obtain information about a query: =over 8 =item command Returns the SQL command, currently one of I statements can return more than one table, in case of joins. Table objects offer a single method, C which returns the table name. =item params my $paramNum = $stmt->params(); # Scalar context my @params = $stmt->params(); # Array context my($p1, $p2) = ($stmt->params(0), $stmt->params(1)); The C method returns information about the input parameters used in a statement. For example, consider the following: INSERT INTO foo VALUES (?, ?) This would return two instances of SQL::Statement::Param. Param objects implement a single method, C<$param->num()>, which retrieves the parameter number. (0 and 1, in the above example). As of now, not very usefull ... :-) =item row_values my $rowValueNum = $stmt->row_values(); # Scalar context my @rowValues = $stmt->row_values(); # Array context my($rval1, $rval2) = ($stmt->row_values(0), $stmt->row_values(1)); This method is used for statements like UPDATE $table SET $col1 = $val1, $col2 = $val2, ... $colN = $valN WHERE ... INSERT INTO $table (...) VALUES ($val1, $val2, ..., $valN) to read the values $val1, $val2, ... $valN. It returns scalar values or SQL::Statement::Param instances. =item Order my $orderNum = $stmt->order(); # Scalar context my @order = $stmt->order(); # Array context my($o1, $o2) = ($stmt->order(0), $stmt->order(1)); In I below for a decsription of $where_clause =head2 UPDATE UPDATE $table SET $col1 = $val1, ... $colN = $valN [ WHERE $where_clause ] See L