view release on metacpan or  search on metacpan

lib/DBIx/QuickORM.pm  view on Meta::CPAN

    $params{+DBS}     //= {};
    $params{+SCHEMAS} //= {};
    $params{+SERVERS} //= {};

    return bless(\%params, $class);
}

sub quick {
    my $class = shift;
    my %params = @_;

    my $creds   = delete $params{credentials};
    my $connect = delete $params{connect};
    my $types   = delete $params{auto_types} // [];
    my $dialect = delete $params{dialect};
    my $autorow = delete $params{autorow};    # 0 = off (default), 1 = generated namespace, or a class-name prefix
    my $row_manager = delete $params{row_manager} // 'DBIx::QuickORM::RowManager::Cached';
    my $no_volatile = delete $params{no_volatile};    # 1 = every table, or an arrayref of table names

    croak "Unknown parameter(s) to quick(): " . join(', ', sort keys %params) if keys %params;

    croak "'no_volatile' must be a true scalar (every table) or an arrayref of table names"
        if defined($no_volatile) && ref($no_volatile) && ref($no_volatile) ne 'ARRAY';

    croak "quick() requires exactly one of 'credentials' or 'connect'"
        unless (($creds ? 1 : 0) + ($connect ? 1 : 0)) == 1;

    croak "'credentials' must be a hashref" if $creds   && ref($creds) ne 'HASH';
    croak "'connect' must be a coderef"     if $connect && ref($connect) ne 'CODE';
    croak "'auto_types' must be an arrayref" if ref($types) ne 'ARRAY';

    my ($dialect_class, $db_name) = $class->_quick_detect($dialect, $creds, $connect);

    require DBIx::QuickORM::DB;
    my %db_params = (dialect => $dialect_class, db_name => $db_name);
    if ($creds) {
        if (my @bad = grep { $_ !~ /^(?:dsn|user|pass|attrs|dbd)$/ } keys %$creds) {
            croak "Unknown credentials key(s): " . join(', ' => sort @bad) . " (valid: dsn, user, pass, attrs, dbd)";
        }
        $db_params{dsn}        = $creds->{dsn}   if defined $creds->{dsn};
        $db_params{user}       = $creds->{user}  if defined $creds->{user};
        $db_params{pass}       = $creds->{pass}  if defined $creds->{pass};
        $db_params{attributes} = $creds->{attrs} if defined $creds->{attrs};
        $db_params{dbi_driver} = $creds->{dbd}   if defined $creds->{dbd};
    }
    else {
        $db_params{connect} = $connect;
    }
    my $db = DBIx::QuickORM::DB->new(%db_params);

    my (%type_map, %affinities);
    for my $type (@$types) {
        my $type_class = load_class($type, 'DBIx::QuickORM::Type') or croak "Could not load type '$type': $@";
        $type_class->qorm_register_type(\%type_map, \%affinities);
    }

    my %autofill_args = (types => \%type_map, affinities => \%affinities, hooks => {}, skip => {});
    $autofill_args{no_volatile} = $no_volatile if defined $no_volatile;
    if ($autorow) {
        my $base = "$autorow" eq '1' ? $class->_generate_autorow_base : $autorow;
        $autofill_args{hooks}{post_table} = [$class->_autorow_hook($base, undef, (caller)[1])];
    }
    my $autofill = DBIx::QuickORM::Schema::Autofill->new(%autofill_args);

    load_class($row_manager) or croak "Could not load row_manager '$row_manager': $@"
        unless ref $row_manager;

    require DBIx::QuickORM::ORM;
    my $orm = DBIx::QuickORM::ORM->new(db => $db, autofill => $autofill, row_manager => $row_manager);

    return $orm->connection;
}

sub _generate_autorow_base {
    my $class = shift;
    state $counter = 0;
    $counter++;
    return "DBIx::QuickORM::Row::Auto${counter}";
}

sub _autorow_hook {
    my $class = shift;
    my ($base, $name_to_class, $caller_file) = @_;

    $name_to_class //= sub {
        my $name = shift;
        my @parts = split /_/, $name;
        return join '' => map { ucfirst(lc($_)) } @parts;
    };

    local $@;
    my $parent = load_class($base);
    unless ($parent) {
        # Only fall back to the stock Row class when the base genuinely does not
        # exist on disk; a base that exists but fails to compile must surface
        # its error rather than silently losing the user's methods.
        my $err = $@;
        die $err unless $err =~ m/Can't locate .+ in \@INC/;
        $parent = load_class('DBIx::QuickORM::Row') or die $@;
    }

    return sub {
        my %params = @_;
        my $autofill = $params{autofill};
        my $table = $params{table};

        my $postfix = $name_to_class->($table->{name});
        my $package = "$base\::$postfix";

        local $@;
        unless (load_class($package)) {
            # A missing per-table row class is expected (autofill generates it);
            # a compile error in an existing one must not be swallowed.
            my $err = $@;
            die $err unless $err =~ m/Can't locate .+ in \@INC/;
        }

        my $isa = do { no strict 'refs'; \@{"$package\::ISA"} };
        push @$isa => $parent unless @$isa;

        my $file = $package;