libdbix-dr-perl-0.26/0000755000000000000000000000000012234755711013126 5ustar rootrootlibdbix-dr-perl-0.26/Makefile.PL0000664000000000000000000000143112234753463015103 0ustar rootrootuse 5.010001; use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( NAME => 'DBIx::DR', VERSION_FROM => 'lib/DBIx/DR.pm', # finds $VERSION PREREQ_PM => { DBI => 1.4, Mouse => 0, }, ABSTRACT_FROM => 'lib/DBIx/DR.pm', # retrieve abstract from module AUTHOR => 'Dmitry E. Oboukhov ', BUILD_REQUIRES => { 'DBD::SQLite' => 1.0 }, LICENSE => 'Artistic License', META_MERGE => { resources => { repository => 'https://github.com/dr-co/dbix-dr', bugtracker => 'https://github.com/dr-co/dbix-dr/issues' } } ); libdbix-dr-perl-0.26/t/0000775000000000000000000000000012234755700013371 5ustar rootrootlibdbix-dr-perl-0.26/t/sql/0000775000000000000000000000000012234753463014174 5ustar rootrootlibdbix-dr-perl-0.26/t/sql/unknown_function.sql.ep0000644000000000000000000000013712072116522020710 0ustar rootrootSELECT % unknown_function; #### UNKNOWN_FUNCTION #### FROM table WHERE 1 <> 1 libdbix-dr-perl-0.26/t/sql/select_ids.sql.ep0000664000000000000000000000011512234753463017433 0ustar rootrootSELECT * FROM tbl WHERE id IN (<% list @$ids %>) ORDER BY id libdbix-dr-perl-0.26/t/sql/usual_select.sql.ep0000644000000000000000000000006712072116522017776 0ustar rootrootSELECT * FROM table WHERE id = <%= $id %> libdbix-dr-perl-0.26/t/sql/include.sql.ep0000644000000000000000000000007612072116522016731 0ustar rootroot/* iid = <%= $iid %> */ % include 'usual_select', id => $iid libdbix-dr-perl-0.26/t/000-dr-iterator.t0000664000000000000000000001257412234755700016320 0ustar rootroot#!/usr/bin/perl use warnings; use strict; use utf8; use open qw(:std :utf8); use lib qw(lib ../lib); use Test::More tests => 69; use Encode qw(decode encode); BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; note "************* DBIx::DR *************"; use_ok 'DBIx::DR::Iterator'; } my $aref = [ { id => 1 }, { id => 2 }, { id => 3 } ]; my $href = { a => {id => 'a', value => 1 }, b => {id => 'b', value => 2 }, c => {id => 'c', value => 3 }, d => {id => 'd', value => 4 }, e => {id => 'e', value => 3 }, }; my $item; my $hiter = new DBIx::DR::Iterator $href; my $aiter = new DBIx::DR::Iterator $aref; isa_ok $hiter => 'DBIx::DR::Iterator', 'HASH iterator has been created'; ok $hiter->{is_hash} && !$hiter->{is_array}, 'HASH detected properly'; ok $hiter->count == keys %$href, 'HASH size detected properly'; isa_ok $aiter => 'DBIx::DR::Iterator', 'ARRAY iterator has been created'; ok $aiter->{is_array} && !$aiter->{is_hash}, 'ARRAY detected properly'; ok $aiter->count == @$aref, 'ARRAY size detected properly'; my $no = 0; while(my $i = $aiter->next) { if ($no >= $aiter->count) { fail 'Array bound exceeded'; last; } is $i->id, $aref->[ $no++ ]{id}, "$no element of array was checked"; } $no = 0; while(my $i = $hiter->next) { if ($no++ >= $hiter->count) { fail 'Hash bound exceeded'; last; } is $i->value, $href->{ $i->id }{value}, "$no element of hash was checked"; } ok $aiter->next, 'array element was autoreseted'; $no = 1; $no++ while $aiter->next; ok $no == $aiter->count, 'array was autoreseted properly'; ok $hiter->next, 'hash element was autoreseted'; $no = 1; $no++ while $hiter->next; ok $no == $hiter->count, 'hash was autoreseted properly'; $aiter->next; $hiter->next; $aiter->reset; $hiter->reset; $no = 0; $no++ while $aiter->next; ok $no == $aiter->count, 'array was reseted properly'; $no = 0; $no++ while $hiter->next; ok $no == $hiter->count, 'hash was reseted properly'; $item = $hiter->next; # note explain $hiter; for my $ss ($hiter->grep(value => 3), $hiter->grep(sub{ $_[0]->value == 3 })) { isa_ok $ss => 'DBIx::DR::Iterator', 'Hash subset'; cmp_ok $ss->count, '==', 2, 'count of elements'; ok $ss->exists('c'), 'element was grepped properly'; ok $ss->exists('e'), 'element was grepped properly'; cmp_ok $ss->get('c')->id, 'eq', 'c', 'id'; cmp_ok $ss->get('c')->value, 'eq', '3', 'value'; cmp_ok $ss->get('e')->id, 'eq', 'e', 'id'; cmp_ok $ss->get('e')->value, 'eq', '3', 'value'; cmp_ok $ss->{item_class}, 'eq', $aiter->{item_class}, 'Item class'; cmp_ok $ss->{item_constructor}, 'eq', $aiter->{item_constructor}, 'Item constructor'; } { my ($ss1) = $hiter->grep(value => 3)->all; my $ss2 = $hiter->find(value => 3); is $ss1->value, $ss2->value, 'find'; } for my $ss($aiter->grep(id => 2), $aiter->grep(sub { $_[0]->id == 2 })) { isa_ok $ss => 'DBIx::DR::Iterator', 'Array subset'; cmp_ok $ss->count, '==', 1, 'count of elements'; ok $ss->exists(0), 'element was grepped properly'; cmp_ok $ss->get(0)->id, '==', 2, 'id'; cmp_ok $ss->{item_class}, 'eq', $aiter->{item_class}, 'Item class'; cmp_ok $ss->{item_constructor}, 'eq', $aiter->{item_constructor}, 'Item constructor'; } ok $item, 'Item extracted'; ok $item->iterator, 'Item has iterator link'; undef $hiter; ok !$item->iterator, 'Item has undefined iterator link after iterator was destroyed'; $item = $aiter->next; ok !$item->is_changed, "Item wasn't changed"; ok !$item->iterator->is_changed, "Iterator wasn't changed"; ok !eval { $item->value; 1 }, 'Unknown method'; ok $item->id(123) == 123, 'Change field'; ok $item->is_changed, 'Field was changed'; ok $item->iterator->is_changed, 'Iterator was changed, too'; my $o = { 1 => 2 }; $item->id($o); $item->iterator->is_changed(0); $item->is_changed(0); # the same object $item->id($o); ok !$item->is_changed, "Item wasn't changed"; ok !$item->iterator->is_changed, "Iterator wasn't changed"; $item->id([]); ok $item->is_changed, 'Field was changed'; ok $item->iterator->is_changed, 'Iterator was changed, too'; { { package TestItem; sub new { my ($class, $item) = @_; return bless { %$item } => $class; } package TestItemD; sub new { my ($class, $item) = @_; return undef if @_ > 2; goto \&TestItem::new; } } my @items = ( { a => 'b' }, { c => 'd' }, { d => 'e' } ); my $l1 = DBIx::DR::Iterator->new(\@items, -item => 'test_item#new'); my $l2 = DBIx::DR::Iterator->new(\@items, -item => 'test_item_d#new'); my $l3 = DBIx::DR::Iterator->new(\@items, -item => 'test_item_d#new', -noitem_iter => 1); is_deeply [ $l2->all ], [ (undef) x 3 ], 'list2 contains only undef'; is_deeply [ $l1->all ], [ $l3->all ], 'Third list did not received iterator'; } =head1 COPYRIGHT Copyright (C) 2011 Dmitry E. Oboukhov Copyright (C) 2011 Roman V. Nikolaev This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License. =cut libdbix-dr-perl-0.26/t/benchmarks/0000775000000000000000000000000012072116522015477 5ustar rootrootlibdbix-dr-perl-0.26/t/benchmarks/01_transform.pl0000644000000000000000000000267612072116522020360 0ustar rootroot#!/usr/bin/perl use warnings; use strict; use utf8; use open qw(:std :utf8); use lib qw(lib); use DBIx::DR::PlPlaceHolders; use Benchmark qw(:all) ; use Data::Dumper; my $sql = q[ SELECT u.* FROM users AS u % if ($filters->{role_name}) { LEFT JOIN roles AS r ON u.rid = r.id % } % if ($filters->{user_name}) { LEFT JOIN user_cards AS uc ON u.id = uc.uid % } WHERE 1 = 1 % if ($filters->{role_name}) { AND r.name = <%= $filters->{role_name} %> % } % if ($filters->{user_name}) { AND uc.name = <%= $filters->{user_name} %> % } ]; print "Two active filters\n"; my $tp = DBIx::DR::PlPlaceHolders->new; my $b1 = timeit 10000, sub { $tp->sql_transform( $sql, filters => { role_name => 'Superadmin', user_name => 'Vasya' } ); }; printf "%s\n", $b1->timestr; printf "One active filter\n"; my $b2 = timeit 10000, sub { $tp->sql_transform( $sql, filters => { role_name => 'Superadmin' } ); }; printf "%s\n", $b2->timestr; print "No active filters\n"; my $b3 = timeit 10000, sub { $tp->sql_transform($sql, filters => {}); }; printf "%s\n", $b3->timestr; =head1 COPYRIGHT Copyright (C) 2011 Dmitry E. Oboukhov Copyright (C) 2011 Roman V. Nikolaev This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License. =cut libdbix-dr-perl-0.26/t/010-dr-perl-ish-template.t0000664000000000000000000001123512234753463020021 0ustar rootroot#!/usr/bin/perl use warnings; use strict; use utf8; use open qw(:std :utf8); use lib qw(lib ../lib); use Test::More tests => 46; use Encode qw(decode encode); BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; note "************* DBIx::DR::PerlishTemplate *************"; use_ok 'DBIx::DR::PerlishTemplate'; use_ok 'File::Spec::Functions', 'catfile', 'rel2abs'; use_ok 'File::Basename', 'dirname', 'basename'; } my $tpl = DBIx::DR::PerlishTemplate->new; ok $tpl, 'DBIx::DR::PerlishTemplate->new'; my @tests = ( { template => q{ %= 50 - 11 + <%== 24 / 12 %> + <%== 12 / 6 %> %== '+ 1' }, prepend => [], args => [], sql => qr{^\s*\?\s*\+\s*2\s*\+\s*2\s*\+\s*1\s*$}s, vars => [ 39 ], name => 'Immediate substitutions', }, { template => '%= 13 / 8', prepend => [], args => [], sql => qr{^\?$}, vars => [ 13 / 8 ], name => 'Placeholder test', }, { template => '%== 13 / 8', prepend => [], args => [], sql => qr{^1\.625$}, vars => [], name => 'Immediate substitution', }, { template => '%= $variable', prepend => ['my $variable = 127'], args => [], sql => qr{^\?$}, vars => [127], name => 'Placeholder substitution with prepend', }, { template => '%= $variable', prepend => [], args => [], sql => qr{^\?$}, vars => [127], name => 'Placeholder substitution without prepend', die => qr{\$variable} }, { template => '<%== 24 / 12 %> + <%== 12 / 6 %>', prepend => [], args => [], sql => qr{^2 \+ 2$}, vars => [], name => 'Immediate substitutions', }, { template => '<%= 24 / 12 %> + <%== 12 / 6 %>', prepend => [], args => [], sql => qr{^\? \+ 2$}, vars => [2], name => 'Immediate and placeholder substitutions', }, { template => 'a%<%== "♥" %>-% + <%= "♥" %>', prepend => [], args => [], sql => qr{^a%♥-% \+ \?$}, vars => ['♥'], name => 'UTF8 Immediate and placeholder substitutions', }, { template => q{ % my $path = $0; % use File::Spec::Functions qw(catfile rel2abs); % use File::Basename qw(dirname); %= rel2abs dirname $0}, prepend => [], args => [], sql => qr{^\s*\?$}, vars => [ rel2abs dirname $0 ], name => 'UTF8 Immediate and placeholder substitutions', }, { template => q[ % for (1 .. 10) { <%= $_ %>, % } ], prepend => [], args => [], sql => qr[^(\s*\?,){10}\s*$]s, vars => [ 1 .. 10 ], name => 'foreach', }, { template => q^ SELECT '{abc}'::text[] AS "array" ^, prepend => [], args => [], sql => qr[SELECT\s+'\{abc\}']s, vars => [], name => '{} brackets', }, ); for my $t(@tests) { $t->{prepend} ||= []; $t->{preprepend} ||= []; $tpl->clean_prepend; $tpl->prepend($_) for @{ $t->{prepend} }; $tpl->preprepend($_) for @{ $t->{preprepend} }; my $res = eval { $tpl->render($t->{template}, @{ $t->{args} }) }; diag $@ unless ok $res || $t->{die}, $t->{name}; if ($t->{die}) { like $@, $t->{die}, 'Renderer died'; } else { diag $@ unless ok !$@, 'Rendered without exceptions'; like $tpl->sql, $t->{sql}, 'Rendering sql'; diag $tpl->sql unless is_deeply $tpl->variables, $t->{vars}, 'Bind variables'; } } =head1 COPYRIGHT Copyright (C) 2011 Dmitry E. Oboukhov Copyright (C) 2011 Roman V. Nikolaev This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License. =cut libdbix-dr-perl-0.26/t/035-dr.t0000664000000000000000000001327312234753463014502 0ustar rootroot#!/usr/bin/perl use warnings; use strict; use utf8; use open qw(:std :utf8); use lib qw(lib ../lib); use Test::More tests => 67; use Encode qw(decode encode); BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; note "************* DBIx::DR *************"; use_ok 'DBIx::DR'; use_ok 'DBD::SQLite'; use_ok 'File::Temp', 'tempdir'; use_ok 'File::Path', 'remove_tree'; use_ok 'File::Spec::Functions', 'catfile', 'rel2abs'; use_ok 'File::Basename', 'dirname', 'basename'; } my $temp_dir = tempdir; END { remove_tree $temp_dir, { verbose => 0 }; ok !-d $temp_dir, "Temporary dir was removed: $temp_dir"; } my $test_dir = catfile(dirname($0), 'sql'); ok -d $test_dir, 'Directory contained sqls is found: ' . $test_dir; ok -d $temp_dir, "Temporary directory was created: $temp_dir"; my $db_file = "$temp_dir/db.sqlite"; my $dbh = DBIx::DR->connect( "dbi:SQLite:dbname=$db_file", '', '', { dr_sql_dir => $test_dir, RaiseError => 1, PrintError => 0, PrintWarn => 0, }); isa_ok $dbh => 'DBIx::DR::db', 'Connector was created'; ok -r $db_file, 'Database file was created'; ok $dbh->{'private_DBIx::DR_iterator'} eq 'dbix-dr-iterator#new', 'Default iterator class'; ok $dbh->{'private_DBIx::DR_item'} eq 'dbix-dr-iterator-item#new', 'Default item class'; my $res = $dbh->perform(q{ CREATE TABLE tbl (id INTEGER PRIMARY KEY, value CARCHAR(32)) } ); is $res, '0E0', 'Table tbl was created'; my @values = (1, 2, 3, 4, 6, 'abc', 'def'); for(@values) { $res = $dbh->perform( 'INSERT INTO tbl (value) VALUES (<%= $value %>)', value => $_ ); ok $res && $res ne '0E0', 'Array item was inserted'; } $res = $dbh->perform(q[ UPDATE tbl SET value = value || <%= $suffix %> WHERE id > <%= $id_limit %> ], suffix => '_suffix', id_limit => 2 ); ok $res == @values - 2, 'Updated was passed'; $res = $dbh->select('SELECT * FROM tbl'); isa_ok $res => 'DBIx::DR::Iterator', 'A few rows were fetched'; ok $res->count == @values, 'Rows count has well value'; while(my $v = $res->next) { ok $v->id > 0, 'Record identifier: ' . $v->id; if ($v->id > 2) { ok $v->value eq $values[ $v->id - 1 ] . '_suffix', 'Record value: ' . $v->value; } else { ok $v->value eq $values[ $v->id - 1 ], 'Record value: ' . $v->value; } } my $select_file = catfile $test_dir, 'select_ids.sql.ep'; ok -r $select_file, 'select.sql is found'; my $w; eval { local $SIG{__WARN__} = sub { $w = shift }; $dbh->select( -f => 'select_ids', ids => [ 1, 2 ], -hash => 'id', -item => 'my_item_package#new', -iterator => 'my_iterator_package#new', -die => 1, -warn => 1, ) }; like $@, qr{SELECT}, '-die statement'; like $w, qr{SELECT}, '-warn statement'; $res = $dbh->select( -f => 'select_ids', ids => [ 1, 2 ], -hash => 'id', -item => 'my_item_package#new', -iterator => 'my_iterator_package#new' ); ok 'HASH' eq ref $res->{fetch}, 'SELECT was done'; ok $res->count == 2, 'Rows count has well value'; ok $res->get(1)->value eq $values[0], 'First item'; ok $res->get(2)->value eq $values[1], 'Second item'; $res = $dbh->select( -f => rel2abs($select_file), ids => [ 1, 2 ], -hash => 'id', -item => 'my_item_package#new', -iterator => 'my_iterator_package#new' ); isa_ok $res => 'MyIteratorPackage', 'Repeat sql from file'; ok $res->count == 2, 'Rows count has well value'; my @a = sort { $a->id <=> $b->id } $res->all; ok @a == $res->count, 'Rows count has well value'; is $a[0]->value, $values[0], 'First item'; is $a[1]->value, $values[1], 'Second item'; $res = $dbh->single('SELECT * FROM tbl WHERE id = <%= $id %>', id => 1); ok $res, 'Select one exists row'; ok $res->id == 1, 'Identifier'; ok $res->value eq $values[0], 'Value'; $res = $dbh->single('SELECT * FROM tbl WHERE id = <%= $id %>', id => 5000); ok !$res, 'No results'; $dbh->set_helper( foo => sub { 'foo' }, bar => sub { $_[0]->call_helper('foo') . 'bar' }, ); $res = $dbh->single('SELECT <%= foo %> AS foo'); ok $res->foo eq 'foo', 'User helper'; $res = $dbh->single('SELECT <%= bar %> AS bar'); ok $res->bar eq 'foobar', 'User helper (call the other helper)'; $res = eval { $dbh->perform(-f => 'unknown_function') }; my $e = $@ // ''; ok $e, 'Exception'; my ($line) = $e =~ /unknown_function\.sql\.ep\s+line\s+(\d+)/; diag $e unless ok $line, '"at line" is present'; my $fname = catfile($test_dir, 'unknown_function.sql.ep'); ok -f $fname, $fname; open my $fh, '<', $fname; my @lines = <$fh>; my ($line_real) = grep { $lines[$_] =~ /UNKNOWN_FUNCTION/ } 0 .. $#lines; $line_real++; cmp_ok $line, '==', $line_real, 'Exception point'; package MyItemPackage; use base 'DBIx::DR::Iterator::Item'; use Test::More; sub value { my ($self) = @_; ok @_ == 1, 'Get item value'; return $self->SUPER::value; } package MyIteratorPackage; use base 'DBIx::DR::Iterator'; use Test::More; sub count { my ($self) = @_; ok @_ == 1, 'Get iterator size'; return $self->SUPER::count; } =head1 COPYRIGHT Copyright (C) 2011 Dmitry E. Oboukhov Copyright (C) 2011 Roman V. Nikolaev This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License. =cut libdbix-dr-perl-0.26/t/020-util.t0000644000000000000000000000310712072116522015022 0ustar rootroot#!/usr/bin/perl use warnings; use strict; use utf8; use open qw(:std :utf8); use lib qw(lib ../lib); use Test::More tests => 9; use Encode qw(decode encode); BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; note "************* DBIx::DR::Util *************"; use_ok 'DBIx::DR::Util'; } my ($module, $method) = camelize 'test-module_name#foo'; ok $module eq 'Test::ModuleName', 'camelize "test-module_name#foo": module'; ok $method eq 'foo', 'camelize "test-module_name#foo": method'; ($module, $method) = camelize 'dbix-dr-iterator#new'; ok $module eq 'DBIx::DR::Iterator', 'camelize "dbix-dr-iterator#new": module'; ok $method eq 'new', 'camelize "dbix-dr-iterator#new": method'; ($module, $method) = camelize 'dbix-dr-iterator'; ok $module eq 'DBIx::DR::Iterator', 'camelize "dbix-dr-iterator": module'; ok !defined $method, 'camelize "dbix-dr-iterator": method'; cmp_ok 'test-module-sub_module#new', 'eq', decamelize('Test::Module::SubModule', 'new'), 'decamelize Test::Module::SubModule->new' ; cmp_ok 'test', 'eq', decamelize('Test'), 'decamelize Test' ; =head1 COPYRIGHT Copyright (C) 2011 Dmitry E. Oboukhov Copyright (C) 2011 Roman V. Nikolaev This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License. =cut libdbix-dr-perl-0.26/t/015-dr-pl-placeholders.t0000664000000000000000000002407512234753463017556 0ustar rootroot#!/usr/bin/perl use warnings; use strict; use utf8; use open qw(:std :utf8); use lib qw(lib ../lib); use Test::More tests => 92; use Encode qw(decode encode); BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; note "************* DBIx::DR::PlPlaceHolders *************"; use_ok 'DBIx::DR::PlPlaceHolders'; use_ok 'File::Spec::Functions', qw(catfile rel2abs); use_ok 'File::Basename', qw(basename dirname); } my $ph = DBIx::DR::PlPlaceHolders->new; ok !eval { $ph->set_helper; 1}, 'Wrong set_helper call'; $ph->set_helper(test1 => sub { my ($t) = @_; $t->quote('this is a test helper') }); ok $ph, 'Constructor'; my $sql_dir = catfile(rel2abs(dirname $0), 'sql'); ok -d $sql_dir, 'Test SQL dir found: ' . $sql_dir; ok !eval { $ph->sql_dir('directory that is not exists'); 1 }, 'Wrong sql_dir'; ok $ph->sql_dir($sql_dir), 'Well sql_dir'; ok $ph->sql_dir eq $sql_dir, 'sql_dir was changed'; ok $ph->file_suffix eq '.sql.ep', 'Default sql file suffix'; ok !eval { $ph->sql_transform; 1 }, 'Wrong arguments for sql_transform'; my @inline_tests = ( { sql => q{<%= $variable %>}, variables => [ variable => 123 ], like => qr{^\?$}, bind_values => [ 123 ], name => 'one variable', died => 0, }, { sql => q{<%= $variable %>}, variables => [ variable => 123 ], like => qr{^\?$}, bind_values => [ 123 ], name => 'one variable', died => 0, }, { sql => q{<%= $variable %>}, variables => [ variable => 123 ], like => qr{^\?$}, bind_values => [ 123 ], name => 'one variable (repeating call)', died => 0, }, { sql => q{<%== $variable %>}, variables => [ variable => 345 ], like => qr{^345$}, bind_values => [], name => 'immediatelly variable substitution', died => 0, }, { sql => q{<%== $variable %>}, variables => [], like => qr{^123$}, bind_values => [], name => 'immediatelly variable substitution', died => 1, die_like => qr{\$variable}, }, { sql => q{<% quote 'abc'; %>}, variables => [], like => qr{^\?$}, bind_values => ['abc'], name => 'Function quote', died => 0, }, { sql => q{<% quote 'русский'; %>}, variables => [], like => qr{^\?$}, bind_values => ['русский'], name => 'Function quote utf8', died => 0, }, { sql => q{<%= quote 'abc' %>}, variables => [], like => qr{^\?$}, bind_values => ['abc'], name => 'Function quote', died => 0, }, { sql => q{<% immediate 'cde'; %>}, variables => [], like => qr{^cde$}, bind_values => [], name => 'Function immediate', died => 0, }, { sql => q{<%= immediate 'cde' %>}, variables => [], like => qr{^cde$}, bind_values => [], name => 'Function immediate', died => 0, }, { sql => q{ % our $var = 987; %== $var }, variables => [], like => qr{^\s*987\s*$}, bind_values => [], name => 'uses our variable', died => 0, }, { sql => q{ % our $var; %= $var }, like => qr{^\s*\?\s*$}, variables => [], bind_values => [undef ], name => 'uses our variable again (clean_namespace)', }, { sql => q{ % test1 }, bind_values => ['this is a test helper'], name => 'helper "test"', like => qr{^\s*\?\s*}, }, { sql => q{ %= list @$ary }, variables => [ ary => [ 1, 2, 3 ] ], bind_values => [ 1, 2, 3], like => qr[^\s*\?(?:\,\?){2}\s*$], name => 'helper "list" (wrong include)', }, { sql => q{ % list @$ary }, variables => [ ary => [ 1, 2, 3 ] ], bind_values => [ 1, 2, 3], like => qr[^\s*\?(?:\,\?){2}\s*$], name => 'helper "list"', }, { sql => q{ % hlist @$ary }, variables => [ ary => [ { a => 1 }, { b => 2 }, { a => 3 } ] ], bind_values => [ 1, 2, 3], like => qr[^\s*\(\?\)(?:\,\(\?\)){2}\s*$], name => 'helper "hlist" - all values', }, { sql => q{ % hlist ['a'], @$ary }, variables => [ ary => [ { a => 1 }, { b => 2 }, { a => 3 } ] ], bind_values => [ 1, undef, 3], like => qr[^\s*\(\?\)(?:\,\(\?\)){2}\s*$], name => 'helper "hlist" - one key name', }, { sql => q{ % hlist ['a', 'b'], @$ary }, variables => [ ary => [ { a => 1 }, { b => 2 }, { a => 3 } ] ], bind_values => [ 1, undef, undef, 2, 3, undef ], like => qr[^\s*\(\?,\?\)(?:\,\(\?,\?\)){2}\s*$], name => 'helper "hlist" - a few key names', }, { sql => q{ %= hlist ['a', 'b'], @$ary }, variables => [ ary => [ { a => 1 }, { b => 2 }, { a => 3 } ] ], bind_values => [ 1, undef, undef, 2, 3, undef ], like => qr[^\s*\(\?,\?\)(?:\,\(\?,\?\)){2}\s*$], name => 'helper "hlist" - a few key names', }, { sql => q{ %== hlist ['a', 'b'], @$ary }, variables => [ ary => [ { a => 1 }, { b => 2 }, { a => 3 } ] ], bind_values => [ 1, undef, undef, 2, 3, undef ], like => qr[^\s*\(\?,\?\)(?:\,\(\?,\?\)){2}\s*$], name => 'helper "hlist" - a few key names', }, { sql => q{ % hlist ['a', 'b'], @$ary }, variables => [ ary => [ { a => 1 }, { b => 2 }, 12345 ] ], name => 'helper "hlist" - a few key names', died => 1, die_like => qr("12345"), }, { sql => q{ line 2 % unknown_function line 4 }, name => 'call for unknown_function', died => 1, die_like => qr{inline template line 3} } ); for my $t (@inline_tests) { my $res = eval { no warnings; $ph->sql_transform($t->{sql}, @{ $t->{variables} }) }; if ($t->{died}) { ok my $err = $@, 'Expected die was thrown: ' . ucfirst $t->{name}; SKIP: { skip "\$t->{die_like} was not noticed", 1 unless $t->{die_like}; like $err, $t->{die_like}, 'Died with expected message'; } next; } diag $@ unless ok $res, "Sql perform: " . ucfirst $t->{name}; SKIP: { skip '$t->{like} was not noticed', 1 unless $t->{like}; like $res->sql, $t->{like}, 'Result SQL'; }; is_deeply scalar $res->bind_values, $t->{bind_values}, 'Result bind_values'; } my $file = rel2abs catfile dirname($0), 'sql', 'usual_select.sql.ep'; my @file_tests = ( { file => 'usual_select', variables => [ id => 123 ], bind_values => [ 123 ], like => qr(id = \?) }, { file => $file, variables => [ id => 123 ], bind_values => [ 123 ], like => qr(id = \?) }, { file => 'usual_select', died => 1, die_like => qr("\$id"), }, { file => 'usual_select.sql.ep', variables => [ id => 123 ], bind_values => [ 123 ], like => qr(id = \?) }, { file => 'usual_select.sqlaep', died => 1, die_like => qr{\.sqlaep\.sql\.ep}, }, { file => 'include.sql.ep', variables => [ iid => 123 ], bind_values => [ 123, 123 ], like => qr(id = \?) }, { file => 'unknown_function.sql.ep', died => 1, die_like => qr{unknown_function\.sql\.ep line 3}, } ); for my $t (@file_tests) { $t->{variables} ||= []; my $res = eval { $ph->sql_transform(-f => $t->{file}, @{ $t->{variables} }) }; my $err = $@; ok $res || $t->{died}, 'Perform file: ' . $t->{file}; if ($t->{died}) { SKIP: { skip '$t->{die_like} is not defined', 1 unless $t->{die_like}; like $err, $t->{die_like}, 'Died with expected message'; } } else { diag $err if $err; SKIP: { skip "perform was died", 2 if $err; diag explain { bind_values => scalar $res->bind_values, expected_bind_values => $t->{bind_values} } unless is_deeply $t->{bind_values}, scalar $res->bind_values, 'Result bind_values'; skip '$t->{like} was not noticed', 1 unless $t->{like}; like $res->sql, $t->{like}, 'Result SQL'; } } } =head1 COPYRIGHT Copyright (C) 2011 Dmitry E. Oboukhov Copyright (C) 2011 Roman V. Nikolaev This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License. =cut libdbix-dr-perl-0.26/Changes0000664000000000000000000000343012234753463014425 0ustar rootrootRevision history for Perl extension DBIx::DR 0.01 Thu Oct 27 01:10:36 MSK 2011 - first public revision. 0.02 Thu Oct 27 01:29:36 MSK 2011 - support dr_sql_dir option. 0.03 Thu Oct 27 15:02:16 MSK 2011 - perldoc. - fix dr_get function. 0.04 Thu Oct 27 18:21:16 MSK 2011 - add indirect substitutions. 0.05 Mon Oct 31 11:40:17 MSK 2011 - add 'push' method in Iterator 0.11 Tue Nov 8 00:38:40 MSK 2011 - back-incompatible changes (bump version) - switches to perlish template - rewite documentation 0.12 Tue Nov 8 14:54:15 MSK 2011 - a few fixes in perldoc 0.14 Tue Dec 6 15:43:53 MSK 2011 - skip 0.13 version ;) - signals are passed more properly. - You can do typo <%= quote 'abc' %> instead <% quote 'abc'; %> but You can't use semicolon in the first case. - Some perldoc fixes. 0.15 Tue Dec 13 14:36:34 MSK 2011 - fix {}-brackets bug in SQL-body. 0.16 Thu Jan 26 12:08:00 MSK 2012 - fix multiline perl-blocks - add 'grep' function into iterator. 0.17 Wed Apr 25 15:56:57 MSK 2012 - add option 'dr_decode_errors' 0.18 Thu May 3 14:15:22 MSK 2012 - make debian package - fix hlist helper 0.19 Fri May 11 09:11:11 MSK 2012 - All files are licensed by Artistic. 0.20 Fri May 11 10:19:32 MSK 2012 - Add license term in Makefile.PL. - Add debian/watch. 0.21 Sun, 06 Jan 2013 02:32:19 +0400 - Add option '-die' for all requests. 0.22 Sun, 14 Apr 2013 21:06:22 +0400 - Add option '-warn' for all requests. 0.23 Sun, 14 Apr 2013 21:15:22 +0400 - Update perldoc. 0.24 Sat Aug 17 12:35:40 MSK 2013 - Fix iterator issue https://rt.cpan.org/Public/Bug/Display.html?id=87313 - Update metainformation 0.25 Wed Sep 25 17:24:00 MSK 2013 - Fix all warnings with Perl 5.18 libdbix-dr-perl-0.26/lib/0000775000000000000000000000000012072116522013665 5ustar rootrootlibdbix-dr-perl-0.26/lib/DBIx/0000775000000000000000000000000012234754232014461 5ustar rootrootlibdbix-dr-perl-0.26/lib/DBIx/DR/0000775000000000000000000000000012234754446014775 5ustar rootrootlibdbix-dr-perl-0.26/lib/DBIx/DR/Iterator.pm0000664000000000000000000002435612234754446017136 0ustar rootrootuse utf8; use strict; use warnings; package DBIx::DR::Iterator; use Scalar::Util qw(blessed weaken); use DBIx::DR::Util; use Carp; # Perl 5.18 refuses smartmatch my $is = sub($$) { my ($v1, $v2) = @_; return 0 if defined($v1) xor defined($v2); return 1 unless defined $v1; return $v1 eq $v2; }; sub new { my ($class, $fetch, %opts) = @_; my ($is_hash, $is_array) = (0, 0); my $count; if ('ARRAY' eq ref $fetch) { $is_array = 1; if ($count = @$fetch) { croak 'You must use array of hashrefs' unless 'HASH' eq ref $fetch->[0] or blessed $fetch->[0]; } } elsif ('HASH' eq ref $fetch) { $is_hash = 1; my ($k) = each %$fetch; if ($count = keys %$fetch) { croak 'You must use hash of hashrefs' unless 'HASH' eq ref $fetch->{$k} or blessed $fetch->{$k}; } } else { croak "You should bless 'HASHREF' or 'ARRAYREF' value"; } my ($item_class, $item_constructor) = camelize($opts{'-item'} || 'dbix-dr-iterator-item#new'); return bless { fetch => $fetch, is_hash => $is_hash, is_array => $is_array, count => $count, iterator => 0, item_class => $item_class, item_constructor => $item_constructor, is_changed => 0, noitem_iter => $opts{-noitem_iter} ? 1 : 0, } => ref($class) || $class; } sub is_changed { my ($self, $value) = @_; $self->{is_changed} = $value ? 1 : 0 if @_ > 1; return $self->{is_changed}; } sub count { my ($self) = @_; return $self->{count}; } sub reset { my ($self) = @_; $self->{iterator} = 0; keys %{ $self->{fetch} } if $self->{is_hash}; return; } sub next : method { my ($self) = @_; if ($self->{is_array}) { return $self->get($self->{iterator}++) if $self->{iterator} < $self->{count}; $self->{iterator} = 0; return; } my ($k) = each %{ $self->{fetch} }; return unless defined $k; return $self->get($k); } sub get { my ($self, $name) = @_; croak "Usage \$collection->get('name|number')" if @_ <= 1 or !defined($name); my $item; if ($self->{is_array}) { croak "Element number must be digit value" unless $name =~ /^\d+$/; croak "Element number is out of arraybound" if $name >= $self->{count} || $name < -$self->{count}; $item = $self->{fetch}[ $name ]; } else { croak "Key '$name' is not exists" unless exists $self->{fetch}{$name}; $item = $self->{fetch}{ $name }; } unless(blessed $item) { if (my $method = $self->{item_constructor}) { $item = $self->{item_class}->$method( $item, ( $self->{noitem_iter} ? () : $self ) ); } else { bless $item => $self->{item_class}; } } return $item; } sub exists { my ($self, $name) = @_; croak "Usage \$collection->exists('name|number')" if @_ <= 1 or !defined($name); if ($self->{is_array}) { croak "Element number must be digit value" unless $name =~ /^\d+$/; return 0 if $name >= $self->{count} || $name < -$self->{count}; return 1; } return exists($self->{fetch}{$name}) || 0; } sub all { my ($self, $field) = @_; return unless defined wantarray; my @res; if ($self->{is_array}) { for (my $i = 0; $i < @{ $self->{fetch} }; $i++) { push @res => $self->get($i); } } else { push @res => $self->get($_) for keys %{ $self->{fetch} }; } @res = map { $_->$field } @res if $field; return @res; } sub grep : method { my ($self, $key, $value) = @_; my $cb; if ('CODE' eq ref $key) { $cb = $key; } else { $cb = sub { $is->($_[0]->$key, $value) }; } my $obj; if ($self->{is_array}) { $obj = [ grep { $cb->($_) } $self->all ]; } else { $obj = { map {( $_ => $self->get($_) )} grep { $cb->( $self->get($_) ) } keys %{ $self->{fetch} } }; } return $self->new( $obj, -item => decamelize($self->{item_class}, $self->{item_constructor}) ); } sub first { my ($self) = @_; if ($self->{is_array}) { return ($self->{iterator} == 1) ? 1 : 0; } croak "'first' and 'last' methods aren't provided for hashiterators"; return; } sub last : method { my ($self) = @_; if ($self->{is_array}) { return ($self->{iterator} == $self->{count}) ? 1 : 0; } croak "'first' and 'last' methods aren't provided for hashiterators"; return; } sub push : method { my ($self, $k, $v) = @_; if ($self->{is_hash}) { croak 'Usage $it->push(key => $value)' unless @_ >= 3; croak 'Value is undefined' unless defined $v; croak "Value isn't HASHREF or object" unless 'HASH' eq ref $v or blessed $v; $self->{count}++ unless exists $self->{fetch}{$k}; $self->{fetch}{$k} = $v; $self->is_changed(1); return; } croak "Value isn't defined" unless defined $k; croak "Value isn't HASHREF or object" unless 'HASH' eq ref $k or blessed $k; push @{ $self->{fetch} }, $k; $self->{count}++; } sub find : method { my ($self, $field, $value) = @_; $self->reset; while(my $item = $self->next) { return $item if $is->($item->$field, $value); } return; } package DBIx::DR::Iterator::Item; use Scalar::Util (); use Carp (); # to exclude this method from AUTOLOAD sub DESTROY {} sub AUTOLOAD { our $AUTOLOAD; my ($method) = $AUTOLOAD =~ /.*::(.*)/; my ($self, $value) = @_; Carp::croak "Can't find method '$self->$method'" unless ref $self; Carp::croak "Can't find method '$method' in this item" unless exists $self->{$method}; if (@_ > 1) { my $is_changed; if (ref $value and ref $self->{$method}) { $is_changed = Scalar::Util::refaddr($value) != Scalar::Util::refaddr($self->{$method}); } elsif(ref($value) ne ref($self->{$method})) { $is_changed = 1; } elsif(defined $value and defined $self->{$method}) { $is_changed = $value ne $self->{$method}; } elsif(defined $value xor defined $self->{$method}) { $is_changed = 1; } $self->is_changed(1) if $is_changed; $self->{$method} = $value; } return $self->{$method}; } sub new { my ($class, $object, $iterator) = @_; return unless defined $object; Carp::croak "Usage: DBIx::DR::Iterator::Item->new(HASHREF [, iterator ])" unless 'HASH' eq ref $object; my $self = bless $object => ref($class) || $class; $self->{iterator} = $iterator; Scalar::Util::weaken($self->{iterator}); $self->{is_changed} = 0; return $self; } sub is_changed { my ($self, $value) = @_; if (@_ > 1) {{ $self->{is_changed} = $value ? 1 : 0; last unless $self->{is_changed}; last unless Scalar::Util::blessed $self->{iterator}; last unless $self->{iterator}->can('is_changed'); $self->{iterator}->is_changed( 1 ); }} return $self->{is_changed}; } sub can { my ($self, $method) = @_; return 1 if ref $self and exists $self->{$method}; return $self->SUPER::can($method); } 1; =head1 NAME DBIx::DR::Iterator - iterator for L. =head1 SYNOPSIS my $it = DBIx::DR::Iterator->new($arrayref); printf "Rows count: %d\n", $it->count; while(my $row == $it->next) { print "Row: %s\n", $row->field; } my $row = $it->get(15); # element 15 my $it = DBIx::DR::Iterator->new($hashref); printf "Rows count: %d\n", $it->count; while(my $row == $it->next) { print "Row: %s\n", $row->field; } my $row = $it->get('abc'); # element with key name eq 'abc' =head1 DESCRIPTION The package constructs iterator from HASHREF or ARRAYREF value. =head1 Methods =head2 new Constructor. my $i = DBIx::DR::Iterator->new($arrayset [, OPTIONS ]); Where B are: =over =item -item => 'decamelized_obj_define'; It will bless (or construct) row into specified class. See below. By default it constructs L objects. =back =head2 count Returns count of elements. =head2 is_changed Returns (or set) flag that one of contained elements was changed. =head2 exists(name|number) Returns B if element 'B' is exists. =head2 get(name|number) Returns element by 'B'. It will throw exception if element isn't L. =head2 next Returns next element or B. =head2 reset Resets internal iterator (that is used by L). =head2 all Returns all elements (as an array). If You notice an argument it will extract specified fields: my @ids = $it->all('id'); The same as: my @ids = map { $_->id } $it->all; =head2 grep Constructs new iterator that is subset of parent iterator. my $busy = $list->grep(sub { $_[0]->busy ? 1 : 0 }); =head2 push Pushes one element into iterator. If You use HASH-iterator You have to note key name. =head3 Example $hiter->push(abc => { id => 1 }); $hiter->push(abc => $oiter->get('abc')); $aiter->push({ id => 1 }); =head1 DBIx::DR::Iterator::Item One row. It has methods names coincident with field names. Also it has a few additional methods: =head2 new Constructor. Receives two arguments: B and link to L. my $row = DBIx::DR::Iterator::Item->new({ id => 1 }); $row = DBIx::DR::Iterator::Item->new({ id => 1 }, $iterator); } =head2 iterator Returns (or set) iterator object. The link is created by constructor. This is a L link. =head2 is_changed Returns (or set) flag if the row has been changed. If You change any of row's fields the flag will be set. Also iterator's flag will be set. =head1 COPYRIGHT Copyright (C) 2011 Dmitry E. Oboukhov Copyright (C) 2011 Roman V. Nikolaev This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License. =cut libdbix-dr-perl-0.26/lib/DBIx/DR/PerlishTemplate.pm0000664000000000000000000001730112234753463020435 0ustar rootrootuse utf8; use strict; use warnings; package DBIx::DR::PerlishTemplate; use Mouse; use Carp; use Scalar::Util; use DBIx::DR::ByteStream; has line_tag => (is => 'rw', isa => 'Str', default => '%'); has open_tag => (is => 'rw', isa => 'Str', default => '<%'); has close_tag => (is => 'rw', isa => 'Str', default => '%>'); has quote_mark => (is => 'rw', isa => 'Str', default => '='); has immediate_mark => (is => 'rw', isa => 'Str', default => '=='); has sql => (is => 'ro', isa => 'Str', default => ''); has variables => (is => 'ro', isa => 'ArrayRef'); has template => (is => 'rw', isa => 'Str', default => ''); has template_file => (is => 'rw', isa => 'Str', default => ''); has utf8_open => (is => 'rw', isa => 'Bool', default => 1); has stashes => (is => 'ro', isa => 'ArrayRef'); has pretokens => (is => 'ro', isa => 'ArrayRef'); has prepretokens => (is => 'ro', isa => 'ArrayRef'); has parsed_template => (is => 'ro', isa => 'Str', default => ''); has namespace => (is => 'rw', isa => 'Str', default => 'DBIx::DR::PerlishTemplate::Sandbox'); sub _render { my ($_PTPL) = @_; my $_PTSUB; unless ($_PTPL->parsed_template) { $_PTSUB = $_PTPL->{parsed_template} = $_PTPL->_parse; } else { $_PTSUB = $_PTPL->parsed_template; } $_PTPL->{parsed_template} = $_PTSUB; my $esub = eval $_PTSUB; if (my $e = $@) { my $do_croak; my $template; if ($_PTPL->template_file) { $template = $_PTPL->template_file; } else { $do_croak = 1; $template = 'inline template'; }; $e =~ s{ at .*?line (\d+)(\.\s*|,\s+.*?)?$} [" at $template line " . ( $1 - $_PTPL->pre_lines )]gsme; if ($1) { $e =~ s/\s*$/\n/g; die $e unless $do_croak; croak $e; } croak "$e at $template"; } $_PTPL->{sql} = ''; $_PTPL->{variables} = []; $esub->( @{ $_PTPL->stashes } ); 1; } sub render { my ($self, $tpl, @args) = @_; $self->{parsed_template} = ''; $self->template($tpl); $self->template_file(''); $self->{stashes} = \@args; $self->clean_namespace; return $self->_render; } sub render_file { my ($self, $file, @args) = @_; croak "File '@{[ $file // 'undef' ]}' not found or readable" unless -r $file; open my $fh, '<', $file; my $data; { local $/; $data = <$fh> } $self->{parsed_template} = ''; $self->template_file($file); $self->template($data); $self->{stashes} = \@args; $self->clean_namespace; return $self->_render; } sub clean_prepends { my ($self) = @_; $self->{pretokens} = []; $self; } sub clean_preprepends { my ($self) = @_; $self->{prepretokens} = []; $self; } sub immediate { my ($self, $str) = @_; if (Scalar::Util::blessed $str) { if ('DBIx::DR::ByteStream' eq Scalar::Util::blessed $str) { $self->{sql} .= $str->content; } elsif ($str->can('content')) { $self->{sql} .= $str->content; } else { croak "Can't extract content from " . Scalar::Util::blessed $str; } } else { $self->{sql} .= $str; } return DBIx::DR::ByteStream->new(''); } sub add_bind_value { my ($self, @values) = @_; push @{ $self->variables } => @values; } sub quote { my ($self, $variable) = @_; if (Scalar::Util::blessed $variable) { return $self->immediate($variable) if 'DBIx::DR::ByteStream' eq Scalar::Util::blessed $variable; } $self->{sql} .= '?'; $self->add_bind_value($variable); return DBIx::DR::ByteStream->new(''); } sub _parse_token { my ($self, $tpl, $prev) = @_; my $line_tag = quotemeta $self->line_tag; my $open_tag = quotemeta $self->open_tag; my $close_tag = quotemeta $self->close_tag; my $prev_eol = $prev =~ /\n\s*\z/s; if ($tpl =~ s{$open_tag(.*?)$close_tag}{}s) { return { type => 'text', content => $` }, { type => 'perl', content => $1 }, { type => 'text', content => $' } ; } if ($tpl =~ s{^(\s*)$line_tag(.+?)$}{}sm) { return { type => 'text', content => $` . $1 }, { type => 'perl', content => $2, line => 1 }, { type => 'text', content => $' } # if length $` or $prev_eol; # warn "aaaaaaaaaaaaaaaaaaaaaaaaaaaaa"; # return # { type => 'text', content => $1 }, # { type => 'text', content => "$line_tag$2$$'" } # ; } return { type => 'text', content => $tpl, text_only => 1, } } sub _put_token { my ($self, $token, $next_token) = @_; my $content = $token->{content}; my $variable; if ($token->{type} eq 'text') { $content =~ s/'/\\'/g; return "immediate('" . $content . "');"; } my $eot = $token->{line} ? "\n" : ''; my $immediate_mark = quotemeta $self->immediate_mark; my $quote_mark = quotemeta $self->quote_mark; if ($content =~ /^$immediate_mark/) { $content = substr $content, length $self->immediate_mark; return 'immediate(' . $content . ");$eot"; } if ($content =~ /^$quote_mark/) { $content = substr $content, length $self->quote_mark; return 'quote(' . $content . ");$eot"; } return "$content;$eot" if !$next_token or $next_token->{type} ne 'perl'; return $content . $eot; } sub _parse { my ($self) = @_; my @tokens = { type => 'text', content => $self->template }; while(1) { my $found_token = 0; for (reverse 0 .. $#tokens) { next unless $tokens[$_]{type} eq 'text'; next if $tokens[$_]{text_only}; my @t = $self->_parse_token($tokens[$_]{content}, $_ ? $tokens[$_ - 1]{content} : "\n" ); next if @t == 1; splice @tokens, $_, 1, grep { length $_->{content} } @t; $found_token = 1; } last unless $found_token; } my $sub = join "" => map { $self->_put_token($tokens[$_], $_ == $#tokens ? undef : $tokens[$_ + 1]) } 0 .. $#tokens; return join '', 'package ', $self->namespace, ';', 'BEGIN { ', '*quote = sub { $_PTPL->quote(@_) };', '*immediate = sub { $_PTPL->immediate(@_) };', '};', $self->preprepend, 'sub {', $self->prepend, $sub, '}'; } sub preprepend { my ($self, @tokens) = @_; $self->{prepretokens} ||= []; push @{ $self->prepretokens } => map "$_;\n", @tokens if @tokens; return join '' => @{ $self->prepretokens } if defined wantarray; } sub prepend { my ($self, @tokens) = @_; $self->{pretokens} ||= []; push @{ $self->pretokens } => map "$_;", @tokens if @tokens; return join '' => @{ $self->pretokens } if defined wantarray; } sub pre_lines { my ($self) = @_; my $lines = 0; $lines += @{[ /\n/g ]} for ($self->preprepend, $self->prepend); return $lines; } sub clean_prepend { my ($self) = shift; $self->{pretokens} = []; } sub clean_namespace { my ($self) = @_; my $sb = $self->namespace; no strict 'refs'; undef *{$sb . '::' . $_} for keys %{ $sb . '::' }; } 1; =head1 NAME DBIx::DR::PerlishTemplate - template engine for L. =head1 COPYRIGHT Copyright (C) 2011 Dmitry E. Oboukhov Copyright (C) 2011 Roman V. Nikolaev This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License. =cut libdbix-dr-perl-0.26/lib/DBIx/DR/ByteStream.pm0000644000000000000000000000134212072116522017373 0ustar rootrootuse utf8; use strict; use warnings; package DBIx::DR::ByteStream; =head1 NAME DBIx::DR::ByteStream - ByteStream =head1 SYNOPSIS use DBIx::DR::ByteStream; my $str = DBIx::DR::ByteStream->new('abc'); print "%s\n", $str->content; =head1 METHODS =head2 new Constructor. =head2 content Returns content. =cut sub new { my ($class, $str) = @_; return bless \$str => ref($class) || $class; } sub content { my ($self) = @_; return $$self; } =head1 COPYRIGHT Copyright (C) 2011 Dmitry E. Oboukhov Copyright (C) 2011 Roman V. Nikolaev This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License. =cut 1; libdbix-dr-perl-0.26/lib/DBIx/DR/PlPlaceHolders.pm0000644000000000000000000001322712072116522020162 0ustar rootrootuse utf8; use strict; use warnings; package DBIx::DR::PlPlaceHolders; use Mouse; extends 'DBIx::DR::PerlishTemplate'; use DBIx::DR::ByteStream; use Carp (); use File::Spec (); use Digest::MD5 (); use Encode qw(encode); has sql_dir => (is => 'bare', isa => 'Str'); has file_suffix => (is => 'rw', isa => 'Str', default => '.sql.ep'); has helpers => (is => 'ro', isa => 'HashRef', default => sub {{}}); sub sql_dir { my ($self, $dir) = @_; if (defined $dir) { Carp::croak "Diectory $dir is not found or a dir" unless -d $dir; $self->{sql_dir} = File::Spec->rel2abs($dir); } elsif(@_ >= 2) { $self->{sql_dir} = undef; } return $self->{sql_dir}; } sub BUILD { my ($self) = @_; # add default helpers $self->set_helper( include => sub { my ($tpl, $file, @args) = @_; my $res = ref($self)->new( pretokens => $self->prepretokens, prepretokens => $self->prepretokens, helpers => $self->helpers, sql_dir => $self->sql_dir, file_suffix => $self->file_suffix, )->sql_transform( -f => $file, @args ); $tpl->immediate($res->sql); $tpl->add_bind_value($res->bind_values); return DBIx::DR::ByteStream->new(''); }, list => sub { my ($tpl, @args) = @_; $tpl->immediate(join ',' => map '?', @args); $tpl->add_bind_value(@args); return DBIx::DR::ByteStream->new(''); }, hlist => sub { my ($tpl, @args) = @_; if ('ARRAY' eq ref $args[0]) { my $filter = shift @args; $tpl->immediate( join ',' => ( '(' . join(',' => ('?')x @$filter) . ')' )x @args ); for my $a (@args) { $tpl->add_bind_value( map { $a->{$_} } @$filter ); } return DBIx::DR::ByteStream->new(''); } $tpl->immediate( join ',' => map { '(' . join(',' => ('?') x keys %$_) . ')' } @args ); $tpl->add_bind_value(map { values %$_ } @args); return DBIx::DR::ByteStream->new(''); }, ); $self; } sub sql_transform { my $self = shift; my ($sql, %opts); my $pt; if (@_ % 2) { ($sql, %opts) = @_; delete $opts{-f}; } else { %opts = @_; Carp::croak $self->usage unless $opts{-f}; my $file = $opts{-f}; $file = File::Spec->catfile($self->sql_dir, $file) if $self->sql_dir and $file !~ m{^/}; my $resuffix = quotemeta $self->file_suffix; $file .= $self->file_suffix if $self->file_suffix and $file !~ /$resuffix$/; my @fstat = stat $file; Carp::croak "Can't find file $file" unless @fstat; $opts{-f} = $file; } my $namespace = $opts{-f} || $sql; $namespace = encode utf8 => $namespace if utf8::is_utf8($namespace); $namespace = Digest::MD5::md5_hex($namespace); $self->{namespace} = __PACKAGE__ . '::Sandbox::t' . $namespace; $self -> clean_prepends -> clean_preprepends ; for my $name (keys %{ $self->helpers }) { $self->preprepend( 'BEGIN{ ' . "*" . $name . '= sub {' . '$_PTPL->call_helper(q{' . $name . '}, @_)' . '} ' . '}' ); } my @args; for (keys %opts) { next unless /^\w/; $self->prepend("my \$$_ = shift"); push @args, $opts{$_}; } if ($sql) { $self->render($sql, @args); } else { $self->render_file($opts{-f}, @args); } my $res = DBIx::DR::PlPlaceHolders::TransformResult->new(rtemplate => $self); # clean memory $self->{sql} = ''; $self->{variables} = []; $res; } sub call_helper { my ($self, $name, @args) = @_; Carp::croak "Helper '$name' is not found or has already been removed" unless exists $self->helpers->{ $name }; $self->helpers->{ $name }->($self, @args); } sub set_helper { my ($self, %opts) = @_; Carp::croak $self->usage unless %opts; while (my ($n, $s) = each %opts) { Carp::croak $self->usage unless 'CODE' eq ref $s and $n =~ /^\w/; $self->helpers->{ $n } = $s ; } $self; } sub usage { my ($self) = @_; my @caller = caller 1; return 'Usage: $ph->sql_transform($sql | -f => $sql_file, ...)' if $caller[3] =~ /sql_transform$/; return 'Usage: $ph->set_helper($name => sub { ... })' if $caller[3] =~ /set_helper$/; return $caller[3]; } package DBIx::DR::PlPlaceHolders::TransformResult; use Mouse; has rtemplate => (is => 'ro', isa => 'Object', weak_ref => 1); has sql => (is => 'ro', isa => 'Str'); sub BUILD { my ($self) = @_; $self->{sql} = $self->rtemplate->sql; $self->{bind_values} = $self->rtemplate->variables; } sub bind_values { my ($self) = @_; return @{ $self->{bind_values} } if wantarray; return $self->{bind_values} || []; } 1; =head1 NAME DBIx::DR::PlPlaceHolders - template converter for L. =head1 COPYRIGHT Copyright (C) 2011 Dmitry E. Oboukhov Copyright (C) 2011 Roman V. Nikolaev This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License. =cut libdbix-dr-perl-0.26/lib/DBIx/DR/Util.pm0000644000000000000000000000172012072116522016231 0ustar rootrootuse utf8; use strict; use warnings; package DBIx::DR::Util; use base qw(Exporter); our @EXPORT = qw(camelize decamelize); sub camelize($) { my ($str) = @_; my ($module, $method) = split /#/, $str; $module = join '', map { ucfirst } split /_/, join '::' => map { ucfirst lc } split /-/ => $module; $module =~ s/dbix::dr::/DBIx::DR::/i; return ($module, $method); } sub decamelize($;$) { my ($class, $constructor) = @_; for ($class) { s/(?. =head1 COPYRIGHT Copyright (C) 2011 Dmitry E. Oboukhov Copyright (C) 2011 Roman V. Nikolaev This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License. =cut libdbix-dr-perl-0.26/lib/DBIx/DR.pm0000664000000000000000000002666012234754232015336 0ustar rootrootuse utf8; use strict; use warnings; use DBIx::DR::Iterator; use DBIx::DR::Util (); use DBIx::DR::PlPlaceHolders; package DBIx::DR; our $VERSION = '0.26'; use base 'DBI'; use Carp; $Carp::Internal{ (__PACKAGE__) } = 1; sub connect { my ($class, $dsn, $user, $auth, $attr) = @_; my $dbh = $class->SUPER::connect($dsn, $user, $auth, $attr); $attr = {} unless ref $attr; $dbh->{"private_DBIx::DR_iterator"} = $attr->{dr_iterator} || 'dbix-dr-iterator#new'; $dbh->{"private_DBIx::DR_item"} = $attr->{dr_item} || 'dbix-dr-iterator-item#new'; $dbh->{"private_DBIx::DR_sql_dir"} = $attr->{dr_sql_dir}; $dbh->{"private_DBIx::DR_template"} = DBIx::DR::PlPlaceHolders->new( sql_dir => $attr->{dr_sql_dir}, ); $dbh->{"private_DBIx::DR_dr_decode_errors"} = $attr->{dr_decode_errors}; return $dbh; } package DBIx::DR::st; use base 'DBI::st'; use Carp; $Carp::Internal{ (__PACKAGE__) } = 1; package DBIx::DR::db; use Encode qw(decode encode); use base 'DBI::db'; use DBIx::DR::Util; use File::Spec::Functions qw(catfile); use Carp; $Carp::Internal{ (__PACKAGE__) } = 1; sub set_helper { my ($self, %opts) = @_; $self->{"private_DBIx::DR_template"}->set_helper(%opts); } sub _dr_extract_args_ep { my $self = shift; my (@sql, %args); if (@_ % 2) { ($sql[0], %args) = @_; delete $args{-f}; } else { %args = @_; } croak "SQL wasn't defined" unless @sql or $args{-f}; my ($iterator, $item); unless ($args{-noiterator}) { $iterator = $args{-iterator} || $self->{'private_DBIx::DR_iterator'}; croak "Iterator class was not defined" unless $iterator; unless($args{-noitem}) { $item = $args{-item} || $self->{'private_DBIx::DR_item'}; croak "Item class was not definded" unless $item; } } 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; } =head1 DESCRIPTION The package I L and allows You: =over =item * to use perl inside Your SQL requests; =item * to bless resultsets into Your package; =item * to place Your SQL's into dedicated directory; =item * to use usual L methods. =back =head1 Additional 'L' options. =head2 dr_iterator A string describes iterator class. Default value is 'B' (decamelized string). =head2 dr_item A string describes item (one row) class. Default value is 'B' (decamelized string). =head2 dr_sql_dir Directory path to seek sql files (If You use dedicated SQLs). =head2 dr_decode_errors Decode database errors into utf-8 =head1 METHODS All methods can receive the following arguments: =over =item -f => $sql_file_name It will load SQL-request from file. It will seek file in directory that was defined in L param of connect. You needn't to use suffixes (B<.sql.ep>) here, but You can. =item -item => 'decamelized_obj_define' It will bless (or construct) row into specified class. See below. Default value defined by L argument of B. =item -noitem Do not bless row into any class. =item -iterator => 'decamelized_obj_define' It will bless (or construct) rowset into specified class. Default value defined by L argument of B. =item -noiterator Do not bless rowset into any class. =item -dbi => HASHREF Additional DBI arguments. =item -hash => FIELDNAME Selects into HASH. Iterator will operate by names (not numbers). =item -die => 0|1 If B the method will die with SQL-request. =item -warn => 0|1 If B the method will warn with SQL-request. =back =head2 Decamelized strings Are strings that represent class [ and method ]. foo_bar => FooBar foo_bar#subroutine => FooBar->subroutine foo_bar-baz => FooBar::Baz =head2 perform Does SQL-request like 'B', 'B', etc. $dbh->perform($sql, value => 1, other_value => 'abc'); $dbh->perform(-f => $sql_file_name, value => 1, other_value => 'abc'); =head2 select Does SQL-request, pack results into iterator class. By default it uses L class. my $res = $dbh->select(-f => $sql_file_name, value => 1); while(my $row = $res->next) { printf "RowId: %d, RowValue: %s\n", $row->id, $row->value; } my $row = $row->get(15); # row 15 my $res = $dbh->select(-f => $sql_file_name, value => 1, -hash => 'name'); while(my $row = $res->next) { printf "RowId: %d, RowName: %s\n", $row->id, $row->name; } my $row = $row->get('Vasya'); # row with name eq 'Vasya' =head2 single Does SQL-request that returns one row. Pack results into item class. Does SQL-request, pack results (one row) into item class. By default it uses L class. =head1 Template language You can use perl inside Your SQL requests: % my $foo = 1; % my $bar = 2; <% my $foo_bar = $foo + $bar %> .. % use POSIX; % my $gid = POSIX::getgid; There are two functions available inside perl: =head2 quote Replaces argument to 'B', add argument value into bindlist. You can also use shortcut 'B<=>' instead of the function. B SELECT * FROM tbl WHERE id = <% quote $id %> B SELECT * FROM tbl WHERE id = ? and B will contain B value. If You use L in place of string the function will recall L function. B SELECT * FROM tbl WHERE id = <%= $id %> =head2 immediate Replaces argument to its value. You can also use shortcut 'B<==>' instead of the function. B SELECT * FROM tbl WHERE id = <% immediate $id %> B SELECT * FROM tbl WHERE id = 123 Where 123 is B value. Be carful! Using the operator You can produce code that will be amenable to SQL-injection. B SELECT * FROM tbl WHERE id = <%== $id %> =head1 Helpers There are a few default helpers. =head2 list Expands array into Your SQL request. =head3 Example SELECT * FROM tbl WHERE status IN (<% list @$ids %>) =head4 Result SELECT * FROM tbl WHERE status IN (?,?,? ...) and B will contain B values. =head2 hlist Expands array of hash into Your SQL request. The first argument can be a list of required keys. Places each group into brackets. =head3 Example INSERT INTO tbl ('a', 'b') VALUES <% hlist ['a', 'b'] => @$inserts =head4 Result INSERT INTO tbl ('a', 'b') VALUES (?, ?), (?, ?) ... and B will contain all B values. =head2 include Includes the other SQL-part. =head3 Example % include 'other_sql', argument1 => 1, argument2 => 2; =head1 User's helpers You can add Your helpers using method L. =head2 set_helper Sets (or replaces) helpers. $dbh->set_helper(foo => sub { ... }, bar => sub { ... }); Each helper receives template object as the first argument. Examples: $dbh->set_helper(foo_AxB => sub { my ($tpl, $a, $b) = @_; $tpl->quote($a * $b); }); You can use L and L functions inside Your helpers. If You want use the other helper inside Your helper You have to do that by Yourself. To call the other helper You can also use C<< $tpl->call_helper >> function. =head3 call_helper $dbh->set_helper( foo => sub { my ($tpl, $a, $b) = @_; $tpl->quote('foo' . $a . $b); }, bar => sub { my $tpl = shift; $tpl->call_helper(foo => 'b', 'c'); } ); =head1 COPYRIGHT Copyright (C) 2011 Dmitry E. Oboukhov Copyright (C) 2011 Roman V. Nikolaev This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License. =head1 VCS The project is placed git repo on github: L =cut libdbix-dr-perl-0.26/MANIFEST0000664000000000000000000000076612234753437014275 0ustar rootrootChanges debian/changelog debian/compat debian/control debian/copyright debian/rules debian/watch lib/DBIx/DR/ByteStream.pm lib/DBIx/DR/Iterator.pm lib/DBIx/DR/PerlishTemplate.pm lib/DBIx/DR/PlPlaceHolders.pm lib/DBIx/DR.pm lib/DBIx/DR/Util.pm Makefile.PL MANIFEST t/000-dr-iterator.t t/010-dr-perl-ish-template.t t/015-dr-pl-placeholders.t t/020-util.t t/035-dr.t t/benchmarks/01_transform.pl t/sql/include.sql.ep t/sql/select_ids.sql.ep t/sql/unknown_function.sql.ep t/sql/usual_select.sql.ep LICENSE libdbix-dr-perl-0.26/LICENSE0000644000000000000000000001373712072116522014135 0ustar rootroot The "Artistic License" Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder as specified below. "Copyright Holder" is whoever is named in the copyright or copyrights for the package. "You" is you, if you're thinking about copying or distributing this Package. "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as uunet.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) give non-standard executables non-standard names, and clearly document the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. You may embed this Package's interpreter within an executable of yours (by linking); this shall be construed as a mere form of aggregation, provided that the complete Standard Version of the interpreter is so embedded. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whoever generated them, and may be sold commercially, and may be aggregated with this Package. If such scripts or library files are aggregated with this Package via the so-called "undump" or "unexec" methods of producing a binary executable image, then distribution of such an image shall neither be construed as a distribution of this Package nor shall it fall under the restrictions of Paragraphs 3 and 4, provided that you do not represent such an executable image as a Standard Version of this Package. 7. C subroutines (or comparably compiled subroutines in other languages) supplied by you and linked into this Package in order to emulate subroutines and variables of the language defined by this Package shall not be considered part of this Package, but are the equivalent of input as in Paragraph 6, provided these subroutines do not change the language in any way that would cause it to fail the regression tests for the language. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End libdbix-dr-perl-0.26/README.pod0000777000000000000000000000000012072116522016752 2lib/DBIx/DR.pmustar rootroot