File Coverage

blib/lib/Pinwheel/Model.pm

Criterion	Covered	Total	%
statement	22	24	91.6
branch			n/a
condition			n/a
subroutine	8	8	100.0
pod			n/a
total	30	32	93.7

package Pinwheel::Model;

use strict;
use warnings;

use Carp;
use DBI qw(SQL_INTEGER);
use Time::Local qw(timegm_nocheck);

use Pinwheel::Context;
use Pinwheel::Database qw(prepare describe fetchone_tables fetchall_tables);
use Pinwheel::Model::Base;
use Pinwheel::Model::Date;
use Pinwheel::Model::Time;

# Terminology in the code below:
# "class" - a class (package) name
# "stash" - the hash ref representing a class (see 'perlguts')
# $base_class / $base_stash - usually the "Model" class, i.e. us
# $model_class / $model_stash - the relevant Models::Foo class

our $AUTOLOAD;

my (%inheritance_keys, %inheritance);


sub import
{
    my ($base_class, $table, @args) = @_;
    return unless defined($table);
    my $base_stash = _get_stash($base_class);
    my $model_class = caller();
    _export_functions($base_stash, $table, $model_class, @args);
}

sub _export_functions
{
    my ($base_stash, $table, $model_class, $ikey, $ivalue) = @_;
    my ($model_stash, $fields, $column, $model, $getter);

    $model_stash = _get_stash($model_class);
    $fields = describe($table);
    $model = {
        table => $table,
        fields => $fields,
        model_class => $model_class,
        model_stash => $model_stash,
        getters => {},
        inheritance_key => $ikey,
        inheritance_value => $ivalue,
        associations => {},
    };

    if ($ikey) {
        $inheritance_keys{$table} = $ikey;
        $inheritance{$table}{$ivalue} = $model;
    }

    # Export these to the models class
    $model_stash->{$_} = $base_stash->{$_}
        for qw( query belongs_to has_one has_many );

    # Column accessors
    _export_accessors($model) unless $ikey;

    $getter = sub {
        my ($fn);
        $fn = _make_finder($model, $1, $2)
            if $AUTOLOAD =~ /::find(_all)?(?:_by_(\w+))?$/;
        $fn = _make_finder($model, 'prefetch', 'id')
            if $AUTOLOAD =~ /::prefetch$/;
        croak "Can't locate $AUTOLOAD" unless $fn;
        no strict 'refs';
        *$AUTOLOAD = $fn;
        goto &$fn;
    };

    no strict 'refs';
    # find, find_by_, find_all_by_, and prefetch
    *{"$model_class\::AUTOLOAD"} = $getter;
    # Private model information
    *{"$model_class\::model"} = $model;
}

sub _export_accessors
{
    my ($model) = @_;
    my ($fields, $model_class, $column, $getter);

    $fields = $model->{fields};
    $model_class = $model->{model_class};

    foreach $column (keys %$fields) {
        if ($fields->{$column}{type} =~ /^date(time)?/) {
            my $class = $1 ? 'Pinwheel::Model::Time' : 'Pinwheel::Model::Date';
            # Time/date column: wrap value in a Pinwheel::Model::Time/Date class
            $getter = sub {
                my $data = $_[0]->{data};
                $_[0]->_fill_out() if (!exists($data->{$column}));
                my $t = $data->{$column};
                return $t if (!defined($t) || ref($t));
                return $data->{$column} = undef if ($t =~ /^0000-00-00/);
                # Convert timestamp/date to seconds-since-epoch (assumption:
                # database handle timezone is GMT) and construct the wrapper
                $t =~ /^(....)-(..)-(..)(?: (..):(..):(..))?/;
                $t = timegm_nocheck($6 || 0, $5 || 0, $4 || 0, $3, $2 - 1, $1);
                return $data->{$column} = $class->new($t);
            };
        } else {
            # Not a time/date column: just return value untouched
            $getter = sub {
                my $data = $_[0]->{data};
                $_[0]->_fill_out() if (!exists($data->{$column}));
                return $data->{$column};
            };
        }
        $model->{getters}{$column} = $getter;
        no strict 'refs';
        *{"$model_class\::$column"} = $getter;
    }
}


