dinislage/SQL-Abstract-Complete
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Release version 1.01

Browse Source
This commit is contained in:
Gryphon Shafer
2013-02-23 16:57:54 -08:00
parent f6642a6d1e
commit e371953544
13 changed files with 673 additions and 4 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
.gitignore vendored
View File

@@ -14,3 +14,7 @@ META.yml
MYMETA.yml
nytprof.out
pm_to_blib
.tar.gz
.lwpcookies
.tmp
SQL-Abstract-Complete-*

4
Changes Normal file
View File

@@ -0,0 +1,4 @@
Revision history for SQL::Abstract::Complete
1.01 Sat Feb 23 16:25:56 PST 2013
First version, released on an unsuspecting world.

11
MANIFEST Normal file
View File

@@ -0,0 +1,11 @@
Changes
MANIFEST
Makefile.PL
README
lib/SQL/Abstract/Complete.pm
t/00-load.t
t/boilerplate.t
t/Complete.t
t/manifest.t
t/pod-coverage.t
t/pod.t

21
Makefile.PL Normal file
View File

@@ -0,0 +1,21 @@
use strict;
use warnings;
use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'SQL::Abstract::Complete',
AUTHOR => q{Gryphon Shafer <gryphon@cpan.org>},
VERSION_FROM => 'lib/SQL/Abstract/Complete.pm',
ABSTRACT_FROM => 'lib/SQL/Abstract/Complete.pm',
($ExtUtils::MakeMaker::VERSION >= 6.3002
? ('LICENSE'=> 'perl')
: ()),
PL_FILES => {},
PREREQ_PM => {
'Test::More' => 0,
'SQL::Abstract' => 1.5,
'Clone::Fast' => 0,
},
dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
clean => { FILES => 'SQL-Abstract-Complete-*' },
);

52
README Normal file
View File

@@ -0,0 +1,52 @@
SQL::Abstract::Complete - Generate complete SQL from Perl data structures
This module was inspired by the excellent 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, SQL::Abstract kept it's first $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 SQL::Abstract is inheritted as-is. Consequently,
you should read the SQL::Abstract documentation before continuing.
INSTALLATION
To install this module, run the following commands:
perl Makefile.PL
make
make test
make install
SUPPORT AND DOCUMENTATION
After installing, you can find documentation for this module with the
perldoc command.
perldoc SQL::Abstract::Complete
You can also look for information at:
RT, CPAN's request tracker
http://rt.cpan.org/NoAuth/Bugs.html?Dist=SQL-Abstract-Complete
AnnoCPAN, Annotated CPAN documentation
http://annocpan.org/dist/SQL-Abstract-Complete
CPAN Ratings
http://cpanratings.perl.org/d/SQL-Abstract-Complete
Search CPAN
http://search.cpan.org/dist/SQL-Abstract-Complete/
AUTHOR AND LICENSE
Gryphon Shafer, gryphon@cpan.org
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.

4
README.md
View File

@@ -1,4 +0,0 @@
libsql-abstract-complete-perl
=============================
SQL::Abstract::Complete (Perl CPAN Library)

335
lib/SQL/Abstract/Complete.pm Normal file
View File

