view release on metacpan or  search on metacpan

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

      } catch {
        $self->throw_exception($_);
      }
    }
    else {
      require DBIO::Storage::Statistics;
      DBIO::Storage::Statistics->new
    }
  };
}



sub debugcb {
    my $self = shift;

    if ($self->debugobj->can('callback')) {
        return $self->debugobj->callback(@_);
    }
}



sub deploy { die "Virtual method!" }


sub connect_info { die "Virtual method!" }

# --- DBIO-private connect attributes (karr #66) --------------------------
# Single authoritative source for the attribute names a caller may pass in
# connect_info that are DBIO-private and must NEVER reach DBI->connect. Both
# connect-info paths consume these lists -- the sync normalizer
# (DBIO::Storage::DBI::_normalize_connect_info) and the async strip
# (DBIO::Storage::Async::connect_info) -- so the two paths can never drift on
# what counts as DBIO-private. They live on this shared base (the common
# ancestor of both DBI and Async storage) rather than on DBIO::Storage::DBI, so
# the async base can reach them without a new Async->DBI dependency direction.

# Storage-config options: routed to the storage, kept out of DBI->connect.
# (cursor_class is a storage option too, but carries its own component_class
# accessor, so it is appended at the split sites rather than listed here.)
sub _dbio_storage_option_names {
  qw/
    on_connect_call on_disconnect_call on_connect_do on_disconnect_do
    disable_sth_caching unsafe auto_savepoint
  /;
}

# SQL-maker options: routed to the sql_maker, kept out of DBI->connect.
sub _dbio_sql_maker_option_names {
  qw/ quote_char name_sep quote_names /;
}


sub select { die "Virtual method!" }


sub insert { die "Virtual method!" }


sub update { die "Virtual method!" }


sub delete { die "Virtual method!" }


sub select_single { die "Virtual method!" }

# Live async backend (a DBIO::Storage::Async) or undef when none configured.
# Overridden in DBIO::Storage::DBI to do real discovery. Base = no backend.
sub _async_storage { undef }

# The connect-time async mode name (ADR 0030), or undef for a sync instance.
# Overridden by the _async_mode accessor on DBIO::Storage::DBI; the base stub
# keeps non-DBI storages on the sync path (their *_async croak).
sub _async_mode { undef }

# Shared dispatch for the six *_async methods (ADR 0030). Three outcomes:
#   - an embedded backend is live    -> route ${op}_async to it (real async)
#   - the instance is in 'immediate'  -> run $op synchronously, wrap the result
#     mode (no backend, mode chosen)     in an immediately-resolved future
#   - the instance is sync            -> croak loudly: *_async was called but no
#     (no async mode chosen)             async mode was chosen at connect time
# _async_storage croaks on its own for a chosen-but-unavailable mode.
sub _run_async {
  my ($self, $op, @args) = @_;

  if (my $async = $self->_async_storage) {
    my $method = "${op}_async";
    return $async->$method(@args);
  }

  $self->throw_exception(
    "not an async connection -- connect with { async => ... } to use ${op}_async"
  ) unless defined $self->_async_mode;

  my $fc = $self->future_class;
  my @r = eval { $self->$op(@args) };
  return $@ ? $fc->fail($@) : $fc->done(@r);
}


sub select_async { shift->_run_async('select', @_) }


sub select_single_async { shift->_run_async('select_single', @_) }


sub insert_async { shift->_run_async('insert', @_) }


sub update_async { shift->_run_async('update', @_) }


sub delete_async { shift->_run_async('delete', @_) }


sub txn_do_async { shift->_run_async('txn_do', @_) }


sub future_class {
  my $self = shift;
  if (ref $self and my $async = $self->_async_storage) {
    return $async->future_class;
  }
  require DBIO::Future::Immediate;
  'DBIO::Future::Immediate';
}


sub columns_info_for { die "Virtual method!" }

# Type registry: maps type names to behavior descriptors, keyed by class so
# subclasses can add or override entries. Use type_info() for MRO-aware lookup.
my %_type_registry;


sub register_type {
  my ($class, $type_name, $info) = @_;
  $_type_registry{$class}{$type_name} = $info;
}


sub type_info {
  my ($class, $type_name) = @_;
  for my $pkg (@{ mro::get_linear_isa($class) }) {
    return $_type_registry{$pkg}{$type_name}
      if exists $_type_registry{$pkg}
      && exists $_type_registry{$pkg}{$type_name};
  }
  return undef;
}


sub all_type_names {
  my ($class) = @_;
  my %seen;
  for my $pkg (@{ mro::get_linear_isa($class) }) {
    $seen{$_}++ for keys %{ $_type_registry{$pkg} || {} };
  }
  return keys %seen;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME