view release on metacpan or  search on metacpan

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

package DBIx::QuickORM::Schema::Autofill;
use strict;
use warnings;

our $VERSION = '0.000022';

use DBIx::QuickORM::Util qw/load_class/;

use Object::HashBase qw{
    <types
    <affinities
    <hooks
    <autorow
    +skip
};

=pod

=encoding UTF-8

=head1 NAME

DBIx::QuickORM::Schema::Autofill - Autofill configuration for schema introspection.

=head1 DESCRIPTION

Holds the type maps, affinity callbacks, and hooks used while autofilling a
schema from a live database. It maps introspected SQL types to
L<DBIx::QuickORM::Type> classes, runs user-supplied hooks at well-known points,
and generates field and link accessors on autovivified row classes.

=head1 SYNOPSIS

    my $autofill = DBIx::QuickORM::Schema::Autofill->new(
        types      => {...},
        affinities => {...},
        hooks      => {...},
    );

    $autofill->define_autorow($row_class, $table);

=head1 ATTRIBUTES

=over 4

=item types

Hashref mapping SQL type names to type objects/classes.

=item affinities

Hashref mapping affinity names to arrayrefs of callbacks.

=item hooks

Hashref mapping hook names to arrayrefs of callbacks.

=item autorow

The autovivified row class configuration.

=item skip

Nested hashref describing what to skip during autofill.

=back

=cut

my %HOOKS = (
    column         => 1,
    columns        => 1,
    index          => 1,
    indexes        => 1,
    links          => 1,
    post_column    => 1,
    post_table     => 1,
    pre_column     => 1,
    pre_table      => 1,
    primary_key    => 1,
    table          => 1,
    unique_keys    => 1,
    link_accessor  => 1,
    field_accessor => 1,
);

=pod

=head1 PUBLIC METHODS

=over 4

=item $bool = $autofill->is_valid_hook($name)

True if C<$name> is a recognized hook name.

=cut

sub is_valid_hook {
    my ($self, $hook) = @_;
    return $HOOKS{$hook} ? 1 : 0;
}

=pod

=item $out = $autofill->hook($name, \%args, $seed)

Run every callback registered for the named hook, threading the result through
each call starting from C<$seed>, and return the final value.

=cut

sub hook {
    my $self = shift;
    my ($hook, $args, $seed) = @_;
    my $out = $seed;
    $out = $_->(%$args, autofill => $self) for @{$self->{+HOOKS}->{$hook} // []};
    return $out;
}

=pod

=item $val = $autofill->skip(@path)

Walk the nested C<skip> hashref along C<@path>, returning the value found or
false (0) as soon as any step is missing.

=cut

sub skip {
    my $self = shift;

    my $from = $self->{+SKIP};
    while(my $arg = shift @_) {
        $from = $from->{$arg} or return 0;
    }
    return $from;
}

=pod

=item $autofill->process_column(\%col)

Resolve the column's scalar-ref type into a real type object, using the type map
first and then affinity callbacks. Updates the column's C<type> and C<affinity>
in place when a match is found.

=cut

sub process_column {
    my $self = shift;
    my ($col) = @_;

    my $type = $col->{type};
    my $tref = ref($type);
    return unless $tref && $tref eq 'SCALAR';

    my $new_type;
    $new_type = $self->{+TYPES}->{$$type} // $self->{+TYPES}->{uc($$type)} // $self->{+TYPES}->{lc($$type)};

    unless ($new_type) {
        if (my $aff = $col->{affinity}) {
            if (my $list = $self->{+AFFINITIES}->{$aff}) {
                for my $cb (@$list) {
                    $new_type = $cb->(%$col) and last;
                }
            }
        }
    }

    return unless $new_type;

    $col->{type} = $new_type;
    $col->{affinity} = $new_type->qorm_affinity(sql_type => $$type);
}

=pod

=item $autofill->define_autorow($row_class, $table)

Load (or autovivify) the row class, then install field accessors for each column
and link accessors for each link, honoring the C<field_accessor> and
C<link_accessor> hooks and never clobbering accessors that already exist.

=back

=cut

sub define_autorow {
    my $self = shift;
    my ($row_class, $table) = @_;

    unless(load_class($row_class)) {
        my $err = $@;
        die $err unless $err =~ m/Can't locate.*in \@INC/;
        my $row_file = $row_class;
        $row_file =~ s{::}{/}g;
        $row_file .= ".pm";
        $INC{$row_file} = __FILE__;
    }

    for my $column ($table->columns) {
        my $field = $column->name;
        my $accessor = $self->hook(field_accessor => {table => $table, name => $field, field => $field, column => $column}, $field);
        next unless $accessor;