341 lines
11 KiB
Perl
341 lines
11 KiB
Perl
package SQL::Abstract::Complete;
|
|
use strict;
|
|
use warnings;
|
|
use SQL::Abstract 1.5;
|
|
use Storable 'dclone';
|
|
use vars '@ISA';
|
|
@ISA = 'SQL::Abstract';
|
|
|
|
our $VERSION = '1.03';
|
|
|
|
sub new {
|
|
my $self = shift;
|
|
$self = $self->SUPER::new(@_);
|
|
$self->{'part_join'} ||= ' ';
|
|
return $self;
|
|
}
|
|
|
|
sub _wipe_space {
|
|
return join( '', map {
|
|
s/\s{2,}/ /g;
|
|
s/^\s+|\s+$//g;
|
|
s/\s+,/,/g;
|
|
$_;
|
|
} @_ );
|
|
}
|
|
|
|
sub _sqlcase {
|
|
return ( $_[0]->{'case'} ) ? $_[1] : uc( ( defined( $_[1] ) ) ? $_[1] : '' );
|
|
}
|
|
|
|
sub select {
|
|
my ( $self, $tables, $columns, $where, $meta ) = @_;
|
|
$columns = ['*'] unless ( $columns and @{$columns} > 0 );
|
|
$tables = dclone($tables) if ( ref $tables );
|
|
|
|
my $columns_sql = $self->_sqlcase('select') . ' ' . _wipe_space(
|
|
( ref($columns) eq 'SCALAR' ) ? ${$columns} :
|
|
( not ref($columns) ) ? $self->_quote($columns) :
|
|
join( ', ', map {
|
|
( ref($_) eq 'SCALAR' ) ? ${$_} :
|
|
( not ref($_) ) ? $self->_quote($_) :
|
|
join( ' AS ', map { $self->_quote($_) } ( ref($_) eq 'HASH' ) ? %{$_} : @{$_} );
|
|
} @{$columns} )
|
|
);
|
|
|
|
my $core_table;
|
|
my $tables_sql = join(
|
|
$self->{'part_join'},
|
|
map { _wipe_space( join( ' ',
|
|
$self->_sqlcase( shift( @{$_} ) ),
|
|
grep { defined } @{$_} )
|
|
) } (
|
|
( ref($tables) eq 'SCALAR' ) ? [ undef, ${$tables} ] :
|
|
( not ref($tables) ) ? [ 'from', $self->_quote($tables) ] :
|
|
map {
|
|
( ref($_) eq 'SCALAR' ) ? [ undef, ${$_} ] :
|
|
( not ref($_) ) ? [ 'from', $self->_quote($_) ] :
|
|
do {
|
|
my @parts = ( ref($_) eq 'HASH' ) ? %{$_} : @{$_};
|
|
my $join_type = ( ref( $parts[0] ) eq 'SCALAR' ) ? ${ shift(@parts) } : 'join';
|
|
|
|
my $join_on =
|
|
( ref( $parts[-1] ) eq 'SCALAR' ) ? ${ pop(@parts) } :
|
|
( ref( $parts[-1] ) eq 'HASH' and @parts > 1 ) ? do {
|
|
my $join_def = pop(@parts);
|
|
$join_type = $join_def->{'join'} . ' join' if ( $join_def->{'join'} );
|
|
|
|
( ref( $join_def->{'using'} || $join_def->{'on'} ) eq 'SCALAR' )
|
|
? ${ $join_def->{'using'} || $join_def->{'on'} } :
|
|
( $join_def->{'using'} )
|
|
? $self->_sqlcase('using') . '(' . $join_def->{'using'} . ')' :
|
|
( $join_def->{'on'} )
|
|
? $self->_sqlcase('on') . ' ' . $join_def->{'on'} : '';
|
|
} :
|
|
( not ref( $parts[-1] ) and @parts > 1 )
|
|
? $self->_sqlcase('using') . '(' . $self->_quote( pop(@parts) ) . ')'
|
|
: '';
|
|
|
|
my $table_def = shift(@parts);
|
|
$table_def =
|
|
( not ref($table_def) ) ? $table_def :
|
|
( ref($table_def) eq 'SCALAR' ) ? ${$table_def} :
|
|
do {
|
|
$table_def = [ %{$table_def} ] if ( ref($table_def) eq 'HASH' );
|
|
my $table_name = shift( @{$table_def} );
|
|
|
|
unless ($core_table) {
|
|
$core_table = $table_name;
|
|
$join_type = 'from';
|
|
}
|
|
|
|
$self->_quote($table_name) . ( ( @{$table_def} ) ? ' ' . join(
|
|
' ',
|
|
$self->_sqlcase('as'),
|
|
map { $self->_quote($_) } @{$table_def},
|
|
) : '' );
|
|
};
|
|
|
|
[ $join_type, $table_def, $join_on ];
|
|
};
|
|
} ( ( ref($tables) ) ? @{$tables} : $tables )
|
|
)
|
|
);
|
|
|
|
my ( $where_sql, @bind ) = $self->where($where);
|
|
|
|
my ( $offset, $rows ) = ( $meta->{'offset'} || 0, $meta->{'rows'} || 0 );
|
|
if ( $meta->{'limit'} ) {
|
|
( $offset, $rows ) = ( ref( $meta->{'limit'} ) eq 'ARRAY' )
|
|
? @{ $meta->{'limit'} }
|
|
: ( 0, $meta->{'limit'} );
|
|
}
|
|
$offset = ( $meta->{'page'} - 1 ) * $rows if ( $meta->{'page'} );
|
|
|
|
my $sql = join(
|
|
$self->{'part_join'},
|
|
grep { defined and $_ } (
|
|
$columns_sql,
|
|
$tables_sql,
|
|
_wipe_space($where_sql),
|
|
( ( $meta->{'group_by'} ) ? do {
|
|
(
|
|
my $group_by = scalar( $self->_order_by( $meta->{'group_by'} ) )
|
|
) =~ s/\s*ORDER BY/GROUP BY/;
|
|
_wipe_space($group_by);
|
|
} : undef ),
|
|
( ( $meta->{'having'} ) ? do {
|
|
( my $having = scalar( $self->where( $meta->{'having'} ) ) ) =~ s/\s*WHERE/HAVING/;
|
|
_wipe_space($having);
|
|
} : undef ),
|
|
( ( $meta->{'order_by'} ) ? _wipe_space( $self->_order_by( $meta->{'order_by'} ) ) : undef ),
|
|
( $offset or $rows )
|
|
? $self->_sqlcase('limit') . " $rows " . $self->_sqlcase('offset') . " $offset"
|
|
: undef,
|
|
),
|
|
);
|
|
|
|
$sql =~ s/^\s+|\s+$//g;
|
|
return ( wantarray() ) ? ( $sql, @bind ) : $sql;
|
|
}
|
|
|
|
1;
|
|
__END__
|
|
=pod
|
|
|
|
=head1 NAME
|
|
|
|
SQL::Abstract::Complete - Generate complete SQL from Perl data structures
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use SQL::Abstract::Complete;
|
|
|
|
my $sac = SQL::Abstract::Complete->new();
|
|
|
|
my ( $sql, @bind ) = $sac->select(
|
|
\@tables, # a table or set of tables and optional aliases
|
|
\@fields, # fields and optional aliases to fetch
|
|
\%where, # where clause
|
|
\%other, # order by, group by, having, and pagination
|
|
);
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This module was inspired by the excellent L<SQL::Abstract>, from which in
|
|
inherits. However, in trying to use the module, I found that what I really
|
|
wanted to do was generate complete SELECT statements including joins and group
|
|
by clauses. So, I set out to create a more complete abstract SQL generation
|
|
module. (To be fair, L<SQL::Abstract> kept it's first C<$table> argument
|
|
inflexible for backwards compatibility reasons.)
|
|
|
|
This module only changes the select() method and adds a small new wrinkle to
|
|
new(). Everything else from L<SQL::Abstract> is inheritted as-is. Consequently,
|
|
you should read the L<SQL::Abstract> documentation before continuing.
|
|
|
|
=head1 FUNCTIONS
|
|
|
|
=head2 new( 'option' => 'value' )
|
|
|
|
The C<new()> function takes a list of options and values, and returns
|
|
a new B<SQL::Abstract::Complete> object which can then be used to generate SQL.
|
|
This function operates in exactly the same way as the same from L<SQL::Abstract>
|
|
only it offers one additional option to set:
|
|
|
|
=over
|
|
|
|
=item part_join
|
|
|
|
This is the value that the SELECT statement components will be concatinated
|
|
together with. By default, this is set to a single space, meaning the returned
|
|
SQL will be all on one line. Setting this to something like C<"\n"> would make
|
|
for slightly more human-readable SQL, depending on the human.
|
|
|
|
=back
|
|
|
|
=head2 select( \@tables, \@fields, \%where, \%other )
|
|
|
|
This returns a SQL SELECT statement and associated list of bind values, as
|
|
specified by the arguments:
|
|
|
|
=over
|
|
|
|
=item \@tables
|
|
|
|
This is a list of tables, optional aliases, and ways to join any multiple
|
|
tables. The first table will be used as the "FROM" part of the statement.
|
|
Subsequent tables will be assumed to be joined by use of an inner join unless
|
|
otherwise specified.
|
|
|
|
There are several ways to specify tables, joins, and their respective aliases:
|
|
|
|
# SELECT * FROM alpha
|
|
my ( $sql, @bind ) = $sac->select('alpha');
|
|
my ( $sql, @bind ) = $sac->select( ['alpha'] );
|
|
|
|
# SELECT * FROM alpha AS a
|
|
( $sql, @bind ) = $sac->select( \q(FROM alpha AS a) );
|
|
( $sql, @bind ) = $sac->select( [ \q(FROM alpha AS a) ] );
|
|
|
|
# SELECT * FROM alpha AS a JOIN beta AS b USING(id)
|
|
$sac->select(
|
|
[
|
|
[ [ qw( alpha a ) ] ],
|
|
[ [ qw( beta b ) ], 'id' ],
|
|
],
|
|
);
|
|
$sac->select(
|
|
[
|
|
[ [ qw( alpha a ) ] ],
|
|
[ { 'beta' => 'b' }, 'id' ],
|
|
],
|
|
);
|
|
|
|
# SELECT *
|
|
# FROM alpha AS a
|
|
# JOIN beta AS b USING(id)
|
|
# LEFT JOIN something AS s USING(whatever)
|
|
# LEFT JOIN omega AS o USING(last_id)
|
|
# LEFT JOIN stuff AS t ON t.thing_id = b.thing_id
|
|
# LEFT JOIN pi AS p USING(number_id)
|
|
$sac->select(
|
|
[
|
|
[ [ qw( alpha a ) ] ],
|
|
[ { 'beta' => 'b' }, 'id' ],
|
|
\q{ LEFT JOIN something AS s USING(whatever) },
|
|
[ \q{ LEFT JOIN }, { 'omega', 'o' }, 'last_id' ],
|
|
[
|
|
\q{ LEFT JOIN },
|
|
{ 'stuff' => 't' },
|
|
\q{ ON t.thing_id = b.thing_id },
|
|
],
|
|
[
|
|
[ qw( pi p ) ],
|
|
{
|
|
'join' => 'left',
|
|
'using' => 'number_id',
|
|
},
|
|
],
|
|
],
|
|
);
|
|
|
|
=item \@fields
|
|
|
|
This is a list of the fields (along with optional aliases) to return.
|
|
There are several ways to specify fields and their respective aliases:
|
|
|
|
# SELECT one, two, three FROM table
|
|
$sac->select(
|
|
'table',
|
|
[ qw( one two three ) ],
|
|
);
|
|
|
|
# SELECT one, IF( two > 10, 1, 0 ) AS two_bool, three AS col_three
|
|
# FROM table
|
|
$sac->select(
|
|
'table',
|
|
[
|
|
'one',
|
|
\q{ IF( two > 10, 1, 0 ) AS two_bool },
|
|
{ 'three' => 'col_three' },
|
|
],
|
|
);
|
|
|
|
=item \%where
|
|
|
|
This is an optional argument to specify the WHERE clause of the query.
|
|
The argument is most often a hashref. This functionality is entirely
|
|
inheritted from L<SQL::Abstract>, so read that fine module's documentation
|
|
for WHERE details.
|
|
|
|
=item \%other
|
|
|
|
This optional argument is where you can specify items like order by, group by,
|
|
and having clauses. You can also stipulate pagination of results.
|
|
|
|
# SELECT one
|
|
# FROM table
|
|
# GROUP BY two
|
|
# HAVING ( MAX(three) > ? )
|
|
# ORDER BY one, four DESC, five
|
|
# LIMIT 10, 5
|
|
$sac->select(
|
|
'table',
|
|
['one'],
|
|
undef,
|
|
{
|
|
'group_by' => 'two',
|
|
'having' => [ { 'MAX(three)' => { '>' => 9 } } ],
|
|
'order_by' => [ 'one', { '-desc' => 'four' }, 'five' ],
|
|
'rows' => 5,
|
|
'page' => 3,
|
|
},
|
|
);
|
|
|
|
The HAVING clause works in the same way as the WHERE clause handling
|
|
from L<SQL::Abstract>. (In fact, we're actually calling the same method
|
|
from the parent class.) ORDER BY clause handling is also purely inheritted
|
|
from L<SQL::Abstract>. The "rows" and "page" pagination functionality is
|
|
inspired from L<DBIx::Class> and operates the same way. Alternatively, you can
|
|
explicitly set a "limit" value.
|
|
|
|
=back
|
|
|
|
=head1 SEE ALSO
|
|
|
|
L<SQL::Abstract>, L<DBIx::Class>, L<DBIx::Abstract>.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Gryphon Shafer E<lt>gryphon@cpan.orgE<gt>.
|
|
|
|
code('Perl') || die;
|
|
|
|
=head1 LICENSE
|
|
|
|
This library is free software; you can redistribute it and/or modify
|
|
it under the same terms as Perl itself, either Perl version 5.8.4 or,
|
|
at your option, any later version of Perl 5 you may have available.
|
|
|
|
=cut
|