File Coverage

lib/SQL/Abstract/Builder.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package SQL::Abstract::Builder;

use v5.14;
use DBIx::Simple;
use SQL::Abstract::More;
use List::Util qw(reduce);
use Hash::Merge qw(merge);
Hash::Merge::set_behavior('RETAINMENT_PRECEDENT');

use Exporter qw(import);
our @EXPORT_OK = qw(query build include);

# ABSTRACT: Quickly build & query relational data
our $VERSION = 'v0.1.1'; # VERSION

sub _refp {
    return unless defined $_[0];
    return @{$_[0]} if ref $_[0] eq ref [];
    return @_;
}

sub _rollup {
    my %row = @_;
    my @fields = grep {m/\w+:\w+/} keys %row;
    for (@fields) {
        my ($t,$c) = split ':';
        $row{$t}{$c} = delete $row{$_};
    }
    %row;
}

sub _smerge {
    my ($a,$b) = @_;
    for (keys $b) {
        $a->{$_} = $b->{$_} unless defined $a->{$_};
        next if $a->{$_} eq $b->{$_};
        $a->{$_} = [_refp $a->{$_}] unless ref $a->{$_} eq ref [];
        push @{$a->{$_}}, _refp $b->{$_};
    }
    return $a;
}

sub query (&;@) {
    my @db = (shift)->();
    my $dbh = ref $db[0] eq 'DBIx::Simple' ? $db[0] : DBIx::Simple->connect(@db);
    my ($key,%row);
    $row{$_->{$key}} = _smerge $row{$_->{$key}}, $_ for map {{_rollup %$_}}
    map {my @q;($key,@q) = $_->(); $dbh->query(@q)->hashes} @_;
    values %row;
}

sub build (&;@) {
    my ($fn,@includes) = @_;
    my %params = $fn->();
    my $table = $params{'-from'};
    $params{'-columns'} = [map {"$table.$_"} _refp $params{'-columns'}];
    my $key = delete $params{'-key'};
    my $a = SQL::Abstract::More->new;
    map {
        my %p = %{merge \%params, {$_->()}};
        $p{'-from'} = [-join =>
            map {ref $_ eq ref sub {} ? ($_->($table,$key)) : $_ } _refp $p{'-from'}
        ];
        sub {$key, $a->select(%p)};
    } @includes;
}

sub include (&;@) {
    my ($fn,@rest) = @_;
    my %params = $fn->();
    my ($jtable,$jfield) = @params{qw(-from -key)};
    $params{'-columns'} = [
        map {"$jtable.$_|'$jtable:$_'"}
        _refp $params{'-columns'}
    ];
    $params{'-from'} = sub {"=>{$_[0].$_[1]=$jtable.$jfield}",$jtable};
    delete $params{'-key'};
    return sub {%params}, @rest;
}

1;

__END__