sub belongs_to { _add_association(_get_stash(caller), 'belongs_to', @_) }
sub has_one { _add_association(_get_stash(caller), 'has_one', @_) }
sub has_many { _add_association(_get_stash(caller), 'has_many', @_) }
sub query { _add_query(scalar(caller), @_) }

sub _add_query
{
    my ($model_class, $name, %opts) = @_;
    my ($model, $wrapfn, $queryfn, $sqldata);

    $model = _get_stash($model_class)->{model};
    $wrapfn = _get_type_wrapper($opts{type}, $name);
    croak 'Unknown query result type' unless $wrapfn;

    $queryfn = sub {
        $sqldata = _parse_sql($model->{model_stash}{sql}{$name}) unless $sqldata;
        return _do_sql($sqldata, $model, $wrapfn, \%opts, @_);
    };

    no strict 'refs';
    *{"$model_class\::$name"} = $queryfn;
}

sub _get_type_wrapper
{
    my ($type, $name) = @_;
    my $fn;

    return if (!$type && !$name);

    if (!$type) {
        $type = '[-]';
        $type = '-' if $name =~ /^find(?!_all)/;
        $type = '1' if $name =~ /^count/;
        $type = 'x' if $name =~ /^
            (?:set|add|remove|create|replace|update|delete)
            (?:$|_)
        /x;
    }

    # [-] = List of rows (wrapped as a list of model objects)
    #  -  = One row (wrapped as a model object)
    # [1] = List of single values
    #  1  = Single value
    #  x  = No result
    if ($type eq '[-]') {
        $fn = \&_wrap_all_rows;
    } elsif ($type eq '-') {
        $fn = \&_wrap_one_row;
    } elsif ($type eq '[1]') {
        $fn = \&_wrap_all_column;
    } elsif ($type eq '1') {
        $fn = \&_wrap_one_value;
    } elsif ($type eq 'x') {
        $fn = \&_wrap_nothing;
    }

    return $fn;
}

sub _add_association
{
    my ($model_stash, $type, $name, %opts) = @_;
    my ($associated_class, $finder, $key) = @opts{qw(package finder key)};
    my $fn;

    if (!$associated_class) {
        $associated_class = make_package_name($name);
    }
    if (!$finder) {
        $finder = 'find';
        if ($type eq 'has_many') {
            $finder .= '_all';
        }
        if ($type ne 'belongs_to') {
            $finder .= '_by_' . _make_singular($model_stash->{model}{table});
        }
    }
    $key = (($type eq 'belongs_to') ? $name . '_id' : 'id') unless $key;

    $fn = sub {
        my $data = $_[0]->{data};
        return $data->{$name} if exists($data->{$name});
        $_[0]->_fill_out() if (!exists($data->{$key}));
        return $data->{$name} = $associated_class->$finder($data->{$key});
    };

    no strict 'refs';
    $model_stash->{model}{associations}{$name} = *{"$associated_class\::"};
    *{$model_stash->{model}{model_class} . "::$name"} = $fn;
}


sub _parse_sql
{
    my ($sql) = @_;
    my ($i, @dynamic, @static, $d);

    $sql =~ s[/\* .*? \*/][ ]gx;

    $i = 0;
    foreach ($sql =~ /\?(?:\$(.*?)\$)?/g) {
        if (defined($_)) {
            push @dynamic, [$i++, qr/^$_$/];
        } else {
            push @static, $i++;
        }
    }

    $d = (scalar(@dynamic) > 0) ? \@dynamic : undef;
    return [$sql, $i, $d, \@static];
}

