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