lib/DBIx/Class/SQLMaker.pm

   1 package DBIx::Class::SQLMaker;
   2
   3 use strict;
   4 use warnings;
   5
   6 =head1 NAME
   7
   8 DBIx::Class::SQLMaker - An SQL::Abstract-based SQL maker class
   9
  10 =head1 DESCRIPTION
  11
  12 This module is a subclass of L<SQL::Abstract> and includes a number of
  13 DBIC-specific workarounds, not yet suitable for inclusion into the
  14 L<SQL::Abstract> core. It also provides all (and more than) the functionality
  15 of L<SQL::Abstract::Limit>, see L<DBIx::Class::SQLMaker::LimitDialects> for
  16 more info.
  17
  18 Currently the enhancements to L<SQL::Abstract> are:
  19
  20 =over
  21
  22 =item * Support for C<JOIN> statements (via extended C<table/from> support)
  23
  24 =item * Support of functions in C<SELECT> lists
  25
  26 =item * C<GROUP BY>/C<HAVING> support (via extensions to the order_by parameter)
  27
  28 =item * Support of C<...FOR UPDATE> type of select statement modifiers
  29
  30 =item * The L</-ident> operator
  31
  32 =item * The L</-value> operator
  33
  34 =back
  35
  36 =cut
  37
  38 use base qw/
  39   SQL::Abstract
  40   DBIx::Class::SQLMaker::LimitDialects
  41 /;
  42 use mro 'c3';
  43
  44 use Module::Runtime qw(use_module);
  45 use Sub::Name 'subname';
  46 use DBIx::Class::Carp;
  47 use DBIx::Class::Exception;
  48 use Moo;
  49 use namespace::clean;
  50
  51 has limit_dialect => (
  52   is => 'rw', default => sub { 'LimitOffset' },
  53   trigger => sub { shift->clear_renderer_class }
  54 );
  55
  56 our %LIMIT_DIALECT_MAP = (
  57   'GenericSubQ' => 'GenericSubquery',
  58   'RowCountOrGenericSubQ' => 'RowCountOrGenericSubquery',
  59 );
  60
  61 sub mapped_limit_dialect {
  62   my ($self) = @_;
  63   my $unmapped = $self->limit_dialect;
  64   $LIMIT_DIALECT_MAP{$unmapped}||$unmapped;
  65 }
  66
  67 around _build_renderer_roles => sub {
  68   my ($orig, $self) = (shift, shift);
  69   return (
  70     $self->$orig(@_),
  71     'Data::Query::Renderer::SQL::Slice::'.$self->mapped_limit_dialect
  72   );
  73 };
  74
  75 # for when I need a normalized l/r pair
  76 sub _quote_chars {
  77   map
  78     { defined $_ ? $_ : '' }
  79     ( ref $_[0]->{quote_char} ? (@{$_[0]->{quote_char}}) : ( ($_[0]->{quote_char}) x 2 ) )
  80   ;
  81 }
  82
  83 sub _build_converter_class {
  84   Module::Runtime::use_module('DBIx::Class::SQLMaker::Converter')
  85 }
  86
  87 # FIXME when we bring in the storage weaklink, check its schema
  88 # weaklink and channel through $schema->throw_exception
  89 sub throw_exception { DBIx::Class::Exception->throw($_[1]) }
  90
  91 BEGIN {
  92   # reinstall the belch()/puke() functions of SQL::Abstract with custom versions
  93   # that use DBIx::Class::Carp/DBIx::Class::Exception instead of plain Carp
  94   no warnings qw/redefine/;
  95
  96   *SQL::Abstract::belch = subname 'SQL::Abstract::belch' => sub (@) {
  97     my($func) = (caller(1))[3];
  98     carp "[$func] Warning: ", @_;
  99   };
 100
 101   *SQL::Abstract::puke = subname 'SQL::Abstract::puke' => sub (@) {
 102     my($func) = (caller(1))[3];
 103     __PACKAGE__->throw_exception("[$func] Fatal: " . join ('',  @_));
 104   };
 105
 106   # Current SQLA pollutes its namespace - clean for the time being
 107   namespace::clean->clean_subroutines(qw/SQL::Abstract carp croak confess/);
 108 }
 109
 110 # the "oh noes offset/top without limit" constant
 111 # limited to 31 bits for sanity (and consistency,
 112 # since it may be handed to the like of sprintf %u)
 113 #
 114 # Also *some* builds of SQLite fail the test
 115 #   some_column BETWEEN ? AND ?: 1, 4294967295
 116 # with the proper integer bind attrs
 117 #
 118 # Implemented as a method, since ::Storage::DBI also
 119 # refers to it (i.e. for the case of software_limit or
 120 # as the value to abuse with MSSQL ordered subqueries)
 121 sub __max_int () { 0x7FFFFFFF };
 122
 123 # poor man's de-qualifier
 124 sub _quote {
 125   $_[0]->next::method( ( $_[0]{_dequalify_idents} and ! ref $_[1] )
 126     ? $_[1] =~ / ([^\.]+) $ /x
 127     : $_[1]
 128   );
 129 }
 130
 131 sub _where_op_NEST {
 132   carp_unique ("-nest in search conditions is deprecated, you most probably wanted:\n"
 133       .q|{..., -and => [ \%cond0, \@cond1, \'cond2', \[ 'cond3', [ col => bind ] ], etc. ], ... }|
 134   );
 135
 136   shift->next::method(@_);
 137 }
 138
 139 # Handle limit-dialect selection
 140 sub select {
 141   my ($self, $table, $fields, $where, $rs_attrs, $limit, $offset) = @_;
 142
 143   if (defined $offset) {
 144     $self->throw_exception('A supplied offset must be a non-negative integer')
 145       if ( $offset =~ /\D/ or $offset < 0 );
 146   }
 147   $offset ||= 0;
 148
 149   if (defined $limit) {
 150     $self->throw_exception('A supplied limit must be a positive integer')
 151       if ( $limit =~ /\D/ or $limit <= 0 );
 152   }
 153   elsif ($offset) {
 154     $limit = $self->__max_int;
 155   }
 156
 157   my %final_attrs = (%{$rs_attrs||{}}, limit => $limit, offset => $offset);
 158
 159   if ($limit or $offset) {
 160     my %slice_stability = $self->renderer->slice_stability;
 161
 162     if (my $stability = $slice_stability{$offset ? 'offset' : 'limit'}) {
 163       my $source = $rs_attrs->{_rsroot_rsrc};
 164       unless (
 165         $final_attrs{order_is_stable}
 166         = $final_attrs{preserve_order}
 167         = $source->schema->storage
 168                  ->_order_by_is_stable(
 169                      @final_attrs{qw(from order_by where)}
 170                    )
 171       ) {
 172         if ($stability eq 'requires') {
 173           if ($self->converter->_order_by_to_dq($final_attrs{order_by})) {
 174             $self->throw_exception(
 175                 $self->limit_dialect.' limit/offset implementation requires a stable order for offset'
 176             );
 177           }
 178           if (my $ident_cols = $source->_identifying_column_set) {
 179             $final_attrs{order_by} = [
 180                 map "$final_attrs{alias}.$_", @$ident_cols
 181             ];
 182             $final_attrs{order_is_stable} = 1;
 183           } else {
 184             $self->throw_exception(sprintf(
 185               'Unable to auto-construct stable order criteria for "skimming type"
 186   limit '
 187               . "dialect based on source '%s'", $source->name) );
 188           }
 189         }
 190       }
 191
 192     }
 193
 194     my %slice_subquery = $self->renderer->slice_subquery;
 195
 196     if (my $subquery = $slice_subquery{$offset ? 'offset' : 'limit'}) {
 197       $fields = [ map {
 198         my $f = $fields->[$_];
 199         if (ref $f) {
 200           $f = { '' => $f } unless ref($f) eq 'HASH';
 201           ($f->{-as} ||= $final_attrs{as}[$_]) =~ s/\Q${\$self->name_sep}/__/g;
 202         } elsif ($f !~ /^\Q$final_attrs{alias}${\$self->name_sep}/) {
 203           $f = { '' => $f };
 204           ($f->{-as} ||= $final_attrs{as}[$_]) =~ s/\Q${\$self->name_sep}/__/g;
 205         }
 206         $f;
 207         } 0 .. $#$fields ];
 208     }
 209   }
 210
 211   my ($sql, @bind) = $self->next::method ($table, $fields, $where, $final_attrs{order_by}, \%final_attrs );
 212
 213   $sql .= $self->_lock_select ($rs_attrs->{for})
 214     if $rs_attrs->{for};
 215
 216   return wantarray ? ($sql, @bind) : $sql;
 217 }
 218
 219 sub _assemble_binds {
 220   my $self = shift;
 221   return map { @{ (delete $self->{"${_}_bind"}) || [] } } (qw/pre_select select from where group having order limit/);
 222 }
 223
 224 my $for_syntax = {
 225   update => 'FOR UPDATE',
 226   shared => 'FOR SHARE',
 227 };
 228 sub _lock_select {
 229   my ($self, $type) = @_;
 230
 231   my $sql;
 232   if (ref($type) eq 'SCALAR') {
 233     $sql = "FOR $$type";
 234   }
 235   else {
 236     $sql = $for_syntax->{$type} || $self->throw_exception( "Unknown SELECT .. FO
 237 R type '$type' requested" );
 238   }
 239
 240   return " $sql";
 241 }
 242
 243 sub _recurse_from {
 244   scalar shift->_render_sqla(table => \@_);
 245 }
 246
 247 1;
 248
 249 =head1 OPERATORS
 250
 251 =head2 -ident
 252
 253 Used to explicitly specify an SQL identifier. Takes a plain string as value
 254 which is then invariably treated as a column name (and is being properly
 255 quoted if quoting has been requested). Most useful for comparison of two
 256 columns:
 257
 258     my %where = (
 259         priority => { '<', 2 },
 260         requestor => { -ident => 'submitter' }
 261     );
 262
 263 which results in:
 264
 265     $stmt = 'WHERE "priority" < ? AND "requestor" = "submitter"';
 266     @bind = ('2');
 267
 268 =head2 -value
 269
 270 The -value operator signals that the argument to the right is a raw bind value.
 271 It will be passed straight to DBI, without invoking any of the SQL::Abstract
 272 condition-parsing logic. This allows you to, for example, pass an array as a
 273 column value for databases that support array datatypes, e.g.:
 274
 275     my %where = (
 276         array => { -value => [1, 2, 3] }
 277     );
 278
 279 which results in:
 280
 281     $stmt = 'WHERE array = ?';
 282     @bind = ([1, 2, 3]);
 283
 284 =head1 AUTHORS
 285
 286 See L<DBIx::Class/CONTRIBUTORS>.
 287
 288 =head1 LICENSE
 289
 290 You may distribute this code under the same terms as Perl itself.
 291
 292 =cut