File Coverage

blib/lib/DBIx/SecureCGI.pm

Criterion	Covered	Total	%
statement	28	335	8.3
branch	8	202	3.9
condition	5	111	4.5
subroutine	8	40	20.0
pod	1	1	100.0
total	50	689	7.2

package DBIx::SecureCGI;
use 5.010001;
use warnings;
use strict;
use utf8;
use Carp;

our $VERSION = 'v3.0.1';

use DBI;
use List::Util qw( any );


## no critic (ProhibitPostfixControls Capitalization ProhibitEnumeratedClasses)

my $PRIVATE = 'private_' . __PACKAGE__;
my $INT     = qr/\A-?\d+\s+(?:SECOND|MINUTE|HOUR|DAY|MONTH|YEAR)\z/msi;
my $IDENT   = qr/((?!__)\w[a-zA-Z0-9]*(?:_(?!_)[a-zA-Z0-9]*)*)/ms;
my %Func    = ();


DefineFunc(eq => sub {
    my ($dbh, $f, $v) = @_;
    my (@val, $null, @expr);
    @val  = ref $v ? @{$v} : $v;
    $null = grep {!defined} @val;
    @val  = grep {defined} @val;
    push @expr, sprintf '%s IS NULL', $f                    if $null;
    push @expr, sprintf '%s = %s', $f, $dbh->quote($val[0]) if @val==1;
    push @expr, sprintf '%s IN (%s)',
        $f, join q{,}, map { $dbh->quote($_) } @val         if @val>1;
    push @expr, 'NOT 1'                                     if !@expr;
    return @expr==1 ? $expr[0] : '('.join(' OR ', @expr).')';
});
DefineFunc(ne => sub {
    my ($dbh, $f, $v) = @_;
    my (@val, $null, @expr);
    @val  = ref $v ? @{$v} : $v;
    $null = grep {!defined} @val;
    @val  = grep {defined} @val;
    push @expr, sprintf '%s IS NOT NULL', $f                if $null && !@val;
    push @expr, sprintf '%s IS NULL', $f                    if !$null && @val;
    push @expr, sprintf '%s != %s', $f,$dbh->quote($val[0]) if @val==1;
    push @expr, sprintf '%s NOT IN (%s)', $f,
        join q{,}, map { $dbh->quote($_) } @val             if @val>1;
    push @expr, 'NOT 0'                                     if !@expr;
    return @expr==1 ? $expr[0] : '('.join(' OR ', @expr).')';
});
DefineFunc(lt       => '%s <  %s');
DefineFunc(gt       => '%s >  %s');
DefineFunc(le       => '%s <= %s');
DefineFunc(ge       => '%s >= %s');
DefineFunc(like     => '%s LIKE %s');
DefineFunc(not_like => '%s NOT LIKE %s');
DefineFunc(date_eq  => [$INT, '%s =  DATE_ADD(NOW(), INTERVAL %s)']);
DefineFunc(date_ne  => [$INT, '%s != DATE_ADD(NOW(), INTERVAL %s)']);
DefineFunc(date_lt  => [$INT, '%s <  DATE_ADD(NOW(), INTERVAL %s)']);
DefineFunc(date_gt  => [$INT, '%s >  DATE_ADD(NOW(), INTERVAL %s)']);
DefineFunc(date_le  => [$INT, '%s <= DATE_ADD(NOW(), INTERVAL %s)']);
DefineFunc(date_ge  => [$INT, '%s >= DATE_ADD(NOW(), INTERVAL %s)']);
DefineFunc(set_date => sub {
    my ($dbh, $f, $v) = @_;
    if (uc $v eq 'NOW') {
        return sprintf '%s = NOW()', $f;
    } elsif ($v =~ /$INT/mso) {
        return sprintf '%s = DATE_ADD(NOW(), INTERVAL %s)', $f, $dbh->quote($v),
    }
    return;
});
DefineFunc(set_add  => sub {
    my ($dbh, $f, $v) = @_;
    return sprintf '%s = %s + %s', $f, $f, $dbh->quote($v);
});


