diff --git a/.gitignore b/.gitignore index c15b52a..5436e84 100644 --- a/.gitignore +++ b/.gitignore @@ -14,3 +14,7 @@ META.yml MYMETA.yml nytprof.out pm_to_blib +.tar.gz +.lwpcookies +.tmp +SQL-Abstract-Complete-* diff --git a/Changes b/Changes new file mode 100644 index 0000000..bcfa503 --- /dev/null +++ b/Changes @@ -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. diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..41c2951 --- /dev/null +++ b/MANIFEST @@ -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 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..904bc4d --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,21 @@ +use strict; +use warnings; +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'SQL::Abstract::Complete', + AUTHOR => q{Gryphon Shafer }, + 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-*' }, +); diff --git a/README b/README new file mode 100644 index 0000000..14b4867 --- /dev/null +++ b/README @@ -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. diff --git a/README.md b/README.md deleted file mode 100644 index 13dedec..0000000 --- a/README.md +++ /dev/null @@ -1,4 +0,0 @@ -libsql-abstract-complete-perl -============================= - -SQL::Abstract::Complete (Perl CPAN Library) \ No newline at end of file diff --git a/lib/SQL/Abstract/Complete.pm b/lib/SQL/Abstract/Complete.pm new file mode 100644 index 0000000..3b07155 --- /dev/null +++ b/lib/SQL/Abstract/Complete.pm @@ -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, 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 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 is inheritted as-is. Consequently, +you should read the L documentation before continuing. + +=head1 FUNCTIONS + +=head2 new( 'option' => 'value' ) + +The C function takes a list of options and values, and returns +a new B object which can then be used to generate SQL. +This function operates in exactly the same way as the same from L +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, 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. (In fact, we're actually calling the same method +from the parent class.) ORDER BY clause handling is also purely inheritted +from L. The "rows" and "page" pagination functionality is +inspired from L and operates the same way. Alternatively, you can +explicitly set a "limit" value. + +=back + +=head1 SEE ALSO + +L, L, L. + +=head1 AUTHOR + +Gryphon Shafer, Egryphon@cpan.orgE + +=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 diff --git a/t/00-load.t b/t/00-load.t new file mode 100644 index 0000000..55a0969 --- /dev/null +++ b/t/00-load.t @@ -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" ); diff --git a/t/Complete.t b/t/Complete.t new file mode 100644 index 0000000..933750d --- /dev/null +++ b/t/Complete.t @@ -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)' ); diff --git a/t/boilerplate.t b/t/boilerplate.t new file mode 100644 index 0000000..8dd9399 --- /dev/null +++ b/t/boilerplate.t @@ -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'); +} diff --git a/t/manifest.t b/t/manifest.t new file mode 100644 index 0000000..15a25cf --- /dev/null +++ b/t/manifest.t @@ -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/]}); diff --git a/t/pod-coverage.t b/t/pod-coverage.t new file mode 100644 index 0000000..621c860 --- /dev/null +++ b/t/pod-coverage.t @@ -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(); diff --git a/t/pod.t b/t/pod.t new file mode 100644 index 0000000..236d03c --- /dev/null +++ b/t/pod.t @@ -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();