@@ -0,0 +1,335 @@
package SQL::Abstract::Complete;
use strict;
use warnings;
use SQL::Abstract 1.5;
use Clone::Fast 'clone';
use vars '@ISA';
@ISA = 'SQL::Abstract';
our $VERSION = '1.01';
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 = clone($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( @{$_} ) ), @{$_} ) ) } (
( 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>
=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

8
t/00-load.t Normal file
View File

@@ -0,0 +1,8 @@
#!perl -T
use Test::More tests => 1;
BEGIN {
use_ok( 'SQL::Abstract::Complete' ) || print "Bail out!\n";
}
diag( "Testing SQL::Abstract::Complete $SQL::Abstract::Complete::VERSION, Perl $], $^X" );

149
t/Complete.t Normal file
View File

@@ -0,0 +1,149 @@
use strict;
use warnings;
use Test::More 'tests' => 22;
use constant MODULE => 'SQL::Abstract::Complete';
BEGIN { use_ok(MODULE); }
require_ok(MODULE);
my %sacs;
ok( $sacs{'A'} = MODULE->new(), MODULE . '->new() ...as A' );
ok(
$sacs{'B'} = MODULE->new( 'part_join' => "\n" ),
MODULE . q{->new( 'part_join' => "\n" ) ...as B},
);
is( ref( $sacs{$_} ), MODULE, 'ref($object) ...with ' . $_ )
foreach ( keys %sacs );
my ( $sql, @bind );
my $sac = $sacs{'A'};
foreach (
[ 'A', 'SELECT * FROM table_name' ],
[ 'B', "SELECT *\nFROM table_name" ],
) {
( $sql, @bind ) = $sacs{ $_->[0] }->select('table_name');
is(
$sql, $_->[1],
'Single simple table ...with ' . $_->[0],
);
}
foreach (
[ 'A', 'SELECT column_a, column_b, column_c FROM table_name' ],
[ 'B', "SELECT column_a, column_b, column_c\nFROM table_name" ],
) {
( $sql, @bind ) = $sacs{ $_->[0] }->select(
'table_name',
[ qw( column_a column_b column_c ) ],
);
is(
$sql, $_->[1],
'Single simple table and columns ...with ' . $_->[0],
);
}
is(
$sac->select('alpha'), 'SELECT * FROM alpha',
q{select('alpha')},
);
is(
$sac->select( \q(FROM alpha AS a) ), 'SELECT * FROM alpha AS a',
q{select( \q(FROM alpha AS a) )},
);
is(
$sac->select( ['alpha'] ), 'SELECT * FROM alpha',
q{select( ['alpha'] )},
);
is(
$sac->select( [ \q(FROM alpha AS a) ] ), 'SELECT * FROM alpha AS a',
q{select( [ \q(FROM alpha AS a) ] )},
);
is(
$sac->select(
[
[ [ qw( alpha a ) ] ],
[ [ qw( beta b ) ], 'id' ],
],
), 'SELECT * FROM alpha AS a JOIN beta AS b USING(id)',
q{select( [ [ [ qw( alpha a ) ] ], [ [ qw( beta b ) ], 'id' ] ] )},
);
is(
$sac->select(
[
[ [ qw( alpha a ) ] ],
[ { 'beta' => 'b' }, 'id' ],
],
), 'SELECT * FROM alpha AS a JOIN beta AS b USING(id)',
q{select( [ [ [ qw( alpha a ) ] ], [ { 'beta' => 'b' }, 'id' ] ] )},
);
is(
$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',
},
],
],
), q{SELECT * FROM alpha AS a JOIN beta AS b USING(id) LEFT JOIN something AS s USING(whatever) } .
q{LEFT JOIN omega AS o USING(last_id) LEFT JOIN stuff AS t ON t.thing_id = b.thing_id } .
q{LEFT JOIN pi AS p USING(number_id)},
'Full select() table functionality',
);
is(
$sac->select(
'table',
[ qw( one two three ) ],
), 'SELECT one, two, three FROM table',
q{select( 'table', [ qw( one two three ) ] )},
);
is(
$sac->select(
'table',
[
'one',
\q{ IF( two > 10, 1, 0 ) AS two_bool },
{ 'three' => 'col_three' },
],
), 'SELECT one, IF( two > 10, 1, 0 ) AS two_bool, three AS col_three FROM table',
'Full select() fields functionality',
);
is(
$sac->select(
'table',
['one'],
undef,
{
'group_by' => 'two',
'having' => [ { 'MAX(three)' => { '>' => 9 } } ],
'order_by' => [ 'one', { '-desc' => 'four' }, 'five' ],
'rows' => 5,
'page' => 3,
},
), q{SELECT one FROM table GROUP BY two HAVING ( MAX(three) > ? ) } .
q{ORDER BY one, four DESC, five LIMIT 5 OFFSET 10},
'Full select() \%other functionality',
);
is( $sac->_sqlcase('from'), 'FROM', q{$sac->_sqlcase('from')} );
is( $sac->_sqlcase(undef), '', '$sac->_sqlcase(undef)' );

51
t/boilerplate.t Normal file
View File

@@ -0,0 +1,51 @@
#!perl -T
use strict;
use warnings;
use Test::More tests => 3;
sub not_in_file_ok {
my ($filename, %regex) = @_;
open( my $fh, '<', $filename ) or die "couldn't open $filename for reading: $!";
my %violated;
while (my $line = <$fh>) {
while (my ($desc, $regex) = each %regex) {
if ($line =~ $regex) {
push @{$violated{$desc}||=[]}, $.;
}
}
}
if (%violated) {
fail("$filename contains boilerplate text");
diag "$_ appears on lines @{$violated{$_}}" for ( keys %violated );
}
else {
pass("$filename contains no boilerplate text");
}
}
sub module_boilerplate_ok {
my ($module) = @_;
not_in_file_ok($module =>
'the great new $MODULENAME' => qr/ - The great new /,
'boilerplate description' => qr/Quick summary of what the module/,
'stub function definition' => qr/function[12]/,
);
}
TODO: {
local $TODO = "Need to replace the boilerplate text";
not_in_file_ok(README =>
"The README is used..." => qr/The README is used/,
"'version information here'" => qr/to provide version information/,
);
not_in_file_ok(Changes =>
"placeholder date/time" => qr(Date/time)
);
module_boilerplate_ok('lib/SQL/Abstract/Complete.pm');
}

8
t/manifest.t Normal file
View File

@@ -0,0 +1,8 @@
#!perl -T
use strict;
use warnings;
use Test::More;
eval "use Test::CheckManifest 0.9";
plan skip_all => "Test::CheckManifest 0.9 required" if $@;
ok_manifest({filter => [qr/\.git/]});

19
t/pod-coverage.t Normal file
View File

@@ -0,0 +1,19 @@
#!perl -T
use strict;
use warnings;
use Test::More;
# Ensure a recent version of Test::Pod::Coverage
my $min_tpc = 1.08;
eval "use Test::Pod::Coverage $min_tpc";
plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage"
if $@;
# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version,
# but older versions don't recognize some common documentation styles
my $min_pc = 0.18;
eval "use Pod::Coverage $min_pc";
plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage"
if $@;
all_pod_coverage_ok();

11
t/pod.t Normal file
View File

@@ -0,0 +1,11 @@
#!perl -T
use strict;
use warnings;
use Test::More;
# Ensure a recent version of Test::Pod
my $min_tp = 1.22;
eval "use Test::Pod $min_tp";
plan skip_all => "Test::Pod $min_tp required for testing POD" if $@;
all_pod_files_ok();