File Coverage

blib/lib/DBIx/Printf.pm

Criterion	Covered	Total	%
statement	42	46	91.3
branch	25	30	83.3
condition	4	4	100.0
subroutine	9	9	100.0
pod			n/a
total	80	89	89.8

use strict;
use warnings;

use DBI;
use Carp::Clan;

package DBIx::Printf;

our $VERSION = '0.08';

sub _printf {
    my ($dbh, $fmt, $params, $in_like, $like_escape) = @_;

    $fmt =~ s/\%(?:([dfst\%])|like\((.*?)\)((?i)\s+ESCAPE\s+(['"])(.*?)\4(?:\s+|$))?)/
        _printf_quote({
            dbh      => $dbh,
            params   => $params,
            type     => $1 || 'like',
            like_fmt => $2,
            like_escape => $3,
            like_escape_char => defined $like_escape ? $like_escape : $5,
            in_like  => $in_like,
        })
            /eg;
    $fmt;
}

sub _printf_quote {
    my $in = shift;
    my $out;

    if ($in->{type} eq '%') {
        return '%';
    } elsif ($in->{type} eq 'like') {
        return "'"
            . _printf(
                $in->{dbh},
                $in->{like_fmt},
                $in->{params},
                1,
                $in->{like_escape_char},
            ) . "'" . ($in->{like_escape} || '');
    }

    return _printf_quote_simple(
        $in->{dbh},
        $in->{type},
        $in->{params},
        $in->{in_like},
        $in->{like_escape_char}
    );
}

sub _printf_quote_simple {
    no warnings;
    my ($dbh, $type, $params, $in_like, $like_escape_char) = @_;

    Carp::Clan::croak "too few parameters\n" unless @$params;
    my $param = shift @$params;

    if ($type eq 'd') {
        $param = int($param);
    } elsif ($type eq 'f') {
        $param = $param + 0;
    } elsif ($type eq 'l') {
        $param = s/[\%_]/\\$1/g;
        $param = $dbh->quote($param); # be paranoiac, use DBI::db::quote
        $param =~ s/^'(.*)'$/$1/s
            or Carp::Clan::croak "unexpected quote char used: $param\n";
    } elsif ($type eq 's') {
        if ($in_like) {
            my $escape_char = defined $like_escape_char ? $like_escape_char : '\\';
            $param =~ s/[${escape_char}%_]/$escape_char$&/g;
        }
        $param = $dbh->quote($param);
        if ($in_like) {
            $param =~ s/^'(.*)'$/$1/s
                or Carp::Clan::croak "unexpected quote char: $param\n";
        }
    } elsif ($type eq 't') {
        # pass thru
    } else {
        Carp::Clan::croak "unexpected type: $type\n";
    }

    $param;
}

package main;

sub DBI::db::printf {
    my ($dbh, $fmt, @params) = @_;

    my $sql = DBIx::Printf::_printf($dbh, $fmt, \@params);
    Carp::Clan::croak "too many parameters\n" if @params;
    $sql;
}

1;

__END__