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