sub DefineFunc {
    my ($func, $cmd) = @_;
    if (!$func || ref $func || $func !~ /\A[A-Za-z]\w*\z/ms) {
        croak "bad function name: $func";
    }
    if (!ref $cmd) {
        if (2 != (() = $cmd =~ /%s/msg)) {
            croak "bad function: $cmd";
        }
    } elsif (ref $cmd eq 'ARRAY') {
        if (2 != @{$cmd}
                || ref $cmd->[0] ne 'Regexp'
                || (ref $cmd->[1] || 2 != (() = $cmd->[1] =~ /%s/msg))) {
            croak "bad function: [@$cmd]";
        }
    } elsif (ref $cmd ne 'CODE') {
        croak 'bad function';
    }
    $Func{$func} = $cmd;
    return;
}

sub _ret {
    my $cb = shift;
    if ($cb) {
        return $cb->(@_);
    } else {
        return wantarray ? @_ : $_[0];
    }
}

sub _ret1 {
    my ($cb, $ret, $h) = @_;
    if ($cb) {
        return $cb->($ret, $h);
    } else {
        return $ret;
    }
}

sub _retdo {
    my ($dbh, $sql, $cb) = @_;
    if (!$cb) {
        return $dbh->do($sql);
    }
    return $dbh->do($sql, undef, $cb);
}

# Set cache to given HASHREF, if any.
# Initialize cache, if needed.
# Return current cache.
sub DBI::db::SecureCGICache {
    my ($dbh, $cache) = @_;
    if ($cache && ref $cache eq 'HASH') {
        $dbh->{$PRIVATE} = $cache;
    } else {
        $dbh->{$PRIVATE} //= {};
    }
    return $dbh->{$PRIVATE};
}

# Ensure $dbh->All("DESC $table") is cached.
# Return cached $dbh->All("DESC $table").
# On error set $dbh->err and return nothing.
sub DBI::db::ColumnInfo {
    my ($dbh, $table, $cb) = @_;
    my $cache = $dbh->SecureCGICache();
    if ($cache->{$table}) {
        return _ret($cb, $cache->{$table});
    }

    if (!$cb) {
        my @desc = $dbh->All('DESC '.$dbh->quote_identifier($table));
        return _set_column_info($dbh, $cache, $table, undef, @desc);
    }
    return $dbh->All('DESC '.$dbh->quote_identifier($table), sub {
        my @desc = @_;
        return _set_column_info($dbh, $cache, $table, $cb, @desc);
    });
}

sub _set_column_info {
    my ($dbh, $cache, $table, $cb, @desc) = @_;
    if (@desc) {
        my @pk = grep {$desc[$_]{Key} eq 'PRI'} 0 .. $#desc;
        if (1 != @pk || $pk[0] != 0) {
            return _ret($cb, $dbh->set_err($DBI::stderr, "first field must be primary key: $table\n", undef, 'ColumnInfo'));
        }
        $cache->{$table} = \@desc;
    }
    return _ret($cb, $cache->{$table});
}

# Ensure DESC for all $tables cached.
# Return $dbh->SecureCGICache().
# On error set $dbh->err and return nothing.
sub DBI::db::TableInfo {
    my ($dbh, $tables, $cb) = @_;
    my @tables = ref $tables eq 'ARRAY' ? @{$tables} : ($tables);
    if (!@tables || any {/\A\z|\s/ms} @tables) {
        return _ret($cb, $dbh->set_err($DBI::stderr, "bad tables: [@tables]\n", undef, 'TableInfo'));
    }

    if (!$cb) {
        while (@tables) {
            my $desc = $dbh->ColumnInfo(shift @tables);
            if (!$desc) {
                return;
            }
        }
        return $dbh->SecureCGICache();
    }
    my $code; $code = sub {
        my ($desc) = @_;
        if (!$desc) {
            undef $code;
            return $cb->();
        }
        if (@tables) {
            return $dbh->ColumnInfo(shift @tables, $code);
        }
        undef $code;
        return $cb->( $dbh->SecureCGICache() );
    };
    return $dbh->ColumnInfo(shift @tables, $code);
}