sub _gather_static_params
{
    my ($sql, $info, $params) = @_;
    my ($pos, $i, @static_params);

    @static_params = ();
    $pos = -1;
    $i = 0;
    while (($pos = index($sql,'?',$pos+1)) > 0)
    {
        my $pnum = $info->[$i];
        croak "not enough parameters given" unless (defined $pnum);
        my $value = $params->[$pnum];
        if (!defined $value) {
            if (substr($sql,$pos-4,5) =~ /(\s*!=\s*\?)$/) {
                substr($sql,$pos-(length($1)-1),length($1)) = ' IS NOT NULL';
            } elsif (substr($sql,$pos-4,5) =~ /(\s*=\s*\?)$/) {
                substr($sql,$pos-(length($1)-1),length($1)) = ' IS NULL';
            } else {
                push(@static_params, [undef]);
            }
        } elsif (ref($value) eq 'HASH') {
            push(@static_params, [each(%$value)]);
        } elsif (ref($value)) {
            push(@static_params, [$value->sql_param]);
        } else {
            push(@static_params, [$value]);
        }
        $i++;
    }

    return ($sql, @static_params);
}


sub _insert_dynamic_params
{
    my ($sql, $info, $params) = @_;
    my (@inserts, $i, $regex, $value);

    foreach (@$info) {
        ($i, $regex) = @$_;
        $value = $params->[$i++] || '';
        push @inserts, $value;
        croak "Parameter $i does not match requirement: $value"
            unless ($value =~ /$regex/);
    }
    $i = 0;
    $sql =~ s/\?\$.*?\$/$inserts[$i++]/ge;

    return $sql;
}

