weaken results from the CPAN

DBIO

package DBIO::Storage::DBI;
# ABSTRACT: DBI storage handler
# -*- mode: cperl; cperl-indent-level: 2 -*-

use strict;
use warnings;

use base qw/DBIO::Storage::QueryRewrite DBIO::Storage::DBI::Capabilities DBIO::Storage::DBI::DataTypeClassifier DBIO::Storage::DBI::AccessBroker DBIO::Storage/;
use mro 'c3';

use DBIO::Carp;
use Scalar::Util qw/refaddr weaken reftype blessed/;
use Context::Preserve 'preserve_context';
use Try::Tiny;
use DBIO::Util qw(is_plain_value is_literal_value);
use DBIO::Util qw(quote_sub perlstring serialize dump_value sigwarn_silencer is_windows is_dev_release old_mro help_url);
use DBIO::Skills;
use DBIO::Storage::Composed;
use namespace::clean;

# default cursor class, overridable in connect_info attributes
__PACKAGE__->cursor_class('DBIO::Storage::DBI::Cursor');

__PACKAGE__->mk_group_accessors('inherited' => qw/
  sql_quote_char sql_name_sep
/);

# Class-level hook to redact bind values before they are interpolated into
# the trace output. The default is the identity function (returns the value
# unchanged) which preserves the historical plaintext trace behavior.
# Install a custom coderef on the storage class:
#
#   __PACKAGE__->redact_bind_value(sub {
#     my ($colname, $value) = @_;
#     return $colname eq 'password' ? '***' : $value;
#   });
#
# The coderef receives the column name (or undef if no column metadata is
# attached to the bind slot) and the raw bind value, and must return the
# value to interpolate into the trace. The original bind value passed to
# the database is *not* modified - only the trace string is.
__PACKAGE__->mk_classdata('redact_bind_value' => sub { return $_[1] });

__PACKAGE__->mk_group_accessors('component_class' => qw/sql_maker_class datetime_parser_type/);

__PACKAGE__->sql_maker_class('DBIO::SQLMaker');
__PACKAGE__->datetime_parser_type('DateTime::Format::MySQL'); # historic default

# Identifier quoting is ON by default (security hardening). Concrete drivers
# override sql_quote_char with their RDBMS-native quote; the bare base storage
# falls back to the ANSI SQL standard double quote so the default-on path never
# has to warn about a missing quote_char.
__PACKAGE__->sql_quote_char('"');
__PACKAGE__->sql_name_sep('.');

__PACKAGE__->mk_group_accessors('simple' => qw/
  _connect_info _dbio_connect_attributes _driver_determined
  _dbh _dbh_details _conn_pid _sql_maker _sql_maker_opts _dbh_autocommit
  _perform_autoinc_retrieval _autoinc_supplied_for_op _async_mode
/);

# Async mode registry (ADR 0030): maps a connect-time mode name to the embedded
# backend class that answers the six *_async methods for an instance connected
# with { async => $mode }. Generic modes (e.g. 'forked', 'future_io') register
# on a base class and are inherited by every driver; native modes (e.g. 'ev')
# are registered by the concrete driver storage class, so the same logical mode
# name resolves to a DB-specific backend. Lookup walks the instance's MRO, so a
# driver registration shadows/extends the generic ones. 'immediate' is the
# in-process degrade mode (no event loop, no embedded backend): it maps to the
# immediate Future class and is recognised by NOT being a DBIO::Storage::Async
# subclass. Core registers only 'immediate' -- 'forked'/'future_io'/'ev' come
# from their add-on/driver dists, never auto-wired here.

lib/DBIO/Storage/DBI.pm view on Meta::CPAN


    if (
      # only fire when invoked on an instance, a valid class-based invocation
      # would e.g. be setting a default for an inherited accessor
      ref $_[0]
        and
      ! $_[0]->{_driver_determined}
        and
      ! $_[0]->{_in_determine_driver}
        and
      # if this is a known *setter* - just set it, no need to connect
      # and determine the driver
      ( %1$s or @_ <= 1 )
        and
      # Only try to determine stuff if we have *something* that either is or can
      # provide a DSN. Allows for bare $schema's generated with a plain ->connect()
      # to still be marginally useful
      $_[0]->_dbi_connect_info->[0]
    ) {
      $_[0]->_determine_driver;

      goto $_[0]->can(%2$s);
    }

    goto $orig;