sub DBI::db::GetSQL {
    my ($dbh, $tables, $P, $cb) = @_;
    # remove possible JOIN info from table names for TableInfo()
    my @tables = map {my $s=$_;$s=~s/\s.*//ms;$s} ref $tables ? @{$tables} : $tables; ## no critic (ProhibitComplexMappings)
    if (!$cb) {
        my $cache = $dbh->TableInfo(\@tables);
        return _get_sql($dbh, $cache, $tables, $P);
    }
    return $dbh->TableInfo(\@tables, sub {
        my $cache = shift;
        return _get_sql($dbh, $cache, $tables, $P, $cb);
    });
}

sub _get_sql { ## no critic (ProhibitExcessComplexity)
    my ($dbh, $cache, $tables, $P, $cb) = @_;
    if (!$cache) {
        return _ret($cb);
    }

    # Extract JOIN type info from table names
    my (@tables, @jointype);
    for (ref $tables eq 'ARRAY' ? @{$tables} : $tables) {
        if (/\A(\S+)(?:\s+(LEFT|INNER))?\s*\z/msi) {
            push @tables, $1;
            push @jointype, $2 // 'INNER';
        }
        else {
            return _ret($cb, $dbh->set_err($DBI::stderr, "unknown join type: $_\n", undef, 'GetSQL'));
        }
    }

    my %SQL = (
        Table       => $tables[0],
        ID          => $cache->{ $tables[0] }[0]{Field},
        Select      => q{},
        From        => q{},
        Set         => q{},
        Where       => q{},
        UpdateWhere => q{},
        Order       => q{},
        Group       => q{},
        Limit       => q{},
        SelectLimit => q{},
    );

    # Detect keys which should be used for JOINing tables
    $SQL{From} = $dbh->quote_identifier($tables[0]);
    my @field = map {{ map {$_->{Field}=>1} @{ $cache->{$_} } }} @tables;   ## no critic (ProhibitComplexMappings,ProhibitVoidMap)
TABLE:
    for my $right (1..$#tables) {
        ## no critic (ProhibitAmbiguousNames)
        my $rkey = $cache->{ $tables[$right] }[0]{Field};
        for my $left (0..$right-1) {
            my $lkey = $cache->{ $tables[$left] }[0]{Field};
            my $key = $field[$left]{$rkey}  ? $rkey :
                      $field[$right]{$lkey} ? $lkey : next;
            $SQL{From} .= sprintf ' %s JOIN %s ON (%s.%s = %s.%s)',
                $jointype[$right],
                map { $dbh->quote_identifier($_) }
                $tables[$right], $tables[$right], $key, $tables[$left], $key;
            next TABLE;
        }
        return _ret($cb, $dbh->set_err($DBI::stderr, "can't join table: $tables[$right]\n", undef, 'GetSQL'));
    }

    # Set $SQL{Select} using qualified field names and without duplicates
    my %qualify;
    for my $t (@tables) {
        for my $f (map {$_->{Field}} @{ $cache->{$t} }) {
            next if $qualify{$f};
            $qualify{$f} = sprintf '%s.%s',
                map { $dbh->quote_identifier($_) } $t, $f;
            $SQL{Select} .= ', '.$qualify{$f};
        }
    }
    $SQL{Select} =~ s/\A, //ms;

    # Set $SQL{Set}, $SQL{Where}, $SQL{UpdateWhere}
    for my $k (keys %{$P}) {
        $k =~ /\A$IDENT(?:__(?!_)$IDENT)?\z/ms or next; # ignore non-field keys
        my $f   = $qualify{$1} or next;                 # ignore non-field keys
        my $func= $2 // q{};
        my $cmd = $Func{$func || 'eq'};
        if (!$cmd) {
            return _ret($cb, $dbh->set_err($DBI::stderr, "unknown function: $k\n", undef, 'GetSQL'));
        }
        if (!$func && ref $P->{$k}) {
            return _ret($cb, $dbh->set_err($DBI::stderr, "ARRAYREF without function: $k\n", undef, 'GetSQL'));
        }
        # WARNING functions `eq' and `ne' must process value array themselves:
        my $is_list = ref $P->{$k} && $func ne 'eq' && $func ne 'ne';
        for my $v ($is_list ? @{$P->{$k}} : $P->{$k}) {
            my $expr
                = ref $cmd eq 'CODE'    ? $cmd->($dbh, $f, $v)
                : ref $cmd eq 'ARRAY'   ? ($v =~ /$cmd->[0]/ms && sprintf $cmd->[1], $f, $v)
                :                         sprintf $cmd, $f, $dbh->quote($v);
            if (!$expr) {
                return _ret($cb, $dbh->set_err($DBI::stderr, "bad value for $k: $v\n", undef, 'GetSQL'));
            }
            $SQL{Set}         .= ", $expr"    if !$func || $func =~ /\Aset_/ms;
            $SQL{Where}       .= " AND $expr" if           $func !~ /\Aset_/ms;
            $SQL{UpdateWhere} .= " AND $expr" if $func &&  $func !~ /\Aset_/ms;
            $SQL{UpdateWhere} .= " AND $expr" if $k eq $SQL{ID};
        }
    }
    $SQL{Set}         =~ s/\A, //ms;
    $SQL{Where}       =~ s/\A AND //ms;
    $SQL{UpdateWhere} =~ s/\A AND //ms;
    $SQL{Set}         =~ s/\s+IS\s+NULL/ = NULL/msg;
    $SQL{Where}       ||= '1';
    $SQL{UpdateWhere} ||= '1';

    # Set $SQL{Order} and $SQL{Group}
    for my $order (ref $P->{__order} ? @{$P->{__order}} : $P->{__order}) {
        next if !defined $order;
        if ($order !~ /\A(\w+)\s*( ASC| DESC|)\z/ms || !$qualify{$1}) {
            return _ret($cb, $dbh->set_err($DBI::stderr, "bad __order value: $order\n", undef, 'GetSQL'));
        }
        $SQL{Order} .= ", $qualify{$1}$2";
    }
    for my $group (ref $P->{__group} ? @{$P->{__group}} : $P->{__group}) {
        next if !defined $group;
        if ($group !~ /\A(\w+)\s*( ASC| DESC|)\z/ms || !$qualify{$1}) {
            return _ret($cb, $dbh->set_err($DBI::stderr, "bad __group value: $group\n", undef, 'GetSQL'));
        }
        $SQL{Group} .= ", $qualify{$1}$2";
    }
    $SQL{Order} =~ s/\A, //ms;
    $SQL{Group} =~ s/\A, //ms;

    # Set $SQL{Limit}, $SQL{SelectLimit}
    my @limit = ref $P->{__limit} ? @{$P->{__limit}} : $P->{__limit} // ();
    for (grep {!m/\A\d+\z/ms} @limit) {
        return _ret($cb, $dbh->set_err($DBI::stderr, "bad __limit value: $_\n", undef, 'GetSQL'));
    }
    if (@limit == 1) {
        $SQL{Limit}       = " $limit[0]"; # make __limit=>0 true value
        $SQL{SelectLimit} = " $limit[0]"; # make __limit=>0 true value
    }
    elsif (@limit == 2) {
        $SQL{SelectLimit} = join q{,}, @limit;
    }
    elsif (@limit > 2) {
        return _ret($cb, $dbh->set_err($DBI::stderr, "too many __limit values: [@limit]\n", undef, 'GetSQL'));
    }

    return _ret($cb, \%SQL);
}

sub DBI::db::Insert {
    my ($dbh, $table, $P, $cb) = @_;
    my $SQL = $dbh->GetSQL($table, $P) or return _ret1($cb, undef, $dbh);

    my $sql = sprintf 'INSERT INTO %s SET %s',
        $dbh->quote_identifier($SQL->{Table}), $SQL->{Set};

    if (!$cb) {
        return $dbh->do($sql) ? $dbh->{mysql_insertid} : undef;
    }
    return $dbh->do($sql, undef, sub {
        my ($rv, $dbh) = @_;    ## no critic (ProhibitReusedNames)
        return $cb->(($rv ? $dbh->{mysql_insertid} : undef), $dbh);
    });
}

sub DBI::db::InsertIgnore {
    my ($dbh, $table, $P, $cb) = @_;
    my $SQL = $dbh->GetSQL($table, $P) or return _ret1($cb, undef, $dbh);

    my $sql = sprintf 'INSERT IGNORE INTO %s SET %s',
        $dbh->quote_identifier($SQL->{Table}), $SQL->{Set};
    return _retdo($dbh, $sql, $cb);
}

sub DBI::db::Update {
    my ($dbh, $table, $P, $cb) = @_;
    my $SQL = $dbh->GetSQL($table, $P) or return _ret1($cb, undef, $dbh);
    if ($SQL->{UpdateWhere} eq '1' && !$P->{__force}) {
        return _ret1($cb, $dbh->set_err($DBI::stderr, "empty WHERE require {__force=>1}\n", undef, 'Update'), $dbh);
    }

    my $sql = sprintf 'UPDATE %s SET %s WHERE %s' . ($SQL->{Limit} ? ' LIMIT %s' : q{}),
        $dbh->quote_identifier($SQL->{Table}), $SQL->{Set}, $SQL->{UpdateWhere},
        $SQL->{Limit} || ();
    return _retdo($dbh, $sql, $cb);
}

sub DBI::db::Replace {
    my ($dbh, $table, $P, $cb) = @_;
    my $SQL = $dbh->GetSQL($table, $P) or return _ret1($cb, undef, $dbh);

    my $sql = sprintf 'REPLACE INTO %s SET %s',
        $dbh->quote_identifier($SQL->{Table}), $SQL->{Set};
    return _retdo($dbh, $sql, $cb);
}

sub _find_tables_for_delete {
    my ($dbh, $fields, $tables, $P, $cb) = @_;
    if (!@{$tables}) {
        return _ret1($cb, undef, $dbh);
    }

    my $found = [];
    if (!$cb) {
        for my $t (@{$tables}) {
            my $desc = $dbh->ColumnInfo($t);
            if ($desc) {
                my @columns = map {$_->{Field}} @{$desc};
                my %seen;
                if (@{$fields} == grep {++$seen{$_}==2} @{$fields}, @columns) {
                    push @{$found}, $t;
                }
            }
        }
        return $dbh->Delete($found, $P);
    }
    my $code; $code = sub {
        my ($desc) = @_;
        my $t = shift @{$tables};
        if ($desc) {
            my @columns = map {$_->{Field}} @{$desc};
            my %seen;
            if (@{$fields} == grep {++$seen{$_}==2} @{$fields}, @columns) {
                push @{$found}, $t;
            }
        }
        if (@{$tables}) {
            return $dbh->ColumnInfo($tables->[0], $code);
        }
        undef $code;
        return $dbh->Delete($found, $P, $cb);
    };
    return $dbh->ColumnInfo($tables->[0], $code);
}

sub DBI::db::Delete { ## no critic (ProhibitExcessComplexity)
    my ($dbh, $table, $P, $cb) = @_;

    if (!defined $table) {
        my %fields = map {/\A$IDENT(?:__(?!_)$IDENT)?\z/ms ? ($1=>1) : ()} keys %{$P};
        my @fields = keys %fields;
        if (!@fields) {
            return _ret1($cb, $dbh->set_err($DBI::stderr, "table undefined, require params\n", undef, 'Delete'), $dbh);
        }
        if (!$cb) {
            return _find_tables_for_delete($dbh, \@fields, [$dbh->Col('SHOW TABLES')], $P);
        }
        return $dbh->Col('SHOW TABLES', sub {
            my (@tables) = @_;
            return _find_tables_for_delete($dbh, \@fields, \@tables, $P, $cb);
        });
    }

    my @tables = ref $table ? @{$table} : $table;
    if (!$cb) {
        my $res;
        for my $t (@tables) {
            my $SQL = $dbh->GetSQL($t, $P) or return;
            if ($SQL->{Where} eq '1' && !$P->{__force}) {
                return $dbh->set_err($DBI::stderr, "empty WHERE require {__force=>1}\n", undef, 'Delete');
            }
            my $sql = sprintf 'DELETE FROM %s WHERE %s' . ($SQL->{Limit} ? ' LIMIT %s' : q{}),
                $dbh->quote_identifier($SQL->{Table}), $SQL->{Where}, $SQL->{Limit} || ();
            $res = $dbh->do($sql) or return;
        }
        return $res;
    }
    my $code; $code = sub {
        my ($SQL) = @_;
        my $t = shift @tables;
        if (!$SQL) {
            undef $code;
            return $cb->(undef, $dbh);
        }
        if ($SQL->{Where} eq '1' && !$P->{__force}) {
            undef $code;
            return $cb->($dbh->set_err($DBI::stderr, "empty WHERE require {__force=>1}\n", undef, 'Delete'), $dbh);
        }
        my $sql = sprintf 'DELETE FROM %s WHERE %s' . ($SQL->{Limit} ? ' LIMIT %s' : q{}),
            $dbh->quote_identifier($SQL->{Table}), $SQL->{Where}, $SQL->{Limit} || ();
        $dbh->do($sql, sub {
            my ($res, $dbh) = @_;   ## no critic (ProhibitReusedNames)
            if ($res && @tables) {
                return $dbh->GetSQL($tables[0], $P, $code);
            }
            undef $code;
            return $cb->($res, $dbh);
        });
    };
    return $dbh->GetSQL($tables[0], $P, $code);
}

sub DBI::db::ID {
    my ($dbh, $table, $P, $cb) = @_;
    my $SQL = $dbh->GetSQL($table, $P) or return _ret1($cb, undef, $dbh);

    my $sql = sprintf 'SELECT %s.%s FROM %s WHERE %s'
        . ($SQL->{Order}        ? ' ORDER BY %s' : q{})
        . ($SQL->{SelectLimit}  ? ' LIMIT %s' : q{}),
        (map { $dbh->quote_identifier($_) } $SQL->{Table}, $SQL->{ID}),
        $SQL->{From}, $SQL->{Where}, $SQL->{Order} || (), $SQL->{SelectLimit} || ();
    return $dbh->Col($sql, $cb // ());
}

sub DBI::db::Count {
    my ($dbh, $table, $P, $cb) = @_;
    my $SQL = $dbh->GetSQL($table, $P) or return _ret1($cb, undef, $dbh);

    my $sql = sprintf 'SELECT count(*) __count FROM %s WHERE %s',
        $SQL->{From}, $SQL->{Where};
    return $dbh->Col($sql, $cb // ());
}

sub DBI::db::Select {
    my ($dbh, $table, $P, $cb) = @_;
    my $SQL = $dbh->GetSQL($table, $P) or return _ret1($cb, undef, $dbh);

    my $sql = sprintf 'SELECT %s'
        . ($SQL->{Group} ? ', count(*) __count' : q{})
        . ' FROM %s WHERE %s'
        . ($SQL->{Group}        ? ' GROUP BY %s' : q{})
        . ($SQL->{Order}        ? ' ORDER BY %s' : q{})
        . ($SQL->{SelectLimit}  ? ' LIMIT %s'    : q{}),
        $SQL->{Select}, $SQL->{From}, $SQL->{Where},
        $SQL->{Group} || (), $SQL->{Order} || (), $SQL->{SelectLimit} || ();
    if (!$cb) {
        return wantarray ? $dbh->All($sql) : $dbh->Row($sql);
    }
    return $dbh->All($sql, $cb);
}

sub _is_cb {
    my $cb = shift;
    my $ref = ref $cb;
    return $ref eq 'CODE' || $ref eq 'AnyEvent::CondVar';
}

sub DBI::db::All {
    my ($dbh, $sql, @bind) = @_;
    my $cb = @bind && _is_cb($bind[-1]) ? pop @bind : undef;
    if (!$cb) {
        (my $sth = $dbh->prepare($sql, {async=>0}))->execute(@bind) or return;
        return @{ $sth->fetchall_arrayref({}) };
    }
    return $dbh->prepare($sql)->execute(@bind, sub {
        my ($rv, $sth) = @_;
        return $cb->(!$rv ? () : @{ $sth->fetchall_arrayref({}) });
    });
}

sub DBI::db::Row {
    my ($dbh, $sql, @bind) = @_;
    return $dbh->selectrow_hashref($sql, undef, @bind);
}

sub DBI::db::Col {
    my ($dbh, $sql, @bind) = @_;
    my $cb = @bind && _is_cb($bind[-1]) ? pop @bind : undef;
    if (!$cb) {
        my @res = @{ $dbh->selectcol_arrayref($sql, undef, @bind) || [] };
        return wantarray ? @res : $res[0];
    }
    return $dbh->selectcol_arrayref($sql, undef, @bind, sub {
        my ($ary_ref) = @_;
        return $cb->($ary_ref ? @{ $ary_ref } : ());
    });
}


1; # Magic true value required at end of module
__END__