sub _do_sql
{
    my ($sqldata, $model, $wrapfn, $opts, @params) = @_;
    my ($tables, $sql, @static_params, %args, $order, $sth, $i, $result);

    $tables = $opts->{include};
    if ($opts->{fn}) {
        # Function was provided to munge the input parameters before running
        # the SQL; can also declare the list of relations being fetched
        # alongside the primary table.
        @params = $opts->{fn}(@params);
        if (@params && ref($params[0]) eq 'ARRAY') {
            $tables = shift(@params);
        }
    } else {
        # If no fn is specified, throw away the first param
        # if it's the class name.
        shift @params if !ref($params[0]);
    }

    $sql = $sqldata->[0];

    # Fill in dynamic parameters
    if ($sqldata->[2]) {
        $sql = _insert_dynamic_params($sql, $sqldata->[2], \@params);
    }

    # Gather bind parameters and rewrite "= ?" to "IS NULL" if the value is undef
    ($sql, @static_params) = _gather_static_params($sql, $sqldata->[3], \@params);

    %args = @params[$sqldata->[1] ... $#params];
    $order = $args{'order'};
    croak 'Invalid sort order'
        if ($order && $order !~ /^ *\w+(?:\.\w+)?(?: +(?:asc|desc))? *$/i);
    $sql .= " ORDER BY $order" if $order;
    $sql .= ' LIMIT ?' if $args{'limit'};
    $sql .= ' OFFSET ?' if $args{'offset'};

    # Fill in static parameters
    $i = 1;
    $sth = prepare($sql, defined($sqldata->[2]));
    foreach (@static_params) {
        $sth->bind_param($i++, @$_);
    }
    $sth->bind_param($i++, $args{'limit'}, SQL_INTEGER) if $args{'limit'};
    $sth->bind_param($i++, $args{'offset'}, SQL_INTEGER) if $args{'offset'};

    $sth->execute();
    $result = &$wrapfn($model, $sth, $tables);
    $result = $opts->{postfn}(\@params,$result) if $opts->{postfn};
    return $result;
}


sub _wrap_one_row
{
    my ($model, $sth, $tables) = @_;
    my $data = fetchone_tables($sth, $tables);
    return _make_model_object($model, $data, $tables) if $data;
}

sub _wrap_all_rows
{
    my ($model, $sth, $tables) = @_;
    my (@objects, $data);
    foreach $data (@{fetchall_tables($sth, $tables)}) {
        push @objects, _make_model_object($model, $data, $tables);
    }
    return \@objects;
}

sub _wrap_all_column
{
    my $sth = $_[1];
    return [map { $_->[0] } @{$sth->fetchall_arrayref([0])}];
}

sub _wrap_one_value
{
    return $_[1]->fetchrow_arrayref()->[0];
}

sub _wrap_nothing
{
    return;
}

sub _find_inherited_model
{
    my ($model, $data) = @_;
    my ($table, $key);

    $table = $model->{table};
    $key = $inheritance_keys{$table};
    if ($key) {
        $key = $data->{$key};
        croak 'Missing inheritance key' unless $key;
        $model = $inheritance{$table}{$key};
        croak "No model found for subclass $key" unless $model;
    }
    return $model;
}

sub _make_model_object
{
    my ($model, $data, $tables) = @_;
    my ($root, $parent, @parts, $key);

    $model = _find_inherited_model($model, $data->{''});
    $root = Pinwheel::Model::Base::new($model->{model_class}, $model, delete $data->{''});

    foreach $key (@$tables) {
        @parts = split(/\./, $key);
        $parent = $root;
        $parent = $parent->$_ foreach (@parts[0 .. $#parts - 1]);
        $parent->_prefetched_link($parts[-1], $data->{$key}) if ($parent);
    }
    return $root;
}

sub _make_finder
{
    my ($model, $all, $column) = @_;
    my ($sql, $null, $ikey, $sqldata, $wrapfn, @conditions);

    $column = 'id' if (!$all && !$column);
    $sql = "SELECT * FROM `$model->{table}`";

    if ($column) {
        $column .= '_id' unless exists($model->{fields}{$column});
        return unless exists($model->{fields}{$column});
    }

    $null = ($column && $model->{fields}{$column}{null});
    $ikey = $model->{inheritance_key};

    if ($ikey) {
        push @conditions, "`$ikey` = '" . $model->{inheritance_value} . "'";
    }

    if ($all && $all eq 'prefetch') {
        push @conditions, "`$column` IN (?\$(?:[0-9]+,?)+\$)";
    } elsif ($column) {
        push @conditions, "`$column` = ?";
    }

    $sql .= " WHERE " . join(" AND ", @conditions)
        if @conditions;

    $sqldata = _parse_sql($sql);
    $wrapfn = $all ? \&_wrap_all_rows : \&_wrap_one_row;
    if (!$column) {
        return sub { _do_sql($sqldata, $model, $wrapfn, {}, @_) };
    } elsif (!$all && !$null && $column eq 'id') {
        return sub {
            my ($ctx, $obj);
            my $class = shift;
            return if !defined($_[0]);
            $ctx = Pinwheel::Context::get('Model--' . $model->{table});
            return $obj if $obj = $ctx->{$_[0]};
            return _do_sql($sqldata, $model, $wrapfn, {}, $class, @_);
        };
    } elsif ($all && $all eq 'prefetch') {
        return sub {
            my $class = shift;
            my ($ctx, %ids, @keys);
            $ctx = Pinwheel::Context::get('Model--' . $model->{table});
            map { $ids{$_} = 1 unless exists($ctx->{$_}) } @_;
            @keys = keys %ids;
            return 0 if scalar(@keys) == 0;
            _do_sql($sqldata, $model, $wrapfn, {}, $class, join(',', @keys));
            return scalar(@keys);
        }
    } elsif (!$null) {
        return sub {
            my $class = shift;
            return if !defined($_[0]);
            return _do_sql($sqldata, $model, $wrapfn, {}, $class, @_);
        };
    } else {
        return sub {
            my $class = shift;
            return _do_sql($sqldata, $model, $wrapfn, {}, $class, @_);
        };
    }
}


sub make_package_name
{
    my $name = shift;
    $name =~ s/_+/ /g;
    $name =~ s/\b(\w)/\U$1/g;
    $name =~ s/ +//g;
    return 'Models::' . _make_singular($name);
}

sub _make_singular
{
    my $s = shift;
    $s =~ s/ories$/ory/;
    $s =~ s/ities/ity/;
    $s =~ s/(?<=[^s])s$// unless $s =~ /ies$/;
    return $s;
}

sub _get_stash
{
    my $class = shift;
    my $stash = \%::;
    $stash = $stash->{"$_\::"} foreach split(/::/, $class);
    return $stash;
}

1;

__DATA__