EOC
}


sub new {
  my $new = shift->next::method(@_);

  $new->_sql_maker_opts({});
  $new->_dbh_details({});
  $new->{_in_do_block} = 0;

  # read below to see what this does
  $new->_arm_global_destructor;

  $new;
}

# This is hack to work around perl shooting stuff in random
# order on exit(). If we do not walk the remaining storage
# objects in an END block, there is a *small but real* chance
# of a fork()ed child to kill the parent's shared DBI handle,
# *before perl reaches the DESTROY in this package*
# Yes, it is ugly and effective.
# Additionally this registry is used by the CLONE method to
# make sure no handles are shared between threads
{
  my %seek_and_destroy;

  sub _arm_global_destructor {

    # quick "garbage collection" pass - prevents the registry
    # from slowly growing with a bunch of undef-valued keys
    defined $seek_and_destroy{$_} or delete $seek_and_destroy{$_}
      for keys %seek_and_destroy;

    weaken (
      $seek_and_destroy{ refaddr($_[0]) } = $_[0]
    );
  }

  END {
    local $?; # just in case the DBI destructor changes it somehow

    # destroy just the object if not native to this process
    $_->_verify_pid for (grep
      { defined $_ }
      values %seek_and_destroy
    );
  }

  sub CLONE {
    # As per DBI's recommendation, DBIO disconnects all handles as
    # soon as possible (DBIO will reconnect only on demand from within
    # the thread)
    my @instances = grep { defined $_ } values %seek_and_destroy;
    %seek_and_destroy = ();

    for (@instances) {
      $_->_dbh(undef);

      $_->transaction_depth(0);
      $_->savepoints([]);

      # properly renumber existing refs
      $_->_arm_global_destructor
    }
  }
}

sub DESTROY {
  $_[0]->_verify_pid unless is_windows();
  # some databases spew warnings on implicit disconnect
  local $SIG{__WARN__} = sub {};
  $_[0]->_dbh(undef);

  # this op is necessary, since the very last perl runtime statement
  # triggers a global destruction shootout, and the $SIG localization
  # may very well be destroyed before perl actually gets to do the
  # $dbh undef
  1;
}

# handle pid changes correctly - do not destroy parent's connection
sub _verify_pid {

  my $pid = $_[0]->_conn_pid;

  if( defined $pid and $pid != $$ and my $dbh = $_[0]->_dbh ) {
    $dbh->{InactiveDestroy} = 1;
    $_[0]->_dbh(undef);
    $_[0]->transaction_depth(0);
    $_[0]->savepoints([]);
  }

  return;
}

