lib/DBIx/Class/Storage/DBI.pm

   1 package DBIx::Class::Storage::DBI;
   2 # -*- mode: cperl; cperl-indent-level: 2 -*-
   3
   4 use strict;
   5 use warnings;
   6
   7 use base qw/DBIx::Class::Storage::DBIHacks DBIx::Class::Storage/;
   8 use mro 'c3';
   9
  10 use DBIx::Class::Carp;
  11 use Scalar::Util qw/refaddr weaken reftype blessed/;
  12 use List::Util qw/first/;
  13 use Context::Preserve 'preserve_context';
  14 use Try::Tiny;
  15 use SQL::Abstract qw(is_plain_value is_literal_value);
  16 use DBIx::Class::_Util qw(
  17   quote_sub perlstring serialize
  18   dbic_internal_try
  19   detected_reinvoked_destructor scope_guard
  20 );
  21 use namespace::clean;
  22
  23 # default cursor class, overridable in connect_info attributes
  24 __PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::Cursor');
  25
  26 __PACKAGE__->mk_group_accessors('inherited' => qw/
  27   sql_limit_dialect sql_quote_char sql_name_sep
  28 /);
  29
  30 __PACKAGE__->mk_group_accessors('component_class' => qw/sql_maker_class datetime_parser_type/);
  31
  32 __PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker');
  33 __PACKAGE__->datetime_parser_type('DateTime::Format::MySQL'); # historic default
  34
  35 __PACKAGE__->sql_name_sep('.');
  36
  37 __PACKAGE__->mk_group_accessors('simple' => qw/
  38   _connect_info _dbic_connect_attributes _driver_determined
  39   _dbh _dbh_details _conn_pid _sql_maker _sql_maker_opts _dbh_autocommit
  40   _perform_autoinc_retrieval _autoinc_supplied_for_op
  41 /);
  42
  43 # the values for these accessors are picked out (and deleted) from
  44 # the attribute hashref passed to connect_info
  45 my @storage_options = qw/
  46   on_connect_call on_disconnect_call on_connect_do on_disconnect_do
  47   disable_sth_caching unsafe auto_savepoint
  48 /;
  49 __PACKAGE__->mk_group_accessors('simple' => @storage_options);
  50
  51
  52 # capability definitions, using a 2-tiered accessor system
  53 # The rationale is:
  54 #
  55 # A driver/user may define _use_X, which blindly without any checks says:
  56 # "(do not) use this capability", (use_dbms_capability is an "inherited"
  57 # type accessor)
  58 #
  59 # If _use_X is undef, _supports_X is then queried. This is a "simple" style
  60 # accessor, which in turn calls _determine_supports_X, and stores the return
  61 # in a special slot on the storage object, which is wiped every time a $dbh
  62 # reconnection takes place (it is not guaranteed that upon reconnection we
  63 # will get the same rdbms version). _determine_supports_X does not need to
  64 # exist on a driver, as we ->can for it before calling.
  65
  66 my @capabilities = (qw/
  67   insert_returning
  68   insert_returning_bound
  69
  70   multicolumn_in
  71
  72   placeholders
  73   typeless_placeholders
  74
  75   join_optimizer
  76 /);
  77 __PACKAGE__->mk_group_accessors( dbms_capability => map { "_supports_$_" } @capabilities );
  78 __PACKAGE__->mk_group_accessors( use_dbms_capability => map { "_use_$_" } (@capabilities ) );
  79
  80 # on by default, not strictly a capability (pending rewrite)
  81 __PACKAGE__->_use_join_optimizer (1);
  82 sub _determine_supports_join_optimizer { 1 };
  83
  84 # Each of these methods need _determine_driver called before itself
  85 # in order to function reliably. We also need to separate accessors
  86 # from plain old method calls, since an accessor called as a setter
  87 # does *not* need the driver determination loop fired (and in fact
  88 # can produce hard to find bugs, like e.g. losing on_connect_*
  89 # semantics on fresh connections)
  90 #
  91 # The construct below is simply a parameterized around()
  92 my $storage_accessor_idx = { map { $_ => 1 } qw(
  93   sqlt_type
  94   datetime_parser_type
  95
  96   sql_maker
  97   cursor_class
  98 )};
  99 for my $meth (keys %$storage_accessor_idx, qw(
 100   deployment_statements
 101
 102   build_datetime_parser
 103
 104   txn_begin
 105
 106   insert
 107   update
 108   delete
 109   select
 110   select_single
 111
 112   _insert_bulk
 113
 114   with_deferred_fk_checks
 115
 116   get_use_dbms_capability
 117   get_dbms_capability
 118
 119   _server_info
 120   _get_server_version
 121 )) {
 122
 123   my $orig = __PACKAGE__->can ($meth)
 124     or die "$meth is not a ::Storage::DBI method!";
 125
 126   my $possibly_a_setter = $storage_accessor_idx->{$meth} ? 1 : 0;
 127
 128   quote_sub
 129     __PACKAGE__ ."::$meth", sprintf( <<'EOC', $possibly_a_setter, perlstring $meth ), { '$orig' => \$orig };
 130
 131     if (
 132       # if this is an actual *setter* - just set it, no need to connect
 133       # and determine the driver
 134       !( %1$s and @_ > 1 )
 135         and
 136       # only fire when invoked on an instance, a valid class-based invocation
 137       # would e.g. be setting a default for an inherited accessor
 138       ref $_[0]
 139         and
 140       ! $_[0]->{_driver_determined}
 141         and
 142       ! $_[0]->{_in_determine_driver}
 143         and
 144       # Only try to determine stuff if we have *something* that either is or can
 145       # provide a DSN. Allows for bare $schema's generated with a plain ->connect()
 146       # to still be marginally useful
 147       $_[0]->_dbi_connect_info->[0]
 148     ) {
 149       $_[0]->_determine_driver;
 150
 151       # work around http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
 152       goto $_[0]->can(%2$s) unless DBIx::Class::_ENV_::BROKEN_GOTO;
 153
 154       my $cref = $_[0]->can(%2$s);
 155       goto $cref;
 156     }
 157
 158     goto $orig;
 159 EOC
 160 }
 161
 162 =head1 NAME
 163
 164 DBIx::Class::Storage::DBI - DBI storage handler
 165
 166 =head1 SYNOPSIS
 167
 168   my $schema = MySchema->connect('dbi:SQLite:my.db');
 169
 170   $schema->storage->debug(1);
 171
 172   my @stuff = $schema->storage->dbh_do(
 173     sub {
 174       my ($storage, $dbh, @args) = @_;
 175       $dbh->do("DROP TABLE authors");
 176     },
 177     @column_list
 178   );
 179
 180   $schema->resultset('Book')->search({
 181      written_on => $schema->storage->datetime_parser->format_datetime(DateTime->now)
 182   });
 183
 184 =head1 DESCRIPTION
 185
 186 This class represents the connection to an RDBMS via L<DBI>.  See
 187 L<DBIx::Class::Storage> for general information.  This pod only
 188 documents DBI-specific methods and behaviors.
 189
 190 =head1 METHODS
 191
 192 =cut
 193
 194 sub new {
 195   my $new = shift->next::method(@_);
 196
 197   $new->_sql_maker_opts({});
 198   $new->_dbh_details({});
 199   $new->{_in_do_block} = 0;
 200
 201   # read below to see what this does
 202   $new->_arm_global_destructor;
 203
 204   $new;
 205 }
 206
 207 # This is hack to work around perl shooting stuff in random
 208 # order on exit(). If we do not walk the remaining storage
 209 # objects in an END block, there is a *small but real* chance
 210 # of a fork()ed child to kill the parent's shared DBI handle,
 211 # *before perl reaches the DESTROY in this package*
 212 # Yes, it is ugly and effective.
 213 # Additionally this registry is used by the CLONE method to
 214 # make sure no handles are shared between threads
 215 {
 216   my %seek_and_destroy;
 217
 218   sub _arm_global_destructor {
 219
 220     # quick "garbage collection" pass - prevents the registry
 221     # from slowly growing with a bunch of undef-valued keys
 222     defined $seek_and_destroy{$_} or delete $seek_and_destroy{$_}
 223       for keys %seek_and_destroy;
 224
 225     weaken (
 226       $seek_and_destroy{ refaddr($_[0]) } = $_[0]
 227     );
 228
 229     # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
 230     # collected before leaving this scope. Depending on the code above, this
 231     # may very well be just a preventive measure guarding future modifications
 232     undef;
 233   }
 234
 235   END {
 236
 237     if(
 238       ! DBIx::Class::_ENV_::BROKEN_FORK
 239         and
 240       my @instances = grep { defined $_ } values %seek_and_destroy
 241     ) {
 242       local $?; # just in case the DBI destructor changes it somehow
 243
 244       # disarm the handle if not native to this process (see comment on top)
 245       $_->_verify_pid for @instances;
 246     }
 247
 248     # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
 249     # collected before leaving this scope. Depending on the code above, this
 250     # may very well be just a preventive measure guarding future modifications
 251     undef;
 252   }
 253
 254   sub CLONE {
 255     # As per DBI's recommendation, DBIC disconnects all handles as
 256     # soon as possible (DBIC will reconnect only on demand from within
 257     # the thread)
 258     my @instances = grep { defined $_ } values %seek_and_destroy;
 259     %seek_and_destroy = ();
 260
 261     for (@instances) {
 262       $_->_dbh(undef);
 263       $_->disconnect;
 264
 265       # properly renumber existing refs
 266       $_->_arm_global_destructor
 267     }
 268
 269     # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
 270     # collected before leaving this scope. Depending on the code above, this
 271     # may very well be just a preventive measure guarding future modifications
 272     undef;
 273   }
 274 }
 275
 276 sub DESTROY {
 277   return if &detected_reinvoked_destructor;
 278
 279   $_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
 280
 281   # some databases spew warnings on implicit disconnect
 282   return unless defined $_[0]->_dbh;
 283
 284   local $SIG{__WARN__} = sub {};
 285   $_[0]->_dbh(undef);
 286   # not calling ->disconnect here - we are being destroyed - nothing to reset
 287
 288   # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
 289   # collected before leaving this scope. Depending on the code above, this
 290   # may very well be just a preventive measure guarding future modifications
 291   undef;
 292 }
 293
 294 # handle pid changes correctly - do not destroy parent's connection
 295 sub _verify_pid {
 296
 297   my $pid = $_[0]->_conn_pid;
 298
 299   if( defined $pid and $pid != $$ and my $dbh = $_[0]->_dbh ) {
 300     $dbh->{InactiveDestroy} = 1;
 301     $_[0]->_dbh(undef);
 302     $_[0]->disconnect;
 303   }
 304
 305   # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
 306   # collected before leaving this scope. Depending on the code above, this
 307   # may very well be just a preventive measure guarding future modifications
 308   undef;
 309 }
 310
 311 =head2 connect_info
 312
 313 This method is normally called by L<DBIx::Class::Schema/connection>, which
 314 encapsulates its argument list in an arrayref before passing them here.
 315
 316 The argument list may contain:
 317
 318 =over
 319
 320 =item *
 321
 322 The same 4-element argument set one would normally pass to
 323 L<DBI/connect>, optionally followed by
 324 L<extra attributes|/DBIx::Class specific connection attributes>
 325 recognized by DBIx::Class:
 326
 327   $connect_info_args = [ $dsn, $user, $password, \%dbi_attributes?, \%extra_attributes? ];
 328
 329 =item *
 330
 331 A single code reference which returns a connected
 332 L<DBI database handle|DBI/connect> optionally followed by
 333 L<extra attributes|/DBIx::Class specific connection attributes> recognized
 334 by DBIx::Class:
 335
 336   $connect_info_args = [ sub { DBI->connect (...) }, \%extra_attributes? ];
 337
 338 =item *
 339
 340 A single hashref with all the attributes and the dsn/user/password
 341 mixed together:
 342
 343   $connect_info_args = [{
 344     dsn => $dsn,
 345     user => $user,
 346     password => $pass,
 347     %dbi_attributes,
 348     %extra_attributes,
 349   }];
 350
 351   $connect_info_args = [{
 352     dbh_maker => sub { DBI->connect (...) },
 353     %dbi_attributes,
 354     %extra_attributes,
 355   }];
 356
 357 This is particularly useful for L<Catalyst> based applications, allowing the
 358 following config (L<Config::General> style):
 359
 360   <Model::DB>
 361     schema_class   App::DB
 362     <connect_info>
 363       dsn          dbi:mysql:database=test
 364       user         testuser
 365       password     TestPass
 366       AutoCommit   1
 367     </connect_info>
 368   </Model::DB>
 369
 370 The C<dsn>/C<user>/C<password> combination can be substituted by the
 371 C<dbh_maker> key whose value is a coderef that returns a connected
 372 L<DBI database handle|DBI/connect>
 373
 374 =back
 375
 376 Please note that the L<DBI> docs recommend that you always explicitly
 377 set C<AutoCommit> to either I<0> or I<1>.  L<DBIx::Class> further
 378 recommends that it be set to I<1>, and that you perform transactions
 379 via our L<DBIx::Class::Schema/txn_do> method.  L<DBIx::Class> will set it
 380 to I<1> if you do not do explicitly set it to zero.  This is the default
 381 for most DBDs. See L</DBIx::Class and AutoCommit> for details.
 382
 383 =head3 DBIx::Class specific connection attributes
 384
 385 In addition to the standard L<DBI|DBI/ATTRIBUTES COMMON TO ALL HANDLES>
 386 L<connection|DBI/Database Handle Attributes> attributes, DBIx::Class recognizes
 387 the following connection options. These options can be mixed in with your other
 388 L<DBI> connection attributes, or placed in a separate hashref
 389 (C<\%extra_attributes>) as shown above.
 390
 391 Every time C<connect_info> is invoked, any previous settings for
 392 these options will be cleared before setting the new ones, regardless of
 393 whether any options are specified in the new C<connect_info>.
 394
 395
 396 =over
 397
 398 =item on_connect_do
 399
 400 Specifies things to do immediately after connecting or re-connecting to
 401 the database.  Its value may contain:
 402
 403 =over
 404
 405 =item a scalar
 406
 407 This contains one SQL statement to execute.
 408
 409 =item an array reference
 410
 411 This contains SQL statements to execute in order.  Each element contains
 412 a string or a code reference that returns a string.
 413
 414 =item a code reference
 415
 416 This contains some code to execute.  Unlike code references within an
 417 array reference, its return value is ignored.
 418
 419 =back
 420
 421 =item on_disconnect_do
 422
 423 Takes arguments in the same form as L</on_connect_do> and executes them
 424 immediately before disconnecting from the database.
 425
 426 Note, this only runs if you explicitly call L</disconnect> on the
 427 storage object.
 428
 429 =item on_connect_call
 430
 431 A more generalized form of L</on_connect_do> that calls the specified
 432 C<connect_call_METHOD> methods in your storage driver.
 433
 434   on_connect_do => 'select 1'
 435
 436 is equivalent to:
 437
 438   on_connect_call => [ [ do_sql => 'select 1' ] ]
 439
 440 Its values may contain:
 441
 442 =over
 443
 444 =item a scalar
 445
 446 Will call the C<connect_call_METHOD> method.
 447
 448 =item a code reference
 449
 450 Will execute C<< $code->($storage) >>
 451
 452 =item an array reference
 453
 454 Each value can be a method name or code reference.
 455
 456 =item an array of arrays
 457
 458 For each array, the first item is taken to be the C<connect_call_> method name
 459 or code reference, and the rest are parameters to it.
 460
 461 =back
 462
 463 Some predefined storage methods you may use:
 464
 465 =over
 466
 467 =item do_sql
 468
 469 Executes a SQL string or a code reference that returns a SQL string. This is
 470 what L</on_connect_do> and L</on_disconnect_do> use.
 471
 472 It can take:
 473
 474 =over
 475
 476 =item a scalar
 477
 478 Will execute the scalar as SQL.
 479
 480 =item an arrayref
 481
 482 Taken to be arguments to L<DBI/do>, the SQL string optionally followed by the
 483 attributes hashref and bind values.
 484
 485 =item a code reference
 486
 487 Will execute C<< $code->($storage) >> and execute the return array refs as
 488 above.
 489
 490 =back
 491
 492 =item datetime_setup
 493
 494 Execute any statements necessary to initialize the database session to return
 495 and accept datetime/timestamp values used with
 496 L<DBIx::Class::InflateColumn::DateTime>.
 497
 498 Only necessary for some databases, see your specific storage driver for
 499 implementation details.
 500
 501 =back
 502
 503 =item on_disconnect_call
 504
 505 Takes arguments in the same form as L</on_connect_call> and executes them
 506 immediately before disconnecting from the database.
 507
 508 Calls the C<disconnect_call_METHOD> methods as opposed to the
 509 C<connect_call_METHOD> methods called by L</on_connect_call>.
 510
 511 Note, this only runs if you explicitly call L</disconnect> on the
 512 storage object.
 513
 514 =item disable_sth_caching
 515
 516 If set to a true value, this option will disable the caching of
 517 statement handles via L<DBI/prepare_cached>.
 518
 519 =item limit_dialect
 520
 521 Sets a specific SQL::Abstract::Limit-style limit dialect, overriding the
 522 default L</sql_limit_dialect> setting of the storage (if any). For a list
 523 of available limit dialects see L<DBIx::Class::SQLMaker::LimitDialects>.
 524
 525 =item quote_names
 526
 527 When true automatically sets L</quote_char> and L</name_sep> to the characters
 528 appropriate for your particular RDBMS. This option is preferred over specifying
 529 L</quote_char> directly.
 530
 531 =item quote_char
 532
 533 Specifies what characters to use to quote table and column names.
 534
 535 C<quote_char> expects either a single character, in which case is it
 536 is placed on either side of the table/column name, or an arrayref of length
 537 2 in which case the table/column name is placed between the elements.
 538
 539 For example under MySQL you should use C<< quote_char => '`' >>, and for
 540 SQL Server you should use C<< quote_char => [qw/[ ]/] >>.
 541
 542 =item name_sep
 543
 544 This parameter is only useful in conjunction with C<quote_char>, and is used to
 545 specify the character that separates elements (schemas, tables, columns) from
 546 each other. If unspecified it defaults to the most commonly used C<.>.
 547
 548 =item unsafe
 549
 550 This Storage driver normally installs its own C<HandleError>, sets
 551 C<RaiseError> and C<ShowErrorStatement> on, and sets C<PrintError> off on
 552 all database handles, including those supplied by a coderef.  It does this
 553 so that it can have consistent and useful error behavior.
 554
 555 If you set this option to a true value, Storage will not do its usual
 556 modifications to the database handle's attributes, and instead relies on
 557 the settings in your connect_info DBI options (or the values you set in
 558 your connection coderef, in the case that you are connecting via coderef).
 559
 560 Note that your custom settings can cause Storage to malfunction,
 561 especially if you set a C<HandleError> handler that suppresses exceptions
 562 and/or disable C<RaiseError>.
 563
 564 =item auto_savepoint
 565
 566 If this option is true, L<DBIx::Class> will use savepoints when nesting
 567 transactions, making it possible to recover from failure in the inner
 568 transaction without having to abort all outer transactions.
 569
 570 =item cursor_class
 571
 572 Use this argument to supply a cursor class other than the default
 573 L<DBIx::Class::Storage::DBI::Cursor>.
 574
 575 =back
 576
 577 Some real-life examples of arguments to L</connect_info> and
 578 L<DBIx::Class::Schema/connect>
 579
 580   # Simple SQLite connection
 581   ->connect_info([ 'dbi:SQLite:./foo.db' ]);
 582
 583   # Connect via subref
 584   ->connect_info([ sub { DBI->connect(...) } ]);
 585
 586   # Connect via subref in hashref
 587   ->connect_info([{
 588     dbh_maker => sub { DBI->connect(...) },
 589     on_connect_do => 'alter session ...',
 590   }]);
 591
 592   # A bit more complicated
 593   ->connect_info(
 594     [
 595       'dbi:Pg:dbname=foo',
 596       'postgres',
 597       'my_pg_password',
 598       { AutoCommit => 1 },
 599       { quote_char => q{"} },
 600     ]
 601   );
 602
 603   # Equivalent to the previous example
 604   ->connect_info(
 605     [
 606       'dbi:Pg:dbname=foo',
 607       'postgres',
 608       'my_pg_password',
 609       { AutoCommit => 1, quote_char => q{"}, name_sep => q{.} },
 610     ]
 611   );
 612
 613   # Same, but with hashref as argument
 614   # See parse_connect_info for explanation
 615   ->connect_info(
 616     [{
 617       dsn         => 'dbi:Pg:dbname=foo',
 618       user        => 'postgres',
 619       password    => 'my_pg_password',
 620       AutoCommit  => 1,
 621       quote_char  => q{"},
 622       name_sep    => q{.},
 623     }]
 624   );
 625
 626   # Subref + DBIx::Class-specific connection options
 627   ->connect_info(
 628     [
 629       sub { DBI->connect(...) },
 630       {
 631           quote_char => q{`},
 632           name_sep => q{@},
 633           on_connect_do => ['SET search_path TO myschema,otherschema,public'],
 634           disable_sth_caching => 1,
 635       },
 636     ]
 637   );
 638
 639
 640
 641 =cut
 642
 643 sub connect_info {
 644   my ($self, $info) = @_;
 645
 646   return $self->_connect_info if !$info;
 647
 648   $self->_connect_info($info); # copy for _connect_info
 649
 650   $info = $self->_normalize_connect_info($info)
 651     if ref $info eq 'ARRAY';
 652
 653   my %attrs = (
 654     %{ $self->_default_dbi_connect_attributes || {} },
 655     %{ $info->{attributes} || {} },
 656   );
 657
 658   my @args = @{ $info->{arguments} };
 659
 660   if (keys %attrs and ref $args[0] ne 'CODE') {
 661     carp_unique (
 662         'You provided explicit AutoCommit => 0 in your connection_info. '
 663       . 'This is almost universally a bad idea (see the footnotes of '
 664       . 'DBIx::Class::Storage::DBI for more info). If you still want to '
 665       . 'do this you can set $ENV{DBIC_UNSAFE_AUTOCOMMIT_OK} to disable '
 666       . 'this warning.'
 667     ) if ! $attrs{AutoCommit} and ! $ENV{DBIC_UNSAFE_AUTOCOMMIT_OK};
 668
 669     push @args, \%attrs if keys %attrs;
 670   }
 671
 672   # this is the authoritative "always an arrayref" thing fed to DBI->connect
 673   # OR a single-element coderef-based $dbh factory
 674   $self->_dbi_connect_info(\@args);
 675
 676   # extract the individual storage options
 677   for my $storage_opt (keys %{ $info->{storage_options} }) {
 678     my $value = $info->{storage_options}{$storage_opt};
 679
 680     $self->$storage_opt($value);
 681   }
 682
 683   # Extract the individual sqlmaker options
 684   #
 685   # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
 686   #  the new set of options
 687   $self->_sql_maker(undef);
 688   $self->_sql_maker_opts({});
 689
 690   for my $sql_maker_opt (keys %{ $info->{sql_maker_options} }) {
 691     my $value = $info->{sql_maker_options}{$sql_maker_opt};
 692
 693     $self->_sql_maker_opts->{$sql_maker_opt} = $value;
 694   }
 695
 696   # FIXME - dirty:
 697   # save attributes in a separate accessor so they are always
 698   # introspectable, even in case of a CODE $dbhmaker
 699   $self->_dbic_connect_attributes (\%attrs);
 700
 701   return $self->_connect_info;
 702 }
 703
 704 sub _dbi_connect_info {
 705   my $self = shift;
 706
 707   return $self->{_dbi_connect_info} = $_[0]
 708     if @_;
 709
 710   my $conninfo = $self->{_dbi_connect_info} || [];
 711
 712   # last ditch effort to grab a DSN
 713   if ( ! defined $conninfo->[0] and $ENV{DBI_DSN} ) {
 714     my @new_conninfo = @$conninfo;
 715     $new_conninfo[0] = $ENV{DBI_DSN};
 716     $conninfo = \@new_conninfo;
 717   }
 718
 719   return $conninfo;
 720 }
 721
 722
 723 sub _normalize_connect_info {
 724   my ($self, $info_arg) = @_;
 725   my %info;
 726
 727   my @args = @$info_arg;  # take a shallow copy for further mutilation
 728
 729   # combine/pre-parse arguments depending on invocation style
 730
 731   my %attrs;
 732   if (ref $args[0] eq 'CODE') {     # coderef with optional \%extra_attributes
 733     %attrs = %{ $args[1] || {} };
 734     @args = $args[0];
 735   }
 736   elsif (ref $args[0] eq 'HASH') { # single hashref (i.e. Catalyst config)
 737     %attrs = %{$args[0]};
 738     @args = ();
 739     if (my $code = delete $attrs{dbh_maker}) {
 740       @args = $code;
 741
 742       my @ignored = grep { delete $attrs{$_} } (qw/dsn user password/);
 743       if (@ignored) {
 744         carp sprintf (
 745             'Attribute(s) %s in connect_info were ignored, as they can not be applied '
 746           . "to the result of 'dbh_maker'",
 747
 748           join (', ', map { "'$_'" } (@ignored) ),
 749         );
 750       }
 751     }
 752     else {
 753       @args = delete @attrs{qw/dsn user password/};
 754     }
 755   }
 756   else {                # otherwise assume dsn/user/password + \%attrs + \%extra_attrs
 757     %attrs = (
 758       % { $args[3] || {} },
 759       % { $args[4] || {} },
 760     );
 761     @args = @args[0,1,2];
 762   }
 763
 764   $info{arguments} = \@args;
 765
 766   my @storage_opts = grep exists $attrs{$_},
 767     @storage_options, 'cursor_class';
 768
 769   @{ $info{storage_options} }{@storage_opts} =
 770     delete @attrs{@storage_opts} if @storage_opts;
 771
 772   my @sql_maker_opts = grep exists $attrs{$_},
 773     qw/limit_dialect quote_char name_sep quote_names/;
 774
 775   @{ $info{sql_maker_options} }{@sql_maker_opts} =
 776     delete @attrs{@sql_maker_opts} if @sql_maker_opts;
 777
 778   $info{attributes} = \%attrs if %attrs;
 779
 780   return \%info;
 781 }
 782
 783 sub _default_dbi_connect_attributes () {
 784   +{
 785     AutoCommit => 1,
 786     PrintError => 0,
 787     RaiseError => 1,
 788     ShowErrorStatement => 1,
 789   };
 790 }
 791
 792 =head2 on_connect_do
 793
 794 This method is deprecated in favour of setting via L</connect_info>.
 795
 796 =cut
 797
 798 =head2 on_disconnect_do
 799
 800 This method is deprecated in favour of setting via L</connect_info>.
 801
 802 =cut
 803
 804 sub _parse_connect_do {
 805   my ($self, $type) = @_;
 806
 807   my $val = $self->$type;
 808   return () if not defined $val;
 809
 810   my @res;
 811
 812   if (not ref($val)) {
 813     push @res, [ 'do_sql', $val ];
 814   } elsif (ref($val) eq 'CODE') {
 815     push @res, $val;
 816   } elsif (ref($val) eq 'ARRAY') {
 817     push @res, map { [ 'do_sql', $_ ] } @$val;
 818   } else {
 819     $self->throw_exception("Invalid type for $type: ".ref($val));
 820   }
 821
 822   return \@res;
 823 }
 824
 825 =head2 dbh_do
 826
 827 Arguments: ($subref | $method_name), @extra_coderef_args?
 828
 829 Execute the given $subref or $method_name using the new exception-based
 830 connection management.
 831
 832 The first two arguments will be the storage object that C<dbh_do> was called
 833 on and a database handle to use.  Any additional arguments will be passed
 834 verbatim to the called subref as arguments 2 and onwards.
 835
 836 Using this (instead of $self->_dbh or $self->dbh) ensures correct
 837 exception handling and reconnection (or failover in future subclasses).
 838
 839 Your subref should have no side-effects outside of the database, as
 840 there is the potential for your subref to be partially double-executed
 841 if the database connection was stale/dysfunctional.
 842
 843 Example:
 844
 845   my @stuff = $schema->storage->dbh_do(
 846     sub {
 847       my ($storage, $dbh, @cols) = @_;
 848       my $cols = join(q{, }, @cols);
 849       $dbh->selectrow_array("SELECT $cols FROM foo");
 850     },
 851     @column_list
 852   );
 853
 854 =cut
 855
 856 sub dbh_do {
 857   my $self = shift;
 858   my $run_target = shift; # either a coderef or a method name
 859
 860   # short circuit when we know there is no need for a runner
 861   #
 862   # FIXME - assumption may be wrong
 863   # the rationale for the txn_depth check is that if this block is a part
 864   # of a larger transaction, everything up to that point is screwed anyway
 865   return $self->$run_target($self->_get_dbh, @_)
 866     if $self->{_in_do_block} or $self->transaction_depth;
 867
 868   # take a ref instead of a copy, to preserve @_ aliasing
 869   # semantics within the coderef, but only if needed
 870   # (pseudoforking doesn't like this trick much)
 871   my $args = @_ ? \@_ : [];
 872
 873   DBIx::Class::Storage::BlockRunner->new(
 874     storage => $self,
 875     wrap_txn => 0,
 876     retry_handler => sub {
 877       $_[0]->failed_attempt_count == 1
 878         and
 879       ! $_[0]->storage->connected
 880     },
 881   )->run(sub {
 882     $self->$run_target ($self->_get_dbh, @$args )
 883   });
 884 }
 885
 886 sub txn_do {
 887   $_[0]->_get_dbh; # connects or reconnects on pid change, necessary to grab correct txn_depth
 888   shift->next::method(@_);
 889 }
 890
 891 =head2 disconnect
 892
 893 Our C<disconnect> method also performs a rollback first if the
 894 database is not in C<AutoCommit> mode.
 895
 896 =cut
 897
 898 sub disconnect {
 899   my $self = shift;
 900
 901   # this physical disconnect below might very well throw
 902   # in order to unambiguously reset the state - do the cleanup in guard
 903
 904   my $g = scope_guard {
 905
 906     {
 907       local $@ if DBIx::Class::_ENV_::UNSTABLE_DOLLARAT;
 908       eval { $self->_dbh->disconnect };
 909     }
 910
 911     $self->_dbh(undef);
 912     $self->_dbh_details({});
 913     $self->transaction_depth(undef);
 914     $self->_dbh_autocommit(undef);
 915     $self->savepoints([]);
 916
 917     # FIXME - this needs reenabling with the proper "no reset on same DSN" check
 918     #$self->_sql_maker(undef); # this may also end up being different
 919   };
 920
 921   if( $self->_dbh ) {
 922
 923     $self->_do_connection_actions(disconnect_call_ => $_) for (
 924       ( $self->on_disconnect_call || () ),
 925       $self->_parse_connect_do ('on_disconnect_do')
 926     );
 927
 928     # stops the "implicit rollback on disconnect" warning
 929     $self->_exec_txn_rollback unless $self->_dbh_autocommit;
 930   }
 931
 932   # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
 933   # collected before leaving this scope. Depending on the code above, this
 934   # may very well be just a preventive measure guarding future modifications
 935   undef;
 936 }
 937
 938 =head2 with_deferred_fk_checks
 939
 940 =over 4
 941
 942 =item Arguments: C<$coderef>
 943
 944 =item Return Value: The return value of $coderef
 945
 946 =back
 947
 948 Storage specific method to run the code ref with FK checks deferred or
 949 in MySQL's case disabled entirely.
 950
 951 =cut
 952
 953 # Storage subclasses should override this
 954 sub with_deferred_fk_checks {
 955   #my ($self, $sub) = @_;
 956   $_[1]->();
 957 }
 958
 959 =head2 connected
 960
 961 =over
 962
 963 =item Arguments: none
 964
 965 =item Return Value: 1|0
 966
 967 =back
 968
 969 Verifies that the current database handle is active and ready to execute
 970 an SQL statement (e.g. the connection did not get stale, server is still
 971 answering, etc.) This method is used internally by L</dbh>.
 972
 973 =cut
 974
 975 sub connected {
 976   return 0 unless $_[0]->_seems_connected;
 977
 978   #be on the safe side
 979   local $_[0]->_dbh->{RaiseError} = 1;
 980
 981   return $_[0]->_ping;
 982 }
 983
 984 sub _seems_connected {
 985   $_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
 986
 987   $_[0]->_dbh
 988     and
 989   $_[0]->_dbh->FETCH('Active')
 990     and
 991   return 1;
 992
 993   # explicitly reset all state
 994   $_[0]->disconnect;
 995   return 0;
 996 }
 997
 998 sub _ping {
 999   ($_[0]->_dbh || return 0)->ping;
1000 }
1001
1002 sub ensure_connected {
1003   $_[0]->connected || ( $_[0]->_populate_dbh && 1 );
1004 }
1005
1006 =head2 dbh
1007
1008 Returns a C<$dbh> - a data base handle of class L<DBI>. The returned handle
1009 is guaranteed to be healthy by implicitly calling L</connected>, and if
1010 necessary performing a reconnection before returning. Keep in mind that this
1011 is very B<expensive> on some database engines. Consider using L</dbh_do>
1012 instead.
1013
1014 =cut
1015
1016 sub dbh {
1017   # maybe save a ping call
1018   $_[0]->_dbh
1019     ? ( $_[0]->ensure_connected and $_[0]->_dbh )
1020     : $_[0]->_populate_dbh
1021   ;
1022 }
1023
1024 # this is the internal "get dbh or connect (don't check)" method
1025 sub _get_dbh {
1026   $_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
1027   $_[0]->_dbh || $_[0]->_populate_dbh;
1028 }
1029
1030 # *DELIBERATELY* not a setter (for the time being)
1031 # Too intertwined with everything else for any kind of sanity
1032 sub sql_maker {
1033   my $self = shift;
1034
1035   $self->throw_exception('sql_maker() is not a setter method') if @_;
1036
1037   unless ($self->_sql_maker) {
1038     my $sql_maker_class = $self->sql_maker_class;
1039
1040     my %opts = %{$self->_sql_maker_opts||{}};
1041     my $dialect =
1042       $opts{limit_dialect}
1043         ||
1044       $self->sql_limit_dialect
1045         ||
1046       do {
1047         my $s_class = (ref $self) || $self;
1048         carp_unique (
1049           "Your storage class ($s_class) does not set sql_limit_dialect and you "
1050         . 'have not supplied an explicit limit_dialect in your connection_info. '
1051         . 'DBIC will attempt to use the GenericSubQ dialect, which works on most '
1052         . 'databases but can be (and often is) painfully slow. '
1053         . "Please file an RT ticket against '$s_class'"
1054         ) if $self->_dbi_connect_info->[0];
1055
1056         'GenericSubQ';
1057       }
1058     ;
1059
1060     my ($quote_char, $name_sep);
1061
1062     if ($opts{quote_names}) {
1063       $quote_char = (delete $opts{quote_char}) || $self->sql_quote_char || do {
1064         my $s_class = (ref $self) || $self;
1065         carp_unique (
1066           "You requested 'quote_names' but your storage class ($s_class) does "
1067         . 'not explicitly define a default sql_quote_char and you have not '
1068         . 'supplied a quote_char as part of your connection_info. DBIC will '
1069         .q{default to the ANSI SQL standard quote '"', which works most of }
1070         . "the time. Please file an RT ticket against '$s_class'."
1071         );
1072
1073         '"'; # RV
1074       };
1075
1076       $name_sep = (delete $opts{name_sep}) || $self->sql_name_sep;
1077     }
1078
1079     $self->_sql_maker($sql_maker_class->new(
1080       bindtype=>'columns',
1081       array_datatypes => 1,
1082       limit_dialect => $dialect,
1083       ($quote_char ? (quote_char => $quote_char) : ()),
1084       name_sep => ($name_sep || '.'),
1085       %opts,
1086     ));
1087   }
1088   return $self->_sql_maker;
1089 }
1090
1091 # nothing to do by default
1092 sub _rebless {}
1093 sub _init {}
1094
1095 sub _populate_dbh {
1096
1097   # reset internal states
1098   # also in case ->connected failed we might get sent here
1099   $_[0]->disconnect;
1100
1101   $_[0]->_dbh($_[0]->_connect);
1102
1103   $_[0]->_conn_pid($$) unless DBIx::Class::_ENV_::BROKEN_FORK; # on win32 these are in fact threads
1104
1105   $_[0]->_determine_driver;
1106
1107   # Always set the transaction depth on connect, since
1108   #  there is no transaction in progress by definition
1109   $_[0]->transaction_depth( $_[0]->_dbh_autocommit ? 0 : 1 );
1110
1111   $_[0]->_run_connection_actions unless $_[0]->{_in_determine_driver};
1112
1113   $_[0]->_dbh;
1114 }
1115
1116 sub _run_connection_actions {
1117
1118   $_[0]->_do_connection_actions(connect_call_ => $_) for (
1119     ( $_[0]->on_connect_call || () ),
1120     $_[0]->_parse_connect_do ('on_connect_do'),
1121   );
1122 }
1123
1124
1125
1126 sub set_use_dbms_capability {
1127   $_[0]->set_inherited ($_[1], $_[2]);
1128 }
1129
1130 sub get_use_dbms_capability {
1131   my ($self, $capname) = @_;
1132
1133   my $use = $self->get_inherited ($capname);
1134   return defined $use
1135     ? $use
1136     : do { $capname =~ s/^_use_/_supports_/; $self->get_dbms_capability ($capname) }
1137   ;
1138 }
1139
1140 sub set_dbms_capability {
1141   $_[0]->_dbh_details->{capability}{$_[1]} = $_[2];
1142 }
1143
1144 sub get_dbms_capability {
1145   my ($self, $capname) = @_;
1146
1147   my $cap = $self->_dbh_details->{capability}{$capname};
1148
1149   unless (defined $cap) {
1150     if (my $meth = $self->can ("_determine$capname")) {
1151       $cap = $self->$meth ? 1 : 0;
1152     }
1153     else {
1154       $cap = 0;
1155     }
1156
1157     $self->set_dbms_capability ($capname, $cap);
1158   }
1159
1160   return $cap;
1161 }
1162
1163 sub _server_info {
1164   my $self = shift;
1165
1166   # FIXME - ideally this needs to be an ||= assignment, and the final
1167   # assignment at the end of this do{} should be gone entirely. However
1168   # this confuses CXSA: https://rt.cpan.org/Ticket/Display.html?id=103296
1169   $self->_dbh_details->{info} || do {
1170
1171     # this guarantees that problematic conninfo won't be hidden
1172     # by the try{} below
1173     $self->ensure_connected;
1174
1175     my $info = {};
1176
1177     my $server_version = dbic_internal_try {
1178       $self->_get_server_version
1179     } catch {
1180       # driver determination *may* use this codepath
1181       # in which case we must rethrow
1182       $self->throw_exception($_) if $self->{_in_determine_driver};
1183
1184       # $server_version on failure
1185       undef;
1186     };
1187
1188     if (defined $server_version) {
1189       $info->{dbms_version} = $server_version;
1190
1191       my ($numeric_version) = $server_version =~ /^([\d\.]+)/;
1192       my @verparts = split (/\./, $numeric_version);
1193       if (
1194         @verparts
1195           &&
1196         $verparts[0] <= 999
1197       ) {
1198         # consider only up to 3 version parts, iff not more than 3 digits
1199         my @use_parts;
1200         while (@verparts && @use_parts < 3) {
1201           my $p = shift @verparts;
1202           last if $p > 999;
1203           push @use_parts, $p;
1204         }
1205         push @use_parts, 0 while @use_parts < 3;
1206
1207         $info->{normalized_dbms_version} = sprintf "%d.%03d%03d", @use_parts;
1208       }
1209     }
1210
1211     $self->_dbh_details->{info} = $info;
1212   };
1213 }
1214
1215 sub _get_server_version {
1216   shift->_dbh_get_info('SQL_DBMS_VER');
1217 }
1218
1219 sub _dbh_get_info {
1220   my ($self, $info) = @_;
1221
1222   if ($info =~ /[^0-9]/) {
1223     require DBI::Const::GetInfoType;
1224     $info = $DBI::Const::GetInfoType::GetInfoType{$info};
1225     $self->throw_exception("Info type '$_[1]' not provided by DBI::Const::GetInfoType")
1226       unless defined $info;
1227   }
1228
1229   $self->_get_dbh->get_info($info);
1230 }
1231
1232 sub _describe_connection {
1233   require DBI::Const::GetInfoReturn;
1234
1235   my $self = shift;
1236
1237   my $drv;
1238   dbic_internal_try {
1239     $drv = $self->_extract_driver_from_connect_info;
1240     $self->ensure_connected;
1241   };
1242
1243   $drv = "DBD::$drv" if $drv;
1244
1245   my $res = {
1246     DBIC_DSN => $self->_dbi_connect_info->[0],
1247     DBI_VER => DBI->VERSION,
1248     DBIC_VER => DBIx::Class->VERSION,
1249     DBIC_DRIVER => ref $self,
1250     $drv ? (
1251       DBD => $drv,
1252       DBD_VER => dbic_internal_try { $drv->VERSION },
1253     ) : (),
1254   };
1255
1256   # try to grab data even if we never managed to connect
1257   # will cover us in cases of an oddly broken half-connect
1258   for my $inf (
1259     #keys %DBI::Const::GetInfoType::GetInfoType,
1260     qw/
1261       SQL_CURSOR_COMMIT_BEHAVIOR
1262       SQL_CURSOR_ROLLBACK_BEHAVIOR
1263       SQL_CURSOR_SENSITIVITY
1264       SQL_DATA_SOURCE_NAME
1265       SQL_DBMS_NAME
1266       SQL_DBMS_VER
1267       SQL_DEFAULT_TXN_ISOLATION
1268       SQL_DM_VER
1269       SQL_DRIVER_NAME
1270       SQL_DRIVER_ODBC_VER
1271       SQL_DRIVER_VER
1272       SQL_EXPRESSIONS_IN_ORDERBY
1273       SQL_GROUP_BY
1274       SQL_IDENTIFIER_CASE
1275       SQL_IDENTIFIER_QUOTE_CHAR
1276       SQL_MAX_CATALOG_NAME_LEN
1277       SQL_MAX_COLUMN_NAME_LEN
1278       SQL_MAX_IDENTIFIER_LEN
1279       SQL_MAX_TABLE_NAME_LEN
1280       SQL_MULTIPLE_ACTIVE_TXN
1281       SQL_MULT_RESULT_SETS
1282       SQL_NEED_LONG_DATA_LEN
1283       SQL_NON_NULLABLE_COLUMNS
1284       SQL_ODBC_VER
1285       SQL_QUALIFIER_NAME_SEPARATOR
1286       SQL_QUOTED_IDENTIFIER_CASE
1287       SQL_TXN_CAPABLE
1288       SQL_TXN_ISOLATION_OPTION
1289     /
1290   ) {
1291     # some drivers barf on things they do not know about instead
1292     # of returning undef
1293     my $v = dbic_internal_try { $self->_dbh_get_info($inf) };
1294     next unless defined $v;
1295
1296     #my $key = sprintf( '%s(%s)', $inf, $DBI::Const::GetInfoType::GetInfoType{$inf} );
1297     my $expl = DBI::Const::GetInfoReturn::Explain($inf, $v);
1298     $res->{$inf} = DBI::Const::GetInfoReturn::Format($inf, $v) . ( $expl ? " ($expl)" : '' );
1299   }
1300
1301   $res;
1302 }
1303
1304 sub _determine_driver {
1305   my ($self) = @_;
1306
1307   if ((not $self->_driver_determined) && (not $self->{_in_determine_driver})) {
1308     my $started_connected = 0;
1309     local $self->{_in_determine_driver} = 1;
1310
1311     if (ref($self) eq __PACKAGE__) {
1312       my $driver;
1313       if ($self->_dbh) { # we are connected
1314         $driver = $self->_dbh->{Driver}{Name};
1315         $started_connected = 1;
1316       }
1317       else {
1318         $driver = $self->_extract_driver_from_connect_info;
1319       }
1320
1321       if ($driver) {
1322         my $storage_class = "DBIx::Class::Storage::DBI::${driver}";
1323         if ($self->load_optional_class($storage_class)) {
1324           mro::set_mro($storage_class, 'c3');
1325           bless $self, $storage_class;
1326           $self->_rebless();
1327         }
1328         else {
1329           $self->_warn_undetermined_driver(
1330             'This version of DBIC does not yet seem to supply a driver for '
1331           . "your particular RDBMS and/or connection method ('$driver')."
1332           );
1333         }
1334       }
1335       else {
1336         $self->_warn_undetermined_driver(
1337           'Unable to extract a driver name from connect info - this '
1338         . 'should not have happened.'
1339         );
1340       }
1341     }
1342
1343     $self->_driver_determined(1);
1344
1345     Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
1346
1347     if ($self->can('source_bind_attributes')) {
1348       $self->throw_exception(
1349         "Your storage subclass @{[ ref $self ]} provides (or inherits) the method "
1350       . 'source_bind_attributes() for which support has been removed as of Jan 2013. '
1351       . 'If you are not sure how to proceed please contact the development team via '
1352       . DBIx::Class::_ENV_::HELP_URL
1353       );
1354     }
1355
1356     $self->_init; # run driver-specific initializations
1357
1358     $self->_run_connection_actions
1359         if !$started_connected && defined $self->_dbh;
1360   }
1361 }
1362
1363 sub _extract_driver_from_connect_info {
1364   my $self = shift;
1365
1366   my $drv;
1367
1368   # if connect_info is a CODEREF, we have no choice but to connect
1369   if (
1370     ref $self->_dbi_connect_info->[0]
1371       and
1372     reftype $self->_dbi_connect_info->[0] eq 'CODE'
1373   ) {
1374     $self->_populate_dbh;
1375     $drv = $self->_dbh->{Driver}{Name};
1376   }
1377   else {
1378     # try to use dsn to not require being connected, the driver may still
1379     # force a connection later in _rebless to determine version
1380     # (dsn may not be supplied at all if all we do is make a mock-schema)
1381     ($drv) = ($self->_dbi_connect_info->[0] || '') =~ /^dbi:([^:]+):/i;
1382     $drv ||= $ENV{DBI_DRIVER};
1383   }
1384
1385   return $drv;
1386 }
1387
1388 sub _determine_connector_driver {
1389   my ($self, $conn) = @_;
1390
1391   my $dbtype = $self->_get_rdbms_name;
1392
1393   if (not $dbtype) {
1394     $self->_warn_undetermined_driver(
1395       'Unable to retrieve RDBMS type (SQL_DBMS_NAME) of the engine behind your '
1396     . "$conn connector - this should not have happened."
1397     );
1398     return;
1399   }
1400
1401   $dbtype =~ s/\W/_/gi;
1402
1403   my $subclass = "DBIx::Class::Storage::DBI::${conn}::${dbtype}";
1404   return if $self->isa($subclass);
1405
1406   if ($self->load_optional_class($subclass)) {
1407     bless $self, $subclass;
1408     $self->_rebless;
1409   }
1410   else {
1411     $self->_warn_undetermined_driver(
1412       'This version of DBIC does not yet seem to supply a driver for '
1413     . "your particular RDBMS and/or connection method ('$conn/$dbtype')."
1414     );
1415   }
1416 }
1417
1418 sub _get_rdbms_name { shift->_dbh_get_info('SQL_DBMS_NAME') }
1419
1420 sub _warn_undetermined_driver {
1421   my ($self, $msg) = @_;
1422
1423   require Data::Dumper::Concise;
1424
1425   carp_once ($msg . ' While we will attempt to continue anyway, the results '
1426   . 'are likely to be underwhelming. Please upgrade DBIC, and if this message '
1427   . "does not go away, file a bugreport including the following info:\n"
1428   . Data::Dumper::Concise::Dumper($self->_describe_connection)
1429   );
1430 }
1431
1432 sub _do_connection_actions {
1433   my ($self, $method_prefix, $call, @args) = @_;
1434
1435   dbic_internal_try {
1436     if (not ref($call)) {
1437       my $method = $method_prefix . $call;
1438       $self->$method(@args);
1439     }
1440     elsif (ref($call) eq 'CODE') {
1441       $self->$call(@args);
1442     }
1443     elsif (ref($call) eq 'ARRAY') {
1444       if (ref($call->[0]) ne 'ARRAY') {
1445         $self->_do_connection_actions($method_prefix, $_) for @$call;
1446       }
1447       else {
1448         $self->_do_connection_actions($method_prefix, @$_) for @$call;
1449       }
1450     }
1451     else {
1452       $self->throw_exception (sprintf ("Don't know how to process conection actions of type '%s'", ref($call)) );
1453     }
1454   }
1455   catch {
1456     if ( $method_prefix =~ /^connect/ ) {
1457       # this is an on_connect cycle - we can't just throw while leaving
1458       # a handle in an undefined state in our storage object
1459       # kill it with fire and rethrow
1460       $self->_dbh(undef);
1461       $self->disconnect;  # the $dbh is gone, but we still need to reset the rest
1462       $self->throw_exception( $_[0] );
1463     }
1464     else {
1465       carp "Disconnect action failed: $_[0]";
1466     }
1467   };
1468
1469   return $self;
1470 }
1471
1472 sub connect_call_do_sql {
1473   my $self = shift;
1474   $self->_do_query(@_);
1475 }
1476
1477 sub disconnect_call_do_sql {
1478   my $self = shift;
1479   $self->_do_query(@_);
1480 }
1481
1482 =head2 connect_call_datetime_setup
1483
1484 A no-op stub method, provided so that one can always safely supply the
1485 L<connection option|/DBIx::Class specific connection attributes>
1486
1487  on_connect_call => 'datetime_setup'
1488
1489 This way one does not need to know in advance whether the underlying
1490 storage requires any sort of hand-holding when dealing with calendar
1491 data.
1492
1493 =cut
1494
1495 sub connect_call_datetime_setup { 1 }
1496
1497 sub _do_query {
1498   my ($self, $action) = @_;
1499
1500   if (ref $action eq 'CODE') {
1501     $action = $action->($self);
1502     $self->_do_query($_) foreach @$action;
1503   }
1504   else {
1505     # Most debuggers expect ($sql, @bind), so we need to exclude
1506     # the attribute hash which is the second argument to $dbh->do
1507     # furthermore the bind values are usually to be presented
1508     # as named arrayref pairs, so wrap those here too
1509     my @do_args = (ref $action eq 'ARRAY') ? (@$action) : ($action);
1510     my $sql = shift @do_args;
1511     my $attrs = shift @do_args;
1512     my @bind = map { [ undef, $_ ] } @do_args;
1513
1514     $self->dbh_do(sub {
1515       $_[0]->_query_start($sql, \@bind);
1516       $_[1]->do($sql, $attrs, @do_args);
1517       $_[0]->_query_end($sql, \@bind);
1518     });
1519   }
1520
1521   return $self;
1522 }
1523
1524 sub _connect {
1525   my $self = shift;
1526
1527   my $info = $self->_dbi_connect_info;
1528
1529   $self->throw_exception("You did not provide any connection_info")
1530     unless defined $info->[0];
1531
1532   my ($old_connect_via, $dbh);
1533
1534   local $DBI::connect_via = 'connect' if $INC{'Apache/DBI.pm'} && $ENV{MOD_PERL};
1535
1536   # this odd anonymous coderef dereference is in fact really
1537   # necessary to avoid the unwanted effect described in perl5
1538   # RT#75792
1539   #
1540   # in addition the coderef itself can't reside inside the try{} block below
1541   # as it somehow triggers a leak under perl -d
1542   my $dbh_error_handler_installer = sub {
1543     weaken (my $weak_self = $_[0]);
1544
1545     # the coderef is blessed so we can distinguish it from externally
1546     # supplied handles (which must be preserved)
1547     $_[1]->{HandleError} = bless sub {
1548       if ($weak_self) {
1549         $weak_self->throw_exception("DBI Exception: $_[0]");
1550       }
1551       else {
1552         # the handler may be invoked by something totally out of
1553         # the scope of DBIC
1554         DBIx::Class::Exception->throw("DBI Exception (unhandled by DBIC, ::Schema GCed): $_[0]");
1555       }
1556     }, '__DBIC__DBH__ERROR__HANDLER__';
1557   };
1558
1559   dbic_internal_try {
1560     if(ref $info->[0] eq 'CODE') {
1561       $dbh = $info->[0]->();
1562     }
1563     else {
1564       require DBI;
1565       $dbh = DBI->connect(@$info);
1566     }
1567
1568     die $DBI::errstr unless $dbh;
1569
1570     die sprintf ("%s fresh DBI handle with a *false* 'Active' attribute. "
1571       . 'This handle is disconnected as far as DBIC is concerned, and we can '
1572       . 'not continue',
1573       ref $info->[0] eq 'CODE'
1574         ? "Connection coderef $info->[0] returned a"
1575         : 'DBI->connect($schema->storage->connect_info) resulted in a'
1576     ) unless $dbh->FETCH('Active');
1577
1578     # sanity checks unless asked otherwise
1579     unless ($self->unsafe) {
1580
1581       $self->throw_exception(
1582         'Refusing clobbering of {HandleError} installed on externally supplied '
1583        ."DBI handle $dbh. Either remove the handler or use the 'unsafe' attribute."
1584       ) if $dbh->{HandleError} and ref $dbh->{HandleError} ne '__DBIC__DBH__ERROR__HANDLER__';
1585
1586       # Default via _default_dbi_connect_attributes is 1, hence it was an explicit
1587       # request, or an external handle. Complain and set anyway
1588       unless ($dbh->{RaiseError}) {
1589         carp( ref $info->[0] eq 'CODE'
1590
1591           ? "The 'RaiseError' of the externally supplied DBI handle is set to false. "
1592            ."DBIx::Class will toggle it back to true, unless the 'unsafe' connect "
1593            .'attribute has been supplied'
1594
1595           : 'RaiseError => 0 supplied in your connection_info, without an explicit '
1596            .'unsafe => 1. Toggling RaiseError back to true'
1597         );
1598
1599         $dbh->{RaiseError} = 1;
1600       }
1601
1602       $dbh_error_handler_installer->($self, $dbh);
1603     }
1604   }
1605   catch {
1606     $self->throw_exception("DBI Connection failed: $_")
1607   };
1608
1609   $self->_dbh_autocommit($dbh->{AutoCommit});
1610   return $dbh;
1611 }
1612
1613 sub txn_begin {
1614   # this means we have not yet connected and do not know the AC status
1615   # (e.g. coderef $dbh), need a full-fledged connection check
1616   if (! defined $_[0]->_dbh_autocommit) {
1617     $_[0]->ensure_connected;
1618   }
1619   # Otherwise simply connect or re-connect on pid changes
1620   else {
1621     $_[0]->_get_dbh;
1622   }
1623
1624   shift->next::method(@_);
1625 }
1626
1627 sub _exec_txn_begin {
1628   my $self = shift;
1629
1630   # if the user is utilizing txn_do - good for him, otherwise we need to
1631   # ensure that the $dbh is healthy on BEGIN.
1632   # We do this via ->dbh_do instead of ->dbh, so that the ->dbh "ping"
1633   # will be replaced by a failure of begin_work itself (which will be
1634   # then retried on reconnect)
1635   if ($self->{_in_do_block}) {
1636     $self->_dbh->begin_work;
1637   } else {
1638     $self->dbh_do(sub { $_[1]->begin_work });
1639   }
1640 }
1641
1642 sub txn_commit {
1643   my $self = shift;
1644
1645   $self->throw_exception("Unable to txn_commit() on a disconnected storage")
1646     unless $self->_seems_connected;
1647
1648   # esoteric case for folks using external $dbh handles
1649   if (! $self->transaction_depth and ! $self->_dbh->FETCH('AutoCommit') ) {
1650     carp "Storage transaction_depth 0 does not match "
1651         ."false AutoCommit of $self->{_dbh}, attempting COMMIT anyway";
1652     $self->transaction_depth(1);
1653   }
1654
1655   $self->next::method(@_);
1656
1657   # if AutoCommit is disabled txn_depth never goes to 0
1658   # as a new txn is started immediately on commit
1659   $self->transaction_depth(1) if (
1660     !$self->transaction_depth
1661       and
1662     defined $self->_dbh_autocommit
1663       and
1664     ! $self->_dbh_autocommit
1665   );
1666 }
1667
1668 sub _exec_txn_commit {
1669   shift->_dbh->commit;
1670 }
1671
1672 sub txn_rollback {
1673   my $self = shift;
1674
1675   # do a minimal connectivity check due to weird shit like
1676   # https://rt.cpan.org/Public/Bug/Display.html?id=62370
1677   $self->throw_exception("lost connection to storage")
1678     unless $self->_seems_connected;
1679
1680   # esoteric case for folks using external $dbh handles
1681   if (! $self->transaction_depth and ! $self->_dbh->FETCH('AutoCommit') ) {
1682     carp "Storage transaction_depth 0 does not match "
1683         ."false AutoCommit of $self->{_dbh}, attempting ROLLBACK anyway";
1684     $self->transaction_depth(1);
1685   }
1686
1687   $self->next::method(@_);
1688
1689   # if AutoCommit is disabled txn_depth never goes to 0
1690   # as a new txn is started immediately on commit
1691   $self->transaction_depth(1) if (
1692     !$self->transaction_depth
1693       and
1694     defined $self->_dbh_autocommit
1695       and
1696     ! $self->_dbh_autocommit
1697   );
1698 }
1699
1700 sub _exec_txn_rollback {
1701   shift->_dbh->rollback;
1702 }
1703
1704 # generate the DBI-specific stubs, which then fallback to ::Storage proper
1705 quote_sub __PACKAGE__ . "::$_" => sprintf (<<'EOS', $_) for qw(svp_begin svp_release svp_rollback);
1706   $_[0]->throw_exception('Unable to %s() on a disconnected storage')
1707     unless $_[0]->_seems_connected;
1708   shift->next::method(@_);
1709 EOS
1710
1711 # This used to be the top-half of _execute.  It was split out to make it
1712 #  easier to override in NoBindVars without duping the rest.  It takes up
1713 #  all of _execute's args, and emits $sql, @bind.
1714 sub _prep_for_execute {
1715   #my ($self, $op, $ident, $args) = @_;
1716   return shift->_gen_sql_bind(@_)
1717 }
1718
1719 sub _gen_sql_bind {
1720   my ($self, $op, $ident, $args) = @_;
1721
1722   my ($colinfos, $from);
1723   if ( blessed($ident) ) {
1724     $from = $ident->from;
1725     $colinfos = $ident->columns_info;
1726   }
1727
1728   my ($sql, $bind);
1729   ($sql, @$bind) = $self->sql_maker->$op( ($from || $ident), @$args );
1730
1731   $bind = $self->_resolve_bindattrs(
1732     $ident, [ @{$args->[2]{bind}||[]}, @$bind ], $colinfos
1733   );
1734
1735   if (
1736     ! $ENV{DBIC_DT_SEARCH_OK}
1737       and
1738     $op eq 'select'
1739       and
1740     first {
1741       length ref $_->[1]
1742         and
1743       blessed($_->[1])
1744         and
1745       $_->[1]->isa('DateTime')
1746     } @$bind
1747   ) {
1748     carp_unique 'DateTime objects passed to search() are not supported '
1749       . 'properly (InflateColumn::DateTime formats and settings are not '
1750       . 'respected.) See ".. format a DateTime object for searching?" in '
1751       . 'DBIx::Class::Manual::FAQ. To disable this warning for good '
1752       . 'set $ENV{DBIC_DT_SEARCH_OK} to true'
1753   }
1754
1755   return( $sql, $bind );
1756 }
1757
1758 sub _resolve_bindattrs {
1759   my ($self, $ident, $bind, $colinfos) = @_;
1760
1761   my $resolve_bindinfo = sub {
1762     #my $infohash = shift;
1763
1764     $colinfos ||= { %{ $self->_resolve_column_info($ident) } };
1765
1766     my $ret;
1767     if (my $col = $_[0]->{dbic_colname}) {
1768       $ret = { %{$_[0]} };
1769
1770       $ret->{sqlt_datatype} ||= $colinfos->{$col}{data_type}
1771         if $colinfos->{$col}{data_type};
1772
1773       $ret->{sqlt_size} ||= $colinfos->{$col}{size}
1774         if $colinfos->{$col}{size};
1775     }
1776
1777     $ret || $_[0];
1778   };
1779
1780   return [ map {
1781       ( ref $_ ne 'ARRAY' or @$_ != 2 ) ? [ {}, $_ ]
1782     : ( ! defined $_->[0] )             ? [ {}, $_->[1] ]
1783     : (ref $_->[0] eq 'HASH')           ? [(
1784                                             ! keys %{$_->[0]}
1785                                               or
1786                                             exists $_->[0]{dbd_attrs}
1787                                               or
1788                                             $_->[0]{sqlt_datatype}
1789                                            ) ? $_->[0]
1790                                              : $resolve_bindinfo->($_->[0])
1791                                            , $_->[1]
1792                                           ]
1793     : (ref $_->[0] eq 'SCALAR')         ? [ { sqlt_datatype => ${$_->[0]} }, $_->[1] ]
1794     :                                     [ $resolve_bindinfo->(
1795                                               { dbic_colname => $_->[0] }
1796                                             ), $_->[1] ]
1797   } @$bind ];
1798 }
1799
1800 sub _format_for_trace {
1801   #my ($self, $bind) = @_;
1802
1803   ### Turn @bind from something like this:
1804   ###   ( [ "artist", 1 ], [ \%attrs, 3 ] )
1805   ### to this:
1806   ###   ( "'1'", "'3'" )
1807
1808   map {
1809     defined( $_ && $_->[1] )
1810       ? qq{'$_->[1]'}
1811       : q{NULL}
1812   } @{$_[1] || []};
1813 }
1814
1815 sub _query_start {
1816   my ( $self, $sql, $bind ) = @_;
1817
1818   $self->debugobj->query_start( $sql, $self->_format_for_trace($bind) )
1819     if $self->debug;
1820 }
1821
1822 sub _query_end {
1823   my ( $self, $sql, $bind ) = @_;
1824
1825   $self->debugobj->query_end( $sql, $self->_format_for_trace($bind) )
1826     if $self->debug;
1827 }
1828
1829 sub _dbi_attrs_for_bind {
1830   #my ($self, $ident, $bind) = @_;
1831
1832   return [ map {
1833
1834     exists $_->{dbd_attrs}  ?  $_->{dbd_attrs}
1835
1836   : ! $_->{sqlt_datatype}   ? undef
1837
1838   :                           do {
1839
1840     # cache the result in the dbh_details hash, as it (usually) can not change
1841     # unless we connect to something else
1842     # FIXME: for the time being Oracle is an exception, pending a rewrite of
1843     # the LOB storage
1844     my $cache = $_[0]->_dbh_details->{_datatype_map_cache} ||= {};
1845
1846     $cache->{$_->{sqlt_datatype}} = $_[0]->bind_attribute_by_data_type($_->{sqlt_datatype})
1847       if ! exists $cache->{$_->{sqlt_datatype}};
1848
1849     $cache->{$_->{sqlt_datatype}};
1850
1851   } } map { $_->[0] } @{$_[2]} ];
1852 }
1853
1854 sub _execute {
1855   my ($self, $op, $ident, @args) = @_;
1856
1857   my ($sql, $bind) = $self->_prep_for_execute($op, $ident, \@args);
1858
1859   # not even a PID check - we do not care about the state of the _dbh.
1860   # All we need is to get the appropriate drivers loaded if they aren't
1861   # already so that the assumption in ad7c50fc26e holds
1862   $self->_populate_dbh unless $self->_dbh;
1863
1864   $self->dbh_do( _dbh_execute =>     # retry over disconnects
1865     $sql,
1866     $bind,
1867     $self->_dbi_attrs_for_bind($ident, $bind),
1868   );
1869 }
1870
1871 sub _dbh_execute {
1872   my ($self, $dbh, $sql, $bind, $bind_attrs) = @_;
1873
1874   $self->_query_start( $sql, $bind );
1875
1876   my $sth = $self->_bind_sth_params(
1877     $self->_prepare_sth($dbh, $sql),
1878     $bind,
1879     $bind_attrs,
1880   );
1881
1882   # Can this fail without throwing an exception anyways???
1883   my $rv = $sth->execute();
1884   $self->throw_exception(
1885     $sth->errstr || $sth->err || 'Unknown error: execute() returned false, but error flags were not set...'
1886   ) if !$rv;
1887
1888   $self->_query_end( $sql, $bind );
1889
1890   return (wantarray ? ($rv, $sth, @$bind) : $rv);
1891 }
1892
1893 sub _prepare_sth {
1894   my ($self, $dbh, $sql) = @_;
1895
1896   # 3 is the if_active parameter which avoids active sth re-use
1897   my $sth = $self->disable_sth_caching
1898     ? $dbh->prepare($sql)
1899     : $dbh->prepare_cached($sql, {}, 3);
1900
1901   # XXX You would think RaiseError would make this impossible,
1902   #  but apparently that's not true :(
1903   $self->throw_exception(
1904     $dbh->errstr
1905       ||
1906     sprintf( "\$dbh->prepare() of '%s' through %s failed *silently* without "
1907             .'an exception and/or setting $dbh->errstr',
1908       length ($sql) > 20
1909         ? substr($sql, 0, 20) . '...'
1910         : $sql
1911       ,
1912       'DBD::' . $dbh->{Driver}{Name},
1913     )
1914   ) if !$sth;
1915
1916   $sth;
1917 }
1918
1919 sub _bind_sth_params {
1920   my ($self, $sth, $bind, $bind_attrs) = @_;
1921
1922   for my $i (0 .. $#$bind) {
1923     if (ref $bind->[$i][1] eq 'SCALAR') {  # any scalarrefs are assumed to be bind_inouts
1924       $sth->bind_param_inout(
1925         $i + 1, # bind params counts are 1-based
1926         $bind->[$i][1],
1927         $bind->[$i][0]{dbd_size} || $self->_max_column_bytesize($bind->[$i][0]), # size
1928         $bind_attrs->[$i],
1929       );
1930     }
1931     else {
1932       # FIXME SUBOPTIMAL - DBI needs fixing to always stringify regardless of DBD
1933       my $v = ( length ref $bind->[$i][1] and is_plain_value $bind->[$i][1] )
1934         ? "$bind->[$i][1]"
1935         : $bind->[$i][1]
1936       ;
1937
1938       $sth->bind_param(
1939         $i + 1,
1940         # The temp-var is CRUCIAL - DO NOT REMOVE IT, breaks older DBD::SQLite RT#79576
1941         $v,
1942         $bind_attrs->[$i],
1943       );
1944     }
1945   }
1946
1947   $sth;
1948 }
1949
1950 sub _prefetch_autovalues {
1951   my ($self, $source, $colinfo, $to_insert) = @_;
1952
1953   my %values;
1954   for my $col (keys %$colinfo) {
1955     if (
1956       $colinfo->{$col}{auto_nextval}
1957         and
1958       (
1959         ! exists $to_insert->{$col}
1960           or
1961         is_literal_value($to_insert->{$col})
1962       )
1963     ) {
1964       $values{$col} = $self->_sequence_fetch(
1965         'NEXTVAL',
1966         ( $colinfo->{$col}{sequence} ||=
1967             $self->_dbh_get_autoinc_seq($self->_get_dbh, $source, $col)
1968         ),
1969       );
1970     }
1971   }
1972
1973   \%values;
1974 }
1975
1976 sub insert {
1977   my ($self, $source, $to_insert) = @_;
1978
1979   my $col_infos = $source->columns_info;
1980
1981   my $prefetched_values = $self->_prefetch_autovalues($source, $col_infos, $to_insert);
1982
1983   # fuse the values, but keep a separate list of prefetched_values so that
1984   # they can be fused once again with the final return
1985   $to_insert = { %$to_insert, %$prefetched_values };
1986
1987   # FIXME - we seem to assume undef values as non-supplied. This is wrong.
1988   # Investigate what does it take to s/defined/exists/
1989   my %pcols = map { $_ => 1 } $source->primary_columns;
1990   my (%retrieve_cols, $autoinc_supplied, $retrieve_autoinc_col);
1991   for my $col ($source->columns) {
1992     if ($col_infos->{$col}{is_auto_increment}) {
1993       $autoinc_supplied ||= 1 if defined $to_insert->{$col};
1994       $retrieve_autoinc_col ||= $col unless $autoinc_supplied;
1995     }
1996
1997     # nothing to retrieve when explicit values are supplied
1998     next if (
1999       defined $to_insert->{$col} and ! is_literal_value($to_insert->{$col})
2000     );
2001
2002     # the 'scalar keys' is a trick to preserve the ->columns declaration order
2003     $retrieve_cols{$col} = scalar keys %retrieve_cols if (
2004       $pcols{$col}
2005         or
2006       $col_infos->{$col}{retrieve_on_insert}
2007     );
2008   };
2009
2010   local $self->{_autoinc_supplied_for_op} = $autoinc_supplied;
2011   local $self->{_perform_autoinc_retrieval} = $retrieve_autoinc_col;
2012
2013   my ($sqla_opts, @ir_container);
2014   if (%retrieve_cols and $self->_use_insert_returning) {
2015     $sqla_opts->{returning_container} = \@ir_container
2016       if $self->_use_insert_returning_bound;
2017
2018     $sqla_opts->{returning} = [
2019       sort { $retrieve_cols{$a} <=> $retrieve_cols{$b} } keys %retrieve_cols
2020     ];
2021   }
2022
2023   my ($rv, $sth) = $self->_execute('insert', $source, $to_insert, $sqla_opts);
2024
2025   my %returned_cols = %$to_insert;
2026   if (my $retlist = $sqla_opts->{returning}) {  # if IR is supported - we will get everything in one set
2027
2028     unless( @ir_container ) {
2029       dbic_internal_try {
2030
2031         # FIXME - need to investigate why Caelum silenced this in 4d4dc518
2032         local $SIG{__WARN__} = sub {};
2033
2034         @ir_container = $sth->fetchrow_array;
2035         $sth->finish;
2036
2037       } catch {
2038         # Evict the $sth from the cache in case we got here, since the finish()
2039         # is crucial, at least on older Firebirds, possibly on other engines too
2040         #
2041         # It would be too complex to make this a proper subclass override,
2042         # and besides we already take the try{} penalty, adding a catch that
2043         # triggers infrequently is a no-brainer
2044         #
2045         if( my $kids = $self->_dbh->{CachedKids} ) {
2046           $kids->{$_} == $sth and delete $kids->{$_}
2047             for keys %$kids
2048         }
2049       };
2050     }
2051
2052     @returned_cols{@$retlist} = @ir_container if @ir_container;
2053   }
2054   else {
2055     # pull in PK if needed and then everything else
2056     if (my @missing_pri = grep { $pcols{$_} } keys %retrieve_cols) {
2057
2058       $self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" )
2059         unless $self->can('last_insert_id');
2060
2061       my @pri_values = $self->last_insert_id($source, @missing_pri);
2062
2063       $self->throw_exception( "Can't get last insert id" )
2064         unless (@pri_values == @missing_pri);
2065
2066       @returned_cols{@missing_pri} = @pri_values;
2067       delete @retrieve_cols{@missing_pri};
2068     }
2069
2070     # if there is more left to pull
2071     if (%retrieve_cols) {
2072       $self->throw_exception(
2073         'Unable to retrieve additional columns without a Primary Key on ' . $source->source_name
2074       ) unless %pcols;
2075
2076       my @left_to_fetch = sort { $retrieve_cols{$a} <=> $retrieve_cols{$b} } keys %retrieve_cols;
2077
2078       my $cur = DBIx::Class::ResultSet->new($source, {
2079         where => { map { $_ => $returned_cols{$_} } (keys %pcols) },
2080         select => \@left_to_fetch,
2081       })->cursor;
2082
2083       @returned_cols{@left_to_fetch} = $cur->next;
2084
2085       $self->throw_exception('Duplicate row returned for PK-search after fresh insert')
2086         if scalar $cur->next;
2087     }
2088   }
2089
2090   return { %$prefetched_values, %returned_cols };
2091 }
2092
2093 sub insert_bulk {
2094   carp_unique(
2095     'insert_bulk() should have never been exposed as a public method and '
2096   . 'calling it is depecated as of Aug 2014. If you believe having a genuine '
2097   . 'use for this method please contact the development team via '
2098   . DBIx::Class::_ENV_::HELP_URL
2099   );
2100
2101   return '0E0' unless @{$_[3]||[]};
2102
2103   shift->_insert_bulk(@_);
2104 }
2105
2106 sub _insert_bulk {
2107   my ($self, $source, $cols, $data) = @_;
2108
2109   $self->throw_exception('Calling _insert_bulk without a dataset to process makes no sense')
2110     unless @{$data||[]};
2111
2112   my $colinfos = $source->columns_info($cols);
2113
2114   local $self->{_autoinc_supplied_for_op} =
2115     (grep { $_->{is_auto_increment} } values %$colinfos)
2116       ? 1
2117       : 0
2118   ;
2119
2120   # get a slice type index based on first row of data
2121   # a "column" in this context may refer to more than one bind value
2122   # e.g. \[ '?, ?', [...], [...] ]
2123   #
2124   # construct the value type index - a description of values types for every
2125   # per-column slice of $data:
2126   #
2127   # nonexistent - nonbind literal
2128   # 0 - regular value
2129   # [] of bindattrs - resolved attribute(s) of bind(s) passed via literal+bind \[] combo
2130   #
2131   # also construct the column hash to pass to the SQL generator. For plain
2132   # (non literal) values - convert the members of the first row into a
2133   # literal+bind combo, with extra positional info in the bind attr hashref.
2134   # This will allow us to match the order properly, and is so contrived
2135   # because a user-supplied literal/bind (or something else specific to a
2136   # resultsource and/or storage driver) can inject extra binds along the
2137   # way, so one can't rely on "shift positions" ordering at all. Also we
2138   # can't just hand SQLA a set of some known "values" (e.g. hashrefs that
2139   # can be later matched up by address), because we want to supply a real
2140   # value on which perhaps e.g. datatype checks will be performed
2141   my ($proto_data, $serialized_bind_type_by_col_idx);
2142   for my $col_idx (0..$#$cols) {
2143     my $colname = $cols->[$col_idx];
2144     if (ref $data->[0][$col_idx] eq 'SCALAR') {
2145       # no bind value at all - no type
2146
2147       $proto_data->{$colname} = $data->[0][$col_idx];
2148     }
2149     elsif (ref $data->[0][$col_idx] eq 'REF' and ref ${$data->[0][$col_idx]} eq 'ARRAY' ) {
2150       # repack, so we don't end up mangling the original \[]
2151       my ($sql, @bind) = @${$data->[0][$col_idx]};
2152
2153       # normalization of user supplied stuff
2154       my $resolved_bind = $self->_resolve_bindattrs(
2155         $source, \@bind, $colinfos,
2156       );
2157
2158       # store value-less (attrs only) bind info - we will be comparing all
2159       # supplied binds against this for sanity
2160       $serialized_bind_type_by_col_idx->{$col_idx} = serialize [ map { $_->[0] } @$resolved_bind ];
2161
2162       $proto_data->{$colname} = \[ $sql, map { [
2163         # inject slice order to use for $proto_bind construction
2164           { %{$resolved_bind->[$_][0]}, _bind_data_slice_idx => $col_idx, _literal_bind_subindex => $_+1 }
2165             =>
2166           $resolved_bind->[$_][1]
2167         ] } (0 .. $#bind)
2168       ];
2169     }
2170     else {
2171       $serialized_bind_type_by_col_idx->{$col_idx} = undef;
2172
2173       $proto_data->{$colname} = \[ '?', [
2174         { dbic_colname => $colname, _bind_data_slice_idx => $col_idx }
2175           =>
2176         $data->[0][$col_idx]
2177       ] ];
2178     }
2179   }
2180
2181   my ($sql, $proto_bind) = $self->_prep_for_execute (
2182     'insert',
2183     $source,
2184     [ $proto_data ],
2185   );
2186
2187   if (! @$proto_bind and keys %$serialized_bind_type_by_col_idx) {
2188     # if the bindlist is empty and we had some dynamic binds, this means the
2189     # storage ate them away (e.g. the NoBindVars component) and interpolated
2190     # them directly into the SQL. This obviously can't be good for multi-inserts
2191     $self->throw_exception('Unable to invoke fast-path insert without storage placeholder support');
2192   }
2193
2194   # sanity checks
2195   # FIXME - devise a flag "no babysitting" or somesuch to shut this off
2196   #
2197   # use an error reporting closure for convenience (less to pass)
2198   my $bad_slice_report_cref = sub {
2199     my ($msg, $r_idx, $c_idx) = @_;
2200     $self->throw_exception(sprintf "%s for column '%s' in populate slice:\n%s",
2201       $msg,
2202       $cols->[$c_idx],
2203       do {
2204         require Data::Dumper::Concise;
2205         local $Data::Dumper::Maxdepth = 5;
2206         Data::Dumper::Concise::Dumper ({
2207           map { $cols->[$_] =>
2208             $data->[$r_idx][$_]
2209           } 0..$#$cols
2210         }),
2211       }
2212     );
2213   };
2214
2215   for my $col_idx (0..$#$cols) {
2216     my $reference_val = $data->[0][$col_idx];
2217
2218     for my $row_idx (1..$#$data) {  # we are comparing against what we got from [0] above, hence start from 1
2219       my $val = $data->[$row_idx][$col_idx];
2220
2221       if (! exists $serialized_bind_type_by_col_idx->{$col_idx}) { # literal no binds
2222         if (ref $val ne 'SCALAR') {
2223           $bad_slice_report_cref->(
2224             "Incorrect value (expecting SCALAR-ref \\'$$reference_val')",
2225             $row_idx,
2226             $col_idx,
2227           );
2228         }
2229         elsif ($$val ne $$reference_val) {
2230           $bad_slice_report_cref->(
2231             "Inconsistent literal SQL value (expecting \\'$$reference_val')",
2232             $row_idx,
2233             $col_idx,
2234           );
2235         }
2236       }
2237       elsif (! defined $serialized_bind_type_by_col_idx->{$col_idx} ) {  # regular non-literal value
2238         if (is_literal_value($val)) {
2239           $bad_slice_report_cref->("Literal SQL found where a plain bind value is expected", $row_idx, $col_idx);
2240         }
2241       }
2242       else {  # binds from a \[], compare type and attrs
2243         if (ref $val ne 'REF' or ref $$val ne 'ARRAY') {
2244           $bad_slice_report_cref->(
2245             "Incorrect value (expecting ARRAYREF-ref \\['${$reference_val}->[0]', ... ])",
2246             $row_idx,
2247             $col_idx,
2248           );
2249         }
2250         # start drilling down and bail out early on identical refs
2251         elsif (
2252           $reference_val != $val
2253             or
2254           $$reference_val != $$val
2255         ) {
2256           if (${$val}->[0] ne ${$reference_val}->[0]) {
2257             $bad_slice_report_cref->(
2258               "Inconsistent literal/bind SQL (expecting \\['${$reference_val}->[0]', ... ])",
2259               $row_idx,
2260               $col_idx,
2261             );
2262           }
2263           # need to check the bind attrs - a bind will happen only once for
2264           # the entire dataset, so any changes further down will be ignored.
2265           elsif (
2266             $serialized_bind_type_by_col_idx->{$col_idx}
2267               ne
2268             serialize [
2269               map
2270               { $_->[0] }
2271               @{$self->_resolve_bindattrs(
2272                 $source, [ @{$$val}[1 .. $#$$val] ], $colinfos,
2273               )}
2274             ]
2275           ) {
2276             $bad_slice_report_cref->(
2277               'Differing bind attributes on literal/bind values not supported',
2278               $row_idx,
2279               $col_idx,
2280             );
2281           }
2282         }
2283       }
2284     }
2285   }
2286
2287   # neither _dbh_execute_for_fetch, nor _dbh_execute_inserts_with_no_binds
2288   # are atomic (even if execute_for_fetch is a single call). Thus a safety
2289   # scope guard
2290   my $guard = $self->txn_scope_guard;
2291
2292   $self->_query_start( $sql, @$proto_bind ? [[ {} => '__BULK_INSERT__' ]] : () );
2293   my $sth = $self->_prepare_sth($self->_dbh, $sql);
2294   my $rv = do {
2295     if (@$proto_bind) {
2296       # proto bind contains the information on which pieces of $data to pull
2297       # $cols is passed in only for prettier error-reporting
2298       $self->_dbh_execute_for_fetch( $source, $sth, $proto_bind, $cols, $data );
2299     }
2300     else {
2301       # bind_param_array doesn't work if there are no binds
2302       $self->_dbh_execute_inserts_with_no_binds( $sth, scalar @$data );
2303     }
2304   };
2305
2306   $self->_query_end( $sql, @$proto_bind ? [[ {} => '__BULK_INSERT__' ]] : () );
2307
2308   $guard->commit;
2309
2310   return wantarray ? ($rv, $sth, @$proto_bind) : $rv;
2311 }
2312
2313 # execute_for_fetch is capable of returning data just fine (it means it
2314 # can be used for INSERT...RETURNING and UPDATE...RETURNING. Since this
2315 # is the void-populate fast-path we will just ignore this altogether
2316 # for the time being.
2317 sub _dbh_execute_for_fetch {
2318   my ($self, $source, $sth, $proto_bind, $cols, $data) = @_;
2319
2320   # If we have any bind attributes to take care of, we will bind the
2321   # proto-bind data (which will never be used by execute_for_fetch)
2322   # However since column bindtypes are "sticky", this is sufficient
2323   # to get the DBD to apply the bindtype to all values later on
2324   my $bind_attrs = $self->_dbi_attrs_for_bind($source, $proto_bind);
2325
2326   for my $i (0 .. $#$proto_bind) {
2327     $sth->bind_param (
2328       $i+1, # DBI bind indexes are 1-based
2329       $proto_bind->[$i][1],
2330       $bind_attrs->[$i],
2331     ) if defined $bind_attrs->[$i];
2332   }
2333
2334   # At this point $data slots named in the _bind_data_slice_idx of
2335   # each piece of $proto_bind are either \[]s or plain values to be
2336   # passed in. Construct the dispensing coderef. *NOTE* the order
2337   # of $data will differ from this of the ?s in the SQL (due to
2338   # alphabetical ordering by colname). We actually do want to
2339   # preserve this behavior so that prepare_cached has a better
2340   # chance of matching on unrelated calls
2341
2342   my $fetch_row_idx = -1; # saner loop this way
2343   my $fetch_tuple = sub {
2344     return undef if ++$fetch_row_idx > $#$data;
2345
2346     return [ map {
2347       my $v = ! defined $_->{_literal_bind_subindex}
2348
2349         ? $data->[ $fetch_row_idx ]->[ $_->{_bind_data_slice_idx} ]
2350
2351         # There are no attributes to resolve here - we already did everything
2352         # when we constructed proto_bind. However we still want to sanity-check
2353         # what the user supplied, so pass stuff through to the resolver *anyway*
2354         : $self->_resolve_bindattrs (
2355             undef,  # a fake rsrc
2356             [ ${ $data->[ $fetch_row_idx ]->[ $_->{_bind_data_slice_idx} ]}->[ $_->{_literal_bind_subindex} ] ],
2357             {},     # a fake column_info bag
2358           )->[0][1]
2359       ;
2360
2361       # FIXME SUBOPTIMAL - DBI needs fixing to always stringify regardless of DBD
2362       # For the time being forcibly stringify whatever is stringifiable
2363       my $vref;
2364
2365       ( !length ref $v or ! ($vref = is_plain_value $v) )   ? $v
2366     : defined blessed( $$vref )                             ? "$$vref"
2367                                                             : $$vref
2368     ;
2369     } map { $_->[0] } @$proto_bind ];
2370   };
2371
2372   my $tuple_status = [];
2373   my ($rv, $err);
2374   dbic_internal_try {
2375     $rv = $sth->execute_for_fetch(
2376       $fetch_tuple,
2377       $tuple_status,
2378     );
2379   }
2380   catch {
2381     $err = shift;
2382   };
2383
2384   # Not all DBDs are create equal. Some throw on error, some return
2385   # an undef $rv, and some set $sth->err - try whatever we can
2386   $err = ($sth->errstr || 'UNKNOWN ERROR ($sth->errstr is unset)') if (
2387     ! defined $err
2388       and
2389     ( !defined $rv or $sth->err )
2390   );
2391
2392   # Statement must finish even if there was an exception.
2393   dbic_internal_try {
2394     $sth->finish
2395   }
2396   catch {
2397     $err = shift unless defined $err
2398   };
2399
2400   if (defined $err) {
2401     my $i = 0;
2402     ++$i while $i <= $#$tuple_status && !ref $tuple_status->[$i];
2403
2404     $self->throw_exception("Unexpected populate error: $err")
2405       if ($i > $#$tuple_status);
2406
2407     require Data::Dumper::Concise;
2408     $self->throw_exception(sprintf "execute_for_fetch() aborted with '%s' at populate slice:\n%s",
2409       ($tuple_status->[$i][1] || $err),
2410       Data::Dumper::Concise::Dumper( { map { $cols->[$_] => $data->[$i][$_] } (0 .. $#$cols) } ),
2411     );
2412   }
2413
2414   return $rv;
2415 }
2416
2417 sub _dbh_execute_inserts_with_no_binds {
2418   my ($self, $sth, $count) = @_;
2419
2420   my $err;
2421   dbic_internal_try {
2422     my $dbh = $self->_get_dbh;
2423     local $dbh->{RaiseError} = 1;
2424     local $dbh->{PrintError} = 0;
2425
2426     $sth->execute foreach 1..$count;
2427   }
2428   catch {
2429     $err = shift;
2430   };
2431
2432   # Make sure statement is finished even if there was an exception.
2433   dbic_internal_try {
2434     $sth->finish
2435   }
2436   catch {
2437     $err = shift unless defined $err;
2438   };
2439
2440   $self->throw_exception($err) if defined $err;
2441
2442   return $count;
2443 }
2444
2445 sub update {
2446   #my ($self, $source, @args) = @_;
2447   shift->_execute('update', @_);
2448 }
2449
2450
2451 sub delete {
2452   #my ($self, $source, @args) = @_;
2453   shift->_execute('delete', @_);
2454 }
2455
2456 sub _select {
2457   my $self = shift;
2458   $self->_execute($self->_select_args(@_));
2459 }
2460
2461 sub _select_args_to_query {
2462   my $self = shift;
2463
2464   $self->throw_exception(
2465     "Unable to generate limited query representation with 'software_limit' enabled"
2466   ) if ($_[3]->{software_limit} and ($_[3]->{offset} or $_[3]->{rows}) );
2467
2468   # my ($op, $ident, $select, $cond, $rs_attrs, $rows, $offset)
2469   #  = $self->_select_args($ident, $select, $cond, $attrs);
2470   my ($op, $ident, @args) =
2471     $self->_select_args(@_);
2472
2473   # my ($sql, $prepared_bind) = $self->_gen_sql_bind($op, $ident, [ $select, $cond, $rs_attrs, $rows, $offset ]);
2474   my ($sql, $bind) = $self->_gen_sql_bind($op, $ident, \@args);
2475
2476   # reuse the bind arrayref
2477   unshift @{$bind}, "($sql)";
2478   \$bind;
2479 }
2480
2481 sub _select_args {
2482   my ($self, $ident, $select, $where, $orig_attrs) = @_;
2483
2484   # FIXME - that kind of caching would be nice to have
2485   # however currently we *may* pass the same $orig_attrs
2486   # with different ident/select/where
2487   # the whole interface needs to be rethought, since it
2488   # was centered around the flawed SQLA API. We can do
2489   # soooooo much better now. But that is also another
2490   # battle...
2491   #return (
2492   #  'select', $orig_attrs->{!args_as_stored_at_the_end_of_this_method!}
2493   #) if $orig_attrs->{!args_as_stored_at_the_end_of_this_method!};
2494
2495   my $sql_maker = $self->sql_maker;
2496
2497   my $attrs = {
2498     %$orig_attrs,
2499     select => $select,
2500     from => $ident,
2501     where => $where,
2502   };
2503
2504   # MySQL actually recommends this approach.  I cringe.
2505   $attrs->{rows} ||= $sql_maker->__max_int
2506     if $attrs->{offset};
2507
2508   # see if we will need to tear the prefetch apart to satisfy group_by == select
2509   # this is *extremely tricky* to get right, I am still not sure I did
2510   #
2511   my ($prefetch_needs_subquery, @limit_args);
2512
2513   if ( $attrs->{_grouped_by_distinct} and $attrs->{collapse} ) {
2514     # we already know there is a valid group_by (we made it) and we know it is
2515     # intended to be based *only* on non-multi stuff
2516     # short circuit the group_by parsing below
2517     $prefetch_needs_subquery = 1;
2518   }
2519   elsif (
2520     # The rationale is that even if we do *not* have collapse, we still
2521     # need to wrap the core grouped select/group_by in a subquery
2522     # so that databases that care about group_by/select equivalence
2523     # are happy (this includes MySQL in strict_mode)
2524     # If any of the other joined tables are referenced in the group_by
2525     # however - the user is on their own
2526     ( $prefetch_needs_subquery or ! $attrs->{_simple_passthrough_construction} )
2527       and
2528     $attrs->{group_by}
2529       and
2530     @{$attrs->{group_by}}
2531       and
2532     my $grp_aliases = dbic_internal_try { # internal_try{} because $attrs->{from} may be unreadable
2533       $self->_resolve_aliastypes_from_select_args({ from => $attrs->{from}, group_by => $attrs->{group_by} })
2534     }
2535   ) {
2536     # no aliases other than our own in group_by
2537     # if there are - do not allow subquery even if limit is present
2538     $prefetch_needs_subquery = ! scalar grep { $_ ne $attrs->{alias} } keys %{ $grp_aliases->{grouping} || {} };
2539   }
2540   elsif ( $attrs->{rows} && $attrs->{collapse} ) {
2541     # active collapse with a limit - that one is a no-brainer unless
2542     # overruled by a group_by above
2543     $prefetch_needs_subquery = 1;
2544   }
2545
2546   if ($prefetch_needs_subquery) {
2547     $attrs = $self->_adjust_select_args_for_complex_prefetch ($attrs);
2548   }
2549   elsif (! $attrs->{software_limit} ) {
2550     push @limit_args, (
2551       $attrs->{rows} || (),
2552       $attrs->{offset} || (),
2553     );
2554   }
2555
2556   # try to simplify the joinmap further (prune unreferenced type-single joins)
2557   if (
2558     ! $prefetch_needs_subquery  # already pruned
2559       and
2560     ref $attrs->{from}
2561       and
2562     reftype $attrs->{from} eq 'ARRAY'
2563       and
2564     @{$attrs->{from}} != 1
2565   ) {
2566     ($attrs->{from}, $attrs->{_aliastypes}) = $self->_prune_unused_joins ($attrs);
2567   }
2568
2569   # FIXME this is a gross, inefficient, largely incorrect and fragile hack
2570   # during the result inflation stage we *need* to know what was the aliastype
2571   # map as sqla saw it when the final pieces of SQL were being assembled
2572   # Originally we simply carried around the entirety of $attrs, but this
2573   # resulted in resultsets that are being reused growing continuously, as
2574   # the hash in question grew deeper and deeper.
2575   # Instead hand-pick what to take with us here (we actually don't need much
2576   # at this point just the map itself)
2577   $orig_attrs->{_last_sqlmaker_alias_map} = $attrs->{_aliastypes};
2578
2579 ###
2580   #   my $alias2source = $self->_resolve_ident_sources ($ident);
2581   #
2582   # This would be the point to deflate anything found in $attrs->{where}
2583   # (and leave $attrs->{bind} intact). Problem is - inflators historically
2584   # expect a result object. And all we have is a resultsource (it is trivial
2585   # to extract deflator coderefs via $alias2source above).
2586   #
2587   # I don't see a way forward other than changing the way deflators are
2588   # invoked, and that's just bad...
2589 ###
2590
2591   return ( 'select', @{$attrs}{qw(from select where)}, $attrs, @limit_args );
2592 }
2593
2594 # Returns a counting SELECT for a simple count
2595 # query. Abstracted so that a storage could override
2596 # this to { count => 'firstcol' } or whatever makes
2597 # sense as a performance optimization
2598 sub _count_select {
2599   #my ($self, $source, $rs_attrs) = @_;
2600   return { count => '*' };
2601 }
2602
2603 =head2 select
2604
2605 =over 4
2606
2607 =item Arguments: $ident, $select, $condition, $attrs
2608
2609 =back
2610
2611 Handle a SQL select statement.
2612
2613 =cut
2614
2615 sub select {
2616   my $self = shift;
2617   my ($ident, $select, $condition, $attrs) = @_;
2618   return $self->cursor_class->new($self, \@_, $attrs);
2619 }
2620
2621 sub select_single {
2622   my $self = shift;
2623   my ($rv, $sth, @bind) = $self->_select(@_);
2624   my @row = $sth->fetchrow_array;
2625   my @nextrow = $sth->fetchrow_array if @row;
2626   if(@row && @nextrow) {
2627     carp "Query returned more than one row.  SQL that returns multiple rows is DEPRECATED for ->find and ->single";
2628   }
2629   # Need to call finish() to work round broken DBDs
2630   $sth->finish();
2631   return @row;
2632 }
2633
2634 =head2 sql_limit_dialect
2635
2636 This is an accessor for the default SQL limit dialect used by a particular
2637 storage driver. Can be overridden by supplying an explicit L</limit_dialect>
2638 to L<DBIx::Class::Schema/connect>. For a list of available limit dialects
2639 see L<DBIx::Class::SQLMaker::LimitDialects>.
2640
2641 =cut
2642
2643 sub _dbh_columns_info_for {
2644   my ($self, $dbh, $table) = @_;
2645
2646   my %result;
2647
2648   if (! DBIx::Class::_ENV_::STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE and $dbh->can('column_info')) {
2649     dbic_internal_try {
2650       my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
2651       my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
2652       $sth->execute();
2653       while ( my $info = $sth->fetchrow_hashref() ){
2654         my %column_info;
2655         $column_info{data_type}   = $info->{TYPE_NAME};
2656         $column_info{size}      = $info->{COLUMN_SIZE};
2657         $column_info{is_nullable}   = $info->{NULLABLE} ? 1 : 0;
2658         $column_info{default_value} = $info->{COLUMN_DEF};
2659         my $col_name = $info->{COLUMN_NAME};
2660         $col_name =~ s/^\"(.*)\"$/$1/;
2661
2662         $result{$col_name} = \%column_info;
2663       }
2664     } catch {
2665       %result = ();
2666     };
2667
2668     return \%result if keys %result;
2669   }
2670
2671   my $sth = $dbh->prepare($self->sql_maker->select($table, undef, \'1 = 0'));
2672   $sth->execute;
2673
2674 ### The acrobatics with lc names is necessary to support both the legacy
2675 ### API that used NAME_lc exclusively, *AND* at the same time work properly
2676 ### with column names differing in cas eonly (thanks pg!)
2677
2678   my ($columns, $seen_lcs);
2679
2680   ++$seen_lcs->{lc($_)} and $columns->{$_} = {
2681     idx => scalar keys %$columns,
2682     name => $_,
2683     lc_name => lc($_),
2684   } for @{$sth->{NAME}};
2685
2686   $seen_lcs->{$_->{lc_name}} == 1
2687     and
2688   $_->{name} = $_->{lc_name}
2689     for values %$columns;
2690
2691   for ( values %$columns ) {
2692     my $inf = {
2693       data_type => $sth->{TYPE}->[$_->{idx}],
2694       size => $sth->{PRECISION}->[$_->{idx}],
2695       is_nullable => $sth->{NULLABLE}->[$_->{idx}] ? 1 : 0,
2696     };
2697
2698     if ($inf->{data_type} =~ m/^(.*?)\((.*?)\)$/) {
2699       @{$inf}{qw( data_type  size)} = ($1, $2);
2700     }
2701
2702     $result{$_->{name}} = $inf;
2703   }
2704
2705   $sth->finish;
2706
2707   if ($dbh->can('type_info')) {
2708     for my $inf (values %result) {
2709       next if ! defined $inf->{data_type};
2710
2711       $inf->{data_type} = (
2712         (
2713           (
2714             $dbh->type_info( $inf->{data_type} )
2715               ||
2716             next
2717           )
2718             ||
2719           next
2720         )->{TYPE_NAME}
2721           ||
2722         next
2723       );
2724
2725       # FIXME - this may be an artifact of the DBD::Pg implmentation alone
2726       # needs more testing in the future...
2727       $inf->{size} -= 4 if (
2728         ( $inf->{size}||0 > 4 )
2729           and
2730         $inf->{data_type} =~ qr/^text$/i
2731       );
2732     }
2733
2734   }
2735
2736   return \%result;
2737 }
2738
2739 sub columns_info_for {
2740   my ($self, $table) = @_;
2741   $self->_dbh_columns_info_for ($self->_get_dbh, $table);
2742 }
2743
2744 =head2 last_insert_id
2745
2746 Return the row id of the last insert.
2747
2748 =cut
2749
2750 sub _dbh_last_insert_id {
2751     my ($self, $dbh, $source, $col) = @_;
2752
2753     my $id = dbic_internal_try { $dbh->last_insert_id (undef, undef, $source->name, $col) };
2754
2755     return $id if defined $id;
2756
2757     my $class = ref $self;
2758     $self->throw_exception ("No storage specific _dbh_last_insert_id() method implemented in $class, and the generic DBI::last_insert_id() failed");
2759 }
2760
2761 sub last_insert_id {
2762   my $self = shift;
2763   $self->_dbh_last_insert_id ($self->_dbh, @_);
2764 }
2765
2766 =head2 _native_data_type
2767
2768 =over 4
2769
2770 =item Arguments: $type_name
2771
2772 =back
2773
2774 This API is B<EXPERIMENTAL>, will almost definitely change in the future, and
2775 currently only used by L<::AutoCast|DBIx::Class::Storage::DBI::AutoCast> and
2776 L<::Sybase::ASE|DBIx::Class::Storage::DBI::Sybase::ASE>.
2777
2778 The default implementation returns C<undef>, implement in your Storage driver if
2779 you need this functionality.
2780
2781 Should map types from other databases to the native RDBMS type, for example
2782 C<VARCHAR2> to C<VARCHAR>.
2783
2784 Types with modifiers should map to the underlying data type. For example,
2785 C<INTEGER AUTO_INCREMENT> should become C<INTEGER>.
2786
2787 Composite types should map to the container type, for example
2788 C<ENUM(foo,bar,baz)> becomes C<ENUM>.
2789
2790 =cut
2791
2792 sub _native_data_type {
2793   #my ($self, $data_type) = @_;
2794   return undef
2795 }
2796
2797 # Check if placeholders are supported at all
2798 sub _determine_supports_placeholders {
2799   my $self = shift;
2800   my $dbh  = $self->_get_dbh;
2801
2802   # some drivers provide a $dbh attribute (e.g. Sybase and $dbh->{syb_dynamic_supported})
2803   # but it is inaccurate more often than not
2804   ( dbic_internal_try {
2805     local $dbh->{PrintError} = 0;
2806     local $dbh->{RaiseError} = 1;
2807     $dbh->do('select ?', {}, 1);
2808     1;
2809   } )
2810     ? 1
2811     : 0
2812   ;
2813 }
2814
2815 # Check if placeholders bound to non-string types throw exceptions
2816 #
2817 sub _determine_supports_typeless_placeholders {
2818   my $self = shift;
2819   my $dbh  = $self->_get_dbh;
2820
2821   ( dbic_internal_try {
2822     local $dbh->{PrintError} = 0;
2823     local $dbh->{RaiseError} = 1;
2824     # this specifically tests a bind that is NOT a string
2825     $dbh->do('select 1 where 1 = ?', {}, 1);
2826     1;
2827   } )
2828     ? 1
2829     : 0
2830   ;
2831 }
2832
2833 =head2 sqlt_type
2834
2835 Returns the database driver name.
2836
2837 =cut
2838
2839 sub sqlt_type {
2840   shift->_get_dbh->{Driver}->{Name};
2841 }
2842
2843 =head2 bind_attribute_by_data_type
2844
2845 Given a datatype from column info, returns a database specific bind
2846 attribute for C<< $dbh->bind_param($val,$attribute) >> or nothing if we will
2847 let the database planner just handle it.
2848
2849 This method is always called after the driver has been determined and a DBI
2850 connection has been established. Therefore you can refer to C<DBI::$constant>
2851 and/or C<DBD::$driver::$constant> directly, without worrying about loading
2852 the correct modules.
2853
2854 =cut
2855
2856 sub bind_attribute_by_data_type {
2857     return;
2858 }
2859
2860 =head2 is_datatype_numeric
2861
2862 Given a datatype from column_info, returns a boolean value indicating if
2863 the current RDBMS considers it a numeric value. This controls how
2864 L<DBIx::Class::Row/set_column> decides whether to mark the column as
2865 dirty - when the datatype is deemed numeric a C<< != >> comparison will
2866 be performed instead of the usual C<eq>.
2867
2868 =cut
2869
2870 sub is_datatype_numeric {
2871   #my ($self, $dt) = @_;
2872
2873   return 0 unless $_[1];
2874
2875   $_[1] =~ /^ (?:
2876     numeric | int(?:eger)? | (?:tiny|small|medium|big)int | dec(?:imal)? | real | float | double (?: \s+ precision)? | (?:big)?serial
2877   ) $/ix;
2878 }
2879
2880
2881 =head2 create_ddl_dir
2882
2883 =over 4
2884
2885 =item Arguments: $schema, \@databases, $version, $directory, $preversion, \%sqlt_args
2886
2887 =back
2888
2889 Creates a SQL file based on the Schema, for each of the specified
2890 database engines in C<\@databases> in the given directory.
2891 (note: specify L<SQL::Translator> names, not L<DBI> driver names).
2892
2893 Given a previous version number, this will also create a file containing
2894 the ALTER TABLE statements to transform the previous schema into the
2895 current one. Note that these statements may contain C<DROP TABLE> or
2896 C<DROP COLUMN> statements that can potentially destroy data.
2897
2898 The file names are created using the C<ddl_filename> method below, please
2899 override this method in your schema if you would like a different file
2900 name format. For the ALTER file, the same format is used, replacing
2901 $version in the name with "$preversion-$version".
2902
2903 See L<SQL::Translator/METHODS> for a list of values for C<\%sqlt_args>.
2904 The most common value for this would be C<< { add_drop_table => 1 } >>
2905 to have the SQL produced include a C<DROP TABLE> statement for each table
2906 created. For quoting purposes supply C<quote_identifiers>.
2907
2908 If no arguments are passed, then the following default values are assumed:
2909
2910 =over 4
2911
2912 =item databases  - ['MySQL', 'SQLite', 'PostgreSQL']
2913
2914 =item version    - $schema->schema_version
2915
2916 =item directory  - './'
2917
2918 =item preversion - <none>
2919
2920 =back
2921
2922 By default, C<\%sqlt_args> will have
2923
2924  { add_drop_table => 1, ignore_constraint_names => 1, ignore_index_names => 1 }
2925
2926 merged with the hash passed in. To disable any of those features, pass in a
2927 hashref like the following
2928
2929  { ignore_constraint_names => 0, # ... other options }
2930
2931
2932 WARNING: You are strongly advised to check all SQL files created, before applying
2933 them.
2934
2935 =cut
2936
2937 sub create_ddl_dir {
2938   my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
2939
2940   unless ($dir) {
2941     carp "No directory given, using ./\n";
2942     $dir = './';
2943   } else {
2944       -d $dir
2945         or
2946       (require File::Path and File::Path::mkpath (["$dir"]))  # mkpath does not like objects (i.e. Path::Class::Dir)
2947         or
2948       $self->throw_exception(
2949         "Failed to create '$dir': " . ($! || $@ || 'error unknown')
2950       );
2951   }
2952
2953   $self->throw_exception ("Directory '$dir' does not exist\n") unless(-d $dir);
2954
2955   $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
2956   $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
2957
2958   my $schema_version = $schema->schema_version || '1.x';
2959   $version ||= $schema_version;
2960
2961   $sqltargs = {
2962     add_drop_table => 1,
2963     ignore_constraint_names => 1,
2964     ignore_index_names => 1,
2965     quote_identifiers => $self->sql_maker->_quoting_enabled,
2966     %{$sqltargs || {}}
2967   };
2968
2969   if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('deploy')) {
2970     $self->throw_exception("Can't create a ddl file without $missing");
2971   }
2972
2973   my $sqlt = SQL::Translator->new( $sqltargs );
2974
2975   $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
2976   my $sqlt_schema = $sqlt->translate({ data => $schema })
2977     or $self->throw_exception ($sqlt->error);
2978
2979   foreach my $db (@$databases) {
2980     $sqlt->reset();
2981     $sqlt->{schema} = $sqlt_schema;
2982     $sqlt->producer($db);
2983
2984     my $file;
2985     my $filename = $schema->ddl_filename($db, $version, $dir);
2986     if (-e $filename && ($version eq $schema_version )) {
2987       # if we are dumping the current version, overwrite the DDL
2988       carp "Overwriting existing DDL file - $filename";
2989       unlink($filename);
2990     }
2991
2992     my $output = $sqlt->translate;
2993     if(!$output) {
2994       carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
2995       next;
2996     }
2997     if(!open($file, ">$filename")) {
2998       $self->throw_exception("Can't open $filename for writing ($!)");
2999       next;
3000     }
3001     print $file $output;
3002     close($file);
3003
3004     next unless ($preversion);
3005
3006     require SQL::Translator::Diff;
3007
3008     my $prefilename = $schema->ddl_filename($db, $preversion, $dir);
3009     if(!-e $prefilename) {
3010       carp("No previous schema file found ($prefilename)");
3011       next;
3012     }
3013
3014     my $difffile = $schema->ddl_filename($db, $version, $dir, $preversion);
3015     if(-e $difffile) {
3016       carp("Overwriting existing diff file - $difffile");
3017       unlink($difffile);
3018     }
3019
3020     my $source_schema;
3021     {
3022       my $t = SQL::Translator->new($sqltargs);
3023       $t->debug( 0 );
3024       $t->trace( 0 );
3025
3026       $t->parser( $db )
3027         or $self->throw_exception ($t->error);
3028
3029       my $out = $t->translate( $prefilename )
3030         or $self->throw_exception ($t->error);
3031
3032       $source_schema = $t->schema;
3033
3034       $source_schema->name( $prefilename )
3035         unless ( $source_schema->name );
3036     }
3037
3038     # The "new" style of producers have sane normalization and can support
3039     # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
3040     # And we have to diff parsed SQL against parsed SQL.
3041     my $dest_schema = $sqlt_schema;
3042
3043     unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) {
3044       my $t = SQL::Translator->new($sqltargs);
3045       $t->debug( 0 );
3046       $t->trace( 0 );
3047
3048       $t->parser( $db )
3049         or $self->throw_exception ($t->error);
3050
3051       my $out = $t->translate( $filename )
3052         or $self->throw_exception ($t->error);
3053
3054       $dest_schema = $t->schema;
3055
3056       $dest_schema->name( $filename )
3057         unless $dest_schema->name;
3058     }
3059
3060     my $diff = do {
3061       # FIXME - this is a terrible workaround for
3062       # https://github.com/dbsrgits/sql-translator/commit/2d23c1e
3063       # Fixing it in this sloppy manner so that we don't hve to
3064       # lockstep an SQLT release as well. Needs to be removed at
3065       # some point, and SQLT dep bumped
3066       local $SQL::Translator::Producer::SQLite::NO_QUOTES
3067         if $SQL::Translator::Producer::SQLite::NO_QUOTES;
3068
3069       SQL::Translator::Diff::schema_diff($source_schema, $db,
3070                                          $dest_schema,   $db,
3071                                          $sqltargs
3072                                        );
3073     };
3074
3075     if(!open $file, ">$difffile") {
3076       $self->throw_exception("Can't write to $difffile ($!)");
3077       next;
3078     }
3079     print $file $diff;
3080     close($file);
3081   }
3082 }
3083
3084 =head2 deployment_statements
3085
3086 =over 4
3087
3088 =item Arguments: $schema, $type, $version, $directory, $sqlt_args
3089
3090 =back
3091
3092 Returns the statements used by L<DBIx::Class::Storage/deploy>
3093 and L<DBIx::Class::Schema/deploy>.
3094
3095 The L<SQL::Translator> (not L<DBI>) database driver name can be explicitly
3096 provided in C<$type>, otherwise the result of L</sqlt_type> is used as default.
3097
3098 C<$directory> is used to return statements from files in a previously created
3099 L</create_ddl_dir> directory and is optional. The filenames are constructed
3100 from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
3101
3102 If no C<$directory> is specified then the statements are constructed on the
3103 fly using L<SQL::Translator> and C<$version> is ignored.
3104
3105 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
3106
3107 =cut
3108
3109 sub deployment_statements {
3110   my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
3111   $type ||= $self->sqlt_type;
3112   $version ||= $schema->schema_version || '1.x';
3113   $dir ||= './';
3114   my $filename = $schema->ddl_filename($type, $version, $dir);
3115   if(-f $filename)
3116   {
3117       # FIXME replace this block when a proper sane sql parser is available
3118       my $file;
3119       open($file, "<$filename")
3120         or $self->throw_exception("Can't open $filename ($!)");
3121       my @rows = <$file>;
3122       close($file);
3123       return join('', @rows);
3124   }
3125
3126   if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') ) {
3127     $self->throw_exception("Can't deploy without a pregenerated 'ddl_dir' directory or $missing");
3128   }
3129
3130   # sources needs to be a parser arg, but for simplicity allow at top level
3131   # coming in
3132   $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
3133       if exists $sqltargs->{sources};
3134
3135   $sqltargs->{quote_identifiers} = $self->sql_maker->_quoting_enabled
3136     unless exists $sqltargs->{quote_identifiers};
3137
3138   my $tr = SQL::Translator->new(
3139     producer => "SQL::Translator::Producer::${type}",
3140     %$sqltargs,
3141     parser => 'SQL::Translator::Parser::DBIx::Class',
3142     data => $schema,
3143   );
3144
3145   return preserve_context {
3146     $tr->translate
3147   } after => sub {
3148     $self->throw_exception( 'Unable to produce deployment statements: ' . $tr->error)
3149       unless defined $_[0];
3150   };
3151 }
3152
3153 # FIXME deploy() currently does not accurately report sql errors
3154 # Will always return true while errors are warned
3155 sub deploy {
3156   my ($self, $schema, $type, $sqltargs, $dir) = @_;
3157   my $deploy = sub {
3158     my $line = shift;
3159     return if(!$line);
3160     return if($line =~ /^--/);
3161     # next if($line =~ /^DROP/m);
3162     return if($line =~ /^BEGIN TRANSACTION/m);
3163     return if($line =~ /^COMMIT/m);
3164     return if $line =~ /^\s+$/; # skip whitespace only
3165     $self->_query_start($line);
3166     dbic_internal_try {
3167       # do a dbh_do cycle here, as we need some error checking in
3168       # place (even though we will ignore errors)
3169       $self->dbh_do (sub { $_[1]->do($line) });
3170     } catch {
3171       carp qq{$_ (running "${line}")};
3172     };
3173     $self->_query_end($line);
3174   };
3175   my @statements = $schema->deployment_statements($type, undef, $dir, { %{ $sqltargs || {} }, no_comments => 1 } );
3176   if (@statements > 1) {
3177     foreach my $statement (@statements) {
3178       $deploy->( $statement );
3179     }
3180   }
3181   elsif (@statements == 1) {
3182     # split on single line comments and end of statements
3183     foreach my $line ( split(/\s*--.*\n|;\n/, $statements[0])) {
3184       $deploy->( $line );
3185     }
3186   }
3187 }
3188
3189 =head2 datetime_parser
3190
3191 Returns the datetime parser class
3192
3193 =cut
3194
3195 sub datetime_parser {
3196   my $self = shift;
3197   return $self->{datetime_parser} ||= do {
3198     $self->build_datetime_parser(@_);
3199   };
3200 }
3201
3202 =head2 datetime_parser_type
3203
3204 Defines the datetime parser class - currently defaults to L<DateTime::Format::MySQL>
3205
3206 =head2 build_datetime_parser
3207
3208 See L</datetime_parser>
3209
3210 =cut
3211
3212 sub build_datetime_parser {
3213   my $self = shift;
3214   my $type = $self->datetime_parser_type(@_);
3215   return $type;
3216 }
3217
3218
3219 =head2 is_replicating
3220
3221 A boolean that reports if a particular L<DBIx::Class::Storage::DBI> is set to
3222 replicate from a master database.  Default is undef, which is the result
3223 returned by databases that don't support replication.
3224
3225 =cut
3226
3227 sub is_replicating {
3228     return;
3229
3230 }
3231
3232 =head2 lag_behind_master
3233
3234 Returns a number that represents a certain amount of lag behind a master db
3235 when a given storage is replicating.  The number is database dependent, but
3236 starts at zero and increases with the amount of lag. Default in undef
3237
3238 =cut
3239
3240 sub lag_behind_master {
3241     return;
3242 }
3243
3244 =head2 relname_to_table_alias
3245
3246 =over 4
3247
3248 =item Arguments: $relname, $join_count
3249
3250 =item Return Value: $alias
3251
3252 =back
3253
3254 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
3255 queries.
3256
3257 This hook is to allow specific L<DBIx::Class::Storage> drivers to change the
3258 way these aliases are named.
3259
3260 The default behavior is C<< "$relname_$join_count" if $join_count > 1 >>,
3261 otherwise C<"$relname">.
3262
3263 =cut
3264
3265 sub relname_to_table_alias {
3266   my ($self, $relname, $join_count) = @_;
3267
3268   my $alias = ($join_count && $join_count > 1 ?
3269     join('_', $relname, $join_count) : $relname);
3270
3271   return $alias;
3272 }
3273
3274 # The size in bytes to use for DBI's ->bind_param_inout, this is the generic
3275 # version and it may be necessary to amend or override it for a specific storage
3276 # if such binds are necessary.
3277 sub _max_column_bytesize {
3278   my ($self, $attr) = @_;
3279
3280   my $max_size;
3281
3282   if ($attr->{sqlt_datatype}) {
3283     my $data_type = lc($attr->{sqlt_datatype});
3284
3285     if ($attr->{sqlt_size}) {
3286
3287       # String/sized-binary types
3288       if ($data_type =~ /^(?:
3289           l? (?:var)? char(?:acter)? (?:\s*varying)?
3290             |
3291           (?:var)? binary (?:\s*varying)?
3292             |
3293           raw
3294         )\b/x
3295       ) {
3296         $max_size = $attr->{sqlt_size};
3297       }
3298       # Other charset/unicode types, assume scale of 4
3299       elsif ($data_type =~ /^(?:
3300           national \s* character (?:\s*varying)?
3301             |
3302           nchar
3303             |
3304           univarchar
3305             |
3306           nvarchar
3307         )\b/x
3308       ) {
3309         $max_size = $attr->{sqlt_size} * 4;
3310       }
3311     }
3312
3313     if (!$max_size and !$self->_is_lob_type($data_type)) {
3314       $max_size = 100 # for all other (numeric?) datatypes
3315     }
3316   }
3317
3318   $max_size || $self->_dbic_connect_attributes->{LongReadLen} || $self->_get_dbh->{LongReadLen} || 8000;
3319 }
3320
3321 # Determine if a data_type is some type of BLOB
3322 sub _is_lob_type {
3323   my ($self, $data_type) = @_;
3324   $data_type && ($data_type =~ /lob|bfile|text|image|bytea|memo/i
3325     || $data_type =~ /^long(?:\s+(?:raw|bit\s*varying|varbit|binary
3326                                   |varchar|character\s*varying|nvarchar
3327                                   |national\s*character\s*varying))?\z/xi);
3328 }
3329
3330 sub _is_binary_lob_type {
3331   my ($self, $data_type) = @_;
3332   $data_type && ($data_type =~ /blob|bfile|image|bytea/i
3333     || $data_type =~ /^long(?:\s+(?:raw|bit\s*varying|varbit|binary))?\z/xi);
3334 }
3335
3336 sub _is_text_lob_type {
3337   my ($self, $data_type) = @_;
3338   $data_type && ($data_type =~ /^(?:clob|memo)\z/i
3339     || $data_type =~ /^long(?:\s+(?:varchar|character\s*varying|nvarchar
3340                         |national\s*character\s*varying))\z/xi);
3341 }
3342
3343 # Determine if a data_type is some type of a binary type
3344 sub _is_binary_type {
3345   my ($self, $data_type) = @_;
3346   $data_type && ($self->_is_binary_lob_type($data_type)
3347     || $data_type =~ /(?:var)?(?:binary|bit|graphic)(?:\s*varying)?/i);
3348 }
3349
3350 1;
3351
3352 =head1 USAGE NOTES
3353
3354 =head2 DBIx::Class and AutoCommit
3355
3356 DBIx::Class can do some wonderful magic with handling exceptions,
3357 disconnections, and transactions when you use C<< AutoCommit => 1 >>
3358 (the default) combined with L<txn_do|DBIx::Class::Storage/txn_do> for
3359 transaction support.
3360
3361 If you set C<< AutoCommit => 0 >> in your connect info, then you are always
3362 in an assumed transaction between commits, and you're telling us you'd
3363 like to manage that manually.  A lot of the magic protections offered by
3364 this module will go away.  We can't protect you from exceptions due to database
3365 disconnects because we don't know anything about how to restart your
3366 transactions.  You're on your own for handling all sorts of exceptional
3367 cases if you choose the C<< AutoCommit => 0 >> path, just as you would
3368 be with raw DBI.
3369
3370 =head1 FURTHER QUESTIONS?
3371
3372 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
3373
3374 =head1 COPYRIGHT AND LICENSE
3375
3376 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
3377 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
3378 redistribute it and/or modify it under the same terms as the
3379 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.