DBIx-Squirrel
view release on metacpan or search on metacpan
1.3.1 2024-08-24 14:10
- General code improvements.
- Removed unnecessary imports.
- Removed call to no longer extant iterator method from
&DBIx::Squirrel::it::DESTROY.
- Added the “count_all†method back into the iterator class, as well
as ensuring that “count†does not affect a future call to “nextâ€.
- Addressed build failures revealed by the CPAN Testers Matrix:
- Rewrote &DBIx::Squirrel::util::callbacks_args - failed on Perl
versions <= 5.18.4;
- Back to using “strict†and “warnings†- Modern::Perl having some
issues with a bundle “all†in Perl versions <= 5.14.4.
- Perls versions <= 5.13 do not support ${^GLOBAL_PHASE}, so used
Devel::GlobalDestruction to work around the issue.
- Testing under Perls <= 5.13 seems to require “done_testing()â€
for each sub-test, as well as at the end of the test script.
- Testing under Perls <= 5.11 does not support sub-test. I can
live without them, so have refactored the tests not to use them.
Tests pass under Perl 5.10!
lib/DBIx/Squirrel/it.pm view on Meta::CPAN
use Exporter ();
use Scalar::Util qw(
looks_like_number
weaken
);
use Sub::Name 'subname';
use DBIx::Squirrel::util qw(
cluckf
confessf
callbacks_args
);
use namespace::clean;
use constant E_BAD_STH => 'Expected a statement handle object';
use constant E_BAD_SLICE => 'Slice must be a reference to an ARRAY or HASH';
use constant E_BAD_CACHE_SIZE =>
'Maximum row count must be an integer greater than zero';
use constant W_MORE_ROWS => 'Query would yield more than one result';
use constant E_EXP_ARRAY_REF => 'Expected an ARRAY-REF';
lib/DBIx/Squirrel/it.pm view on Meta::CPAN
Creates a new iterator object.
This method is not intended to be called directly, but rather indirectly
via the C<iterate> or C<results> methods of L<DBIx::Squirrel::st> and
L<DBIx::Squirrel::db> packages.
=cut
sub new {
my $class = ref $_[0] ? ref shift : shift;
my( $transforms, $sth, @bind_values ) = callbacks_args(@_);
confessf E_BAD_STH unless UNIVERSAL::isa( $sth, 'DBIx::Squirrel::st' );
my $self = bless {}, $class;
$self->_private_state( {
sth => $sth,
bind_values_initial => [@bind_values],
transforms_initial => $transforms,
} );
return $self;
}
lib/DBIx/Squirrel/it.pm view on Meta::CPAN
}
return $self;
}
BEGIN {
*slice_buffer_size = subname( slice_buffer_size => \&slice_cache_size );
}
sub start {
my( $attr, $self ) = shift->_private_state;
my( $transforms, @bind_values ) = callbacks_args(@_);
if ( @{$transforms} ) {
$attr->{transforms} = [ @{ $attr->{transforms_initial} }, @{$transforms} ];
}
else {
unless ( defined $attr->{transforms} && @{ $attr->{transforms} } ) {
$attr->{transforms} = [ @{ $attr->{transforms_initial} } ];
}
}
if (@bind_values) {
$attr->{bind_values} = [@bind_values];
lib/DBIx/Squirrel/util.pm view on Meta::CPAN
=head1 DESCRIPTION
A collection of helper functions used by other DBIx::Squirrel packages.
=cut
our @ISA = qw(Exporter);
our @EXPORT;
our %EXPORT_TAGS = ( all => [
our @EXPORT_OK = qw(
callbacks
callbacks_args
carpf
cluckf
confessf
decrypt
get_file_contents
global_destruct_phase
has_callbacks
slurp
uncompress
unmarshal
utf8decode
)
] );
use Carp ();
use Compress::Bzip2 ();
use Devel::GlobalDestruction ();
lib/DBIx/Squirrel/util.pm view on Meta::CPAN
Dotenv->load();
}
=head2 EXPORTS
Nothing is exported by default.
=cut
=head3 C<callbacks>
@callbacks = callbacks(\@array);
$count = callbacks(\@array);
When called in list-context, this function removes and returns any trailing
CODEREFs found in the array referenced by the only argument. Be mindful that
this operation potentially alters the referenced array.
When called in scalar-context then the function returns a non-zero count of
the number of trailing CODEREFs found, or C<undef> if there were none. When
called in scalar-context then the array is not altered, even if there were
trailing CODEREFs.
=cut
sub callbacks {
return unless 1 == @_ && UNIVERSAL::isa( $_[0], 'ARRAY' );
goto &_callbacks;
}
sub _callbacks {
return unless my @splice = _has_callbacks( $_[0] );
return $splice[1] unless wantarray;
return splice @{ $_[0] }, $splice[0], $splice[1];
}
=head3 C<callbacks_args>
(\@callbacks, @arguments) = callbacks_args(@argments);
When using C<DBIx::Squirrel>, some calls allow the caller to reshape results
before they are returned, using transformation pipelines. A transformation
pipeline is one or more contiguous code-references presented at the end of
a call's argument list.
Th C<callbacks_args> function inspects an array of arguments, moving any
trailing code-references from the source array into a separate array — the
transformation pipeline. It returns a reference to that array, followed by
any remaining arguments, to the caller.
(\@callbacks, @arguments) = &callbacks_args;
The terse C<&>-sigil calling style causes C<callbacks_args> to use the
calling function's C<@_> array.
=cut
sub callbacks_args {
return [], @_ unless my @callbacks = callbacks( \@_ );
return \@callbacks, @_;
}
=head3 C<carpf>
Emits a warning without a stack-trace.
carpf();
The warning will be set to C<$@> if it contains something useful. Otherwise
lib/DBIx/Squirrel/util.pm view on Meta::CPAN
don't support the ${^GLOBAL_PHASE} variable, so provide a shim that
works regardless of Perl version.
=cut
sub global_destruct_phase {
return Devel::GlobalDestruction::in_global_destruction();
}
=head3 C<has_callbacks>
($position, $count) = has_callbacks(\@array);
When called in list-context, this function returns the starting position
and a count of the trailing CODEREFs found in the array referenced in the
only argument. If no trailing CODEREFs were found then the function will
return an empty list.
When called in scalar-context then a truthy value indicating the presence
of callbacks will be returned.
=cut
sub has_callbacks {
return unless 1 == @_ && UNIVERSAL::isa( $_[0], 'ARRAY' );
goto &_has_callbacks;
}
sub _has_callbacks {
my $n = my $s = scalar @{ $_[0] };
$n-- while $n && UNIVERSAL::isa( $_[0][ $n - 1 ], 'CODE' );
return if $n == $s;
return $n ? ( $n, $s - $n ) : ( 0, $s ) if wantarray;
return $n;
}
=head3 C<slurp>
t/00-util.t view on Meta::CPAN
#
use Test::More::UTF8;
BEGIN {
use_ok( 'DBIx::Squirrel', database_entity => 'db' )
or print "Bail out!\n";
use_ok( 'T::Squirrel', qw(:var diagdump) )
or print "Bail out!\n";
use_ok(
'DBIx::Squirrel::util',
qw(callbacks carpf cluckf confessf has_callbacks callbacks_args),
) or print "Bail out!\n";
}
diag join(
', ',
"Testing DBIx::Squirrel $DBIx::Squirrel::VERSION",
"Perl $]", "$^X",
);
{
t/00-util.t view on Meta::CPAN
}
{
my $sub1 = sub { 'DUMMY 1' };
my $sub2 = sub { 'DUMMY 2' };
my $sub3 = sub { 'DUMMY 3' };
my @tests = (
{
line => __LINE__, name => 'ok - callbacks_args (no arguments)',
got => [ callbacks_args() ],
exp => [ [] ],
},
{
line => __LINE__, name => 'ok - callbacks_args (single argument)',
got => [ callbacks_args(1) ],
exp => [ [], 1 ],
},
{
line => __LINE__, name => 'ok - callbacks_args (multiple arguments)',
got => [ callbacks_args( 1, 2 ) ],
exp => [ [], 1, 2 ],
},
{
line => __LINE__, name => 'ok - callbacks_args (single callback)',
got => [ callbacks_args($sub1) ],
exp => [ [$sub1] ],
},
{
line => __LINE__, name => 'ok - callbacks_args (multiple callbacks)',
got => [ callbacks_args( $sub1, $sub2 ) ],
exp => [ [ $sub1, $sub2 ] ],
},
{
line => __LINE__,
name => 'ok - callbacks_args (single argument, single callback)',
got => [ callbacks_args( 1 => $sub1 ) ],
exp => [ [$sub1], 1 ],
},
{
line => __LINE__,
name => 'ok - callbacks_args (multiple arguments, single callback)',
got => [ callbacks_args( 1, 2 => $sub1 ) ],
exp => [ [$sub1], 1, 2 ],
},
{
line => __LINE__,
name => 'ok - callbacks_args (multiple arguments, multiple callbacks)',
got => [ callbacks_args( 1, 2 => $sub1, $sub2 ) ],
exp => [ [ $sub1, $sub2 ], 1, 2 ],
},
{
line => __LINE__,
name =>
'ok - callbacks_args (multiple arguments, multiple callbacks, non-callback argument)',
got => [ callbacks_args( 1, $sub1, 3 => $sub2, $sub3 ) ],
exp => [ [ $sub2, $sub3 ], 1, $sub1, 3 ],
},
);
for my $t (@tests) {
is_deeply $t->{got}, $t->{exp},
sprintf( 'line %d%s', $t->{line}, $t->{name} ? " $t->{name}" : '' );
}
}
{
for (
{
loc => __LINE__,
got => [ has_callbacks( [] ) ],
exp => [],
},
{
loc => __LINE__,
got => [ has_callbacks( [1] ) ],
exp => [],
},
{
loc => __LINE__,
got => [ has_callbacks( [ 1, 2, 3 ] ) ],
exp => [],
},
{
loc => __LINE__,
got => [ has_callbacks( [ sub { }, 1, 2, 3 ] ) ],
exp => [],
},
{
loc => __LINE__,
got => [ has_callbacks( [ sub { } ] ) ],
exp => [ 0, 1 ],
},
{
loc => __LINE__,
got => [ has_callbacks( [ 1, 2, 3, sub { } ] ) ],
exp => [ 3, 1 ],
},
) {
is_deeply $_->{got}, $_->{exp}, "has_callbacks, line $_->{loc}";
}
}
done_testing();
( run in 3.224 seconds using v1.01-cache-2.11-cpan-9b1e4054eb1 )