lib/DBIO/Storage/DBI.pm view on Meta::CPAN

      # layers (with their plain ::Async mixins) sit more-specific than the
      # driver in ref($self)'s MRO -- probing those would find a layer's async
      # mixin (not a DBIO::Storage::Async) before the driver's real adapter and
      # croak. For a non-composed instance the base IS ref($self) (karr #70).
      my $class = $self->_async_resolution_class;
      my @tried;
      for my $pkg (@{ mro::get_linear_isa($class) }) {
        last if $pkg eq __PACKAGE__;   # stop strictly BEFORE the generic base
        my $adapter = $pkg . '::Async';
        push @tried, $adapter;
        # Genuinely absent -> keep walking; present-but-unloadable (its own
        # async dependency missing, or broken) -> fail loud with the cause.
        next unless $self->_try_load_async_class($adapter, 'future_io adapter');

        # Loaded -- it MUST be a proper backend or we fail loud, naming it;
        # never silently skip past it to a parent's adapter (ADR 0030 Â§3).
        $self->throw_exception(
          "driver $class does not support future_io -- "
          . "$adapter loaded but is not a DBIO::Storage::Async"
        ) unless $adapter->isa('DBIO::Storage::Async');

        $backend_class = $adapter;
        last;
      }

      $self->throw_exception(
        "driver $class does not support future_io -- no ${class}::Async adapter "
        . "found on it or any parent (tried: @{[ join ', ', @tried ]})"
      ) unless defined $backend_class;
    }
  }
  else {
    $backend_class = $self->_resolve_async_mode_class($mode);

    $self->throw_exception(
      "async mode '$mode' is not available -- no driver or add-on registers it"
    ) if !defined $backend_class;

    $self->throw_exception(
      "async mode '$mode' is not available -- install $backend_class"
    ) unless $self->load_optional_class($backend_class);
  }

  # A non-DBIO::Storage::Async target (the 'immediate' Future class) is the
  # in-process degrade mode: no embedded backend is built.
  return $self->{_async_storage_obj} = undef
    unless $backend_class->isa('DBIO::Storage::Async');

  # --- WP2 (karr #70): async mirror composition. The transport class is now
  # resolved; mirror each registered SYNC storage layer onto its ASYNC
  # counterpart and compose them over the transport, so an extension's async
  # behaviour rides every transport just as its sync behaviour rides every
  # driver (one behaviour, one transport). Per sync layer L, in registration
  # order:
  #   * L->async_layer_class($mode) if L defines it -- a package (must load, or
  #     croak) or undef (fall back to convention);
  #   * otherwise the convention sibling "${L}::Async" via load_optional_class;
  #   * absent -> skip L silently (a sync-only extension, e.g. PostGIS).
  # This does NOT touch the transport resolution above (ADR 0030: the mode
  # stays explicit; only the layer CLASSES are added by composition).
  # A storage with no live schema (weakened ref already gone) can carry no
  # registered layers, so there is nothing to mirror.
  my $schema = $self->schema;
  my @async_layers;
  for my $sync_layer ($schema ? @{ $schema->storage_layers } : ()) {
    my $async_layer;

    if ($sync_layer->can('async_layer_class')) {
      $async_layer = $sync_layer->async_layer_class($mode);
      if (defined $async_layer) {
        # An explicitly declared class MUST load: genuinely absent -> the
        # "could not be loaded" croak; present-but-unloadable -> _try_load's
        # cause-naming croak (never a raw compile stack).
        $self->throw_exception(
          "async layer class '$async_layer' for storage layer '$sync_layer' "
        . "(async mode '$mode') could not be loaded"
        ) unless $self->_try_load_async_class(
          $async_layer, "async layer class for storage layer '$sync_layer'"
        );
      }
    }

    if (!defined $async_layer) {
      my $candidate = "${sync_layer}::Async";
      # Convention sibling: genuinely absent -> skip L silently (sync-only
      # extension, e.g. PostGIS); present-but-unloadable -> fail loud naming
      # the cause, never a silent feature loss nor a raw compile stack.
      $async_layer = $candidate
        if $self->_try_load_async_class($candidate, 'async layer');
    }

    push @async_layers, $async_layer if defined $async_layer;
  }

  if (@async_layers) {
    # Capability gate: an async layer may only compose over a transport that
    # provides every capability it declares as required. A shortfall croaks
    # naming the layer, the missing capabilities and the transport -- a
    # transport gap becomes that transport's ticket, never a silent feature loss.
    my %have = map { $_ => 1 } $backend_class->transport_capabilities;
    for my $async_layer (@async_layers) {
      next unless $async_layer->can('required_transport_capabilities');
      my @missing = grep { !$have{$_} }
        $async_layer->required_transport_capabilities;
      next unless @missing;
      $self->throw_exception(
        "async layer '$async_layer' requires transport "
      . (@missing == 1 ? 'capability' : 'capabilities') . " '"
      . join("', '", @missing) . "' which transport '$backend_class' does not "
      . "provide -- upgrade the transport '$backend_class' (or its "
      . "distribution) or choose another async mode"
      );
    }

    $backend_class =
      DBIO::Storage::Composed->compose($backend_class, \@async_layers);
  }

  # Build the embedded backend (ADR 0028 mechanism): ->new($schema) fed this
  # storage's DBI-form connect_info.
  my $async = $backend_class->new($self->schema);

lib/DBIO/Storage/DBI.pm view on Meta::CPAN

        "The 'rebase_sqlmaker' target class '$requested_base_class' must inherit from SQL::Abstract or SQL::Abstract::Classic"
      ) unless $requested_base_class->isa( 'SQL::Abstract' )
            or $requested_base_class->isa( 'SQL::Abstract::Classic' );

      $self->inject_base( $synthetic_class, $old_class, $requested_base_class );

      Class::C3->reinitialize
        if old_mro();
    }
  }

  # force re-build on next access for this particular $storage instance
  $self->sql_maker_class( $synthetic_class );
  $self->_sql_maker( undef );
}

