DB-Handy
view release on metacpan or search on metacpan
lib/DB/Handy.pm view on Meta::CPAN
sub begin_work {
my($self) = @_;
$self->_set_err(
"Transactions are not supported: DB::Handy always operates in "
. "AutoCommit mode. begin_work/commit/rollback are not available."
);
return undef;
}
sub commit {
my($self) = @_;
$self->_set_err(
"Transactions are not supported: DB::Handy always operates in "
. "AutoCommit mode. begin_work/commit/rollback are not available."
);
return undef;
}
sub rollback {
my($self) = @_;
$self->_set_err(
"Transactions are not supported: DB::Handy always operates in "
. "AutoCommit mode. begin_work/commit/rollback are not available."
);
return undef;
}
# errstr / err accessors
sub errstr { return $_[0]->{errstr} }
sub err { return $_[0]->{err} }
sub _set_err {
my($self, $msg, $code) = @_;
$code = 1 unless defined $code;
$self->{errstr} = $msg;
$self->{err} = $code;
$errstr = $msg;
if ($self->{PrintError}) {
warn "DB::Handy: $msg\n";
}
if ($self->{RaiseError}) {
die "DB::Handy: $msg\n";
}
}
###############################################################################
# DB::Handy::Statement -- statement handle (like $sth)
###############################################################################
package DB::Handy::Statement;
use vars qw($VERSION);
$VERSION = $DB::Handy::VERSION;
$VERSION = $VERSION;
use vars qw($errstr);
$errstr = '';
sub new {
my($class, $dbh, $sql) = @_;
my $self = {
_dbh => $dbh,
_sql => $sql,
_rows => undef,
_cursor => 0,
_executed => 0,
_bind_params => [],
rows => 0,
errstr => '',
err => 0,
NAME => [],
NUM_OF_FIELDS => 0,
};
bless $self, $class;
return $self;
}
# execute(@bind_values) -- substitute ? placeholders and run the statement
sub execute {
my($self, @bind) = @_;
# merge values pre-set via bind_param()
if (!@bind && @{$self->{_bind_params}}) {
@bind = @{$self->{_bind_params}};
}
my $sql = $self->{_sql};
# substitute ? placeholders with actual values
if (@bind) {
my @params = @bind;
$sql =~ s/\?/_dbi_quote(shift @params)/ge;
}
my $engine = $self->{_dbh}{_engine};
my $res = $engine->execute($sql);
$self->{_result} = $res;
$self->{_executed} = 1;
if ($res->{type} eq 'error') {
$self->_set_err($res->{message});
return undef;
}
if ($res->{type} eq 'rows') {
my $data = $res->{data};
$self->{_rows} = $data;
$self->{_cursor} = 0;
my $n = scalar @$data;
$self->{rows} = $n;
# Determine column order: prefer SELECT list order; for SELECT *
# use schema declaration order; fall back to alphabetical.
my @name_order = $self->_col_order_from_sql($sql, $data, $engine);
$self->{NAME} = [ @name_order ];
$self->{NUM_OF_FIELDS} = scalar @name_order;
return $n || '0E0';
}
# INSERT / UPDATE / DELETE / DDL
if ($res->{type} eq 'ok') {
my $affected = 0;
if (defined($res->{message}) && ($res->{message} =~ /(\d+)\s+row/)) {
$affected = $1 + 0;
}
$self->{rows} = $affected;
$self->{_rows} = undef;
if ($sql =~ /^\s*INSERT\b/i) {
$self->{_dbh}{_last_insert_id} = $affected;
}
return $affected || '0E0';
}
# SHOW / DESCRIBE and other statement types
if (ref($res->{data}) eq 'ARRAY') {
$self->{_rows} = $res->{data};
$self->{_cursor} = 0;
$self->{rows} = scalar @{$res->{data}};
}
return '0E0';
}
# _col_order_from_sql($sql, $data, $engine)
#
# Return column names in the order they should be presented to the caller.
#
# For named SELECT lists (SELECT a, b, c) the order follows the SELECT list,
# including AS aliases (already handled since 1.01).
#
# For SELECT * on a single table the order follows the CREATE TABLE column
# declaration order, obtained from the schema.
#
# For SELECT * on a JOIN the order follows the table appearance order in
# the FROM/JOIN clause, each table's columns in declaration order, returned
# as 'alias.col' qualified names matching the result-row hash keys.
#
# Falls back to alphabetical (sorted keys of the first data row) when the
# schema cannot be resolved or the SQL cannot be parsed.
#
sub _col_order_from_sql {
my($self, $sql, $data, $engine) = @_;
# Fallback: alphabetical from first row (or empty)
my @fallback = ($data && @$data) ? sort keys %{$data->[0]} : ();
return @fallback unless defined $sql;
# Strip leading SELECT keyword
my $col_str;
if ($sql =~ /^SELECT\s+(.*?)\s+FROM\b/si) {
$col_str = $1;
}
else {
return @fallback;
}
$col_str =~ s/^DISTINCT\s+//si;
# SELECT * (or alias.*): try to use schema declaration order
if ($col_str =~ /^\*$/ || $col_str =~ /^\w+\.\*$/) {
return @fallback unless defined $engine;
# Parse FROM clause to get table name and optional alias
if ($sql =~ /\bFROM\s+(\w+)(?:\s+(?:AS\s+)?(\w+))?\s*(?:WHERE|ORDER|GROUP|LIMIT|OFFSET|$)/si
&& $sql !~ /\bJOIN\b/i) {
my($tbl, $alias) = ($1, $2);
my $sch = $engine->_load_schema($tbl);
return @fallback unless $sch;
my @names = map { $_->{name} } @{$sch->{cols}};
# Verify names match result keys
if (@$data) {
my %keys = map { $_ => 1 } keys %{$data->[0]};
return @fallback if grep { !$keys{$_} } @names;
}
return @names;
}
# JOIN: collect tables in FROM/JOIN order, build alias.col names
if ($sql =~ /\bJOIN\b/i) {
return @fallback unless defined $engine;
my @table_aliases;
# Extract first table from FROM
if ($sql =~ /\bFROM\s+(\w+)(?:\s+(?:AS\s+)?(\w+))?/si) {
push @table_aliases, [ $1, (defined $2 ? $2 : $1) ];
lib/DB/Handy.pm view on Meta::CPAN
push @names, "$alias.$col->{name}";
}
}
if (@names) {
# Verify names match result keys
if (@$data) {
my %keys = map { $_ => 1 } keys %{$data->[0]};
return @fallback if grep { !$keys{$_} } @names;
}
return @names;
}
return @fallback;
}
return @fallback;
}
# Split on commas (not inside parentheses)
my @parts;
my($cur, $depth) = ('', 0);
for my $ch (split //, $col_str) {
if ($ch eq '(') { $depth++; $cur .= $ch }
elsif ($ch eq ')') { $depth--; $cur .= $ch }
elsif ($ch eq ',' && $depth == 0) { push @parts, $cur; $cur = '' }
else { $cur .= $ch }
}
push @parts, $cur if length $cur;
my @names;
for my $part (@parts) {
$part =~ s/^\s+|\s+$//g;
# explicit alias: expr AS alias
if ($part =~ /\bAS\s+(\w+)\s*$/si) {
push @names, $1;
}
# qualified alias.col -> keep as 'alias.col' (JOIN result key format)
elsif ($part =~ /^(\w+)\.(\w+)$/) {
push @names, "$1.$2";
}
# bare column name
elsif ($part =~ /^(\w+)$/) {
push @names, $1;
}
# complex expression without alias -> fall back entirely
else {
return @fallback;
}
}
# Verify that every parsed name exists as a key in the result
# (guards against mis-parses; also handles 0-row results)
if (@$data) {
my %keys = map { $_ => 1 } keys %{$data->[0]};
for my $nm (@names) {
return @fallback unless $keys{$nm};
}
}
return @names;
}
# fetchrow_hashref -- return next row as hashref (undef at EOF)
sub fetchrow_hashref {
my($self) = @_;
return undef unless defined $self->{_rows};
return undef if $self->{_cursor} >= scalar @{$self->{_rows}};
my $row = $self->{_rows}[ $self->{_cursor}++ ];
return { %$row };
}
# fetchrow_arrayref -- return next row as arrayref (columns in NAME order)
sub fetchrow_arrayref {
my($self) = @_;
my $href = $self->fetchrow_hashref or return undef;
my @cols = @{$self->{NAME}} ? @{$self->{NAME}} : sort keys %$href;
return [ map { $href->{$_} } @cols ];
}
# fetchrow_array -- return next row as a list
sub fetchrow_array {
my($self) = @_;
my $aref = $self->fetchrow_arrayref or return ();
return @$aref;
}
# fetch -- alias for fetchrow_arrayref
sub fetch { return $_[0]->fetchrow_arrayref }
# fetchall_arrayref([$slice])
# $slice = {} -> [{col=>val,...}, ...]
# $slice = [] -> [[val,...], ...] (default)
sub fetchall_arrayref {
my($self, $slice) = @_;
return undef unless defined $self->{_rows};
my @all;
if (ref($slice) eq 'HASH') {
while (my $row = $self->fetchrow_hashref) {
push @all, $row;
}
}
else {
while (my $row = $self->fetchrow_arrayref) {
push @all, $row;
}
}
return [ @all ];
}
# fetchall_hashref($key_col) -- return rows as a hashref keyed by $key_col
sub fetchall_hashref {
my($self, $key_col) = @_;
my %h;
while (my $row = $self->fetchrow_hashref) {
$h{$row->{$key_col}} = $row;
}
return { %h };
}
# bind_param($pos, $val [, $attr]) -- pre-bind a placeholder by position
sub bind_param {
my($self, $pos, $val, $attr) = @_;
$self->{_bind_params}[$pos - 1] = $val;
return 1;
}
# finish -- reset cursor and release resources
sub finish {
my($self) = @_;
$self->{_rows} = undef;
$self->{_cursor} = 0;
$self->{_bind_params} = [];
return 1;
}
# rows -- number of rows affected or fetched by the last execute
sub rows { return $_[0]->{rows} }
# errstr / err accessors
sub errstr { return $_[0]->{errstr} }
sub err { return $_[0]->{err} }
sub _set_err {
my($self, $msg, $code) = @_;
$code = 1 unless defined $code;
$self->{errstr} = $msg;
$self->{err} = $code;
$errstr = $msg;
my $dbh = $self->{_dbh};
$dbh->_set_err($msg, $code) if ref($dbh);
}
# _dbi_quote($val) -- internal helper for ? placeholder substitution
sub _dbi_quote {
my($val) = @_;
return 'NULL' unless defined $val;
return $val if $val =~ /^-?\d+\.?\d*$/; # numeric: pass through as-is
$val =~ s/'/''/g;
return "'$val'";
}
###############################################################################
# Add connect() class method to DB::Handy
###############################################################################
package DB::Handy;
sub connect {
my($class, $dsn, $database, $opts) = @_;
return DB::Handy::Connection->connect($dsn, $database, $opts);
}
1;
__END__
=encoding utf-8
=head1 NAME
DB::Handy - Pure-Perl flat-file relational database with DBI-like interface
=head1 VERSION
Version 1.07
=head1 SYNOPSIS
use DB::Handy;
# -------------------------------------------------------
# DBI-like interface (recommended)
lib/DB/Handy.pm view on Meta::CPAN
=item * B<File locking> - shared/exclusive C<flock> on data files for safe
concurrent access from multiple processes.
=item * B<Portable> - works on Windows and UNIX/Linux without modification.
=back
=head1 INCLUDED DOCUMENTATION
The C<doc/> directory contains SQL cheat sheets in 21 languages
for use as learning materials.
=head1 DBI COMPATIBILITY
DB::Handy intentionally mirrors the L<DBI> programming interface so that
application code can be ported between the two with minimal change.
The table below summarises which parts of DBI are supported and which are
not.
=head2 Compatible (works the same way as DBI)
=over 4
=item * B<connect / disconnect> -
C<< DB::Handy->connect($dir, $db, \%opts) >> and C<$dbh->disconnect> follow
DBI conventions. C<RaiseError> and C<PrintError> behave as in DBI.
=item * B<do> -
C<< $dbh->do($sql, @bind) >> prepares, executes, and discards the result
in one call, returning the number of affected rows or C<'0E0'> for zero
rows, just like DBI.
=item * B<prepare / execute> -
C<< $dbh->prepare($sql) >> returns a statement handle.
C<< $sth->execute(@bind) >> substitutes C<?> positional placeholders and
runs the statement. The return value semantics (affected rows, C<'0E0'>,
C<undef> on error) match DBI.
=item * B<bind_param> -
C<< $sth->bind_param($pos, $value) >> (1-based position) works the same
as DBI.
=item * B<fetchrow_hashref / fetchrow_arrayref / fetchrow_array / fetch> -
All four fetch methods work as in DBI. C<fetch> is an alias for
C<fetchrow_arrayref>.
=item * B<fetchall_arrayref> -
Accepts C<{Slice =E<gt> {}}> (array of hash-refs) and C<{Slice =E<gt> []}>
(array of array-refs, the default), matching DBI.
=item * B<fetchall_hashref> - Works as in DBI.
=item * B<selectall_arrayref / selectall_hashref / selectrow_hashref / selectrow_arrayref> -
All four convenience methods have the same signature and return values as
their DBI counterparts.
=item * B<quote> -
Single-quotes a scalar and doubles embedded single-quotes; returns C<NULL>
for C<undef>. Behaviour matches DBI's default C<quote>.
=item * B<finish> - Resets the cursor; returns 1.
=item * B<rows> -
C<< $sth->rows >> returns the row count for the last execute, as in DBI.
=item * B<errstr / err> -
Both the handle-level accessors (C<< $dbh->errstr >>, C<< $sth->errstr >>)
and the package-level variable (C<$DB::Handy::errstr>) work the same way
as C<$DBI::errstr> / C<$DBI::err>.
=item * B<NAME / NUM_OF_FIELDS> -
C<< $sth->{NAME} >> (array-ref of column names in SELECT list order
for named columns, alphabetical for C<SELECT *> / JOIN) and
C<< $sth->{NUM_OF_FIELDS} >> (integer count) are set after C<execute>,
matching DBI statement-handle attributes.
C<NAME> is also populated from the SQL for zero-row results.
=item * B<table_info / column_info> -
Return data in the same key-naming convention as DBI
(C<TABLE_NAME>, C<TABLE_TYPE>, C<COLUMN_NAME>, C<DATA_TYPE>,
C<ORDINAL_POSITION>, C<IS_NULLABLE>, C<COLUMN_DEF>).
=item * B<ping> - Returns 1 when active, 0 after disconnect.
=back
=head2 Not Compatible (differs from or absent in DBI)
=over 4
=item * B<No DBI DSN format> -
DBI uses C<"dbi:Driver:param=val"> DSNs. DB::Handy uses a plain directory
path or the proprietary C<"base_dir=DIR;database=DB"> mini-DSN.
C<dbi:Handy:...> strings are B<not> recognised.
=item * B<No transaction support> -
DB::Handy B<always operates in AutoCommit mode>; there is no way to
group statements into an atomic transaction. C<begin_work>, C<commit>,
and C<rollback> are implemented but always return C<undef> and set
C<errstr>. C<AutoCommit> always returns C<1>.
=item * B<Column order> -
DB::Handy preserves column order for named SELECT lists (including
C<AS> aliases), C<SELECT *> (uses CREATE TABLE order), and
JOIN with C<SELECT *> (table appearance order, each in CREATE order).
Compatible with DBI.
=item * B<RaiseError / PrintError are standalone> -
In DBI, C<RaiseError> and C<PrintError> are handled by the DBI framework
itself. In DB::Handy they are implemented by the connection-handle code
only and may not fire in every error path that DBI would cover.
=item * B<No type_info / type_info_all> -
DBI provides C<type_info> and C<type_info_all> to query data-type
capabilities. These methods are not implemented.
=item * B<No statement-level attributes beyond NAME/NUM_OF_FIELDS> -
DBI statement handles expose many attributes (C<TYPE>, C<PRECISION>,
C<SCALE>, C<NULLABLE>, C<CursorName>, etc.). DB::Handy only supports
C<NAME> and C<NUM_OF_FIELDS>.
lib/DB/Handy.pm view on Meta::CPAN
(SELECT list order for named columns, alphabetical for C<SELECT *>),
or an empty list at end of result.
B<Note:> Column order matches the SELECT list for named columns.
Compatible with DBI.
=head2 fetch()
Alias for C<fetchrow_arrayref>. Compatible with DBI.
=head2 fetchall_arrayref( [$slice] )
# Array of hash-refs
my $all = $sth->fetchall_arrayref({});
# Array of array-refs (default)
my $all = $sth->fetchall_arrayref([]);
my $all = $sth->fetchall_arrayref;
Consume all remaining rows and return them as an array-ref. The optional
C<$slice> argument controls the row format:
=over 4
=item Hash-ref slice C<{}>
Each row is returned as a hash-ref C<{ col =E<gt> val, ... }>.
=item Array-ref slice C<[]> or omitted
Each row is returned as an array-ref with values in alphabetical column
order.
=back
Returns C<undef> if no statement has been executed.
Compatible with DBI.
=head2 fetchall_hashref( $key_field )
my $h = $sth->fetchall_hashref('id');
print $h->{1}{name};
Consume all remaining rows and return a hash-ref keyed by C<$key_field>.
Each value is a row hash-ref. If the key column has duplicate values,
later rows overwrite earlier ones.
Compatible with DBI.
=head2 rows()
my $count = $sth->rows;
Return the number of rows affected by the last DML statement or returned
by the last SELECT. This value is also the return value of C<execute>.
Compatible with DBI.
=head2 finish()
$sth->finish;
Reset the cursor to the beginning of the result set and release any
associated resources. Does not close the statement handle; the same
C<$sth> can be re-executed. Always returns 1.
Compatible with DBI.
=head2 errstr() / err()
The error message and error code from the most recent failed operation on
this statement handle. See L</"errstr()"> and L</"err()"> under the
connection handle section.
Compatible with DBI.
=head1 ATTRIBUTES
=head2 Statement-handle attributes
The following attributes are available on C<$sth> after a successful
C<execute>:
=over 4
=item C<$sth-E<gt>{NAME}>
An array-ref of column names in the result set:
=over 4
=item *
Named SELECT list: follows the SELECT list order.
C<SELECT salary, name> gives C<['salary', 'name']>.
=item *
C<SELECT *> on a single table: follows the C<CREATE TABLE> declaration
order. C<SELECT * FROM emp> where emp has columns (id, name, dept)
gives C<['id', 'name', 'dept']>.
=item *
C<SELECT *> with C<JOIN>: table appearance order (FROM first, then
each JOIN table in order), each table's columns in declaration order,
as qualified names C<alias.col>.
=back
The attribute is set correctly even for zero-row results.
Compatible with DBI.
=item C<$sth-E<gt>{NUM_OF_FIELDS}>
The number of columns in the result set (integer). Set to 0 for
non-SELECT statements. Compatible with DBI.
=back
The following DBI statement-handle attributes are B<not> implemented:
C<TYPE>, C<PRECISION>, C<SCALE>, C<NULLABLE>, C<CursorName>,
C<ParamValues>, C<Statement>, C<RowsInCache>.
=head2 Connection-handle attributes
( run in 0.644 second using v1.01-cache-2.11-cpan-cdf2f3d4e48 )