view release on metacpan or  search on metacpan

lib/DBIO.pm  view on Meta::CPAN

package DBIO;
# ABSTRACT: Native relational mapping for Perl, built on DBI

use strict;
use warnings;

our $VERSION = '0.900002';

use DBIO::Base ();
use DBIO::Skills ();

sub import {
  my ($class, @args) = @_;
  my $caller = caller;

  my ($role, @opts);
  for my $arg (@args) {
    if (defined $arg && $arg =~ /^-/) { push @opts, $arg }
    elsif (!defined $role)            { $role = $arg }
    else                              { push @opts, $arg }
  }

  unless (defined $role) {
    if    ($caller =~ /::Result::[^:]+$/)    { $role = 'Core' }
    elsif ($caller =~ /::ResultSet::[^:]+$/) { $role = 'ResultSet' }
    else                                      { $role = 'Core' }
  }

  my $base = "DBIO::$role";
  eval "require $base; 1"
    or die "use DBIO '$role': cannot load $base: $@";

  {
    no strict 'refs';
    push @{"${caller}::ISA"}, $base unless $caller->isa($base);
  }

  strict->import;
  warnings->import;

  # Schema classes get the skills-override declaration sugar (see DBIO::Skills).
  _install_skill_sugar($caller) if $caller->isa('DBIO::Schema');

  _apply_shortcut($caller, $_) for @opts;
}

# Install the per-schema skills-override sugar into a schema class body:
#
#   skills { 'mysql-database' => $md, ... };   # set/replace the whole map
#   skill  'mysql-database' => $md;            # merge a single entry
#
# Both write the schema's skills() classdata (DBIO::Schema). namespace::clean
# removes the helpers after compilation, so at runtime $schema->skill(...) and
# $schema->skills resolve to the inherited DBIO::Schema accessor/method rather
# than these declaration helpers. The classdata accessor is reached via its
# fully-qualified name to bypass the (still-installed) sugar during the body.
sub _install_skill_sugar {
  my ($caller) = @_;
  no strict 'refs';
  no warnings 'redefine';
  *{"${caller}::skills"} = sub {
    my $map = (@_ == 1 && ref $_[0] eq 'HASH') ? $_[0] : { @_ };
    $caller->DBIO::Schema::skills($map);
  };
  *{"${caller}::skill"} = sub {
    my ($name, $markdown) = @_;
    my $cur = $caller->DBIO::Schema::skills || {};
    $caller->DBIO::Schema::skills({ %$cur, $name => $markdown });
  };
  require namespace::clean;
  namespace::clean->import(-cleanee => $caller, qw(skills skill));
}


sub skill { shift; DBIO::Skills->skill(@_) }


sub skills { shift; DBIO::Skills->skills(@_) }

# Shortcut resolution is two-tier and core never names a single driver:
#
#  1. Explicit stub DBIO::Shortcut::<key> -- a driver ships one for each
#     curated alias (e.g. -pg, -my). It is lazy-loaded here (so it works even
#     "cold") and its apply($caller) decides what to do, usually delegating to
#     DBIO->apply_driver:
#         package DBIO::Shortcut::pg;
#         sub apply { DBIO->apply_driver($_[1], 'PostgreSQL') }
#         1;
#
#  2. No stub? Fall back to an ALREADY-LOADED driver whose name matches the key
#     case-insensitively (-postgresql -> DBIO::PostgreSQL). The correct casing
#     comes from the loaded symbol table, not from guessing. This is why the
#     canonical name "just works" once the driver is loaded, with no stub.
sub _apply_shortcut {
  my ($caller, $opt) = @_;
  (my $key = lc $opt) =~ s/^-//;

  $key =~ /\A[a-z0-9_]+\z/