sub _connect {
  my $self = shift;

  if ($self->access_broker) {
    my $broker_info = $self->_current_dbi_connect_info($self->access_broker_mode);
    # Broker returns HASHREF; normalize to ARRAYREF for _normalize_connect_info
    $broker_info = [$broker_info] if ref $broker_info eq 'HASH';
    my $info = $self->_normalize_connect_info($broker_info);

    my %attrs = (
      %{ $self->_default_dbi_connect_attributes || {} },
      %{ $info->{attributes} || {} },
    );

    my @args = @{ $info->{arguments} };

    # _dbio_connect_attributes keeps the full set (including DBIO-private
    # keys like ignore_version) for introspection by upper layers.
    # _dbi_connect_info must only contain attrs that DBI/DBD understands.
    my %dbi_attrs = %attrs;
    delete @dbi_attrs{qw( ignore_version )};

    push @args, \%dbi_attrs if keys %dbi_attrs and ref $args[0] ne 'CODE';

    $self->_dbi_connect_info(\@args);
    $self->_dbio_connect_attributes(\%attrs);
  }

  my $info = $self->_dbi_connect_info;

  $self->throw_exception("You did not provide any connection_info")
    unless defined $info->[0];

  my ($old_connect_via, $dbh);

  local $DBI::connect_via = 'connect' if $INC{'Apache/DBI.pm'} && $ENV{MOD_PERL};

  # this odd anonymous coderef dereference is in fact really
  # necessary to avoid the unwanted effect described in perl5
  # RT#75792
  #
  # in addition the coderef itself can't reside inside the try{} block below
  # as it somehow triggers a leak under perl -d
  my $dbh_error_handler_installer = sub {
    weaken (my $weak_self = $_[0]);

    # the coderef is blessed so we can distinguish it from externally
    # supplied handles (which must be preserved)
    $_[1]->{HandleError} = bless sub {
      if ($weak_self) {
        $weak_self->throw_exception("DBI Exception: $_[0]");
      }
      else {
        # the handler may be invoked by something totally out of
        # the scope of DBIO
        DBIO::Exception->throw("DBI Exception (unhandled by DBIO, ::Schema GCed): $_[0]");
      }
    }, '__DBIO__DBH__ERROR__HANDLER__';
  };

  try {
    if(ref $info->[0] eq 'CODE') {
      $dbh = $info->[0]->();
    }
    else {
      require DBI;
      $dbh = DBI->connect(@$info);
    }

    die $DBI::errstr unless $dbh;

    die sprintf ("%s fresh DBI handle with a *false* 'Active' attribute. "
      . 'This handle is disconnected as far as DBIO is concerned, and we can '
      . 'not continue',
      ref $info->[0] eq 'CODE'
        ? "Connection coderef $info->[0] returned a"
        : 'DBI->connect($schema->storage->connect_info) resulted in a'
    ) unless $dbh->FETCH('Active');

    # sanity checks unless asked otherwise
    unless ($self->unsafe) {

      $self->throw_exception(
        'Refusing clobbering of {HandleError} installed on externally supplied '
       ."DBI handle $dbh. Either remove the handler or use the 'unsafe' attribute."
      ) if $dbh->{HandleError} and ref $dbh->{HandleError} ne '__DBIO__DBH__ERROR__HANDLER__';

      # Default via _default_dbi_connect_attributes is 1, hence it was an explicit
      # request, or an external handle. Complain and set anyway
      unless ($dbh->{RaiseError}) {
        carp( ref $info->[0] eq 'CODE'

          ? "The 'RaiseError' of the externally supplied DBI handle is set to false. "
           ."DBIO will toggle it back to true, unless the 'unsafe' connect "
           .'attribute has been supplied'

          : 'RaiseError => 0 supplied in your connection_info, without an explicit '
           .'unsafe => 1. Toggling RaiseError back to true'
        );

        $dbh->{RaiseError} = 1;
      }

      $dbh_error_handler_installer->($self, $dbh);
    }

( run in 0.534 second using v1.01-cache-2.11-cpan-995e09ba956 )