Skip to content
Browse files

First commit.

  • Loading branch information...
0 parents commit 4f9c33a4d2fe816eb913bcc2b9ce2c0dd8d6602c @bluefeet committed Sep 4, 2011
486 lib/SQL/Abstract/Query.pm
@@ -0,0 +1,486 @@
+package SQL::Abstract::Query;
+use Moose;
+use namespace::autoclean;
+
+=head1 NAME
+
+SQL::Abstract::Query - An advanced SQL generator.
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+This library provides the ability to generate SQL using database-independent Perl
+data structures, is built upon the proven capabilities of L<SQL::Abstract>, and
+robust and extendable thanks to L<Moose>.
+
+Much of the inspiration for this library came from such modules as
+L<SQL::Abstract::Limit>, L<SQL::Maker>, and L<SQL::Abstract::More>.
+
+=over
+
+=item * Queries are constructed as objects which can be re-used.
+
+=item * Supports explicit JOINs.
+
+=item * GROUP BY is supported.
+
+=item * LIMIT/OFFSET is supported (with cross-database compatibility) and uses placeholders.
+
+=item * Easy to extend with Moose subclassing, traits, and roles.
+
+=item * The API has been designed in such a way that extending the functionality in the
+future should be less likely to break backwards compatibility.
+
+=item * Re-using a query via prepare/execute is trivial and can be done with for all
+query types (even UPDATE ... WHERE ...).
+
+=back
+
+=cut
+
+use SQL::Abstract;
+use Moose::Util::TypeConstraints;
+
+use SQL::Abstract::Query::Insert;
+use SQL::Abstract::Query::Update;
+use SQL::Abstract::Query::Select;
+use SQL::Abstract::Query::Delete;
+
+=head1 CONSTRUCTOR
+
+ # Create a new instance with the standard dialect:
+ my $query = SQL::Abstract::Query->new();
+
+ # Auto-detect the appropriate dialect from a DBI handle:
+ my $query = SQL::Abstract::Query->new( $dbh );
+
+ # Explicitly set the dialect that you want:
+ my $query = SQL::Abstract::Query->new( 'oracle' );
+
+ # Or specify attributes explicitly:
+ my $query = SQL::Abstract::Query->new( %attributes );
+
+=cut
+
+around 'BUILDARGS' => sub{
+ my $orig = shift;
+ my $self = shift;
+
+ if (@_ == 1) {
+ return $self->$orig( dialect => $_[0] );
+ }
+
+ return $self->$orig( @_ );
+};
+
+=head1 ATTRIBUTES
+
+=head2 dialect
+
+Each implementation, or dialect, of SQL has quirks that slightly (or in some cases
+drastically) change the way that the SQL must be written to get a particular task
+done. In order for this module to know which particular set of quirks it should
+use a dialect must be declared. The dialect will default to "standard" which will
+match the ISO SQL standards. But, unless you are using PostgreSQL or SQLite, you
+are most likely using a database that does not conform to the standards and will
+need special treatment by this module to produce SQL that is compatible.
+
+Currently a dialect can be one of:
+
+ standard
+ mysql
+ oracle
+
+When declaring the dialect that you want you can either specify one of the dialects
+above, or you can just pass a DBI handle ($dbh) and it will be auto-detected. Currently
+the list of supported DBI Driver is limited to:
+
+ DBD::mysql (mysql)
+ DBD::Oracle (oracle)
+ DBD::Pg (standard)
+ DBD::PgPP (standard)
+ DBD::SQLite (standard)
+
+If the driver that you are using is not in the above list then please contact the
+author and work with them to get it added.
+
+=cut
+
+my $dbd_dialects = {
+ 'mysql' => 'mysql',
+ 'Oracle' => 'oracle',
+ 'Pg' => 'standard',
+ 'PgPP' => 'standard',
+ 'SQLite' => 'standard',
+};
+
+my $dialects = {
+ standard => {
+ limit => 'offset',
+ quote_char => q["],
+ sep_char => q[.],
+ },
+ mysql => {
+ limit => 'xy',
+ quote_char => q[`],
+ sep_char => q[.],
+ },
+ oracle => {
+ limit => 'rownum',
+ quote_char => q["],
+ sep_char => q[.],
+ },
+};
+
+subtype 'SQL::Abstract::Query::Types::Dialect',
+ as enum([ keys %$dialects ]);
+
+coerce 'SQL::Abstract::Query::Types::Dialect',
+ from class_type('DBI::db'),
+ via { $dbd_dialects->{ $_->{Driver}->{Name} } };
+
+has dialect => (
+ is => 'ro',
+ isa => 'SQL::Abstract::Query::Types::Dialect',
+ coerce => 1,
+ default => 'standard',
+);
+
+=head2 limit_dialect
+
+This is the dialect that is used to limit results for a select. The
+possible values are:
+
+ offset (standard dialect)
+ xy (mysql dialect)
+ rownum (oracle dialect)
+
+The limit dialect will be automatically derived from the overall dialect
+so you will normally not want to override this.
+
+=cut
+
+my $limit_dialects = [qw(
+ xy
+ offset
+ rownum
+)];
+
+has limit_dialect => (
+ is => 'ro',
+ isa => enum( $limit_dialects ),
+ lazy_build => 1,
+);
+sub _build_limit_dialect {
+ my ($self) = @_;
+ return $dialects->{ $self->dialect() }->{limit};
+}
+
+=head2 quote_char
+
+The character that is used to quote identifiers, such as table and column
+names. This will default to the appropriate quoting character for the
+current dialect.
+
+=cut
+
+subtype 'SQL::Abstract::Query::Types::QuoteChar',
+ as 'Str',
+ where { length($_) == 1 },
+ message { 'The quote_char attribute must be a single-character scalar' };
+
+has quote_char => (
+ is => 'ro',
+ isa => 'SQL::Abstract::Query::Types::QuoteChar',
+ lazy_build => 1,
+);
+sub _build_quote_char {
+ my ($self) = @_;
+ return $dialects->{ $self->dialect() }->{quote_char};
+}
+
+=head2 sep_char
+
+The character that is used to separate linked identifiers, such as
+a table name followed by a column name. This will default to the appropriate
+separation character for the current dialect.
+
+=cut
+
+subtype 'SQL::Abstract::Query::Types::SepChar',
+ as 'Str',
+ where { length($_) == 1 },
+ message { 'The sep_char attribute must be a single-character scalar' };
+
+has sep_char => (
+ is => 'ro',
+ isa => 'SQL::Abstract::Query::Types::SepChar',
+ lazy_build => 1,
+);
+sub _build_sep_char {
+ my ($self) = @_;
+ return $dialects->{ $self->dialect() }->{sep_char};
+}
+
+=head2 abstract
+
+The underlying L<SQL::Abstract> object that will be used to generate
+much of the SQL for this module. There really isn't much need for you
+to set this attribute yourself unless you are doing something really
+crazy.
+
+=cut
+
+has abstract => (
+ is => 'ro',
+ isa => 'SQL::Abstract',
+ lazy_build => 1,
+);
+sub _build_abstract {
+ my ($self) = @_;
+ return SQL::Abstract->new(
+ quote_char => $self->quote_char(),
+ name_sep => $self->sep_char(),
+ );
+}
+
+=head1 METHODS
+
+=head2 insert
+
+ # Create a new SQL::Abstract::Query::Insert object:
+ my $insert = $query->insert( $table, \@fields, \%attributes );
+
+ # Or bypass the object alltogether if you don't need it:
+ my ($sql, @bind_values) = $query->insert( $table, \%field_values, \%attributes );
+
+See the L<SQL::Abstract::Query::Insert> documentation for more details.
+
+=cut
+
+sub insert {
+ my $self = shift;
+ if (wantarray()) { return SQL::Abstract::Query::Insert->call( $self, @_ ); }
+ else { return SQL::Abstract::Query::Insert->new( $self, @_ ); }
+}
+
+=head2 update
+
+ my $update = $query->update( $table, \@fields, \%where, \%attributes );
+
+ my ($sql, @bind_values) = $query->update( $table, \%field_values, \%where, \%attributes );
+
+See the L<SQL::Abstract::Query::Update> documentation for more details.
+
+=cut
+
+sub update {
+ my $self = shift;
+ if (wantarray()) { return SQL::Abstract::Query::Update->call( $self, @_ ); }
+ else { return SQL::Abstract::Query::Update->new( $self, @_ ); }
+}
+
+=head2 select
+
+ my $select = $query->select( \@fields, $from, \%where, \%attributes );
+
+ my ($sql, @bind_values) = $query->select( \@fields, $from, \%where, \%attributes );
+
+See the L<SQL::Abstract::Query::Select> documentation for more details.
+
+=cut
+
+sub select {
+ my $self = shift;
+ if (wantarray()) { return SQL::Abstract::Query::Select->call( $self, @_ ); }
+ else { return SQL::Abstract::Query::Select->new( $self, @_ ); }
+}
+
+=head2 delete
+
+ my $delete = $query->delete( $table, \%where, \%attributes );
+
+ my ($sql, @bind_values) = $query->delete( $table, \%where, \%attributes );
+
+See the L<SQL::Abstract::Query::Delete> documentation for more details.
+
+=cut
+
+sub delete {
+ my $self = shift;
+ if (wantarray()) { return SQL::Abstract::Query::Delete->call( $self, @_ ); }
+ else { return SQL::Abstract::Query::Delete->new( $self, @_ ); }
+}
+
+__PACKAGE__->meta->make_immutable;
+1;
+__END__
+
+=head1 APPENDIX
+
+=head2 Why Yet Another SQL Generator?
+
+There are quite a few SQL generators out there, including:
+
+=over
+
+=item * L<SQL::Abstract>
+
+=item * L<SQL::Maker>
+
+=item * L<SQL::Generator>
+
+=item * L<SQL::OOP>
+
+=item * L<SQL::Entity>
+
+=back
+
+By far the most popular and battle tested is SQL::Abstract. This module
+takes the great things about SQL::Abstract and makes them better. Others
+have tried to do this, but with limited success, so this module aims to do
+it right.
+
+=head2 API Stability
+
+This module is currently in a working draft state. I am confident that
+the current implementation is complete, well thought-out, and well
+tested. But, I still need to receive some input from the perl community
+before I can say the API is 100% stable. Until then it is possible that
+changes will be made that break backwards compatibility.
+
+If you use this module then please contact the author describing your
+experience and any thoughts you may have.
+
+If this statement concerns you then you should also send the author an
+e-mail asking about the API stability. It may very well be that the
+API can now be considered stable but a release of this library has not
+yet been made that states as much.
+
+=head2 Compatibility
+
+This module aims to be compatible with the core L<SQL::Abstract> API as much
+as possible, but not at the expense of degrading quality. There are
+parts of the SQL::Abstract API that are difficult to extend, others
+that are sub-optimal but cannot be changed due to backwards compatibility
+requirements, and still others that just don't make sense due to the drastic
+design difference of this module. These aspects of SQL::Abstract will not
+be reproduced in this module.
+
+Here is a list of the current differences between this module's API and SQL
+generation and what SQL::Abstract does:
+
+=over
+
+=item * The select() method takes the fields as the first argument rather
+than the second argument. This better matches how SQL is written and
+is more natural.
+
+=item * All identifiers are quoted by default since not doing so will
+cause SQL that has identifiers which look like reserved words to fail.
+
+=item * The fourth argument to select() is not $order as it is in
+SQL::Abstract, instead it is a hash of L<SQL::Abstract::Query::Select>
+attributes where one of the attributes may be order_by.
+
+=item * SQL::Abstract is not being used to generate the ORDER BY clause.
+This is partly due to other clauses needing to gain access to the SQL
+before the ORDER BY is appended to it, and also because SQL::Abstract's
+implementation of ORDER BY is a bit convoluted.
+
+=item * Many of SQL::Abstract's methods and attributes are not reproduced.
+Some of these may be made available at a later date, but likely not unless
+someone has a use-case for needing them.
+
+=item * SQL::Abstract supports *very* complex arguments, which is great, but
+some of them seem to be supported because they can be, rather than because
+someone actually needs it. For example, the ability to provide a reference
+of an array reference as the source for a select. Also, by not supporting
+all the multitudes of variations of arguments this module has much more room
+to grow and take advantage of these available argument formats for different
+purposes.
+
+=item * The insert() method does not accept field values as an array reference.
+This is by design - SQL that depends on the order of the columns in the
+database is brittle and will eventually break. Also, due to the need for the
+query objects to be re-useable the array ref form of fields has been re-purposed.
+That being said, perhaps there is a use case where this would be useful. If so,
+thunk the author on the head and let him know.
+
+=item * The insert() method does not yet accept a returning option. This
+may change if a flexible implementation is developed.
+
+=back
+
+If there is something in SQL::Abstract that you think this module should
+support then please let the author know.
+
+=head1 EXTENDING
+
+Guidelines for extending the functionality of this module using plugins, or
+otherwise, have not yet been developed as the internal workings of this
+module are still in flux. There are several entries in the TODO section
+that reflect this.
+
+For now, just shoot the author an e-mail.
+
+=head1 CONTRIBUTING
+
+If you'd like to contribute bug fixes, enhancements, additional test covergage,
+or documentation to this module then by all means do so. You can fork this
+repository using github (l<https://github.com/bluefeet/SQL-Abstract-Query>) and
+then send the author a pull request.
+
+Please contact the author if you are considering doing this and discuss your ideas.
+
+=head1 SUPPORT
+
+Currently there is no particular mailing list or IRC channel for this project.
+You can shoot the author an e-mail if you have a question.
+
+If you'd like to report an issue you can use github's issue tracker:
+L<https://github.com/bluefeet/SQL-Abstract-Query/issues>
+
+=head1 TODO
+
+=over
+
+=item * Document all the various ways this module can be used, possibly as a
+cookboob. Documentation is sorely missing info on placeholders, for one.
+
+=item * Create a unit test that compares the output of this module compared to
+SQL::Abstract, proving that this module is at least as capable.
+
+=item * Support more dialects of SQL (and thus more DBD drivers). Help from
+generous volunteers encouraged and appreciated!
+
+=item * Support the ability to extend the SQL generation logic by hooking in to
+various stages of the SQL generation and alter the behavior. This would, for
+example, allow the LIMIT logic to be moved out of SQL::Abstract::Query::Select
+and in to SQL::Abstract::Query::Select::Limit. This would also allow other
+people to write their own modules that modify SQL generation without having to
+write brittle hacks.
+
+=item * In addition to the above it would be nice if just a portion of a SQL query
+could be generated, such as just the GROUP BY clause, etc. This would be similar
+to SQL::Abstracts's where() method but that API would likely be very different.
+
+=item * Allow for more join types. Currently only JOIN and LEFT JOIN work. This
+should be trivial to add.
+
+=item * Support UPDATE ... SELECT.
+
+=item * Possibly support more SQL commands such as TRUNCATE, ALTER, CREATE, DROP, etc.
+
+=back
+
+=head1 AUTHOR
+
+Aran Clary Deltac <bluefeet@gmail.com>
+
+=head1 LICENSE
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
102 lib/SQL/Abstract/Query/Base.pm
@@ -0,0 +1,102 @@
+package SQL::Abstract::Query::Base;
+use Moose::Role;
+
+=head1 NAME
+
+SQL::Abstract::Query::Base - A role providing base functionality for query objects.
+
+=cut
+
+requires(qw( _build_abstract_result ));
+
+use List::MoreUtils qw( zip );
+use Moose::Util::TypeConstraints;
+
+subtype 'SQL::Abstract::Query::Types::FieldValues',
+ as 'HashRef';
+
+coerce 'SQL::Abstract::Query::Types::FieldValues',
+ from 'ArrayRef',
+ via { return { zip( @$_, @$_ ) } };
+
+subtype 'SQL::Abstract::Query::Types::Table',
+ as 'Str';
+
+has query => (
+ is => 'ro',
+ isa => 'SQL::Abstract::Query',
+ required => 1,
+);
+
+has abstract_result => (
+ is => 'ro',
+ isa => 'ArrayRef',
+ lazy_build => 1,
+);
+
+sub original_values {
+ my ($self) = @_;
+ return @{ $self->_original_values() };
+}
+
+has _original_values => (
+ is => 'ro',
+ isa => 'ArrayRef',
+ lazy_build => 1,
+);
+sub _build__original_values {
+ my ($self) = @_;
+ my @values = @{ $self->abstract_result() };
+ shift( @values );
+ return \@values;
+}
+
+has sql => (
+ is => 'ro',
+ isa => 'Str',
+ lazy_build => 1,
+);
+sub _build_sql {
+ my ($self) = @_;
+ return $self->abstract_result->[0];
+}
+
+sub call {
+ my $class = shift;
+
+ my $self = $class->new( @_ );
+
+ return(
+ $self->sql(),
+ $self->original_values(),
+ );
+}
+
+sub values {
+ my ($self, $field_values) = @_;
+
+ my @values;
+ foreach my $value ($self->original_values()) {
+ push @values, $field_values->{$value};
+ }
+
+ return @values;
+}
+
+sub _quote {
+ my $self = shift;
+ return $self->query->abstract->_quote( @_ );
+}
+
+1;
+__END__
+
+=head1 AUTHOR
+
+Aran Clary Deltac <bluefeet@gmail.com>
+
+=head1 LICENSE
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
88 lib/SQL/Abstract/Query/Delete.pm
@@ -0,0 +1,88 @@
+package SQL::Abstract::Query::Delete;
+use Moose;
+use namespace::autoclean;
+
+=head1 NAME
+
+SQL::Abstract::Query::Delete - An object that represents a SQL DELETE.
+
+=head1 DESCRIPTION
+
+The delete query is a very lightweight wrapper around L<SQL::Abstract>'s delete()
+method and provides no additional SQL syntax.
+
+=cut
+
+with 'SQL::Abstract::Query::Base';
+
+around 'BUILDARGS' => sub{
+ my $orig = shift;
+ my $class = shift;
+
+ if (@_ and ref($_[0])) {
+ my ($query, $table, $where, $attributes) = @_;
+
+ $attributes ||= {};
+ my $args = {
+ query => $query,
+ table => $table,
+ %$attributes,
+ };
+
+ $args->{where} = $where if $where;
+
+ return $class->$orig( $args );
+ }
+
+ return $class->$orig( @_ );
+};
+
+=head1 ATTRIBUTES
+
+=head2 table
+
+The table to delete rows from. Gets passed straight on to L<SQL::Abstract>.
+
+=cut
+
+has table => (
+ is => 'ro',
+ isa => 'Str',
+ required => 1,
+);
+
+=head2 where
+
+The where clause, optional. Gets passed on, unmodified, to L<SQL::Abstract>.
+
+=cut
+
+has where => (
+ is => 'ro',
+ isa => 'HashRef|ArrayRef|Str',
+);
+
+sub _build_abstract_result {
+ my ($self) = @_;
+
+ my ($sql, @bind_values) = $self->query->abstract->delete(
+ $self->table(),
+ $self->where(),
+ );
+
+ return [$sql, @bind_values];
+}
+
+__PACKAGE__->meta->make_immutable;
+1;
+__END__
+
+=head1 AUTHOR
+
+Aran Clary Deltac <bluefeet@gmail.com>
+
+=head1 LICENSE
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
80 lib/SQL/Abstract/Query/Insert.pm
@@ -0,0 +1,80 @@
+package SQL::Abstract::Query::Insert;
+use Moose;
+use namespace::autoclean;
+
+=head1 NAME
+
+SQL::Abstract::Query::Insert - An object that represents a SQL INSERT.
+
+=cut
+
+with 'SQL::Abstract::Query::Base';
+
+around 'BUILDARGS' => sub{
+ my $orig = shift;
+ my $class = shift;
+
+ if (@_ and ref($_[0])) {
+ my ($query, $table, $field_values, $attributes) = @_;
+
+ $attributes ||= {};
+ my $args = {
+ query => $query,
+ table => $table,
+ field_values => $field_values,
+ %$attributes,
+ };
+
+ return $class->$orig( $args );
+ }
+
+ return $class->$orig( @_ );
+};
+
+=head1 ATTRIBUTES
+
+=head2 table
+
+=cut
+
+has table => (
+ is => 'ro',
+ isa => 'SQL::Abstract::Query::Types::Table',
+ required => 1,
+);
+
+=head2 field_values
+
+=cut
+
+has field_values => (
+ is => 'ro',
+ isa => 'SQL::Abstract::Query::Types::FieldValues',
+ coerce => 1,
+ required => 1,
+);
+
+sub _build_abstract_result {
+ my ($self) = @_;
+
+ my ($sql, @bind_values) = $self->query->abstract->insert(
+ $self->table(),
+ $self->field_values(),
+ );
+
+ return [$sql, @bind_values];
+}
+
+__PACKAGE__->meta->make_immutable;
+1;
+__END__
+
+=head1 AUTHOR
+
+Aran Clary Deltac <bluefeet@gmail.com>
+
+=head1 LICENSE
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
443 lib/SQL/Abstract/Query/Select.pm
@@ -0,0 +1,443 @@
+package SQL::Abstract::Query::Select;
+use Moose;
+use namespace::autoclean;
+
+=head1 NAME
+
+SQL::Abstract::Query::Select - An object that represents a SQL SELECT.
+
+=head1 SYNOPSIS
+
+You'll need to create an L<SQL::Abstract::Query> object first:
+
+ use SQL::Abstract::Query;
+ my $query = SQL::Absract::Query->new();
+
+Now you can create a select object and use it:
+
+ my $select = $query->select(
+ [qw( name email )],
+ 'users',
+ { is_admin => 'is_admin', age => {'>=', 'min_age'} },
+ \%attributes,
+ );
+
+ my $sql = $select->sql();
+ my $sth = $dbh->prepare( $sql );
+
+ my @bind_values = $select->values({ is_admin => 1, min_age => 18 });
+ $sth->execute( @bind_values );
+
+ while (my $row = $sth->fetchrow_array()) {
+ print "$row->{name}: $row->{email}\n";
+ }
+
+Or you can bypass object creation and use an interface very similar
+to L<SQL::Abstract>'s:
+
+ my ($sql, @bind_values) = $query->select(
+ [qw( name email )],
+ 'users',
+ { is_admin => 1, age => {'>=', 18} },
+ \%attributes,
+ );
+
+=head1 DESCRIPTION
+
+This module extends L<SQL::Abstract>'s select() method by wrapping it
+up in to an object that can be re-used and adding additional functionality.
+
+=cut
+
+with 'SQL::Abstract::Query::Base';
+
+use Carp qw( croak );
+use Clone qw( clone );
+use List::MoreUtils qw( zip any );
+use List::Util qw( first );
+
+around 'BUILDARGS' => sub{
+ my $orig = shift;
+ my $class = shift;
+
+ if (@_ and ref($_[0])) {
+ my ($query, $fields, $from, $where, $attributes) = @_;
+
+ $attributes ||= {};
+ my $args = {
+ query => $query,
+ fields => $fields,
+ from => $from,
+ %$attributes,
+ };
+
+ $args->{where} = $where if $where;
+
+ return $class->$orig( $args );
+ }
+
+ return $class->$orig( @_ );
+};
+
+=head1 ATTRIBUTES
+
+=head2 fields
+
+An array ref of field names or a scalar. This is passed unmodified to
+L<SQL::Abstract>.
+
+=cut
+
+has fields => (
+ is => 'ro',
+ isa => 'ArrayRef|Str',
+ required => 1,
+);
+
+=head2 from
+
+The FROM section of the SELECT query. Can be either a Scalar which will be quoted,
+an array ref of either scalars or arrays, or a scalar ref wich will not be quoted.
+
+A single table, quoted:
+
+ from => 'users'
+ FROM "users"
+
+An arbitrary string, not quoted:
+
+ from => \'users'
+ FROM users
+
+A list of table names, some may be quoted, some not, separated by commas:
+
+ from => ['users', \'user_emails']
+ FROM "users", user_emails
+
+A list of table names, the first one with an alias:
+
+ from => [ {name => users, as => 'u'}, 'user_emails' ]
+ FROM "users" "u", "user_emails"
+
+A join with aliases:
+
+ from => [ {users => 'u'}, {user_emails => e, using => 'user_id'} ]
+ FROM "users" "u" JOIN "user_emails" "e" ON ( "e"."user_id" = "u"."user_id" )
+
+Another join but using "on" instead of "using", and adding another non-join table:
+
+ from => [ {users => 'u'}, {user_emails => 'e', on=>{ 'e.user_id' => \'= u.user_id' }}, 'logs' ]
+ FROM "users" "u" JOIN "user_emails" "e" ON ( "e"."user_id" = u.user_id ), logs
+
+Note that the FROM part of the SELECT is not handled by L<SQL::Abstract> at all.
+
+=cut
+
+has from => (
+ is => 'ro',
+ isa => 'Str|ArrayRef[Str|HashRef]|ScalarRef',
+ required => 1,
+);
+
+=head2 where
+
+The WHERE clause which can be a hash ref, an array ref, or a scalar. This gets
+passed to L<SQL::Abstract> unmodified.
+
+=cut
+
+has where => (
+ is => 'ro',
+ isa => 'HashRef|ArrayRef|Str',
+);
+
+=head2 group_by
+
+The GROUP BY clause which can be a scalar or an array reference. L<SQL::Abstract>
+does not natively support GROUP BY so this module generates the SQL itself. Here are
+some samples:
+
+Group by a single column:
+
+ group_by => 'foo'
+ GROUP BY "foo"
+
+Group by several columns:
+
+ group_by => ['foo', 'bar']
+ GROUP BY "foo", "bar"
+
+=cut
+
+has group_by => (
+ is => 'ro',
+ isa => 'Str|ArrayRef',
+);
+
+=head2 order_by
+
+The ORDER BY clause which can be a scalar or an array reference. This order_by
+is not processed by L<SQL::Abstract> at all and is instead handled by this module
+completely. Here are some samples of valid input and what the SQL would look like:
+
+Order by a single column:
+
+ order_by => 'foo'
+ ORDER BY "foo"
+
+Order by several columns:
+
+ order_by => ['foo', 'bar']
+ ORDER BY "foo", "bar"
+
+Order by several columns, setting the ordering direction:
+
+ order_by => [ [foo => 'asc'], 'bar' ]
+ ORDER BY "foo" ASC, "bar"
+
+=cut
+
+has order_by => (
+ is => 'ro',
+ isa => 'Str|HashRef|ArrayRef',
+);
+
+=head2 limit
+
+The maximum number of rows that the query should return. This can
+be either an integer or a string for use with values().
+
+=cut
+
+has limit => (
+ is => 'ro',
+ isa => 'Str',
+);
+
+=head2 offset
+
+The number of rows to offset the query by. For example, if you had 20
+rows and set the limit to 10 and the offset to 5 you'd get rows 5
+through 14 (where row 1 is the first row). The setting of offset will
+be ignored if the limit is not also set.
+
+This can be either an integer or a string for use with values().
+
+=cut
+
+has offset => (
+ is => 'ro',
+ isa => 'Str',
+);
+
+sub _build_abstract_result {
+ my ($self) = @_;
+
+ my ($from, @from_values) = $self->_apply_from();
+
+ my ($sql, @bind_values) = $self->query->abstract->select(
+ $from,
+ $self->fields(),
+ $self->where(),
+ );
+
+ $self->_apply_group_by( \$sql );
+
+ $self->_apply_order_by( \$sql );
+
+ $self->_apply_limit( \$sql, \@bind_values );
+
+ return [$sql, @from_values, @bind_values];
+}
+
+sub _apply_from {
+ my ($self) = @_;
+
+ my $from = $self->from();
+ return $from if ref($from) ne 'ARRAY';
+
+ my $abstract = $self->query->abstract();
+
+ my $sql = '';
+ my @bind_values;
+ my $previous_table;
+ foreach my $table (@$from) {
+ if (!ref $table) {
+ $sql .= ', ' if $sql;
+ $sql .= $self->_quote( $table );
+ $previous_table = { name => $table, common => $table };
+ next;
+ }
+ elsif (ref($table) eq 'SCALAR') {
+ $sql .= ', ' if $sql;
+ $sql .= $table;
+ next;
+ }
+ elsif (ref($table) ne 'HASH') {
+ croak 'A non scalar or hash entry found in the from attribute';
+ }
+
+ $table = clone( $table );
+
+ if (!$table->{name}) {
+ my $key = first {
+ my $key = $_;
+ return (any { $key eq $_ } qw( on using join )) ? 0 : 1;
+ } keys %$table;
+ $table->{name} = $key;
+ $table->{as} = $table->{$key};
+ }
+
+ $table->{common} = $table->{as} || $table->{name};
+
+ my $is_join = ($table->{join} or $table->{on} or $table->{using}) ? 1 : 0;
+
+ if ($sql) {
+ $sql .= ',' if !$is_join;
+ $sql .= ' ';
+ }
+
+ my @parts;
+
+ if ($is_join) {
+ if ($table->{join}) {
+ push @parts, 'LEFT' if $table->{join} eq 'left';
+ }
+ push @parts, 'JOIN';
+ }
+
+ push @parts, $self->_quote( $table->{name} );
+ push @parts, $self->_quote( $table->{as} ) if $table->{as};
+
+ if ($table->{using}) {
+ my $right = '= ' . $self->_quote( $previous_table->{common} . '.' . $table->{using} );
+ $table->{on} = { $table->{common} . '.' . $table->{using} => \$right };
+ }
+
+ if ($table->{on}) {
+ my ($where_sql, @where_values) = $abstract->where( $table->{on} );
+ $where_sql =~ s{^ WHERE }{}s;
+
+ # SQL::Abstract has an annoying habit if adding too many braces in some situations.
+ my $start_braces = ($where_sql =~ m{^([( ]+)}s)[0];
+ my $end_braces = ($where_sql =~ m{([) ]+)$}s)[0];
+ $start_braces =~ s{ }{}g;
+ $end_braces =~ s{ }{}g;
+ my $braces_count = (length($start_braces) <= length($end_braces)) ? length($start_braces) : length($end_braces);
+ foreach (1..$braces_count) {
+ $where_sql =~ s{^ *\( *(.+?) *\) *$}{$1};
+ }
+
+ push @parts, 'ON', '(', $where_sql, ')';
+ push @bind_values, @where_values;
+ }
+
+ $sql .= join(' ', @parts);
+ $previous_table = $table;
+ }
+
+ return( \$sql, @bind_values );
+}
+
+sub _apply_group_by {
+ my ($self, $sql) = @_;
+
+ my $group_by = $self->group_by();
+ return if !$group_by;
+
+ my $abstract = $self->query->abstract();
+
+ $$sql .= ' GROUP BY ';
+ if (ref $group_by) {
+ $$sql .= join(', ', map { $self->_quote( $_ ) } @$group_by);
+ }
+ else {
+ $$sql .= $self->_quote( $group_by );
+ }
+
+ return;
+}
+
+sub _apply_order_by {
+ my ($self, $sql) = @_;
+
+ my $order_by = $self->order_by();
+ return if !$order_by;
+
+ my $abstract = $self->query->abstract();
+
+ $$sql .= ' ORDER BY ';
+ if (ref $order_by) {
+ my @parts;
+ foreach my $field (@$order_by) {
+ if (ref($field) eq 'ARRAY' and @$field==2) {
+ push @parts, $self->_quote( $field->[0] ) . ' ' . uc( $field->[1] );
+ next;
+ }
+
+ push @parts, $self->_quote( $field );
+ }
+
+ $$sql .= join(', ', @parts);
+ }
+ else {
+ $$sql .= $self->_quote( $order_by );
+ }
+
+ return;
+}
+
+sub _apply_limit {
+ my ($self, $sql, $bind_values) = @_;
+
+ my $limit = $self->limit();
+
+ return if !$limit;
+
+ my $offset = $self->offset();
+ my $abstract = $self->query->abstract();
+ my $dialect = $self->query->limit_dialect();
+
+ if ($dialect eq 'offset') {
+ $$sql .= ' LIMIT ?';
+ push @$bind_values, $limit;
+
+ if (defined $offset) {
+ $$sql .= ' OFFSET ?';
+ push @$bind_values, $offset;
+ }
+ }
+ elsif ($dialect eq 'xy') {
+ $$sql .= ' LIMIT';
+ if (defined $offset) {
+ $$sql .= ' ?,';
+ push @$bind_values, $offset;
+ }
+ $$sql .= ' ?';
+ push @$bind_values, $limit;
+ }
+ elsif ($dialect eq 'rownum') {
+ my $inner_table = $self->_quote('A');
+ my $outer_table = $self->_quote('B');
+ my $rownum_column = $self->_quote('r');
+
+ $$sql = "SELECT * FROM ( SELECT $inner_table.*, ROWNUM $rownum_column FROM ( " . $$sql . " ) $inner_table WHERE ROWNUM <= ? + ? ) $outer_table WHERE $rownum_column > ?";
+ push @$bind_values, $limit, $offset, $offset;
+ }
+
+ return;
+}
+
+__PACKAGE__->meta->make_immutable;
+1;
+__END__
+
+=head1 AUTHOR
+
+Aran Clary Deltac <bluefeet@gmail.com>
+
+=head1 LICENSE
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
94 lib/SQL/Abstract/Query/Update.pm
@@ -0,0 +1,94 @@
+package SQL::Abstract::Query::Update;
+use Moose;
+use namespace::autoclean;
+
+=head1 NAME
+
+SQL::Abstract::Query::Update - An object that represents a SQL UPDATE.
+
+=cut
+
+with 'SQL::Abstract::Query::Base';
+
+around 'BUILDARGS' => sub{
+ my $orig = shift;
+ my $class = shift;
+
+ if (@_ and ref($_[0])) {
+ my ($query, $table, $field_values, $where, $attributes) = @_;
+
+ $attributes ||= {};
+ my $args = {
+ query => $query,
+ table => $table,
+ field_values => $field_values,
+ %$attributes,
+ };
+
+ $args->{where} = $where if $where;
+
+ return $class->$orig( $args );
+ }
+
+ return $class->$orig( @_ );
+};
+
+=head1 ATTRIBUTES
+
+=head2 table
+
+=cut
+
+has table => (
+ is => 'ro',
+ isa => 'SQL::Abstract::Query::Types::Table',
+ required => 1,
+);
+
+=head2 field_values
+
+=cut
+
+has field_values => (
+ is => 'ro',
+ isa => 'SQL::Abstract::Query::Types::FieldValues',
+ coerce => 1,
+ required => 1,
+);
+
+=head2 where
+
+=cut
+
+has where => (
+ is => 'ro',
+ isa => 'HashRef|ArrayRef|Str',
+);
+
+sub _build_abstract_result {
+ my ($self) = @_;
+
+ my $abstract = $self->query->abstract();
+
+ my ($sql, @bind_values) = $abstract->update(
+ $self->table(),
+ $self->field_values(),
+ $self->where(),
+ );
+
+ return [$sql, @bind_values];
+}
+
+__PACKAGE__->meta->make_immutable;
+1;
+__END__
+
+=head1 AUTHOR
+
+Aran Clary Deltac <bluefeet@gmail.com>
+
+=head1 LICENSE
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
90 t/dbi.t
@@ -0,0 +1,90 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use Test::More;
+use SQL::Abstract::Query;
+use Try::Tiny;
+
+try {
+ require DBI;
+ require DBD::SQLite;
+}
+catch {
+ plan skip_all => 'DBI and DBD::SQLite must be installed to run these tests';
+};
+
+unlink('test.db') if -e 'test.db';
+my $dbh = DBI->connect('dbi:SQLite:dbname=test.db', '', '', {RaiseError=>1, AutoCommit=>1});
+
+my $query = SQL::Abstract::Query->new( $dbh );
+
+$dbh->do(q[
+ CREATE TABLE users (
+ user_id INTEGER,
+ email TEXT,
+ is_admin INTEGER DEFAULT 0
+ )
+]);
+
+{
+ my $insert = $query->insert('users', [qw( user_id email )]);
+
+ my $sth = $dbh->prepare( $insert->sql() );
+
+ foreach my $user_id (1..100) {
+ $sth->execute(
+ $insert->values({ user_id => $user_id, email => 'user' . $user_id . '@example.com' }),
+ );
+ }
+
+ is(
+ count(),
+ 100,
+ '100 users inserted',
+ );
+}
+
+{
+ is( count({is_admin=>1}), 0, 'no admins yet' );
+
+ my $update = $query->update('users', ['is_admin'], {user_id=>{'<=', 'max_user_id'}});
+
+ my $sth = $dbh->prepare( $update->sql() );
+
+ $sth->execute( $update->values({is_admin=>1, max_user_id=>10}) );
+ is( count({is_admin=>1}), 10, '10 users updated to be admins' );
+
+ $sth->execute( $update->values({is_admin=>1, max_user_id=>30}) );
+ is( count({is_admin=>1}), 30, '20 more (30 total) users updated to be admins' );
+}
+
+{
+ my $delete = $query->delete('users', {email=>'email'});
+
+ my $sth = $dbh->prepare( $delete->sql() );
+
+ $sth->execute( $delete->values({email => 'user1@example.com'}) );
+ is( count(), 99, 'deleted one user' );
+
+ $sth->execute( $delete->values({email => 'user11@example.com'}) );
+ $sth->execute( $delete->values({email => 'user31@example.com'}) );
+ is( count(), 97, 'delete 2 more users' );
+ is( count({is_admin=>1}), 28, '2 of those deleted were admins' );
+ is( count({is_admin=>0}), 69, '1 of those deleted were not admins' );
+}
+
+done_testing;
+
+sub count {
+ my ($where) = @_;
+ $where ||= {};
+
+ my ($sql, @bind_values) = $query->select(
+ [\'COUNT(*)'],
+ 'users',
+ $where,
+ );
+
+ return ( $dbh->selectrow_array( $sql, undef, @bind_values ) )[0];
+}
37 t/delete.t
@@ -0,0 +1,37 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use Test::More;
+
+BEGIN {
+ use_ok( 'SQL::Abstract::Query::Delete' );
+ use_ok( 'SQL::Abstract::Query' );
+}
+
+my $query = SQL::Abstract::Query->new();
+
+{
+ my $delete = $query->delete('users');
+ is(
+ $delete->sql(),
+ 'DELETE FROM "users"',
+ 'basic delete',
+ );
+}
+
+{
+ my $delete = $query->delete('users', { user_id => 32 });
+ is(
+ $delete->sql(),
+ 'DELETE FROM "users" WHERE ( "user_id" = ? )',
+ 'delete with where',
+ );
+ is_deeply(
+ [ $delete->original_values() ],
+ ['32'],
+ 'values is correct',
+ );
+}
+
+done_testing;
50 t/insert.t
@@ -0,0 +1,50 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use Test::More;
+
+BEGIN {
+ use_ok( 'SQL::Abstract::Query::Insert' );
+ use_ok( 'SQL::Abstract::Query' );
+}
+
+my $query = SQL::Abstract::Query->new();
+
+{
+ my $insert = $query->insert('users', ['foo']);
+ is(
+ $insert->sql(),
+ 'INSERT INTO "users" ( "foo") VALUES ( ? )',
+ 'basic insert',
+ );
+
+ is_deeply(
+ [ $insert->original_values() ],
+ ['foo'],
+ 'original values is correct',
+ );
+
+ is_deeply(
+ [ $insert->values({foo=>32}) ],
+ [32],
+ 'values is correct',
+ );
+}
+
+{
+ my ($sql, @bind_values) = $query->insert('users', {foo => 32});
+ is(
+ $sql,
+ 'INSERT INTO "users" ( "foo") VALUES ( ? )',
+ 'SQL for non-OO insert are correct',
+ );
+
+ is_deeply(
+ \@bind_values,
+ [32],
+ 'bind values for non-OO insert are correct',
+ );
+}
+
+done_testing;
198 t/select.t
@@ -0,0 +1,198 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use Test::More;
+
+BEGIN {
+ use_ok( 'SQL::Abstract::Query::Select' );
+ use_ok( 'SQL::Abstract::Query' );
+}
+
+my $query = SQL::Abstract::Query->new();
+
+# JOIN
+
+{
+ my $select = $query->select(
+ ['users.user_id', 'email' ],
+ ['users', 'user_emails'],
+ { 'user_emails.user_id' => \'= users.user_id' },
+ );
+
+ is(
+ $select->sql(),
+ 'SELECT "users"."user_id", "email" FROM "users", "user_emails" WHERE ( "user_emails"."user_id" = users.user_id )',
+ 'implicit joins',
+ );
+}
+
+{
+ my $select = $query->select(
+ ['users.user_id', 'email'],
+ [
+ 'users',
+ { name => 'user_emails', using => 'user_id' },
+ ],
+ );
+
+ is(
+ $select->sql(),
+ 'SELECT "users"."user_id", "email" FROM "users" JOIN "user_emails" ON ( "user_emails"."user_id" = "users"."user_id" )',
+ 'explicit joins',
+ );
+}
+
+# GROUP BY
+
+{
+ my $select = $query->select(
+ ['gender', \'AVG(age)'],
+ 'users',
+ undef,
+ { group_by => 'gender' },
+ );
+
+ is(
+ $select->sql(),
+ 'SELECT "gender", AVG(age) FROM "users" GROUP BY "gender"',
+ 'scalar group by',
+ );
+}
+
+{
+ my $select = $query->select(
+ ['gender', 'title', \'AVG(age)'],
+ 'users',
+ undef,
+ { group_by => ['gender', 'title'] },
+ );
+
+ is(
+ $select->sql(),
+ 'SELECT "gender", "title", AVG(age) FROM "users" GROUP BY "gender", "title"',
+ 'array group by',
+ );
+}
+
+# ORDER BY
+
+{
+ my $select = $query->select(
+ ['name', 'age'],
+ 'users',
+ undef,
+ { order_by => 'age' },
+ );
+
+ is(
+ $select->sql(),
+ 'SELECT "name", "age" FROM "users" ORDER BY "age"',
+ 'scalar order by',
+ );
+}
+
+{
+ my $select = $query->select(
+ ['name', 'age', 'height'],
+ 'users',
+ undef,
+ { order_by => [['age','desc'], 'height'] },
+ );
+
+ is(
+ $select->sql(),
+ 'SELECT "name", "age", "height" FROM "users" ORDER BY "age" DESC, "height"',
+ 'array order by',
+ );
+}
+
+# LIMIT
+
+{
+ my $query = SQL::Abstract::Query->new( limit_dialect => 'offset' );
+
+ my $select = $query->select(
+ ['user_id'],
+ 'users',
+ undef,
+ { limit => 20, offset => 100 },
+ );
+
+ is(
+ $select->sql(),
+ 'SELECT "user_id" FROM "users" LIMIT ? OFFSET ?',
+ 'offset limit dialect sql',
+ );
+
+ is_deeply(
+ [ $select->original_values() ],
+ [20, 100],
+ 'offset limit dialect values',
+ );
+}
+
+{
+ my $query = SQL::Abstract::Query->new( limit_dialect => 'xy' );
+
+ my $select = $query->select(
+ ['user_id'],
+ 'users',
+ undef,
+ { limit => 20, offset => 100 },
+ );
+
+ is(
+ $select->sql(),
+ 'SELECT "user_id" FROM "users" LIMIT ?, ?',
+ 'xy limit dialect sql',
+ );
+
+ is_deeply(
+ [ $select->original_values() ],
+ [100, 20],
+ 'xy limit dialect values',
+ );
+}
+
+{
+ my $query = SQL::Abstract::Query->new( limit_dialect => 'rownum' );
+
+ my $select = $query->select(
+ ['user_id'],
+ 'users',
+ undef,
+ { limit => 20, offset => 100 },
+ );
+
+ is(
+ $select->sql(),
+ 'SELECT * FROM ( SELECT "A".*, ROWNUM "r" FROM ( SELECT "user_id" FROM "users" ) "A" WHERE ROWNUM <= ? + ? ) "B" WHERE "r" > ?',
+ 'rownum limit dialect sql',
+ );
+
+ is_deeply(
+ [ $select->original_values() ],
+ [20, 100, 100],
+ 'rownum limit dialect values',
+ );
+}
+
+# ALL TOGETHER NOW!
+
+{
+ my $select = $query->select(
+ ['u.user_id', 'e.address', \'MAX(logs.level)'],
+ [ {'users' => 'u'}, {name=>'user_emails', as=>'e', on=>{'e.user_id' => \'= u.user_id'}}, 'logs' ],
+ { 'logs.user_id' => \'= u.user_id' },
+ { order_by => 'u.user_id', group_by => [qw( u.user_id e.adress )], limit => 20, offset => 100 },
+ );
+
+ is(
+ $select->sql(),
+ 'SELECT "u"."user_id", "e"."address", MAX(logs.level) FROM "users" "u" JOIN "user_emails" "e" ON ( "e"."user_id" = u.user_id ), "logs" WHERE ( "logs"."user_id" = u.user_id ) GROUP BY "u"."user_id", "e"."adress" ORDER BY "u"."user_id" LIMIT ? OFFSET ?',
+ 'joins, ordery by, group by, and limit',
+ );
+}
+
+done_testing;
44 t/update.t
@@ -0,0 +1,44 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use Test::More;
+
+BEGIN {
+ use_ok( 'SQL::Abstract::Query::Update' );
+ use_ok( 'SQL::Abstract::Query' );
+}
+
+my $query = SQL::Abstract::Query->new();
+
+{
+ my $update = $query->update('users', ['foo']);
+ is(
+ $update->sql(),
+ 'UPDATE "users" SET "foo" = ?',
+ 'basic update',
+ );
+
+ is_deeply(
+ [ $update->original_values() ],
+ ['foo'],
+ 'original values is correct',
+ );
+
+ is_deeply(
+ [ $update->values({foo=>32}) ],
+ [32],
+ 'values is correct',
+ );
+}
+
+{
+ my ($sql, @bind_values) = $query->update('users', {foo => 32});
+ is(
+ $sql,
+ 'UPDATE "users" SET "foo" = ?',
+ 'basic update using non-OO API',
+ );
+}
+
+done_testing;

0 comments on commit 4f9c33a

Please sign in to comment.
Something went wrong with that request. Please try again.