view release on metacpan or  search on metacpan

lib/DBIx/DR.pm  view on Meta::CPAN

    return (
        $self,
        \@sql,
        \%args,
        $item,
        $iterator,
    );
}



sub _user_sql($@) {
    my ($sql, @bv) = @_;
    $sql =~ s/\?/'$_'/ for @bv;
    return $sql;
}


sub select {
    my ($self, $sql, $args, $item, $iterator) = &_dr_extract_args_ep;

    my $req = $self->{"private_DBIx::DR_template"}->sql_transform(
        @$sql,
        %$args
    );

    carp  _user_sql($req->sql, $req->bind_values) if $args->{'-warn'};
    croak _user_sql($req->sql, $req->bind_values) if $args->{'-die'};

    my $res;

    local $SIG{__DIE__} = sub { croak $self->_dr_decode_err(@_) };

    if (exists $args->{-hash}) {
        $res = $self->selectall_hashref(
                $req->sql,
                $args->{-hash},
                $args->{-dbi},
                $req->bind_values
            );

    } else {
        my $dbi = $args->{-dbi} // {};
        croak "argument '-dbi' must be HASHREF or undef"
            unless 'HASH' eq ref $dbi;
        $res = $self->selectall_arrayref(
                $req->sql,
                { %$dbi, Slice => {} },
                $req->bind_values
            );
    }


    return $res unless $iterator;

    my ($class, $method) = camelize $iterator;

    return $class->$method(
        $res, -item => $item, -noitem_iter => $args->{-noitem_iter}) if $method;
    return bless $res => $class;
}

sub single {
    my ($self, $sql, $args, $item) = &_dr_extract_args_ep;
    my $req = $self->{"private_DBIx::DR_template"}->sql_transform(
        @$sql,
        %$args
    );
    
    carp  _user_sql($req->sql, $req->bind_values) if $args->{'-warn'};
    croak _user_sql($req->sql, $req->bind_values) if $args->{'-die'};

    local $SIG{__DIE__} = sub { croak $self->_dr_decode_err(@_) };
    my $res = $self->selectrow_hashref(
            $req->sql,
            $args->{-dbi},
            $req->bind_values
        );

    return unless $res;

    my ($class, $method) = camelize $item;
    return $class->$method($res) if $method;
    return bless $res => $class;
}

sub perform {
    my ($self, $sql, $args) = &_dr_extract_args_ep;
    my $req = $self->{"private_DBIx::DR_template"}->sql_transform(
        @$sql,
        %$args
    );
    
    carp  _user_sql($req->sql, $req->bind_values) if $args->{'-warn'};
    croak _user_sql($req->sql, $req->bind_values) if $args->{'-die'};

    local $SIG{__DIE__} = sub { croak $self->_dr_decode_err(@_) };
    my $res = $self->do(
            $req->sql,
            $args->{-dbi},
            $req->bind_values
        );
    return $res;
}


sub _dr_decode_err {
    my ($self, @arg) = @_;
    if ($self->{"private_DBIx::DR_dr_decode_errors"}) {
        for (@arg) {
            $_ = eval { decode utf8 => $_ } || $_ unless utf8::is_utf8 $_;
        }
    }
    return @arg if wantarray;
    return join ' ' => @arg;
}


1;

__END__

=head1 NAME

DBIx::DR - easy DBI helper (perl inside SQL and blessed results)

=head1 SYNOPSIS

    my $dbh = DBIx::DR->connect($dsn, $login, $passed);

    $dbh->perform(
        'UPDATE tbl SET a = 1 WHERE id = <%= $id %>',
        id => 123
    );

    my $rowset = $dbh->select(
        'SELECT * FROM tbl WHERE id IN (<% list @$ids %>)',
        ids => [ 123, 456 ]
    );
    my $rowset = $dbh->select(-f => 'sqlfile.sql.ep', ids => [ 123, 456 ]);

    while(my $row = $rowset->next) {
        print "id: %d, value: %s\n", $row->id, $row->value;
    }