packing ・ 019d4dd ・ Gitprep

- packing;
- Browse files
- yuki-kimoto commited on 2009-11-12
- 1 parent 8eeaa6b
  
  commit 019d4dd59254624a4d3d28fe0fe379a6c2f5bf84

Showing 83 changed files with 3305 additions and 0 deletions

.gitignore → DBIx-Custom-Basic/.gitignore

File renamed without changes.

+23

DBIx-Custom-Basic/Build.PL

...	...	@@ -0,0 +1,23 @@
	1	+use strict;
	2	+use warnings;
	3	+use Module::Build;
	4	+
	5	+my $builder = Module::Build->new(
	6	+ module_name => 'DBIx::Custom::Basic',
	7	+ license => 'perl',
	8	+ dist_author => 'Yuki Kimoto <kimoto.yuki@gmail.com>',
	9	+ dist_version_from => 'lib/DBIx/Custom/Basic.pm',
	10	+ build_requires => {
	11	+ 'Test::More' => 0,
	12	+ },
	13	+ requires => {
	14	+ 'DBIx::Custom' => 0.0101
	15	+ },
	16	+ recommends => {
	17	+ 'Time::Piece' => 1.15
	18	+ },
	19	+ add_to_cleanup => [ 'DBIx-Custom-Basic-*' ],
	20	+ create_makefile_pl => 'traditional',
	21	+);
	22	+
	23	+$builder->create_build_script();

DBIx-Custom-Basic/Changes

View

...	...	@@ -0,0 +1,2 @@
	1	+0.0101
	2	+ First release

MANIFEST.SKIP → DBIx-Custom-Basic/MANIFEST.SKIP

View

File renamed without changes.

+15

DBIx-Custom-Basic/README

View

...	...	@@ -0,0 +1,15 @@
	1	+DBIx-Custom-Basic
	2	+
	3	+DBIx::Custom basic implementation
	4	+
	5	+INSTALLATION
	6	+
	7	+cpan DBIx::Custom::Basic
	8	+
	9	+COPYRIGHT AND LICENCE
	10	+
	11	+Copyright (C) 2009 Yuki Kimoto
	12	+
	13	+This program is free software; you can redistribute it and/or modify it
	14	+under the same terms as Perl itself.
	15	+

+52

DBIx-Custom-Basic/lib/DBIx/Custom/Basic.pm

View

...	...	@@ -0,0 +1,52 @@
	1	+package DBIx::Custom::Basic;
	2	+use base 'DBIx::Custom';
	3	+use Encode qw/decode encode/;
	4	+
	5	+use warnings;
	6	+use strict;
	7	+
	8	+our $VERSION = '0.0101';
	9	+
	10	+my $class = __PACKAGE__;
	11	+
	12	+$class->add_filter(
	13	+ default_bind_filter => sub { encode('UTF-8', $_[1]) },
	14	+ default_fetch_filter => sub { decode('UTF-8', $_[1]) }
	15	+);
	16	+
	17	+$class->bind_filter($class->filters->{default_bind_filter});
	18	+$class->fetch_filter($class->filters->{default_fetch_filter});
	19	+
	20	+$class->add_format(
	21	+ 'SQL99_date' => '%Y-%m-%d',
	22	+ 'SQL99_datetime' => '%Y-%m-%d %H:%M:%S',
	23	+ 'SQL99_time' => '%H:%M:%S',
	24	+ 'ISO-8601_date' => '%Y-%m-%d',
	25	+ 'ISO-8601_datetime' => '%Y-%m-%dT%H:%M:%S',
	26	+ 'ISO-8601_time' => '%H:%M:%S',
	27	+);
	28	+
	29	+1;
	30	+
	31	+=head1 NAME
	32	+
	33	+DBIx::Custom::Basic - DBIx::Custom basic class
	34	+
	35	+=head1 VERSION
	36	+
	37	+Version 0.0101
	38	+
	39	+=head1 AUTHOR
	40	+
	41	+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >>
	42	+
	43	+Github L<http://github.com/yuki-kimoto>
	44	+
	45	+=head1 COPYRIGHT & LICENSE
	46	+
	47	+Copyright 2009 Yuki Kimoto, all rights reserved.
	48	+
	49	+This program is free software; you can redistribute it and/or modify it
	50	+under the same terms as Perl itself.
	51	+
	52	+=cut

DBIx-Custom-Basic/t/00-load.t

View

...	...	@@ -0,0 +1,9 @@
	1	+#!perl -T
	2	+
	3	+use Test::More tests => 1;
	4	+
	5	+BEGIN {
	6	+ use_ok( 'DBIx::Custom::Basic' );
	7	+}
	8	+
	9	+diag( "Testing DBIx::Custom::Basic $DBIx::Custom::Basic::VERSION, Perl $], $^X" );

+60

DBIx-Custom-Basic/t/01-sqlite.t

View

...	...	@@ -0,0 +1,60 @@
	1	+use Test::More;
	2	+use strict;
	3	+use warnings;
	4	+use utf8;
	5	+use Encode qw/decode encode/;
	6	+
	7	+BEGIN {
	8	+ eval { require DBD::SQLite; 1 }
	9	+ or plan skip_all => 'DBD::SQLite required';
	10	+ eval { DBD::SQLite->VERSION >= 1 }
	11	+ or plan skip_all => 'DBD::SQLite >= 1.00 required';
	12	+
	13	+ plan 'no_plan';
	14	+ use_ok('DBIx::Custom');
	15	+}
	16	+
	17	+# Function for test name
	18	+my $test;
	19	+sub test {
	20	+ $test = shift;
	21	+}
	22	+
	23	+# Constant varialbes for test
	24	+my $CREATE_TABLE = {
	25	+ 0 => 'create table table1 (key1 char(255), key2 char(255));',
	26	+ 1 => 'create table table1 (key1 char(255), key2 char(255), key3 char(255), key4 char(255), key5 char(255));',
	27	+ 2 => 'create table table2 (key1 char(255), key3 char(255));'
	28	+};
	29	+
	30	+my $SELECT_TMPL = {
	31	+ 0 => 'select * from table1;'
	32	+};
	33	+
	34	+my $DROP_TABLE = {
	35	+ 0 => 'drop table table1'
	36	+};
	37	+
	38	+my $NEW_ARGS = {
	39	+ 0 => {data_source => 'dbi:SQLite:dbname=:memory:'}
	40	+};
	41	+
	42	+# Variables for test
	43	+my $dbi;
	44	+my $decoded_str;
	45	+my $encoded_str;
	46	+my $array;
	47	+
	48	+use DBIx::Custom::Basic;
	49	+
	50	+test 'Filter';
	51	+$dbi = DBIx::Custom::Basic->new($NEW_ARGS->{0});
	52	+ok($dbi->filters->{default_bind_filter}, "$test : exists default_bind_filter");
	53	+ok($dbi->filters->{default_fetch_filter}, "$test : exists default_fetch_filter");
	54	+is($dbi->bind_filter, $dbi->filters->{default_bind_filter}, 'default bind filter');
	55	+is($dbi->fetch_filter, $dbi->filters->{default_fetch_filter}, 'default fetch filter');
	56	+
	57	+$decoded_str = 'あ';
	58	+$encoded_str = $dbi->bind_filter->('', $decoded_str);
	59	+is($encoded_str, encode('UTF-8', $decoded_str), 'encode utf8');
	60	+is($decoded_str, $dbi->fetch_filter->('', $encoded_str), "$test : fetch_filter");

+64

DBIx-Custom-Basic/t/02-time_format.t

View

...	...	@@ -0,0 +1,64 @@
	1	+use Test::More;
	2	+use strict;
	3	+use warnings;
	4	+
	5	+BEGIN {
	6	+ eval { require Time::Piece; 1 }
	7	+ or plan skip_all => 'Time::Piece required';
	8	+
	9	+ plan 'no_plan';
	10	+ use_ok('DBIx::Custom');
	11	+}
	12	+
	13	+# Function for test name
	14	+my $test;
	15	+sub test {
	16	+ $test = shift;
	17	+}
	18	+
	19	+# Varialbe for tests
	20	+
	21	+my $format;
	22	+my $data;
	23	+my $timepiece;
	24	+my $dbi;
	25	+
	26	+use DBIx::Custom::Basic;
	27	+
	28	+
	29	+test 'SQL99 format';
	30	+$dbi = DBIx::Custom::Basic->new;
	31	+$data = '2009-01-02 03:04:05';
	32	+$format = $dbi->formats->{'SQL99_datetime'};
	33	+$timepiece = Time::Piece->strptime($data, $format);
	34	+is($timepiece->strftime('%F'), '2009-01-02', "$test : datetime date");
	35	+is($timepiece->strftime('%T'), '03:04:05', "$test : datetime time");
	36	+
	37	+$data = '2009-01-02';
	38	+$format = $dbi->formats->{'SQL99_date'};
	39	+$timepiece = Time::Piece->strptime($data, $format);
	40	+is($timepiece->strftime('%F'), '2009-01-02', "$test : date");
	41	+
	42	+$data = '03:04:05';
	43	+$format = $dbi->formats->{'SQL99_time'};
	44	+$timepiece = Time::Piece->strptime($data, $format);
	45	+is($timepiece->strftime('%T'), '03:04:05', "$test : time");
	46	+
	47	+
	48	+test 'ISO-8601 format';
	49	+$data = '2009-01-02T03:04:05';
	50	+$format = $dbi->formats->{'ISO-8601_datetime'};
	51	+$timepiece = Time::Piece->strptime($data, $format);
	52	+is($timepiece->strftime('%F'), '2009-01-02', "$test : datetime date");
	53	+is($timepiece->strftime('%T'), '03:04:05', "$test : datetime time");
	54	+
	55	+$data = '2009-01-02';
	56	+$format = $dbi->formats->{'ISO-8601_date'};
	57	+$timepiece = Time::Piece->strptime($data, $format);
	58	+is($timepiece->strftime('%F'), '2009-01-02', "$test : date");
	59	+
	60	+$data = '03:04:05';
	61	+$format = $dbi->formats->{'ISO-8601_time'};
	62	+$timepiece = Time::Piece->strptime($data, $format);
	63	+is($timepiece->strftime('%T'), '03:04:05', "$test : time");
	64	+

+49

DBIx-Custom-Basic/t/boilerplate.t

View

...	...	@@ -0,0 +1,49 @@
	1	+#!perl -T
	2	+
	3	+use strict;
	4	+use warnings;
	5	+use Test::More tests => 3;
	6	+
	7	+sub not_in_file_ok {
	8	+ my ($filename, %regex) = @_;
	9	+ open( my $fh, '<', $filename )
	10	+ or die "couldn't open $filename for reading: $!";
	11	+
	12	+ my %violated;
	13	+
	14	+ while (my $line = <$fh>) {
	15	+ while (my ($desc, $regex) = each %regex) {
	16	+ if ($line =~ $regex) {
	17	+ push @{$violated{$desc}\|\|=[]}, $.;
	18	+ }
	19	+ }
	20	+ }
	21	+
	22	+ if (%violated) {
	23	+ fail("$filename contains boilerplate text");
	24	+ diag "$_ appears on lines @{$violated{$_}}" for keys %violated;
	25	+ } else {
	26	+ pass("$filename contains no boilerplate text");
	27	+ }
	28	+}
	29	+
	30	+sub module_boilerplate_ok {
	31	+ my ($module) = @_;
	32	+ not_in_file_ok($module =>
	33	+ 'the great new $MODULENAME' => qr/ - The great new /,
	34	+ 'boilerplate description' => qr/Quick summary of what the module/,
	35	+ 'stub function definition' => qr/function[12]/,
	36	+ );
	37	+}
	38	+
	39	+ not_in_file_ok(README =>
	40	+ "The README is used..." => qr/The README is used/,
	41	+ "'version information here'" => qr/to provide version information/,
	42	+ );
	43	+
	44	+ not_in_file_ok(Changes =>
	45	+ "placeholder date/time" => qr(Date/time)
	46	+ );
	47	+
	48	+ module_boilerplate_ok('lib/DBIx/Custom/Basic.pm');
	49	+

t/pod-coverage.t → DBIx-Custom-Basic/t/pod-coverage.t

View

File renamed without changes.

t/pod.t → DBIx-Custom-Basic/t/pod.t

View

File renamed without changes.

+11

DBIx-Custom-MySQL/.gitignore

View

...	...	@@ -0,0 +1,11 @@
	1	+*.bak
	2	+*.BAK
	3	+Build
	4	+MANIFEST
	5	+META.yml
	6	+Makefile.PL
	7	+_build/*
	8	+blib/*
	9	+*.tar.gz
	10	+cover_db/*
	11	+*.tmp

+21

DBIx-Custom-MySQL/Build.PL

View

...	...	@@ -0,0 +1,21 @@
	1	+use strict;
	2	+use warnings;
	3	+use Module::Build;
	4	+
	5	+my $builder = Module::Build->new(
	6	+ module_name => 'DBIx::Custom::MySQL',
	7	+ license => 'perl',
	8	+ dist_author => 'Yuki Kimoto <kimoto.yuki@gmail.com>',
	9	+ dist_version_from => 'lib/DBIx/Custom/MySQL.pm',
	10	+ build_requires => {
	11	+ 'Test::More' => 0,
	12	+ },
	13	+ requires => {
	14	+ 'DBIx::Custom::Basic' => 0.0101,
	15	+ 'DBD::mysql' => 4.010
	16	+ },
	17	+ add_to_cleanup => [ 'DBIx-Custom-MySQL-*' ],
	18	+ create_makefile_pl => 'traditional',
	19	+);
	20	+
	21	+$builder->create_build_script();

DBIx-Custom-MySQL/Changes

View

...	...	@@ -0,0 +1,2 @@
	1	+0.0101
	2	+ First release

+15

DBIx-Custom-MySQL/MANIFEST.SKIP

View

...	...	@@ -0,0 +1,15 @@
	1	+\bRCS\b
	2	+\bCVS\b
	3	+^MANIFEST\.
	4	+^Makefile$
	5	+^Build$
	6	+^Build.bat$
	7	+^_build/
	8	+\.(bak\|tdy\|old\|tmp)$
	9	+~$
	10	+^blib/
	11	+^pm_to_blib
	12	+\.cvsignore
	13	+\.gz$
	14	+^\.git
	15	+^cover_db/

+15

DBIx-Custom-MySQL/README

View

...	...	@@ -0,0 +1,15 @@
	1	+DBIx-Custom-MySQL
	2	+
	3	+DBIx::Custom MySQL implementation
	4	+
	5	+INSTALLATION
	6	+
	7	+cpan DBIx::Custom::MySQL
	8	+
	9	+COPYRIGHT AND LICENCE
	10	+
	11	+Copyright (C) 2009 Yuki Kimoto
	12	+
	13	+This program is free software; you can redistribute it and/or modify it
	14	+under the same terms as Perl itself.
	15	+

+85

DBIx-Custom-MySQL/lib/DBIx/Custom/MySQL.pm

View

...	...	@@ -0,0 +1,85 @@
	1	+package DBIx::Custom::MySQL;
	2	+use base 'DBIx::Custom::Basic';
	3	+
	4	+use warnings;
	5	+use strict;
	6	+our $VERSION = '0.0101';
	7	+
	8	+my $class = __PACKAGE__;
	9	+
	10	+$class->add_format(
	11	+ datetime => $class->formats->{SQL99_datetime},
	12	+ date => $class->formats->{SQL99_date},
	13	+ time => $class->formats->{SQL99_time},
	14	+);
	15	+
	16	+
	17	+sub connect {
	18	+ my $self = shift;
	19	+
	20	+ if (!$self->data_source && (my $database = $self->database)) {
	21	+ $self->data_source("dbi:mysql:dbname=$database");
	22	+ }
	23	+
	24	+ return $self->SUPER::connect;
	25	+}
	26	+
	27	+=head1 NAME
	28	+
	29	+DBIx::Custom::MySQL - DBIx::Custom MySQL implementation
	30	+
	31	+=head1 VERSION
	32	+
	33	+Version 0.0101
	34	+
	35	+=head1 SYNOPSIS
	36	+
	37	+ # New
	38	+ my $dbi = DBIx::Custom::MySQL->new(user => 'taro', $password => 'kliej&@K',
	39	+ database => 'sample_db');
	40	+ # Insert
	41	+ $dbi->insert('books', {title => 'perl', author => 'taro'});
	42	+
	43	+ # Update
	44	+ # same as 'update books set (title = 'aaa', author = 'ken') where id = 5;
	45	+ $dbi->update('books', {title => 'aaa', author => 'ken'}, {id => 5});
	46	+
	47	+ # Delete
	48	+ $dbi->delete('books', {author => 'taro'});
	49	+
	50	+ # select * from books;
	51	+ $dbi->select('books');
	52	+
	53	+ # select * from books where ahthor = 'taro';
	54	+ $dbi->select('books', {author => 'taro'});
	55	+
	56	+=head1 CAUTION
	57	+
	58	+This module automatically encode_utf8 or decode_utf8
	59	+If you do not want to this, you set
	60	+
	61	+ $dbi->bind_filter(undef);
	62	+ $dbi->fetch_filter(undef);
	63	+
	64	+=head1 OBJECT METHOD
	65	+
	66	+=head2 connect
	67	+
	68	+ This method override DBIx::Custom::connect
	69	+
	70	+ If database is set, automatically data source is created and connect
	71	+
	72	+=head1 AUTHOR
	73	+
	74	+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >>
	75	+
	76	+Github L<http://github.com/yuki-kimoto>
	77	+
	78	+=head1 COPYRIGHT & LICENSE
	79	+
	80	+Copyright 2009 Yuki Kimoto, all rights reserved.
	81	+
	82	+This program is free software; you can redistribute it and/or modify it
	83	+under the same terms as Perl itself.
	84	+
	85	+

DBIx-Custom-MySQL/t/00-load.t

View

...	...	@@ -0,0 +1,9 @@
	1	+#!perl -T
	2	+
	3	+use Test::More tests => 1;
	4	+
	5	+BEGIN {
	6	+ use_ok( 'DBIx::Custom::MySQL' );
	7	+}
	8	+
	9	+diag( "Testing DBIx::Custom::MySQL $DBIx::Custom::MySQL::VERSION, Perl $], $^X" );

+82

DBIx-Custom-MySQL/t/02-time_format.t

View

...	...	@@ -0,0 +1,82 @@
	1	+use Test::More;
	2	+use strict;
	3	+use warnings;
	4	+
	5	+BEGIN {
	6	+ eval { require Time::Piece; 1 }
	7	+ or plan skip_all => 'Time::Piece required';
	8	+
	9	+ plan 'no_plan';
	10	+ use_ok('DBIx::Custom');
	11	+}
	12	+
	13	+# Function for test name
	14	+my $test;
	15	+sub test {
	16	+ $test = shift;
	17	+}
	18	+
	19	+# Varialbe for tests
	20	+
	21	+my $format;
	22	+my $data;
	23	+my $timepiece;
	24	+my $dbi;
	25	+
	26	+use DBIx::Custom::MySQL;
	27	+
	28	+
	29	+test 'SQL99 format';
	30	+$dbi = DBIx::Custom::MySQL->new;
	31	+$data = '2009-01-02 03:04:05';
	32	+$format = $dbi->formats->{'SQL99_datetime'};
	33	+$timepiece = Time::Piece->strptime($data, $format);
	34	+is($timepiece->strftime('%F'), '2009-01-02', "$test : datetime date");
	35	+is($timepiece->strftime('%T'), '03:04:05', "$test : datetime time");
	36	+
	37	+$data = '2009-01-02';
	38	+$format = $dbi->formats->{'SQL99_date'};
	39	+$timepiece = Time::Piece->strptime($data, $format);
	40	+is($timepiece->strftime('%F'), '2009-01-02', "$test : date");
	41	+
	42	+$data = '03:04:05';
	43	+$format = $dbi->formats->{'SQL99_time'};
	44	+$timepiece = Time::Piece->strptime($data, $format);
	45	+is($timepiece->strftime('%T'), '03:04:05', "$test : time");
	46	+
	47	+
	48	+test 'ISO-8601 format';
	49	+$data = '2009-01-02T03:04:05';
	50	+$format = $dbi->formats->{'ISO-8601_datetime'};
	51	+$timepiece = Time::Piece->strptime($data, $format);
	52	+is($timepiece->strftime('%F'), '2009-01-02', "$test : datetime date");
	53	+is($timepiece->strftime('%T'), '03:04:05', "$test : datetime time");
	54	+
	55	+$data = '2009-01-02';
	56	+$format = $dbi->formats->{'ISO-8601_date'};
	57	+$timepiece = Time::Piece->strptime($data, $format);
	58	+is($timepiece->strftime('%F'), '2009-01-02', "$test : date");
	59	+
	60	+$data = '03:04:05';
	61	+$format = $dbi->formats->{'ISO-8601_time'};
	62	+$timepiece = Time::Piece->strptime($data, $format);
	63	+is($timepiece->strftime('%T'), '03:04:05', "$test : time");
	64	+
	65	+
	66	+test 'default format';
	67	+$data = '2009-01-02 03:04:05';
	68	+$format = $dbi->formats->{'datetime'};
	69	+$timepiece = Time::Piece->strptime($data, $format);
	70	+is($timepiece->strftime('%F'), '2009-01-02', "$test : datetime date");
	71	+is($timepiece->strftime('%T'), '03:04:05', "$test : datetime time");
	72	+
	73	+$data = '2009-01-02';
	74	+$format = $dbi->formats->{'date'};
	75	+$timepiece = Time::Piece->strptime($data, $format);
	76	+is($timepiece->strftime('%F'), '2009-01-02', "$test : date");
	77	+
	78	+$data = '03:04:05';
	79	+$format = $dbi->formats->{'time'};
	80	+$timepiece = Time::Piece->strptime($data, $format);
	81	+is($timepiece->strftime('%T'), '03:04:05', "$test : time");
	82	+

+47

DBIx-Custom-MySQL/t/101-mysql_private.t

View

...	...	@@ -0,0 +1,47 @@
	1	+use Test::More;
	2	+use strict;
	3	+use warnings;
	4	+
	5	+# user password database
	6	+our ($USER, $PASSWORD, $DATABASE) = connect_info();
	7	+
	8	+plan skip_all => 'private MySQL test' unless $USER;
	9	+
	10	+plan 'no_plan';
	11	+
	12	+# Function for test name
	13	+my $test;
	14	+sub test {
	15	+ $test = shift;
	16	+}
	17	+
	18	+
	19	+# Functions for tests
	20	+sub connect_info {
	21	+ my $file = 'password.tmp';
	22	+ open my $fh, '<', $file
	23	+ or return;
	24	+
	25	+ my ($user, $password, $database) = split(/\s/, (<$fh>)[0]);
	26	+
	27	+ close $fh;
	28	+
	29	+ return ($user, $password, $database);
	30	+}
	31	+
	32	+
	33	+# Constat variables for tests
	34	+my $CLASS = 'DBIx::Custom::MySQL';
	35	+
	36	+# Varialbes for tests
	37	+my $dbi;
	38	+
	39	+use DBIx::Custom::MySQL;
	40	+
	41	+test 'connect';
	42	+$dbi = $CLASS->new(user => $USER, password => $PASSWORD,
	43	+ database => $DATABASE);
	44	+$dbi->connect;
	45	+is(ref $dbi->dbh, 'DBI::db', $test);
	46	+
	47	+

+51

DBIx-Custom-MySQL/t/boilerplate.t

View

...	...	@@ -0,0 +1,51 @@
	1	+#!perl -T
	2	+
	3	+use strict;
	4	+use warnings;
	5	+use Test::More tests => 3;
	6	+
	7	+sub not_in_file_ok {
	8	+ my ($filename, %regex) = @_;
	9	+ open( my $fh, '<', $filename )
	10	+ or die "couldn't open $filename for reading: $!";
	11	+
	12	+ my %violated;
	13	+
	14	+ while (my $line = <$fh>) {
	15	+ while (my ($desc, $regex) = each %regex) {
	16	+ if ($line =~ $regex) {
	17	+ push @{$violated{$desc}\|\|=[]}, $.;
	18	+ }
	19	+ }
	20	+ }
	21	+
	22	+ if (%violated) {
	23	+ fail("$filename contains boilerplate text");
	24	+ diag "$_ appears on lines @{$violated{$_}}" for keys %violated;
	25	+ } else {
	26	+ pass("$filename contains no boilerplate text");
	27	+ }
	28	+}
	29	+
	30	+sub module_boilerplate_ok {
	31	+ my ($module) = @_;
	32	+ not_in_file_ok($module =>
	33	+ 'the great new $MODULENAME' => qr/ - The great new /,
	34	+ 'boilerplate description' => qr/Quick summary of what the module/,
	35	+ 'stub function definition' => qr/function[12]/,
	36	+ );
	37	+}
	38	+
	39	+
	40	+ not_in_file_ok(README =>
	41	+ "The README is used..." => qr/The README is used/,
	42	+ "'version information here'" => qr/to provide version information/,
	43	+ );
	44	+
	45	+ not_in_file_ok(Changes =>
	46	+ "placeholder date/time" => qr(Date/time)
	47	+ );
	48	+
	49	+ module_boilerplate_ok('lib/DBIx/Custom/MySQL.pm');
	50	+
	51	+

+18

DBIx-Custom-MySQL/t/pod-coverage.t

View

...	...	@@ -0,0 +1,18 @@
	1	+use strict;
	2	+use warnings;
	3	+use Test::More;
	4	+
	5	+# Ensure a recent version of Test::Pod::Coverage
	6	+my $min_tpc = 1.08;
	7	+eval "use Test::Pod::Coverage $min_tpc";
	8	+plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage"
	9	+ if $@;
	10	+
	11	+# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version,
	12	+# but older versions don't recognize some common documentation styles
	13	+my $min_pc = 0.18;
	14	+eval "use Pod::Coverage $min_pc";
	15	+plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage"
	16	+ if $@;
	17	+
	18	+all_pod_coverage_ok();

+12

DBIx-Custom-MySQL/t/pod.t

View

...	...	@@ -0,0 +1,12 @@
	1	+#!perl -T
	2	+
	3	+use strict;
	4	+use warnings;
	5	+use Test::More;
	6	+
	7	+# Ensure a recent version of Test::Pod
	8	+my $min_tp = 1.22;
	9	+eval "use Test::Pod $min_tp";
	10	+plan skip_all => "Test::Pod $min_tp required for testing POD" if $@;
	11	+
	12	+all_pod_files_ok();

+11

DBIx-Custom-Query/.gitignore

View

...	...	@@ -0,0 +1,11 @@
	1	+*.bak
	2	+*.BAK
	3	+Build
	4	+MANIFEST
	5	+META.yml
	6	+Makefile.PL
	7	+_build/*
	8	+blib/*
	9	+*.tar.gz
	10	+cover_db/*
	11	+*.tmp

+20

DBIx-Custom-Query/Build.PL

View

...	...	@@ -0,0 +1,20 @@
	1	+use strict;
	2	+use warnings;
	3	+use Module::Build;
	4	+
	5	+my $builder = Module::Build->new(
	6	+ module_name => 'DBIx::Custom::Query',
	7	+ license => 'perl',
	8	+ dist_author => 'Yuki Kimoto <kimoto.yuki@gmail.com>',
	9	+ dist_version_from => 'lib/DBIx/Custom/Query.pm',
	10	+ build_requires => {
	11	+ 'Test::More' => 0,
	12	+ },
	13	+ requires => {
	14	+ 'Object::Simple' => 2.0702,
	15	+ },
	16	+ add_to_cleanup => [ 'DBIx-Custom-Query-*' ],
	17	+ create_makefile_pl => 'traditional',
	18	+);
	19	+
	20	+$builder->create_build_script();

DBIx-Custom-Query/Changes

View

...	...	@@ -0,0 +1,2 @@
	1	+0.0101
	2	+ First release

+15

DBIx-Custom-Query/MANIFEST.SKIP

View

...	...	@@ -0,0 +1,15 @@
	1	+\bRCS\b
	2	+\bCVS\b
	3	+^MANIFEST\.
	4	+^Makefile$
	5	+^Build$
	6	+^Build.bat$
	7	+^_build/
	8	+\.(bak\|tdy\|old\|tmp)$
	9	+~$
	10	+^blib/
	11	+^pm_to_blib
	12	+\.cvsignore
	13	+\.gz$
	14	+^\.git
	15	+^cover_db/

+14

DBIx-Custom-Query/README

View

...	...	@@ -0,0 +1,14 @@
	1	+DBIx-Custom-Query
	2	+
	3	+Query object for DBIx::Custom
	4	+
	5	+INSTLLATION
	6	+
	7	+cpan DBIx::Custom::Query
	8	+
	9	+COPYRIGHT AND LICENCE
	10	+
	11	+Copyright (C) 2009 Yuki Kimoto
	12	+
	13	+This program is free software; you can redistribute it and/or modify it
	14	+under the same terms as Perl itself.

+103

DBIx-Custom-Query/lib/DBIx/Custom/Query.pm

View

...	...	@@ -0,0 +1,103 @@
	1	+package DBIx::Custom::Query;
	2	+use Object::Simple;
	3	+
	4	+our $VERSION = '0.0101';
	5	+
	6	+sub sql : Attr {}
	7	+sub key_infos : Attr {}
	8	+sub bind_filter : Attr {}
	9	+sub fetch_filter : Attr {}
	10	+sub sth : Attr {}
	11	+
	12	+sub no_bind_filters : Attr { type => 'array', trigger => sub {
	13	+ my $self = shift;
	14	+ my $no_bind_filters = $self->no_bind_filters \|\| [];
	15	+ my %no_bind_filters_map = map {$_ => 1} @{$no_bind_filters};
	16	+ $self->_no_bind_filters_map(\%no_bind_filters_map);
	17	+}}
	18	+sub _no_bind_filters_map : Attr {default => sub { {} }}
	19	+
	20	+sub no_fetch_filters : Attr { type => 'array', default => sub { [] } }
	21	+
	22	+Object::Simple->build_class;
	23	+
	24	+=head1 NAME
	25	+
	26	+DBIx::Custom::Query - Query object for DBIx::Custom
	27	+
	28	+=head1 VERSION
	29	+
	30	+Version 0.0101
	31	+
	32	+=head1 SYNOPSIS
	33	+
	34	+ # Create query
	35	+ my $dbi = DBIx::Custom->new;
	36	+ my $query = $dbi->create_query($template);
	37	+
	38	+ # Set query attributes
	39	+ $query->bind_filter($dbi->filters->{default_bind_filter});
	40	+ $query->no_bind_filters('title', 'author');
	41	+
	42	+ $query->fetch_filter($dbi->filters->{default_fetch_filter});
	43	+ $query->no_fetch_filters('title', 'author');
	44	+
	45	+ # Execute query
	46	+ $dbi->execute($query, $params);
	47	+
	48	+=head1 OBJECT ACCESSORS
	49	+
	50	+=head2 sth
	51	+
	52	+ # Set and get statement handle
	53	+ $self = $query->sth($sql);
	54	+ $sth = $query->sth;
	55	+
	56	+=head2 sql
	57	+
	58	+ # Set and get SQL
	59	+ $self = $query->sql($sql);
	60	+ $sql = $query->sql;
	61	+
	62	+=head2 bind_filter
	63	+
	64	+ # Set and get bind filter
	65	+ $self = $query->bind_filter($bind_filter);
	66	+ $bind_filter = $query->bind_filter;
	67	+
	68	+=head2 no_bind_filters
	69	+
	70	+ # Set and get keys of no filtering
	71	+ $self = $query->no_bind_filters($no_filters);
	72	+ $no_bind_filters = $query->no_bind_filters;
	73	+
	74	+=head2 fetch_filter
	75	+
	76	+ # Set and get fetch filter
	77	+ $self = $query->fetch_filter($fetch_filter);
	78	+ $fetch_filter = $query->fetch_filter;
	79	+
	80	+=head2 no_fetch_filters
	81	+
	82	+ # Set and get keys of no filtering
	83	+ $self = $query->no_fetch_filters($no_filters);
	84	+ $no_fetch_filters = $query->no_fetch_filters;
	85	+
	86	+=head2 key_infos
	87	+
	88	+ # Set and get key informations
	89	+ $self = $query->key_infos($key_infos);
	90	+ $key_infos = $query->key_infos;
	91	+
	92	+=head1 AUTHOR
	93	+
	94	+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >>
	95	+
	96	+Github L<http://github.com/yuki-kimoto>
	97	+
	98	+=head1 COPYRIGHT & LICENSE
	99	+
	100	+Copyright 2009 Yuki Kimoto, all rights reserved.
	101	+
	102	+This program is free software; you can redistribute it and/or modify it
	103	+under the same terms as Perl itself.

DBIx-Custom-Query/t/00-load.t

View

...	...	@@ -0,0 +1,9 @@
	1	+#!perl -T
	2	+
	3	+use Test::More tests => 1;
	4	+
	5	+BEGIN {
	6	+ use_ok( 'DBIx::Custom::Query' );
	7	+}
	8	+
	9	+diag( "Testing DBIx::Custom::Query $DBIx::Custom::Query::VERSION, Perl $], $^X" );

+37

DBIx-Custom-Query/t/01-core.t

View

...	...	@@ -0,0 +1,37 @@
	1	+use Test::More 'no_plan';
	2	+
	3	+use strict;
	4	+use warnings;
	5	+use DBIx::Custom::Query;
	6	+
	7	+# Function for test name
	8	+my $test;
	9	+sub test{
	10	+ $test = shift;
	11	+}
	12	+
	13	+# Variables for test
	14	+my $query;
	15	+
	16	+test 'Accessors';
	17	+$query = DBIx::Custom::Query->new(
	18	+ sql => 'a',
	19	+ key_infos => 'b',
	20	+ bind_filter => 'c',
	21	+ no_bind_filters => [qw/d e/],
	22	+ sth => 'e',
	23	+ fetch_filter => 'f',
	24	+ no_fetch_filters => [qw/g h/],
	25	+);
	26	+
	27	+is($query->sql, 'a', "$test : sql");
	28	+is($query->key_infos, 'b', "$test : key_infos ");
	29	+is($query->bind_filter, 'c', "$test : bind_filter");
	30	+is_deeply(scalar $query->no_bind_filters, [qw/d e/], "$test : no_bind_filters");
	31	+is_deeply(scalar $query->_no_bind_filters_map, {d => 1, e => 1}, "$test : _no_bind_filters_map");
	32	+is_deeply(scalar $query->no_fetch_filters, [qw/g h/], "$test : no_fetch_filters");
	33	+is($query->sth, 'e', "$test : sth");
	34	+
	35	+$query->no_bind_filters(undef);
	36	+is_deeply(scalar $query->_no_bind_filters_map, {}, "$test _no_bind_filters_map undef value");
	37	+

+51

DBIx-Custom-Query/t/boilerplate.t

View

...	...	@@ -0,0 +1,51 @@
	1	+#!perl -T
	2	+
	3	+use strict;
	4	+use warnings;
	5	+use Test::More tests => 3;
	6	+
	7	+sub not_in_file_ok {
	8	+ my ($filename, %regex) = @_;
	9	+ open( my $fh, '<', $filename )
	10	+ or die "couldn't open $filename for reading: $!";
	11	+
	12	+ my %violated;
	13	+
	14	+ while (my $line = <$fh>) {
	15	+ while (my ($desc, $regex) = each %regex) {
	16	+ if ($line =~ $regex) {
	17	+ push @{$violated{$desc}\|\|=[]}, $.;
	18	+ }
	19	+ }
	20	+ }
	21	+
	22	+ if (%violated) {
	23	+ fail("$filename contains boilerplate text");
	24	+ diag "$_ appears on lines @{$violated{$_}}" for keys %violated;
	25	+ } else {
	26	+ pass("$filename contains no boilerplate text");
	27	+ }
	28	+}
	29	+
	30	+sub module_boilerplate_ok {
	31	+ my ($module) = @_;
	32	+ not_in_file_ok($module =>
	33	+ 'the great new $MODULENAME' => qr/ - The great new /,
	34	+ 'boilerplate description' => qr/Quick summary of what the module/,
	35	+ 'stub function definition' => qr/function[12]/,
	36	+ );
	37	+}
	38	+
	39	+
	40	+ not_in_file_ok(README =>
	41	+ "The README is used..." => qr/The README is used/,
	42	+ "'version information here'" => qr/to provide version information/,
	43	+ );
	44	+
	45	+ not_in_file_ok(Changes =>
	46	+ "placeholder date/time" => qr(Date/time)
	47	+ );
	48	+
	49	+ module_boilerplate_ok('lib/DBIx/Custom/Query.pm');
	50	+
	51	+

+18

DBIx-Custom-Query/t/pod-coverage.t

View

...	...	@@ -0,0 +1,18 @@
	1	+use strict;
	2	+use warnings;
	3	+use Test::More;
	4	+
	5	+# Ensure a recent version of Test::Pod::Coverage
	6	+my $min_tpc = 1.08;
	7	+eval "use Test::Pod::Coverage $min_tpc";
	8	+plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage"
	9	+ if $@;
	10	+
	11	+# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version,
	12	+# but older versions don't recognize some common documentation styles
	13	+my $min_pc = 0.18;
	14	+eval "use Pod::Coverage $min_pc";
	15	+plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage"
	16	+ if $@;
	17	+
	18	+all_pod_coverage_ok();

+12

DBIx-Custom-Query/t/pod.t

View

...	...	@@ -0,0 +1,12 @@
	1	+#!perl -T
	2	+
	3	+use strict;
	4	+use warnings;
	5	+use Test::More;
	6	+
	7	+# Ensure a recent version of Test::Pod
	8	+my $min_tp = 1.22;
	9	+eval "use Test::Pod $min_tp";
	10	+plan skip_all => "Test::Pod $min_tp required for testing POD" if $@;
	11	+
	12	+all_pod_files_ok();

+10

DBIx-Custom-Result/.gitignore

View

...	...	@@ -0,0 +1,10 @@
	1	+*.bak
	2	+*.BAK
	3	+Build
	4	+MANIFEST
	5	+META.yml
	6	+Makefile.PL
	7	+_build/*
	8	+blib/*
	9	+*.tar.gz
	10	+cover_db/*

+20

DBIx-Custom-Result/Build.PL

View

...	...	@@ -0,0 +1,20 @@
	1	+use strict;
	2	+use warnings;
	3	+use Module::Build;
	4	+
	5	+my $builder = Module::Build->new(
	6	+ module_name => 'DBIx::Custom::Result',
	7	+ license => 'perl',
	8	+ dist_author => 'Yuki Kimoto <kimoto.yuki@gmail.com>',
	9	+ dist_version_from => 'lib/DBIx/Custom/Result.pm',
	10	+ build_requires => {
	11	+ 'Test::More' => 0,
	12	+ },
	13	+ requires => {
	14	+ 'Object::Simple' => 2.0702,
	15	+ },
	16	+ add_to_cleanup => [ 'DBIx-Custom-Result-*' ],
	17	+ create_makefile_pl => 'traditional',
	18	+);
	19	+
	20	+$builder->create_build_script();

DBIx-Custom-Result/Changes

View

...	...	@@ -0,0 +1,2 @@
	1	+0.0101
	2	+ First release

+15

DBIx-Custom-Result/MANIFEST.SKIP

View

...	...	@@ -0,0 +1,15 @@
	1	+\bRCS\b
	2	+\bCVS\b
	3	+^MANIFEST\.
	4	+^Makefile$
	5	+^Build$
	6	+^Build.bat$
	7	+^_build/
	8	+\.(bak\|tdy\|old\|tmp)$
	9	+~$
	10	+^blib/
	11	+^pm_to_blib
	12	+\.cvsignore
	13	+\.gz$
	14	+^\.git
	15	+^cover_db/

+15

DBIx-Custom-Result/README

View

...	...	@@ -0,0 +1,15 @@
	1	+DBIx-Custom-Result
	2	+
	3	+Resultset for DBIx::Custom
	4	+
	5	+INSTALLATION
	6	+
	7	+cpan DBIx::Custom::Result
	8	+
	9	+COPYRIGHT AND LICENCE
	10	+
	11	+Copyright (C) 2009 Yuki Kimoto
	12	+
	13	+This program is free software; you can redistribute it and/or modify it
	14	+under the same terms as Perl itself.
	15	+

+385

DBIx-Custom-Result/lib/DBIx/Custom/Result.pm

View

...	...	@@ -0,0 +1,385 @@
	1	+package DBIx::Custom::Result;
	2	+use Object::Simple;
	3	+
	4	+our $VERSION = '0.0101';
	5	+
	6	+use Carp 'croak';
	7	+
	8	+# Attributes
	9	+sub sth : Attr {}
	10	+sub fetch_filter : Attr {}
	11	+sub no_fetch_filters : Attr { type => 'array', trigger => sub {
	12	+ my $self = shift;
	13	+ my $no_fetch_filters = $self->no_fetch_filters \|\| [];
	14	+ my %no_fetch_filters_map = map {$_ => 1} @{$no_fetch_filters};
	15	+ $self->_no_fetch_filters_map(\%no_fetch_filters_map);
	16	+}}
	17	+sub _no_fetch_filters_map : Attr {default => sub { {} }}
	18	+
	19	+# Fetch (array)
	20	+sub fetch {
	21	+ my ($self, $type) = @_;
	22	+ my $sth = $self->sth;
	23	+ my $fetch_filter = $self->fetch_filter;
	24	+
	25	+ # Fetch
	26	+ my $row = $sth->fetchrow_arrayref;
	27	+
	28	+ # Cannot fetch
	29	+ return unless $row;
	30	+
	31	+ # Filter
	32	+ if ($fetch_filter) {
	33	+ my $keys = $sth->{NAME_lc};
	34	+ my $types = $sth->{TYPE};
	35	+ for (my $i = 0; $i < @$keys; $i++) {
	36	+ next if $self->_no_fetch_filters_map->{$keys->[$i]};
	37	+ $row->[$i]= $fetch_filter->($keys->[$i], $row->[$i], $types->[$i],
	38	+ $sth, $i);
	39	+ }
	40	+ }
	41	+ return wantarray ? @$row : $row;
	42	+}
	43	+
	44	+# Fetch (hash)
	45	+sub fetch_hash {
	46	+ my $self = shift;
	47	+ my $sth = $self->sth;
	48	+ my $fetch_filter = $self->fetch_filter;
	49	+
	50	+ # Fetch
	51	+ my $row = $sth->fetchrow_arrayref;
	52	+
	53	+ # Cannot fetch
	54	+ return unless $row;
	55	+
	56	+ # Keys
	57	+ my $keys = $sth->{NAME_lc};
	58	+
	59	+ # Filter
	60	+ my $row_hash = {};
	61	+ if ($fetch_filter) {
	62	+ my $types = $sth->{TYPE};
	63	+ for (my $i = 0; $i < @$keys; $i++) {
	64	+ if ($self->_no_fetch_filters_map->{$keys->[$i]}) {
	65	+ $row_hash->{$keys->[$i]} = $row->[$i];
	66	+ }
	67	+ else {
	68	+ $row_hash->{$keys->[$i]}
	69	+ = $fetch_filter->($keys->[$i], $row->[$i],
	70	+ $types->[$i], $sth, $i);
	71	+ }
	72	+ }
	73	+ }
	74	+
	75	+ # No filter
	76	+ else {
	77	+ for (my $i = 0; $i < @$keys; $i++) {
	78	+ $row_hash->{$keys->[$i]} = $row->[$i];
	79	+ }
	80	+ }
	81	+ return wantarray ? %$row_hash : $row_hash;
	82	+}
	83	+
	84	+# Fetch only first (array)
	85	+sub fetch_first {
	86	+ my $self = shift;
	87	+
	88	+ # Fetch
	89	+ my $row = $self->fetch;
	90	+
	91	+ # Not exist
	92	+ return unless $row;
	93	+
	94	+ # Finish statement handle
	95	+ $self->finish;
	96	+
	97	+ return wantarray ? @$row : $row;
	98	+}
	99	+
	100	+# Fetch only first (hash)
	101	+sub fetch_first_hash {
	102	+ my $self = shift;
	103	+
	104	+ # Fetch hash
	105	+ my $row = $self->fetch_hash;
	106	+
	107	+ # Not exist
	108	+ return unless $row;
	109	+
	110	+ # Finish statement handle
	111	+ $self->finish;
	112	+
	113	+ return wantarray ? %$row : $row;
	114	+}
	115	+
	116	+# Fetch multi rows (array)
	117	+sub fetch_rows {
	118	+ my ($self, $count) = @_;
	119	+
	120	+ # Not specified Row count
	121	+ croak("Row count must be specified")
	122	+ unless $count;
	123	+
	124	+ # Fetch multi rows
	125	+ my $rows = [];
	126	+ for (my $i = 0; $i < $count; $i++) {
	127	+ my @row = $self->fetch;
	128	+
	129	+ last unless @row;
	130	+
	131	+ push @$rows, \@row;
	132	+ }
	133	+
	134	+ return unless @$rows;
	135	+ return wantarray ? @$rows : $rows;
	136	+}
	137	+
	138	+# Fetch multi rows (hash)
	139	+sub fetch_rows_hash {
	140	+ my ($self, $count) = @_;
	141	+
	142	+ # Not specified Row count
	143	+ croak("Row count must be specified")
	144	+ unless $count;
	145	+
	146	+ # Fetch multi rows
	147	+ my $rows = [];
	148	+ for (my $i = 0; $i < $count; $i++) {
	149	+ my %row = $self->fetch_hash;
	150	+
	151	+ last unless %row;
	152	+
	153	+ push @$rows, \%row;
	154	+ }
	155	+
	156	+ return unless @$rows;
	157	+ return wantarray ? @$rows : $rows;
	158	+}
	159	+
	160	+
	161	+# Fetch all (array)
	162	+sub fetch_all {
	163	+ my $self = shift;
	164	+
	165	+ my $rows = [];
	166	+ while(my @row = $self->fetch) {
	167	+ push @$rows, [@row];
	168	+ }
	169	+ return wantarray ? @$rows : $rows;
	170	+}
	171	+
	172	+# Fetch all (hash)
	173	+sub fetch_all_hash {
	174	+ my $self = shift;
	175	+
	176	+ my $rows = [];
	177	+ while(my %row = $self->fetch_hash) {
	178	+ push @$rows, {%row};
	179	+ }
	180	+ return wantarray ? @$rows : $rows;
	181	+}
	182	+
	183	+# Finish
	184	+sub finish { shift->sth->finish }
	185	+
	186	+# Error
	187	+sub error {
	188	+ my $self = shift;
	189	+ my $sth = $self->sth;
	190	+ return wantarray ? ($sth->errstr, $sth->err, $sth->state) : $sth->errstr;
	191	+}
	192	+
	193	+Object::Simple->build_class;
	194	+
	195	+=head1 NAME
	196	+
	197	+DBIx::Custom::Result - Resultset for DBIx::Custom
	198	+
	199	+=head1 VERSION
	200	+
	201	+Version 0.0101
	202	+
	203	+=head1 SYNOPSIS
	204	+
	205	+ # $result is DBIx::Custom::Result object
	206	+ my $dbi = DBIx::Custom->new;
	207	+ my $result = $dbi->query($sql_template, $param);
	208	+
	209	+ while (my ($val1, $val2) = $result->fetch) {
	210	+ # do something
	211	+ }
	212	+
	213	+=head1 OBJECT ACCESSORS
	214	+
	215	+=head2 sth
	216	+
	217	+ # Set and Get statement handle
	218	+ $self = $result->sth($sth);
	219	+ $sth = $reuslt->sth
	220	+
	221	+Statement handle is automatically set by DBIx::Custom.
	222	+so you do not set statement handle.
	223	+
	224	+If you need statement handle, you can get statement handle by using this method.
	225	+
	226	+=head2 fetch_filter
	227	+
	228	+ # Set and Get fetch filter
	229	+ $self = $result->fetch_filter($sth);
	230	+ $fetch_filter = $result->fech_filter;
	231	+
	232	+Statement handle is automatically set by DBIx::Custom.
	233	+If you want to set your fetch filter, you set it.
	234	+
	235	+=head2 no_fetch_filters
	236	+
	237	+ # Set and Get no filter keys when fetching
	238	+ $self = $result->no_fetch_filters($no_fetch_filters);
	239	+ $no_fetch_filters = $result->no_fetch_filters;
	240	+
	241	+=head1 METHODS
	242	+
	243	+=head2 fetch
	244	+
	245	+ # Fetch row as array reference (Scalar context)
	246	+ $row = $result->fetch;
	247	+
	248	+ # Fetch row as array (List context)
	249	+ @row = $result->fecth
	250	+
	251	+ # Sample
	252	+ while (my $row = $result->fetch) {
	253	+ # do something
	254	+ my $val1 = $row->[0];
	255	+ my $val2 = $row->[1];
	256	+ }
	257	+
	258	+fetch method is fetch resultset and get row as array or array reference.
	259	+
	260	+=head2 fetch_hash
	261	+
	262	+ # Fetch row as hash reference (Scalar context)
	263	+ $row = $result->fetch_hash;
	264	+
	265	+ # Fetch row as hash (List context)
	266	+ %row = $result->fecth_hash
	267	+
	268	+ # Sample
	269	+ while (my $row = $result->fetch_hash) {
	270	+ # do something
	271	+ my $val1 = $row->{key1};
	272	+ my $val2 = $row->{key2};
	273	+ }
	274	+
	275	+fetch_hash method is fetch resultset and get row as hash or hash reference.
	276	+
	277	+=head2 fetch_first
	278	+
	279	+ # Fetch only first (Scalar context)
	280	+ $row = $result->fetch_first;
	281	+
	282	+ # Fetch only first (List context)
	283	+ @row = $result->fetch_first;
	284	+
	285	+This method fetch only first and finish statement handle
	286	+
	287	+=head2 fetch_first_hash
	288	+
	289	+ # Fetch only first as hash (Scalar context)
	290	+ $row = $result->fetch_first_hash;
	291	+
	292	+ # Fetch only first as hash (Scalar context)
	293	+ @row = $result->fetch_first_hash;
	294	+
	295	+This method fetch only first and finish statement handle
	296	+
	297	+=head2 fetch_rows
	298	+
	299	+ # Fetch multi rows (Scalar context)
	300	+ $rows = $result->fetch_rows($row_count);
	301	+
	302	+ # Fetch multi rows (List context)
	303	+ @rows = $result->fetch_rows($row_count);
	304	+
	305	+ # Sapmle
	306	+ $rows = $result->fetch_rows(10);
	307	+
	308	+=head2 fetch_rows_hash
	309	+
	310	+ # Fetch multi rows as hash (Scalar context)
	311	+ $rows = $result->fetch_rows_hash($row_count);
	312	+
	313	+ # Fetch multi rows as hash (List context)
	314	+ @rows = $result->fetch_rows_hash($row_count);
	315	+
	316	+ # Sapmle
	317	+ $rows = $result->fetch_rows_hash(10);
	318	+
	319	+=head2 fetch_all
	320	+
	321	+ # Fetch all row as array ref of array ref (Scalar context)
	322	+ $rows = $result->fetch_all;
	323	+
	324	+ # Fetch all row as array of array ref (List context)
	325	+ @rows = $result->fecth_all;
	326	+
	327	+ # Sample
	328	+ my $rows = $result->fetch_all;
	329	+ my $val0_0 = $rows->[0][0];
	330	+ my $val1_1 = $rows->[1][1];
	331	+
	332	+fetch_all method is fetch resultset and get all rows as array or array reference.
	333	+
	334	+=head2 fetch_all_hash
	335	+
	336	+ # Fetch all row as array ref of hash ref (Scalar context)
	337	+ $rows = $result->fetch_all_hash;
	338	+
	339	+ # Fetch all row as array of hash ref (List context)
	340	+ @rows = $result->fecth_all_hash;
	341	+
	342	+ # Sample
	343	+ my $rows = $result->fetch_all_hash;
	344	+ my $val0_key1 = $rows->[0]{key1};
	345	+ my $val1_key2 = $rows->[1]{key2};
	346	+
	347	+=head2 error
	348	+
	349	+ # Get error infomation
	350	+ $error_messege = $result->error;
	351	+ ($error_message, $error_number, $error_state) = $result->error;
	352	+
	353	+You can get get information. This is crenspond to the following.
	354	+
	355	+ $error_message : $result->sth->errstr
	356	+ $error_number : $result->sth->err
	357	+ $error_state : $result->sth->state
	358	+
	359	+=head2 finish
	360	+
	361	+ # Finish statement handle
	362	+ $result->finish
	363	+
	364	+ # Sample
	365	+ my $row = $reuslt->fetch; # fetch only one row
	366	+ $result->finish
	367	+
	368	+You can finish statement handle.This is equel to
	369	+
	370	+ $result->sth->finish;
	371	+
	372	+=head1 AUTHOR
	373	+
	374	+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >>
	375	+
	376	+Github L<http://github.com/yuki-kimoto>
	377	+
	378	+=head1 COPYRIGHT & LICENSE
	379	+
	380	+Copyright 2009 Yuki Kimoto, all rights reserved.
	381	+
	382	+This program is free software; you can redistribute it and/or modify it
	383	+under the same terms as Perl itself.
	384	+
	385	+=cut

DBIx-Custom-Result/t/00-load.t

View

...	...	@@ -0,0 +1,9 @@
	1	+#!perl -T
	2	+
	3	+use Test::More tests => 1;
	4	+
	5	+BEGIN {
	6	+ use_ok( 'DBIx::Custom::Result' );
	7	+}
	8	+
	9	+diag( "Testing DBIx::Custom::Result $DBIx::Custom::Result::VERSION, Perl $], $^X" );

+257

DBIx-Custom-Result/t/01-sqlite.t

View

...	...	@@ -0,0 +1,257 @@
	1	+use Test::More;
	2	+use strict;
	3	+use warnings;
	4	+use DBI;
	5	+
	6	+BEGIN {
	7	+ eval { require DBD::SQLite; 1 }
	8	+ or plan skip_all => 'DBD::SQLite required';
	9	+ eval { DBD::SQLite->VERSION >= 1 }
	10	+ or plan skip_all => 'DBD::SQLite >= 1.00 required';
	11	+
	12	+ plan 'no_plan';
	13	+ use_ok('DBIx::Custom::Result');
	14	+}
	15	+
	16	+my $test;
	17	+sub test {
	18	+ $test = shift;
	19	+}
	20	+
	21	+sub query {
	22	+ my ($dbh, $sql) = @_;
	23	+ my $sth = $dbh->prepare($sql);
	24	+ $sth->execute;
	25	+ return DBIx::Custom::Result->new(sth => $sth);
	26	+}
	27	+
	28	+my $dbh;
	29	+my $sql;
	30	+my $sth;
	31	+my @row;
	32	+my $row;
	33	+my @rows;
	34	+my $rows;
	35	+my $result;
	36	+my $fetch_filter;
	37	+my @error;
	38	+my $error;
	39	+
	40	+$dbh = DBI->connect('dbi:SQLite:dbname=:memory:', undef, undef, {PrintError => 0, RaiseError => 1});
	41	+$dbh->do("create table table1 (key1 char(255), key2 char(255));");
	42	+$dbh->do("insert into table1 (key1, key2) values ('1', '2');");
	43	+$dbh->do("insert into table1 (key1, key2) values ('3', '4');");
	44	+
	45	+$sql = "select key1, key2 from table1";
	46	+
	47	+test 'fetch scalar context';
	48	+$result = query($dbh, $sql);
	49	+@rows = ();
	50	+while (my $row = $result->fetch) {
	51	+ push @rows, [@$row];
	52	+}
	53	+is_deeply(\@rows, [[1, 2], [3, 4]], $test);
	54	+
	55	+
	56	+test 'fetch list context';
	57	+$result = query($dbh, $sql);
	58	+@rows = ();
	59	+while (my @row = $result->fetch) {
	60	+ push @rows, [@row];
	61	+}
	62	+is_deeply(\@rows, [[1, 2], [3, 4]], $test);
	63	+
	64	+test 'fetch_hash scalar context';
	65	+$result = query($dbh, $sql);
	66	+@rows = ();
	67	+while (my $row = $result->fetch_hash) {
	68	+ push @rows, {%$row};
	69	+}
	70	+is_deeply(\@rows, [{key1 => 1, key2 => 2}, {key1 => 3, key2 => 4}], $test);
	71	+
	72	+
	73	+test 'fetch hash list context';
	74	+$result = query($dbh, $sql);
	75	+@rows = ();
	76	+while (my %row = $result->fetch_hash) {
	77	+ push @rows, {%row};
	78	+}
	79	+is_deeply(\@rows, [{key1 => 1, key2 => 2}, {key1 => 3, key2 => 4}], $test);
	80	+
	81	+
	82	+test 'fetch_first';
	83	+$result = query($dbh, $sql);
	84	+$row = $result->fetch_first;
	85	+is_deeply($row, [1, 2], "$test : row");
	86	+$row = $result->fetch;
	87	+ok(!$row, "$test : finished");
	88	+
	89	+
	90	+test 'fetch_first list context';
	91	+$result = query($dbh, $sql);
	92	+@row = $result->fetch_first;
	93	+is_deeply([@row], [1, 2], "$test : row");
	94	+@row = $result->fetch;
	95	+ok(!@row, "$test : finished");
	96	+
	97	+
	98	+test 'fetch_first_hash';
	99	+$result = query($dbh, $sql);
	100	+$row = $result->fetch_first_hash;
	101	+is_deeply($row, {key1 => 1, key2 => 2}, "$test : row");
	102	+$row = $result->fetch_hash;
	103	+ok(!$row, "$test : finished");
	104	+
	105	+
	106	+test 'fetch_first_hash list context';
	107	+$result = query($dbh, $sql);
	108	+@row = $result->fetch_first_hash;
	109	+is_deeply({@row}, {key1 => 1, key2 => 2}, "$test : row");
	110	+@row = $result->fetch_hash;
	111	+ok(!@row, "$test : finished");
	112	+
	113	+
	114	+test 'fetch_rows';
	115	+$dbh->do("insert into table1 (key1, key2) values ('5', '6');");
	116	+$dbh->do("insert into table1 (key1, key2) values ('7', '8');");
	117	+$dbh->do("insert into table1 (key1, key2) values ('9', '10');");
	118	+$result = query($dbh, $sql);
	119	+$rows = $result->fetch_rows(2);
	120	+is_deeply($rows, [[1, 2],
	121	+ [3, 4]], "$test : fetch_rows first");
	122	+$rows = $result->fetch_rows(2);
	123	+is_deeply($rows, [[5, 6],
	124	+ [7, 8]], "$test : fetch_rows secound");
	125	+$rows = $result->fetch_rows(2);
	126	+is_deeply($rows, [[9, 10]], "$test : fetch_rows third");
	127	+$rows = $result->fetch_rows(2);
	128	+ok(!$rows);
	129	+
	130	+
	131	+test 'fetch_rows list context';
	132	+$result = query($dbh, $sql);
	133	+@rows = $result->fetch_rows(2);
	134	+is_deeply([@rows], [[1, 2],
	135	+ [3, 4]], "$test : fetch_rows first");
	136	+@rows = $result->fetch_rows(2);
	137	+is_deeply([@rows], [[5, 6],
	138	+ [7, 8]], "$test : fetch_rows secound");
	139	+@rows = $result->fetch_rows(2);
	140	+is_deeply([@rows], [[9, 10]], "$test : fetch_rows third");
	141	+@rows = $result->fetch_rows(2);
	142	+ok(!@rows);
	143	+
	144	+
	145	+test 'fetch_rows error';
	146	+$result = query($dbh, $sql);
	147	+eval {$result->fetch_rows};
	148	+like($@, qr/Row count must be specified/, "$test : Not specified row count");
	149	+
	150	+
	151	+test 'fetch_rows_hash';
	152	+$result = query($dbh, $sql);
	153	+$rows = $result->fetch_rows_hash(2);
	154	+is_deeply($rows, [{key1 => 1, key2 => 2},
	155	+ {key1 => 3, key2 => 4}], "$test : fetch_rows first");
	156	+$rows = $result->fetch_rows_hash(2);
	157	+is_deeply($rows, [{key1 => 5, key2 => 6},
	158	+ {key1 => 7, key2 => 8}], "$test : fetch_rows secound");
	159	+$rows = $result->fetch_rows_hash(2);
	160	+is_deeply($rows, [{key1 => 9, key2 => 10}], "$test : fetch_rows third");
	161	+$rows = $result->fetch_rows_hash(2);
	162	+ok(!$rows);
	163	+
	164	+
	165	+test 'fetch_rows list context';
	166	+$result = query($dbh, $sql);
	167	+@rows = $result->fetch_rows_hash(2);
	168	+is_deeply([@rows], [{key1 => 1, key2 => 2},
	169	+ {key1 => 3, key2 => 4}], "$test : fetch_rows first");
	170	+@rows = $result->fetch_rows_hash(2);
	171	+is_deeply([@rows], [{key1 => 5, key2 => 6},
	172	+ {key1 => 7, key2 => 8}], "$test : fetch_rows secound");
	173	+@rows = $result->fetch_rows_hash(2);
	174	+is_deeply([@rows], [{key1 => 9, key2 => 10}], "$test : fetch_rows third");
	175	+@rows = $result->fetch_rows_hash(2);
	176	+ok(!@rows);
	177	+$dbh->do("delete from table1 where key1 = 5 or key1 = 7 or key1 = 9");
	178	+
	179	+
	180	+test 'fetch_rows error';
	181	+$result = query($dbh, $sql);
	182	+eval {$result->fetch_rows_hash};
	183	+like($@, qr/Row count must be specified/, "$test : Not specified row count");
	184	+
	185	+
	186	+test 'fetch_all';
	187	+$result = query($dbh, $sql);
	188	+$rows = $result->fetch_all;
	189	+is_deeply($rows, [[1, 2], [3, 4]], $test);
	190	+
	191	+test 'fetch_all list context';
	192	+$result = query($dbh, $sql);
	193	+@rows = $result->fetch_all;
	194	+is_deeply(\@rows, [[1, 2], [3, 4]], $test);
	195	+
	196	+
	197	+test 'fetch_all_hash';
	198	+$result = query($dbh, $sql);
	199	+@rows = $result->fetch_all_hash;
	200	+is_deeply($rows, [[1, 2], [3, 4]], $test);
	201	+
	202	+
	203	+test 'fetch_all_hash list context';
	204	+$result = query($dbh, $sql);
	205	+@rows = $result->fetch_all;
	206	+is_deeply(\@rows, [[1, 2], [3, 4]], $test);
	207	+
	208	+
	209	+test 'fetch filter';
	210	+$fetch_filter = sub {
	211	+ my ($key, $value, $type, $sth, $i) = @_;
	212	+ if ($key eq 'key1' && $value == 1 && $type =~ /char/i && $i == 0 && $sth->{TYPE}->[$i] eq $type) {
	213	+ return $value * 3;
	214	+ }
	215	+ return $value;
	216	+};
	217	+
	218	+$result = query($dbh, $sql);
	219	+$result->fetch_filter($fetch_filter);
	220	+$rows = $result->fetch_all;
	221	+is_deeply($rows, [[3, 2], [3, 4]], "$test array");
	222	+
	223	+$result = query($dbh, $sql);
	224	+$result->fetch_filter($fetch_filter);
	225	+$rows = $result->fetch_all_hash;
	226	+is_deeply($rows, [{key1 => 3, key2 => 2}, {key1 => 3, key2 => 4}], "$test hash");
	227	+
	228	+$result = query($dbh, $sql);
	229	+$result->no_fetch_filters(['key1']);
	230	+$rows = $result->fetch_all;
	231	+is_deeply($rows, [[1, 2], [3, 4]], "$test array no filter keys");
	232	+
	233	+$result = query($dbh, $sql);
	234	+$result->no_fetch_filters(['key1']);
	235	+$rows = $result->fetch_all_hash;
	236	+is_deeply($rows, [{key1 => 1, key2 => 2}, {key1 => 3, key2 => 4}], "$test hash no filter keys");
	237	+
	238	+
	239	+test 'finish';
	240	+$result = query($dbh, $sql);
	241	+$result->fetch;
	242	+$result->finish;
	243	+ok(!$result->fetch, $test);
	244	+
	245	+test 'error'; # Cannot real test
	246	+$result = query($dbh, $sql);
	247	+$sth = $result->sth;
	248	+
	249	+@error = $result->error;
	250	+is(scalar @error, 3, "$test list context count");
	251	+is($error[0], $sth->errstr, "$test list context errstr");
	252	+is($error[1], $sth->err, "$test list context err");
	253	+is($error[2], $sth->state, "$test list context state");
	254	+
	255	+$error = $result->error;
	256	+is($error, $sth->errstr, "$test scalar context");
	257	+

+50

DBIx-Custom-Result/t/boilerplate.t

View

...	...	@@ -0,0 +1,50 @@
	1	+#!perl -T
	2	+
	3	+use strict;
	4	+use warnings;
	5	+use Test::More tests => 3;
	6	+
	7	+sub not_in_file_ok {
	8	+ my ($filename, %regex) = @_;
	9	+ open( my $fh, '<', $filename )
	10	+ or die "couldn't open $filename for reading: $!";
	11	+
	12	+ my %violated;
	13	+
	14	+ while (my $line = <$fh>) {
	15	+ while (my ($desc, $regex) = each %regex) {
	16	+ if ($line =~ $regex) {
	17	+ push @{$violated{$desc}\|\|=[]}, $.;
	18	+ }
	19	+ }
	20	+ }
	21	+
	22	+ if (%violated) {
	23	+ fail("$filename contains boilerplate text");
	24	+ diag "$_ appears on lines @{$violated{$_}}" for keys %violated;
	25	+ } else {
	26	+ pass("$filename contains no boilerplate text");
	27	+ }
	28	+}
	29	+
	30	+sub module_boilerplate_ok {
	31	+ my ($module) = @_;
	32	+ not_in_file_ok($module =>
	33	+ 'the great new $MODULENAME' => qr/ - The great new /,
	34	+ 'boilerplate description' => qr/Quick summary of what the module/,
	35	+ 'stub function definition' => qr/function[12]/,
	36	+ );
	37	+}
	38	+
	39	+ not_in_file_ok(README =>
	40	+ "The README is used..." => qr/The README is used/,
	41	+ "'version information here'" => qr/to provide version information/,
	42	+ );
	43	+
	44	+ not_in_file_ok(Changes =>
	45	+ "placeholder date/time" => qr(Date/time)
	46	+ );
	47	+
	48	+ module_boilerplate_ok('lib/DBIx/Custom/Result.pm');
	49	+
	50	+

+18

DBIx-Custom-Result/t/pod-coverage.t

View

...	...	@@ -0,0 +1,18 @@
	1	+use strict;
	2	+use warnings;
	3	+use Test::More;
	4	+
	5	+# Ensure a recent version of Test::Pod::Coverage
	6	+my $min_tpc = 1.08;
	7	+eval "use Test::Pod::Coverage $min_tpc";
	8	+plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage"
	9	+ if $@;
	10	+
	11	+# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version,
	12	+# but older versions don't recognize some common documentation styles
	13	+my $min_pc = 0.18;
	14	+eval "use Pod::Coverage $min_pc";
	15	+plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage"
	16	+ if $@;
	17	+
	18	+all_pod_coverage_ok();

+12

DBIx-Custom-Result/t/pod.t

View

...	...	@@ -0,0 +1,12 @@
	1	+#!perl -T
	2	+
	3	+use strict;
	4	+use warnings;
	5	+use Test::More;
	6	+
	7	+# Ensure a recent version of Test::Pod
	8	+my $min_tp = 1.22;
	9	+eval "use Test::Pod $min_tp";
	10	+plan skip_all => "Test::Pod $min_tp required for testing POD" if $@;
	11	+
	12	+all_pod_files_ok();

+10

DBIx-Custom-SQL-Template/.gitignore

View

...	...	@@ -0,0 +1,10 @@
	1	+*.bak
	2	+*.BAK
	3	+Build
	4	+MANIFEST
	5	+META.yml
	6	+Makefile.PL
	7	+_build/*
	8	+blib/*
	9	+*.tar.gz
	10	+cover_db/*

+20

DBIx-Custom-SQL-Template/Build.PL

View

...	...	@@ -0,0 +1,20 @@
	1	+use strict;
	2	+use warnings;
	3	+use Module::Build;
	4	+
	5	+my $builder = Module::Build->new(
	6	+ module_name => 'DBIx::Custom::SQL::Template',
	7	+ license => 'perl',
	8	+ dist_author => 'Yuki Kimoto <kimoto.yuki@gmail.com>',
	9	+ dist_version_from => 'lib/DBIx/Custom/SQL/Template.pm',
	10	+ build_requires => {
	11	+ 'Test::More' => 0,
	12	+ },
	13	+ requires => {
	14	+ 'Object::Simple' => 2.0702,
	15	+ },
	16	+ add_to_cleanup => [ 'DBIx-Custom-SQL-Template-*' ],
	17	+ create_makefile_pl => 'traditional',
	18	+);
	19	+
	20	+$builder->create_build_script();

DBIx-Custom-SQL-Template/Changes

View

...	...	@@ -0,0 +1,2 @@
	1	+0.0101
	2	+ First release

+15

DBIx-Custom-SQL-Template/MANIFEST.SKIP

View

...	...	@@ -0,0 +1,15 @@
	1	+\bRCS\b
	2	+\bCVS\b
	3	+^MANIFEST\.
	4	+^Makefile$
	5	+^Build$
	6	+^Build.bat$
	7	+^_build/
	8	+\.(bak\|tdy\|old\|tmp)$
	9	+~$
	10	+^blib/
	11	+^pm_to_blib
	12	+\.cvsignore
	13	+\.gz$
	14	+^\.git
	15	+^cover_db/

+15

DBIx-Custom-SQL-Template/README

View

...	...	@@ -0,0 +1,15 @@
	1	+DBIx-Custom-SQL-Template
	2	+
	3	+SQL Template for DBIx::Custom
	4	+
	5	+INSTALLATION
	6	+
	7	+cpan DBIx::Custom::SQL::Template
	8	+
	9	+COPYRIGHT AND LICENCE
	10	+
	11	+Copyright (C) 2009 Yuki Kimoto
	12	+
	13	+This program is free software; you can redistribute it and/or modify it
	14	+under the same terms as Perl itself.
	15	+

+696

DBIx-Custom-SQL-Template/lib/DBIx/Custom/SQL/Template.pm

View

...	...	@@ -0,0 +1,696 @@
	1	+package DBIx::Custom::SQL::Template;
	2	+use Object::Simple;
	3	+
	4	+our $VERSION = '0.0101';
	5	+
	6	+use Carp 'croak';
	7	+
	8	+# Accessor is created by Object::Simple. Please read Object::Simple document
	9	+
	10	+### Class-Object accessors
	11	+
	12	+# Tag start
	13	+sub tag_start : ClassObjectAttr {
	14	+ initialize => {default => '{', clone => 'scalar'}
	15	+}
	16	+
	17	+# Tag end
	18	+sub tag_end : ClassObjectAttr {
	19	+ initialize => {default => '}', clone => 'scalar'}
	20	+}
	21	+
	22	+# Tag syntax
	23	+sub tag_syntax : ClassObjectAttr {
	24	+ initialize => {default => <<'EOS', clone => 'scalar'}}
	25	+[tag] [expand]
	26	+{? name} ?
	27	+{= name} name = ?
	28	+{<> name} name <> ?
	29	+
	30	+{< name} name < ?
	31	+{> name} name > ?
	32	+{>= name} name >= ?
	33	+{<= name} name <= ?
	34	+
	35	+{like name} name like ?
	36	+{in name number} name in [?, ?, ..]
	37	+
	38	+{insert key1 key2} (key1, key2) values (?, ?)
	39	+{update key1 key2} set key1 = ?, key2 = ?
	40	+EOS
	41	+
	42	+# Tag processors
	43	+sub tag_processors : ClassObjectAttr {
	44	+ type => 'hash',
	45	+ deref => 1,
	46	+ initialize => {
	47	+ clone => 'hash',
	48	+ default => sub {{
	49	+ '?' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_basic_tag,
	50	+ '=' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_basic_tag,
	51	+ '<>' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_basic_tag,
	52	+ '>' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_basic_tag,
	53	+ '<' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_basic_tag,
	54	+ '>=' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_basic_tag,
	55	+ '<=' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_basic_tag,
	56	+ 'like' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_basic_tag,
	57	+ 'in' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_in_tag,
	58	+ 'insert' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_insert_tag,
	59	+ 'update' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_update_tag
	60	+ }}
	61	+ }
	62	+}
	63	+
	64	+# Add Tag processor
	65	+sub add_tag_processor {
	66	+ my $invocant = shift;
	67	+ my $tag_processors = ref $_[0] eq 'HASH' ? $_[0] : {@_};
	68	+ $invocant->tag_processors(%{$invocant->tag_processors}, %{$tag_processors});
	69	+ return $invocant;
	70	+}
	71	+
	72	+# Clone
	73	+sub clone {
	74	+ my $self = shift;
	75	+ my $new = $self->new;
	76	+
	77	+ $new->tag_start($self->tag_start);
	78	+ $new->tag_end($self->tag_end);
	79	+ $new->tag_syntax($self->tag_syntax);
	80	+ $new->tag_processors({%{$self->tag_processors \|\| {}}});
	81	+
	82	+ return $new;
	83	+}
	84	+
	85	+
	86	+### Object Methods
	87	+
	88	+# Create Query
	89	+sub create_query {
	90	+ my ($self, $template) = @_;
	91	+
	92	+ # Parse template
	93	+ my $tree = $self->_parse_template($template);
	94	+
	95	+ # Build query
	96	+ my $query = $self->_build_query($tree);
	97	+
	98	+ return $query;
	99	+}
	100	+
	101	+# Parse template
	102	+sub _parse_template {
	103	+ my ($self, $template) = @_;
	104	+ $template \|\|= '';
	105	+
	106	+ my $tree = [];
	107	+
	108	+ # Tags
	109	+ my $tag_start = quotemeta $self->tag_start;
	110	+ my $tag_end = quotemeta $self->tag_end;
	111	+
	112	+ # Tokenize
	113	+ my $state = 'text';
	114	+
	115	+ # Save original template
	116	+ my $original_template = $template;
	117	+
	118	+ # Parse template
	119	+ while ($template =~ s/([^$tag_start]?)$tag_start([^$tag_end].?)$tag_end//sm) {
	120	+ my $text = $1;
	121	+ my $tag = $2;
	122	+
	123	+ # Parse tree
	124	+ push @$tree, {type => 'text', tag_args => [$text]} if $text;
	125	+
	126	+ if ($tag) {
	127	+ # Get tag name and arguments
	128	+ my ($tag_name, @tag_args) = split /\s+/, $tag;
	129	+
	130	+ # Tag processor is exist?
	131	+ unless ($self->tag_processors->{$tag_name}) {
	132	+ my $tag_syntax = $self->tag_syntax;
	133	+ croak("Tag '{$tag}' in SQL template is not exist.\n\n" .
	134	+ "<SQL template tag syntax>\n" .
	135	+ "$tag_syntax\n" .
	136	+ "<Your SQL template>\n" .
	137	+ "$original_template\n\n");
	138	+ }
	139	+
	140	+ # Check tag arguments
	141	+ foreach my $tag_arg (@tag_args) {
	142	+ # Cannot cantain placehosder '?'
	143	+ croak("Tag '{t }' arguments cannot contain '?'")
	144	+ if $tag_arg =~ /\?/;
	145	+ }
	146	+
	147	+ # Add tag to parsing tree
	148	+ push @$tree, {type => 'tag', tag_name => $tag_name, tag_args => [@tag_args]};
	149	+ }
	150	+ }
	151	+
	152	+ # Add text to parsing tree
	153	+ push @$tree, {type => 'text', tag_args => [$template]} if $template;
	154	+
	155	+ return $tree;
	156	+}
	157	+
	158	+# Build SQL from parsing tree
	159	+sub _build_query {
	160	+ my ($self, $tree) = @_;
	161	+
	162	+ # SQL
	163	+ my $sql = '';
	164	+
	165	+ # All parameter key infomation
	166	+ my $all_key_infos = [];
	167	+
	168	+ # Build SQL
	169	+ foreach my $node (@$tree) {
	170	+
	171	+ # Get type, tag name, and arguments
	172	+ my $type = $node->{type};
	173	+ my $tag_name = $node->{tag_name};
	174	+ my $tag_args = $node->{tag_args};
	175	+
	176	+ # Text
	177	+ if ($type eq 'text') {
	178	+ # Join text
	179	+ $sql .= $tag_args->[0];
	180	+ }
	181	+
	182	+ # Tag
	183	+ elsif ($type eq 'tag') {
	184	+
	185	+ # Get tag processor
	186	+ my $tag_processor = $self->tag_processors->{$tag_name};
	187	+
	188	+ # Tag processor is code ref?
	189	+ croak("Tag processor '$tag_name' must be code reference")
	190	+ unless ref $tag_processor eq 'CODE';
	191	+
	192	+ # Expand tag using tag processor
	193	+ my ($expand, $key_infos)
	194	+ = $tag_processor->($tag_name, $tag_args);
	195	+
	196	+ # Check tag processor return value
	197	+ croak("Tag processor '$tag_name' must return (\$expand, \$key_infos)")
	198	+ if !defined $expand \|\| ref $key_infos ne 'ARRAY';
	199	+
	200	+ # Check placeholder count
	201	+ croak("Placeholder count in SQL created by tag processor '$tag_name' " .
	202	+ "must be same as key informations count")
	203	+ unless $self->_placeholder_count($expand) eq @$key_infos;
	204	+
	205	+ # Add key information
	206	+ push @$all_key_infos, @$key_infos;
	207	+
	208	+ # Join expand tag to SQL
	209	+ $sql .= $expand;
	210	+ }
	211	+ }
	212	+
	213	+ # Add semicolon
	214	+ $sql .= ';' unless $sql =~ /;$/;
	215	+
	216	+ # Query
	217	+ my $query = {sql => $sql, key_infos => $all_key_infos};
	218	+
	219	+ return $query;
	220	+}
	221	+
	222	+# Get placeholder count
	223	+sub _placeholder_count {
	224	+ my ($self, $expand) = @_;
	225	+ $expand \|\|= '';
	226	+
	227	+ my $count = 0;
	228	+ my $pos = -1;
	229	+ while (($pos = index($expand, '?', $pos + 1)) != -1) {
	230	+ $count++;
	231	+ }
	232	+ return $count;
	233	+}
	234	+
	235	+Object::Simple->build_class;
	236	+
	237	+
	238	+package DBIx::Custom::SQL::Template::TagProcessor;
	239	+use strict;
	240	+use warnings;
	241	+use Carp 'croak';
	242	+
	243	+# Expand tag '?', '=', '<>', '>', '<', '>=', '<=', 'like'
	244	+sub expand_basic_tag {
	245	+ my ($tag_name, $tag_args) = @_;
	246	+ my $original_key = $tag_args->[0];
	247	+
	248	+ # Key is not exist
	249	+ croak("You must be pass key as argument to tag '{$tag_name }'")
	250	+ if !$original_key;
	251	+
	252	+ # Expanded tag
	253	+ my $expand = $tag_name eq '?'
	254	+ ? '?'
	255	+ : "$original_key $tag_name ?";
	256	+
	257	+ # Get table and clumn name
	258	+ my ($table, $column) = get_table_and_column($original_key);
	259	+
	260	+ # Parameter key infomation
	261	+ my $key_info = {};
	262	+
	263	+ # Original key
	264	+ $key_info->{original_key} = $original_key;
	265	+
	266	+ # Table
	267	+ $key_info->{table} = $table;
	268	+
	269	+ # Column name
	270	+ $key_info->{column} = $column;
	271	+
	272	+ # Access keys
	273	+ my $access_keys = [];
	274	+ push @$access_keys, [$original_key];
	275	+ push @$access_keys, [$table, $column] if $table && $column;
	276	+ $key_info->{access_keys} = $access_keys;
	277	+
	278	+ # Add parameter key information
	279	+ my $key_infos = [];
	280	+ push @$key_infos, $key_info;
	281	+
	282	+ return ($expand, $key_infos);
	283	+}
	284	+
	285	+# Expand tag 'in'
	286	+sub expand_in_tag {
	287	+ my ($tag_name, $tag_args) = @_;
	288	+ my ($original_key, $placeholder_count) = @$tag_args;
	289	+
	290	+ # Key must be specified
	291	+ croak("You must be pass key as first argument of tag '{$tag_name }'\n" .
	292	+ "Usage: {$tag_name \$key \$placeholder_count}")
	293	+ unless $original_key;
	294	+
	295	+
	296	+ # Place holder count must be specified
	297	+ croak("You must be pass placeholder count as second argument of tag '{$tag_name }'\n" .
	298	+ "Usage: {$tag_name \$key \$placeholder_count}")
	299	+ if !$placeholder_count \|\| $placeholder_count =~ /\D/;
	300	+
	301	+ # Expand tag
	302	+ my $expand = "$original_key $tag_name (";
	303	+ for (my $i = 0; $i < $placeholder_count; $i++) {
	304	+ $expand .= '?, ';
	305	+ }
	306	+
	307	+ $expand =~ s/, $//;
	308	+ $expand .= ')';
	309	+
	310	+ # Get table and clumn name
	311	+ my ($table, $column) = get_table_and_column($original_key);
	312	+
	313	+ # Create parameter key infomations
	314	+ my $key_infos = [];
	315	+ for (my $i = 0; $i < $placeholder_count; $i++) {
	316	+ # Parameter key infomation
	317	+ my $key_info = {};
	318	+
	319	+ # Original key
	320	+ $key_info->{original_key} = $original_key;
	321	+
	322	+ # Table
	323	+ $key_info->{table} = $table;
	324	+
	325	+ # Column name
	326	+ $key_info->{column} = $column;
	327	+
	328	+ # Access keys
	329	+ my $access_keys = [];
	330	+ push @$access_keys, [$original_key, [$i]];
	331	+ push @$access_keys, [$table, $column, [$i]] if $table && $column;
	332	+ $key_info->{access_keys} = $access_keys;
	333	+
	334	+ # Add parameter key infos
	335	+ push @$key_infos, $key_info;
	336	+ }
	337	+
	338	+ return ($expand, $key_infos);
	339	+}
	340	+
	341	+# Get table and column
	342	+sub get_table_and_column {
	343	+ my $key = shift;
	344	+ $key \|\|= '';
	345	+
	346	+ return ('', $key) unless $key =~ /\./;
	347	+
	348	+ my ($table, $column) = split /\./, $key;
	349	+
	350	+ return ($table, $column);
	351	+}
	352	+
	353	+# Expand tag 'insert'
	354	+sub expand_insert_tag {
	355	+ my ($tag_name, $tag_args) = @_;
	356	+ my $original_keys = $tag_args;
	357	+
	358	+ # Insert key (k1, k2, k3, ..)
	359	+ my $insert_keys = '(';
	360	+
	361	+ # placeholder (?, ?, ?, ..)
	362	+ my $place_holders = '(';
	363	+
	364	+ foreach my $original_key (@$original_keys) {
	365	+ # Get table and column
	366	+ my ($table, $column) = get_table_and_column($original_key);
	367	+
	368	+ # Join insert column
	369	+ $insert_keys .= "$column, ";
	370	+
	371	+ # Join place holder
	372	+ $place_holders .= "?, ";
	373	+ }
	374	+
	375	+ # Delete last ', '
	376	+ $insert_keys =~ s/, $//;
	377	+
	378	+ # Close
	379	+ $insert_keys .= ')';
	380	+ $place_holders =~ s/, $//;
	381	+ $place_holders .= ')';
	382	+
	383	+ # Expand tag
	384	+ my $expand = "$insert_keys values $place_holders";
	385	+
	386	+ # Create parameter key infomations
	387	+ my $key_infos = [];
	388	+ foreach my $original_key (@$original_keys) {
	389	+ # Get table and clumn name
	390	+ my ($table, $column) = get_table_and_column($original_key);
	391	+
	392	+ # Parameter key infomation
	393	+ my $key_info = {};
	394	+
	395	+ # Original key
	396	+ $key_info->{original_key} = $original_key;
	397	+
	398	+ # Table
	399	+ $key_info->{table} = $table;
	400	+
	401	+ # Column name
	402	+ $key_info->{column} = $column;
	403	+
	404	+ # Access keys
	405	+ my $access_keys = [];
	406	+ push @$access_keys, ['#insert', $original_key];
	407	+ push @$access_keys, ['#insert', $table, $column] if $table && $column;
	408	+ push @$access_keys, [$original_key];
	409	+ push @$access_keys, [$table, $column] if $table && $column;
	410	+ $key_info->{access_keys} = $access_keys;
	411	+
	412	+ # Add parameter key infos
	413	+ push @$key_infos, $key_info;
	414	+ }
	415	+
	416	+ return ($expand, $key_infos);
	417	+}
	418	+
	419	+# Expand tag 'update'
	420	+sub expand_update_tag {
	421	+ my ($tag_name, $tag_args) = @_;
	422	+ my $original_keys = $tag_args;
	423	+
	424	+ # Expanded tag
	425	+ my $expand = 'set ';
	426	+
	427	+ #
	428	+ foreach my $original_key (@$original_keys) {
	429	+ # Get table and clumn name
	430	+ my ($table, $column) = get_table_and_column($original_key);
	431	+
	432	+ # Join key and placeholder
	433	+ $expand .= "$column = ?, ";
	434	+ }
	435	+
	436	+ # Delete last ', '
	437	+ $expand =~ s/, $//;
	438	+
	439	+ # Create parameter key infomations
	440	+ my $key_infos = [];
	441	+ foreach my $original_key (@$original_keys) {
	442	+ # Get table and clumn name
	443	+ my ($table, $column) = get_table_and_column($original_key);
	444	+
	445	+ # Parameter key infomation
	446	+ my $key_info = {};
	447	+
	448	+ # Original key
	449	+ $key_info->{original_key} = $original_key;
	450	+
	451	+ # Table
	452	+ $key_info->{table} = $table;
	453	+
	454	+ # Column name
	455	+ $key_info->{column} = $column;
	456	+
	457	+ # Access keys
	458	+ my $access_keys = [];
	459	+ push @$access_keys, ['#update', $original_key];
	460	+ push @$access_keys, ['#update', $table, $column] if $table && $column;
	461	+ push @$access_keys, [$original_key];
	462	+ push @$access_keys, [$table, $column] if $table && $column;
	463	+ $key_info->{access_keys} = $access_keys;
	464	+
	465	+ # Add parameter key infos
	466	+ push @$key_infos, $key_info;
	467	+ }
	468	+
	469	+ return ($expand, $key_infos);
	470	+}
	471	+
	472	+1;
	473	+
	474	+=head1 NAME
	475	+
	476	+DBIx::Custom::SQL::Template - Custamizable SQL Template for DBIx::Custom
	477	+
	478	+=head1 VERSION
	479	+
	480	+Version 0.0101
	481	+
	482	+=cut
	483	+
	484	+=head1 SYNOPSIS
	485	+
	486	+ my $sql_tmpl = DBIx::Custom::SQL::Template->new;
	487	+
	488	+ my $tmpl = "select from table {= k1} && {<> k2} \|\| {like k3}";
	489	+ my $param = {k1 => 1, k2 => 2, k3 => 3};
	490	+
	491	+ my $query = $sql_template->create_query($tmpl);
	492	+
	493	+
	494	+ # Using query from DBIx::Custom
	495	+ use DBIx::Custom;
	496	+ my $dbi = DBI->new(
	497	+ data_source => $data_source,
	498	+ user => $user,
	499	+ password => $password,
	500	+ dbi_options => {PrintError => 0, RaiseError => 1}
	501	+ );
	502	+
	503	+ $query = $dbi->create_query($tmpl); # This is SQL::Template create_query
	504	+ $dbi->query($query, $param);
	505	+
	506	+=head1 CLASS-OBJECT ACCESSORS
	507	+
	508	+Class-Object accessor is used from both object and class
	509	+
	510	+ $class->$accessor # call from class
	511	+ $self->$accessor # call form object
	512	+
	513	+=head2 tag_processors
	514	+
	515	+ # Set and get
	516	+ $self = $sql_tmpl->tag_processors($tag_processors);
	517	+ $tag_processors = $sql_tmpl->tag_processors;
	518	+
	519	+ # Sample
	520	+ $sql_tmpl->tag_processors(
	521	+ '?' => \&expand_question,
	522	+ '=' => \&expand_equel
	523	+ );
	524	+
	525	+You can use add_tag_processor to add tag processor
	526	+
	527	+=head2 tag_start
	528	+
	529	+ # Set and get
	530	+ $self = $sql_tmpl->tag_start($tag_start);
	531	+ $tag_start = $sql_tmpl->tag_start;
	532	+
	533	+ # Sample
	534	+ $sql_tmpl->tag_start('{');
	535	+
	536	+Default is '{'
	537	+
	538	+=head2 tag_end
	539	+
	540	+ # Set and get
	541	+ $self = $sql_tmpl->tag_start($tag_end);
	542	+ $tag_end = $sql_tmpl->tag_start;
	543	+
	544	+ # Sample
	545	+ $sql_tmpl->tag_start('}');
	546	+
	547	+Default is '}'
	548	+
	549	+=head2 tag_syntax
	550	+
	551	+ # Set and get
	552	+ $self = $sql_tmpl->tag_syntax($tag_syntax);
	553	+ $tag_syntax = $sql_tmpl->tag_syntax;
	554	+
	555	+ # Sample
	556	+ $sql_tmpl->tag_syntax(
	557	+ "[Tag] [Expand]\n" .
	558	+ "{? name} ?\n" .
	559	+ "{= name} name = ?\n" .
	560	+ "{<> name} name <> ?\n"
	561	+ );
	562	+
	563	+=head1 METHODS
	564	+
	565	+=head2 create_query
	566	+
	567	+ # Create SQL form SQL template
	568	+ $query = $sql_tmpl->create_query($tmpl);
	569	+
	570	+ # Sample
	571	+ $query = $sql_tmpl->create_sql(
	572	+ "select * from table where {= title} && {like author} \|\| {<= price}")
	573	+
	574	+ # Result
	575	+ $qeury->{sql} : "select * from table where title = ? && author like ? price <= ?;"
	576	+ $query->{key_infos} : [['title'], ['author'], ['price']]
	577	+
	578	+ # Sample2 (with table name)
	579	+ ($sql, @bind_values) = $sql_tmpl->create_sql(
	580	+ "select * from table where {= table.title} && {like table.author}",
	581	+ {table => {title => 'Perl', author => '%Taro%'}}
	582	+ )
	583	+
	584	+ # Result2
	585	+ $query->{sql} : "select * from table where table.title = ? && table.title like ?;"
	586	+ $query->{key_infos} :[ [['table.title'],['table', 'title']],
	587	+ [['table.author'],['table', 'author']] ]
	588	+
	589	+This method create query using by DBIx::Custom.
	590	+query is two infomation
	591	+
	592	+ 1.sql : SQL
	593	+ 2.key_infos : Parameter access key information
	594	+
	595	+=head2 add_tag_processor
	596	+
	597	+Add tag processor
	598	+
	599	+ # Add
	600	+ $self = $sql_tmpl->add_tag_processor($tag_processor);
	601	+
	602	+ # Sample
	603	+ $sql_tmpl->add_tag_processor(
	604	+ '?' => sub {
	605	+ my ($tag_name, $tag_args) = @_;
	606	+
	607	+ my $key1 = $tag_args->[0];
	608	+ my $key2 = $tag_args->[1];
	609	+
	610	+ my $key_infos = [];
	611	+
	612	+ # Expand tag and create key informations
	613	+
	614	+ # Return expand tags and key informations
	615	+ return ($expand, $key_infos);
	616	+ }
	617	+ );
	618	+
	619	+Tag processor recieve 2 argument
	620	+
	621	+ 1. Tag name (?, =, <>, or etc)
	622	+ 2. Tag arguments (arg1 and arg2 in {tag_name arg1 arg2})
	623	+
	624	+Tag processor return 2 value
	625	+
	626	+ 1. Expanded Tag (For exsample, '{= title}' is expanded to 'title = ?')
	627	+ 2. Key infomations
	628	+
	629	+You must be return expanded tag and key infomations.
	630	+
	631	+Key information is a little complex. so I will explan this in future.
	632	+
	633	+If you want to know more, Please see DBIx::Custom::SQL::Template source code.
	634	+
	635	+=head2 clone
	636	+
	637	+ # Clone DBIx::Custom::SQL::Template object
	638	+ $clone = $self->clone;
	639	+
	640	+=head1 Available Tags
	641	+
	642	+ # Available Tags
	643	+ [tag] [expand]
	644	+ {? name} ?
	645	+ {= name} name = ?
	646	+ {<> name} name <> ?
	647	+
	648	+ {< name} name < ?
	649	+ {> name} name > ?
	650	+ {>= name} name >= ?
	651	+ {<= name} name <= ?
	652	+
	653	+ {like name} name like ?
	654	+ {in name} name in [?, ?, ..]
	655	+
	656	+ {insert} (key1, key2, key3) values (?, ?, ?)
	657	+ {update} set key1 = ?, key2 = ?, key3 = ?
	658	+
	659	+ # Sample1
	660	+ $query = $sql_tmpl->create_sql(
	661	+ "insert into table {insert key1 key2}"
	662	+ );
	663	+ # Result1
	664	+ $sql : "insert into table (key1, key2) values (?, ?)"
	665	+
	666	+
	667	+ # Sample2
	668	+ $query = $sql_tmpl->create_sql(
	669	+ "update table {update key1 key2} where {= key3}"
	670	+ );
	671	+
	672	+ # Result2
	673	+ $query->{sql} : "update table set key1 = ?, key2 = ? where key3 = ?;"
	674	+
	675	+=head1 AUTHOR
	676	+
	677	+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >>
	678	+
	679	+Github
	680	+L<http://github.com/yuki-kimoto>
	681	+L<http://github.com/yuki-kimoto/DBIx-Custom-SQL-Template>
	682	+
	683	+Please let know me bag if you find
	684	+Please request me if you want to do something
	685	+
	686	+=head1 COPYRIGHT & LICENSE
	687	+
	688	+Copyright 2009 Yuki Kimoto, all rights reserved.
	689	+
	690	+This program is free software; you can redistribute it and/or modify it
	691	+under the same terms as Perl itself.
	692	+
	693	+
	694	+=cut
	695	+
	696	+1; # End of DBIx::Custom::SQL::Template

DBIx-Custom-SQL-Template/t/00-load.t

View

...	...	@@ -0,0 +1,9 @@
	1	+#!perl -T
	2	+
	3	+use Test::More tests => 1;
	4	+
	5	+BEGIN {
	6	+ use_ok( 'DBIx::Custom::SQL::Template' );
	7	+}
	8	+
	9	+diag( "Testing DBIx::Custom::SQL::Template $DBIx::Custom::SQL::Template::VERSION, Perl $], $^X" );

+236

DBIx-Custom-SQL-Template/t/01-core.t

View

...	...	@@ -0,0 +1,236 @@
	1	+use strict;
	2	+use warnings;
	3	+
	4	+use Test::More 'no_plan';
	5	+
	6	+use DBIx::Custom::SQL::Template;
	7	+
	8	+# Function for test name
	9	+my $test;
	10	+sub test{
	11	+ $test = shift;
	12	+}
	13	+
	14	+# Variable for test
	15	+my $datas;
	16	+my $sql_tmpl;
	17	+my $query;
	18	+my $ret_val;
	19	+my $clone;
	20	+
	21	+test "Various template pattern";
	22	+$datas = [
	23	+ # Basic tests
	24	+ { name => 'placeholder basic',
	25	+ tmpl => "a {? k1} b {= k2} {<> k3} {> k4} {< k5} {>= k6} {<= k7} {like k8}", ,
	26	+ sql_expected => "a ? b k2 = ? k3 <> ? k4 > ? k5 < ? k6 >= ? k7 <= ? k8 like ?;",
	27	+ key_infos_expected => [
	28	+ {original_key => 'k1', table => '', column => 'k1', access_keys => [['k1']]},
	29	+ {original_key => 'k2', table => '', column => 'k2', access_keys => [['k2']]},
	30	+ {original_key => 'k3', table => '', column => 'k3', access_keys => [['k3']]},
	31	+ {original_key => 'k4', table => '', column => 'k4', access_keys => [['k4']]},
	32	+ {original_key => 'k5', table => '', column => 'k5', access_keys => [['k5']]},
	33	+ {original_key => 'k6', table => '', column => 'k6', access_keys => [['k6']]},
	34	+ {original_key => 'k7', table => '', column => 'k7', access_keys => [['k7']]},
	35	+ {original_key => 'k8', table => '', column => 'k8', access_keys => [['k8']]},
	36	+ ],
	37	+ },
	38	+ {
	39	+ name => 'placeholder in',
	40	+ tmpl => "{in k1 3};",
	41	+ sql_expected => "k1 in (?, ?, ?);",
	42	+ key_infos_expected => [
	43	+ {original_key => 'k1', table => '', column => 'k1', access_keys => [['k1', [0]]]},
	44	+ {original_key => 'k1', table => '', column => 'k1', access_keys => [['k1', [1]]]},
	45	+ {original_key => 'k1', table => '', column => 'k1', access_keys => [['k1', [2]]]},
	46	+ ],
	47	+ },
	48	+ {
	49	+ name => 'insert',
	50	+ tmpl => "{insert k1 k2 k3}",
	51	+ sql_expected => "(k1, k2, k3) values (?, ?, ?);",
	52	+ key_infos_expected => [
	53	+ {original_key => 'k1', table => '', column => 'k1', access_keys => [['#insert', 'k1'], ['k1']]},
	54	+ {original_key => 'k2', table => '', column => 'k2', access_keys => [['#insert', 'k2'], ['k2']]},
	55	+ {original_key => 'k3', table => '', column => 'k3', access_keys => [['#insert', 'k3'], ['k3']]},
	56	+ ],
	57	+ },
	58	+ {
	59	+ name => 'update',
	60	+ tmpl => "{update k1 k2 k3}",
	61	+ sql_expected => "set k1 = ?, k2 = ?, k3 = ?;",
	62	+ key_infos_expected => [
	63	+ {original_key => 'k1', table => '', column => 'k1', access_keys => [['#update', 'k1'], ['k1']]},
	64	+ {original_key => 'k2', table => '', column => 'k2', access_keys => [['#update', 'k2'], ['k2']]},
	65	+ {original_key => 'k3', table => '', column => 'k3', access_keys => [['#update', 'k3'], ['k3']]},
	66	+ ],
	67	+ },
	68	+
	69	+ # Table name
	70	+ {
	71	+ name => 'placeholder with table name',
	72	+ tmpl => "{= a.k1} {= a.k2}",
	73	+ sql_expected => "a.k1 = ? a.k2 = ?;",
	74	+ key_infos_expected => [
	75	+ {original_key => 'a.k1', table => 'a', column => 'k1', access_keys => [['a.k1'], ['a', 'k1']]},
	76	+ {original_key => 'a.k2', table => 'a', column => 'k2', access_keys => [['a.k2'], ['a', 'k2']]},
	77	+ ],
	78	+ },
	79	+ {
	80	+ name => 'placeholder in with table name',
	81	+ tmpl => "{in a.k1 2} {in b.k2 2}",
	82	+ sql_expected => "a.k1 in (?, ?) b.k2 in (?, ?);",
	83	+ key_infos_expected => [
	84	+ {original_key => 'a.k1', table => 'a', column => 'k1', access_keys => [['a.k1', [0]], ['a', 'k1', [0]]]},
	85	+ {original_key => 'a.k1', table => 'a', column => 'k1', access_keys => [['a.k1', [1]], ['a', 'k1', [1]]]},
	86	+ {original_key => 'b.k2', table => 'b', column => 'k2', access_keys => [['b.k2', [0]], ['b', 'k2', [0]]]},
	87	+ {original_key => 'b.k2', table => 'b', column => 'k2', access_keys => [['b.k2', [1]], ['b', 'k2', [1]]]},
	88	+ ],
	89	+ },
	90	+ {
	91	+ name => 'insert with table name',
	92	+ tmpl => "{insert a.k1 b.k2}",
	93	+ sql_expected => "(k1, k2) values (?, ?);",
	94	+ key_infos_expected => [
	95	+ {original_key => 'a.k1', table => 'a', column => 'k1', access_keys => [['#insert', 'a.k1'], ['#insert', 'a', 'k1'], ['a.k1'], ['a', 'k1']]},
	96	+ {original_key => 'b.k2', table => 'b', column => 'k2', access_keys => [['#insert', 'b.k2'], ['#insert', 'b', 'k2'], ['b.k2'], ['b', 'k2']]},
	97	+ ],
	98	+ },
	99	+ {
	100	+ name => 'update with table name',
	101	+ tmpl => "{update a.k1 b.k2}",
	102	+ sql_expected => "set k1 = ?, k2 = ?;",
	103	+ key_infos_expected => [
	104	+ {original_key => 'a.k1', table => 'a', column => 'k1', access_keys => [['#update', 'a.k1'], ['#update', 'a', 'k1'], ['a.k1'], ['a', 'k1']]},
	105	+ {original_key => 'b.k2', table => 'b', column => 'k2', access_keys => [['#update', 'b.k2'], ['#update', 'b', 'k2'], ['b.k2'], ['b', 'k2']]},
	106	+ ],
	107	+ },
	108	+ {
	109	+ name => 'not contain tag',
	110	+ tmpl => "aaa",
	111	+ sql_expected => "aaa;",
	112	+ key_infos_expected => [],
	113	+ }
	114	+];
	115	+
	116	+for (my $i = 0; $i < @$datas; $i++) {
	117	+ my $data = $datas->[$i];
	118	+ my $sql_tmpl = DBIx::Custom::SQL::Template->new;
	119	+ my $query = $sql_tmpl->create_query($data->{tmpl});
	120	+ is($query->{sql}, $data->{sql_expected}, "$test : $data->{name} : sql");
	121	+ is_deeply($query->{key_infos}, $data->{key_infos_expected}, "$test : $data->{name} : key_infos");
	122	+}
	123	+
	124	+
	125	+test 'Original tag processor';
	126	+$sql_tmpl = DBIx::Custom::SQL::Template->new;
	127	+
	128	+$ret_val = $sql_tmpl->add_tag_processor(
	129	+ p => sub {
	130	+ my ($tag_name, $args) = @_;
	131	+
	132	+ my $expand = "$tag_name ? $args->[0] $args->[1]";
	133	+ my $key_infos = [2];
	134	+ return ($expand, $key_infos);
	135	+ }
	136	+);
	137	+
	138	+$query = $sql_tmpl->create_query("{p a b}");
	139	+is($query->{sql}, "p ? a b;", "$test : add_tag_processor sql");
	140	+is_deeply($query->{key_infos}, [2], "$test : add_tag_processor key_infos");
	141	+isa_ok($ret_val, 'DBIx::Custom::SQL::Template');
	142	+
	143	+
	144	+test "Tag processor error case";
	145	+$sql_tmpl = DBIx::Custom::SQL::Template->new;
	146	+
	147	+
	148	+eval{$sql_tmpl->create_query("{a }")};
	149	+like($@, qr/Tag '{a }' in SQL template is not exist/, "$test : tag_processor not exist");
	150	+
	151	+$sql_tmpl->add_tag_processor({
	152	+ q => 'string'
	153	+});
	154	+
	155	+eval{$sql_tmpl->create_query("{q}", {})};
	156	+like($@, qr/Tag processor 'q' must be code reference/, "$test : tag_processor not code ref");
	157	+
	158	+$sql_tmpl->add_tag_processor({
	159	+ r => sub {}
	160	+});
	161	+
	162	+eval{$sql_tmpl->create_query("{r}")};
	163	+like($@, qr/\QTag processor 'r' must return (\E\$expand\Q, \E\$key_infos\Q)/, "$test : tag processor return noting");
	164	+
	165	+$sql_tmpl->add_tag_processor({
	166	+ s => sub { return ("a", "")}
	167	+});
	168	+
	169	+eval{$sql_tmpl->create_query("{s}")};
	170	+like($@, qr/\QTag processor 's' must return (\E\$expand\Q, \E\$key_infos\Q)/, "$test : tag processor return not array key_infos");
	171	+
	172	+$sql_tmpl->add_tag_processor(
	173	+ t => sub {return ("a", [])}
	174	+);
	175	+
	176	+eval{$sql_tmpl->create_query("{t ???}")};
	177	+like($@, qr/Tag '{t }' arguments cannot contain '?'/, "$test : cannot contain '?' in tag argument");
	178	+
	179	+
	180	+test 'General error case';
	181	+$sql_tmpl = DBIx::Custom::SQL::Template->new;
	182	+$sql_tmpl->add_tag_processor(
	183	+ a => sub {
	184	+ return ("? ? ?", [[],[]]);
	185	+ }
	186	+);
	187	+eval{$sql_tmpl->create_query("{a}")};
	188	+like($@, qr/Placeholder count in SQL created by tag processor 'a' must be same as key informations count/, "$test placeholder count is invalid");
	189	+
	190	+
	191	+test 'Default tag processor Error case';
	192	+eval{$sql_tmpl->create_query("{= }")};
	193	+like($@, qr/You must be pass key as argument to tag '{= }'/, "$test : basic '=' : key not exist");
	194	+
	195	+eval{$sql_tmpl->create_query("{in }")};
	196	+like($@, qr/You must be pass key as first argument of tag '{in }'/, "$test : in : key not exist");
	197	+
	198	+eval{$sql_tmpl->create_query("{in a}")};
	199	+like($@, qr/\QYou must be pass placeholder count as second argument of tag '{in }'\E\n\QUsage: {in \E\$key\Q \E\$placeholder_count\Q}/,
	200	+ "$test : in : key not exist");
	201	+
	202	+eval{$sql_tmpl->create_query("{in a r}")};
	203	+like($@, qr/\QYou must be pass placeholder count as second argument of tag '{in }'\E\n\QUsage: {in \E\$key\Q \E\$placeholder_count\Q}/,
	204	+ "$test : in : key not exist");
	205	+
	206	+
	207	+test 'Clone';
	208	+$sql_tmpl = DBIx::Custom::SQL::Template->new;
	209	+$sql_tmpl
	210	+ ->tag_start('[')
	211	+ ->tag_end(']')
	212	+ ->tag_syntax('syntax')
	213	+ ->tag_processors({a => 1, b => 2});
	214	+
	215	+$clone = $sql_tmpl->clone;
	216	+is($clone->tag_start, $sql_tmpl->tag_start, "$test : tag_start");
	217	+is($clone->tag_end, $sql_tmpl->tag_end, "$test : tag_end");
	218	+is($clone->tag_syntax, $sql_tmpl->tag_syntax, "$test : tag_syntax");
	219	+
	220	+is_deeply( scalar $clone->tag_processors, scalar $sql_tmpl->tag_processors,
	221	+ "$test : tag_processors deep clone");
	222	+
	223	+isnt($clone->tag_processors, $sql_tmpl->tag_processors,
	224	+ "$test : tag_processors reference not copy");
	225	+
	226	+$sql_tmpl->tag_processors(undef);
	227	+
	228	+$clone = $sql_tmpl->clone;
	229	+is_deeply(scalar $clone->tag_processors, {}, "$test tag_processor undef copy");
	230	+
	231	+
	232	+
	233	+__END__
	234	+
	235	+
	236	+

+51

DBIx-Custom-SQL-Template/t/boilerplate.t

View

...	...	@@ -0,0 +1,51 @@
	1	+#!perl -T
	2	+
	3	+use strict;
	4	+use warnings;
	5	+use Test::More tests => 3;
	6	+
	7	+sub not_in_file_ok {
	8	+ my ($filename, %regex) = @_;
	9	+ open( my $fh, '<', $filename )
	10	+ or die "couldn't open $filename for reading: $!";
	11	+
	12	+ my %violated;
	13	+
	14	+ while (my $line = <$fh>) {
	15	+ while (my ($desc, $regex) = each %regex) {
	16	+ if ($line =~ $regex) {
	17	+ push @{$violated{$desc}\|\|=[]}, $.;
	18	+ }
	19	+ }
	20	+ }
	21	+
	22	+ if (%violated) {
	23	+ fail("$filename contains boilerplate text");
	24	+ diag "$_ appears on lines @{$violated{$_}}" for keys %violated;
	25	+ } else {
	26	+ pass("$filename contains no boilerplate text");
	27	+ }
	28	+}
	29	+
	30	+sub module_boilerplate_ok {
	31	+ my ($module) = @_;
	32	+ not_in_file_ok($module =>
	33	+ 'the great new $MODULENAME' => qr/ - The great new /,
	34	+ 'boilerplate description' => qr/Quick summary of what the module/,
	35	+ 'stub function definition' => qr/function[12]/,
	36	+ );
	37	+}
	38	+
	39	+
	40	+ not_in_file_ok(README =>
	41	+ "The README is used..." => qr/The README is used/,
	42	+ "'version information here'" => qr/to provide version information/,
	43	+ );
	44	+
	45	+ not_in_file_ok(Changes =>
	46	+ "placeholder date/time" => qr(Date/time)
	47	+ );
	48	+
	49	+ module_boilerplate_ok('lib/DBIx/Custom/SQL/Template.pm');
	50	+
	51	+

+18

DBIx-Custom-SQL-Template/t/pod-coverage.t

View

...	...	@@ -0,0 +1,18 @@
	1	+use strict;
	2	+use warnings;
	3	+use Test::More;
	4	+
	5	+# Ensure a recent version of Test::Pod::Coverage
	6	+my $min_tpc = 1.08;
	7	+eval "use Test::Pod::Coverage $min_tpc";
	8	+plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage"
	9	+ if $@;
	10	+
	11	+# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version,
	12	+# but older versions don't recognize some common documentation styles
	13	+my $min_pc = 0.18;
	14	+eval "use Pod::Coverage $min_pc";
	15	+plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage"
	16	+ if $@;
	17	+
	18	+all_pod_coverage_ok(also_private => [qw//]);

+12

DBIx-Custom-SQL-Template/t/pod.t

View

...	...	@@ -0,0 +1,12 @@
	1	+#!perl -T
	2	+
	3	+use strict;
	4	+use warnings;
	5	+use Test::More;
	6	+
	7	+# Ensure a recent version of Test::Pod
	8	+my $min_tp = 1.22;
	9	+eval "use Test::Pod $min_tp";
	10	+plan skip_all => "Test::Pod $min_tp required for testing POD" if $@;
	11	+
	12	+all_pod_files_ok();

+10

DBIx-Custom-SQLite/.cvsignore

View

...	...	@@ -0,0 +1,10 @@
	1	+blib*
	2	+Makefile
	3	+Makefile.old
	4	+Build
	5	+_build*
	6	+pm_to_blib*
	7	+*.tar.gz
	8	+.lwpcookies
	9	+DBIx-Custom-SQLite-*
	10	+cover_db

+11

DBIx-Custom-SQLite/.gitignore

View

...	...	@@ -0,0 +1,11 @@
	1	+*.bak
	2	+*.BAK
	3	+Build
	4	+MANIFEST
	5	+META.yml
	6	+Makefile.PL
	7	+_build/*
	8	+blib/*
	9	+*.tar.gz
	10	+cover_db/*
	11	+*.tmp

+21

DBIx-Custom-SQLite/Build.PL

View

...	...	@@ -0,0 +1,21 @@
	1	+use strict;
	2	+use warnings;
	3	+use Module::Build;
	4	+
	5	+my $builder = Module::Build->new(
	6	+ module_name => 'DBIx::Custom::SQLite',
	7	+ license => 'perl',
	8	+ dist_author => 'Yuki Kimoto <kimoto.yuki@gmail.com>',
	9	+ dist_version_from => 'lib/DBIx/Custom/SQLite.pm',
	10	+ build_requires => {
	11	+ 'Test::More' => 0,
	12	+ },
	13	+ requires => {
	14	+ 'DBIx::Custom::Basic' => 0.0101,
	15	+ 'DBD::SQLite' => 1.25
	16	+ },
	17	+ add_to_cleanup => [ 'DBIx-Custom-SQLite-*' ],
	18	+ create_makefile_pl => 'traditional',
	19	+);
	20	+
	21	+$builder->create_build_script();

DBIx-Custom-SQLite/Changes

View

...	...	@@ -0,0 +1,2 @@
	1	+0.0101
	2	+ First release

+15

DBIx-Custom-SQLite/MANIFEST.SKIP

View

...	...	@@ -0,0 +1,15 @@
	1	+\bRCS\b
	2	+\bCVS\b
	3	+^MANIFEST\.
	4	+^Makefile$
	5	+^Build$
	6	+^Build.bat$
	7	+^_build/
	8	+\.(bak\|tdy\|old\|tmp)$
	9	+~$
	10	+^blib/
	11	+^pm_to_blib
	12	+\.cvsignore
	13	+\.gz$
	14	+^\.git
	15	+^cover_db/

+15

DBIx-Custom-SQLite/README

View

...	...	@@ -0,0 +1,15 @@
	1	+DBIx-Custom-SQLite
	2	+
	3	+DBIx::Custom SQLite implementation
	4	+
	5	+INSTALLATION
	6	+
	7	+cpan DBIx::Custom::SQLite
	8	+
	9	+COPYRIGHT AND LICENCE
	10	+
	11	+Copyright (C) 2009 Yuki Kimoto
	12	+
	13	+This program is free software; you can redistribute it and/or modify it
	14	+under the same terms as Perl itself.
	15	+

+133

DBIx-Custom-SQLite/lib/DBIx/Custom/SQLite.pm

View

...	...	@@ -0,0 +1,133 @@
	1	+package DBIx::Custom::SQLite;
	2	+use base 'DBIx::Custom::Basic';
	3	+
	4	+use warnings;
	5	+use strict;
	6	+use Carp 'croak';
	7	+
	8	+our $VERSION = '0.0101';
	9	+
	10	+my $class = __PACKAGE__;
	11	+
	12	+$class->add_format(
	13	+ datetime => $class->formats->{SQL99_datetime},
	14	+ date => $class->formats->{SQL99_date},
	15	+ time => $class->formats->{SQL99_time},
	16	+);
	17	+
	18	+sub connect {
	19	+ my $self = shift;
	20	+
	21	+ if (!$self->data_source && (my $database = $self->database)) {
	22	+ $self->data_source("dbi:SQLite:dbname=$database");
	23	+ }
	24	+
	25	+ return $self->SUPER::connect;
	26	+}
	27	+
	28	+sub connect_memory {
	29	+ my $self = shift;
	30	+
	31	+ # Data source for memory database
	32	+ $self->data_source('dbi:SQLite:dbname=:memory:');
	33	+
	34	+ # Already connected
	35	+ croak("Already connected") if $self->connected;
	36	+
	37	+ # Connect
	38	+ $self->connect;
	39	+
	40	+ return $self;
	41	+}
	42	+
	43	+sub reconnect_memory {
	44	+ my $self = shift;
	45	+
	46	+ # Data source for memory database
	47	+ $self->data_source('dbi:SQLite:dbname=:memory:');
	48	+
	49	+ # Reconnect
	50	+ $self->reconnect;
	51	+
	52	+ return $self;
	53	+}
	54	+
	55	+
	56	+=head1 NAME
	57	+
	58	+DBIx::Custom::SQLite - DBIx::Custom SQLite implementation
	59	+
	60	+=head1 VERSION
	61	+
	62	+Version 0.0101
	63	+
	64	+=head1 SYNOPSYS
	65	+
	66	+ use DBIx::Custom::SQLite;
	67	+
	68	+ # New
	69	+ my $dbi = DBIx::Custom::SQLite->new(user => 'taro', $password => 'kliej&@K',
	70	+ database => 'sample.db');
	71	+
	72	+ # Insert
	73	+ $dbi->insert('books', {title => 'perl', author => 'taro'});
	74	+
	75	+ # Update
	76	+ # same as 'update books set (title = 'aaa', author = 'ken') where id = 5;
	77	+ $dbi->update('books', {title => 'aaa', author => 'ken'}, {id => 5});
	78	+
	79	+ # Delete
	80	+ $dbi->delete('books', {author => 'taro'});
	81	+
	82	+ # select * from books;
	83	+ $dbi->select('books');
	84	+
	85	+ # select * from books where ahthor = 'taro';
	86	+ $dbi->select('books', {author => 'taro'});
	87	+
	88	+ # select author, title from books where author = 'taro'
	89	+ $dbi->select('books', [qw/author title/], {author => 'taro'});
	90	+
	91	+ # select author, title from books where author = 'taro' order by id limit 1;
	92	+ $dbi->select('books', [qw/author title/], {author => 'taro'},
	93	+ 'order by id limit 1');
	94	+
	95	+=head1 CAUTION
	96	+
	97	+This module automatically encode_utf8 or decode_utf8
	98	+If you do not want to this, you set
	99	+
	100	+ $dbi->bind_filter(undef);
	101	+ $dbi->fetch_filter(undef);
	102	+
	103	+=head1 OBJECT METHOD
	104	+
	105	+=head2 connect
	106	+
	107	+ This method override DBIx::Custom::connect
	108	+
	109	+ If database is set, automatically data source is created and connect
	110	+
	111	+=head2 connect_memory
	112	+
	113	+ # Connect memory database
	114	+ $self = $dbi->connect_memory;
	115	+
	116	+=head2 reconnect_memory
	117	+
	118	+ # Reconnect memory database
	119	+ $self = $dbi->reconnect_memory;
	120	+
	121	+=head1 AUTHOR
	122	+
	123	+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >>
	124	+
	125	+Github L<http://github.com/yuki-kimoto>
	126	+
	127	+=head1 COPYRIGHT & LICENSE
	128	+
	129	+Copyright 2009 Yuki Kimoto, all rights reserved.
	130	+
	131	+This program is free software; you can redistribute it and/or modify it
	132	+under the same terms as Perl itself.
	133	+

DBIx-Custom-SQLite/t/00-load.t

View

...	...	@@ -0,0 +1,9 @@
	1	+#!perl -T
	2	+
	3	+use Test::More tests => 1;
	4	+
	5	+BEGIN {
	6	+ use_ok( 'DBIx::Custom::SQLite' );
	7	+}
	8	+
	9	+diag( "Testing DBIx::Custom::SQLite $DBIx::Custom::SQLite::VERSION, Perl $], $^X" );

+60

DBIx-Custom-SQLite/t/01-core.t

View

...	...	@@ -0,0 +1,60 @@
	1	+use Test::More 'no_plan';
	2	+use strict;
	3	+use warnings;
	4	+use utf8;
	5	+
	6	+use DBIx::Custom::SQLite;
	7	+
	8	+# Function for test name
	9	+my $test;
	10	+sub test {
	11	+ $test = shift;
	12	+}
	13	+
	14	+# Constant varialbes for test
	15	+my $CREATE_TABLE = {
	16	+ 0 => 'create table table1 (key1 char(255), key2 char(255));',
	17	+ 1 => 'create table table1 (key1 char(255), key2 char(255), key3 char(255), key4 char(255), key5 char(255));',
	18	+ 2 => 'create table table2 (key1 char(255), key3 char(255));'
	19	+};
	20	+
	21	+
	22	+# Variables for tests
	23	+my $dbi;
	24	+my $ret_val;
	25	+my $rows;
	26	+my $db_file;
	27	+
	28	+test 'connect_memory';
	29	+$dbi = DBIx::Custom::SQLite->new;
	30	+$dbi->connect_memory;
	31	+$ret_val = $dbi->do($CREATE_TABLE->{0});
	32	+ok(defined $ret_val, $test);
	33	+$dbi->insert('table1', {key1 => 'あ', key2 => 2});
	34	+$rows = $dbi->select('table1', {key1 => 'あ'})->fetch_all_hash;
	35	+is_deeply($rows, [{key1 => 'あ', key2 => 2}], "$test : select rows");
	36	+
	37	+test 'connect_memory error';
	38	+eval{$dbi->connect_memory};
	39	+like($@, qr/Already connected/, "$test : already connected");
	40	+
	41	+test 'reconnect_memory';
	42	+$dbi = DBIx::Custom::SQLite->new;
	43	+$dbi->reconnect_memory;
	44	+$ret_val = $dbi->do($CREATE_TABLE->{0});
	45	+ok(defined $ret_val, "$test : connect first");
	46	+$dbi->reconnect_memory;
	47	+$ret_val = $dbi->do($CREATE_TABLE->{2});
	48	+ok(defined $ret_val, "$test : connect first");
	49	+
	50	+test 'connect';
	51	+$db_file = 't/test.db';
	52	+unlink $db_file if -f $db_file;
	53	+$dbi = DBIx::Custom::SQLite->new(database => $db_file);
	54	+$dbi->connect;
	55	+ok(-f $db_file, "$test : database file");
	56	+$ret_val = $dbi->do($CREATE_TABLE->{0});
	57	+ok(defined $ret_val, "$test : database");
	58	+$dbi->disconnect;
	59	+unlink $db_file if -f $db_file;
	60	+

+82

DBIx-Custom-SQLite/t/02-time_format.t

View

...	...	@@ -0,0 +1,82 @@
	1	+use Test::More;
	2	+use strict;
	3	+use warnings;
	4	+
	5	+BEGIN {
	6	+ eval { require Time::Piece; 1 }
	7	+ or plan skip_all => 'Time::Piece required';
	8	+
	9	+ plan 'no_plan';
	10	+ use_ok('DBIx::Custom');
	11	+}
	12	+
	13	+# Function for test name
	14	+my $test;
	15	+sub test {
	16	+ $test = shift;
	17	+}
	18	+
	19	+# Varialbe for tests
	20	+
	21	+my $format;
	22	+my $data;
	23	+my $timepiece;
	24	+my $dbi;
	25	+
	26	+use DBIx::Custom::SQLite;
	27	+
	28	+
	29	+test 'SQL99 format';
	30	+$dbi = DBIx::Custom::SQLite->new;
	31	+$data = '2009-01-02 03:04:05';
	32	+$format = $dbi->formats->{'SQL99_datetime'};
	33	+$timepiece = Time::Piece->strptime($data, $format);
	34	+is($timepiece->strftime('%F'), '2009-01-02', "$test : datetime date");
	35	+is($timepiece->strftime('%T'), '03:04:05', "$test : datetime time");
	36	+
	37	+$data = '2009-01-02';
	38	+$format = $dbi->formats->{'SQL99_date'};
	39	+$timepiece = Time::Piece->strptime($data, $format);
	40	+is($timepiece->strftime('%F'), '2009-01-02', "$test : date");
	41	+
	42	+$data = '03:04:05';
	43	+$format = $dbi->formats->{'SQL99_time'};
	44	+$timepiece = Time::Piece->strptime($data, $format);
	45	+is($timepiece->strftime('%T'), '03:04:05', "$test : time");
	46	+
	47	+
	48	+test 'ISO-8601 format';
	49	+$data = '2009-01-02T03:04:05';
	50	+$format = $dbi->formats->{'ISO-8601_datetime'};
	51	+$timepiece = Time::Piece->strptime($data, $format);
	52	+is($timepiece->strftime('%F'), '2009-01-02', "$test : datetime date");
	53	+is($timepiece->strftime('%T'), '03:04:05', "$test : datetime time");
	54	+
	55	+$data = '2009-01-02';
	56	+$format = $dbi->formats->{'ISO-8601_date'};
	57	+$timepiece = Time::Piece->strptime($data, $format);
	58	+is($timepiece->strftime('%F'), '2009-01-02', "$test : date");
	59	+
	60	+$data = '03:04:05';
	61	+$format = $dbi->formats->{'ISO-8601_time'};
	62	+$timepiece = Time::Piece->strptime($data, $format);
	63	+is($timepiece->strftime('%T'), '03:04:05', "$test : time");
	64	+
	65	+
	66	+test 'default format';
	67	+$data = '2009-01-02 03:04:05';
	68	+$format = $dbi->formats->{'datetime'};
	69	+$timepiece = Time::Piece->strptime($data, $format);
	70	+is($timepiece->strftime('%F'), '2009-01-02', "$test : datetime date");
	71	+is($timepiece->strftime('%T'), '03:04:05', "$test : datetime time");
	72	+
	73	+$data = '2009-01-02';
	74	+$format = $dbi->formats->{'date'};
	75	+$timepiece = Time::Piece->strptime($data, $format);
	76	+is($timepiece->strftime('%F'), '2009-01-02', "$test : date");
	77	+
	78	+$data = '03:04:05';
	79	+$format = $dbi->formats->{'time'};
	80	+$timepiece = Time::Piece->strptime($data, $format);
	81	+is($timepiece->strftime('%T'), '03:04:05', "$test : time");
	82	+

+50

DBIx-Custom-SQLite/t/boilerplate.t

View

...	...	@@ -0,0 +1,50 @@
	1	+#!perl -T
	2	+
	3	+use strict;
	4	+use warnings;
	5	+use Test::More tests => 3;
	6	+
	7	+sub not_in_file_ok {
	8	+ my ($filename, %regex) = @_;
	9	+ open( my $fh, '<', $filename )
	10	+ or die "couldn't open $filename for reading: $!";
	11	+
	12	+ my %violated;
	13	+
	14	+ while (my $line = <$fh>) {
	15	+ while (my ($desc, $regex) = each %regex) {
	16	+ if ($line =~ $regex) {
	17	+ push @{$violated{$desc}\|\|=[]}, $.;
	18	+ }
	19	+ }
	20	+ }
	21	+
	22	+ if (%violated) {
	23	+ fail("$filename contains boilerplate text");
	24	+ diag "$_ appears on lines @{$violated{$_}}" for keys %violated;
	25	+ } else {
	26	+ pass("$filename contains no boilerplate text");
	27	+ }
	28	+}
	29	+
	30	+sub module_boilerplate_ok {
	31	+ my ($module) = @_;
	32	+ not_in_file_ok($module =>
	33	+ 'the great new $MODULENAME' => qr/ - The great new /,
	34	+ 'boilerplate description' => qr/Quick summary of what the module/,
	35	+ 'stub function definition' => qr/function[12]/,
	36	+ );
	37	+}
	38	+
	39	+ not_in_file_ok(README =>
	40	+ "The README is used..." => qr/The README is used/,
	41	+ "'version information here'" => qr/to provide version information/,
	42	+ );
	43	+
	44	+ not_in_file_ok(Changes =>
	45	+ "placeholder date/time" => qr(Date/time)
	46	+ );
	47	+
	48	+ module_boilerplate_ok('lib/DBIx/Custom/SQLite.pm');
	49	+
	50	+

+18

DBIx-Custom-SQLite/t/pod-coverage.t

View

...	...	@@ -0,0 +1,18 @@
	1	+use strict;
	2	+use warnings;
	3	+use Test::More;
	4	+
	5	+# Ensure a recent version of Test::Pod::Coverage
	6	+my $min_tpc = 1.08;
	7	+eval "use Test::Pod::Coverage $min_tpc";
	8	+plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage"
	9	+ if $@;
	10	+
	11	+# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version,
	12	+# but older versions don't recognize some common documentation styles
	13	+my $min_pc = 0.18;
	14	+eval "use Pod::Coverage $min_pc";
	15	+plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage"
	16	+ if $@;
	17	+
	18	+all_pod_coverage_ok();

+12

DBIx-Custom-SQLite/t/pod.t

View

...	...	@@ -0,0 +1,12 @@
	1	+#!perl -T
	2	+
	3	+use strict;
	4	+use warnings;
	5	+use Test::More;
	6	+
	7	+# Ensure a recent version of Test::Pod
	8	+my $min_tp = 1.22;
	9	+eval "use Test::Pod $min_tp";
	10	+plan skip_all => "Test::Pod $min_tp required for testing POD" if $@;
	11	+
	12	+all_pod_files_ok();

+11

DBIx-Custom/.gitignore

View

...	...	@@ -0,0 +1,11 @@
	1	+*.bak
	2	+*.BAK
	3	+Build
	4	+MANIFEST
	5	+META.yml
	6	+Makefile.PL
	7	+_build/*
	8	+blib/*
	9	+*.tar.gz
	10	+cover_db/*
	11	+*.tmp

Build.PL → DBIx-Custom/Build.PL

View

File renamed without changes.

Changes → DBIx-Custom/Changes

View

File renamed without changes.

+15

DBIx-Custom/MANIFEST.SKIP

View

...	...	@@ -0,0 +1,15 @@
	1	+\bRCS\b
	2	+\bCVS\b
	3	+^MANIFEST\.
	4	+^Makefile$
	5	+^Build$
	6	+^Build.bat$
	7	+^_build/
	8	+\.(bak\|tdy\|old\|tmp)$
	9	+~$
	10	+^blib/
	11	+^pm_to_blib
	12	+\.cvsignore
	13	+\.gz$
	14	+^\.git
	15	+^cover_db/

README → DBIx-Custom/README

View

File renamed without changes.

lib/DBIx/Custom.pm → DBIx-Custom/lib/DBIx/Custom.pm

View

File renamed without changes.

t/00-load.t → DBIx-Custom/t/00-load.t

View

File renamed without changes.

t/01-core.t → DBIx-Custom/t/01-core.t

View

File renamed without changes.

t/02-sqlite.t → DBIx-Custom/t/02-sqlite.t

View

File renamed without changes.

t/101-mysql_private.t → DBIx-Custom/t/101-mysql_private.t

View

File renamed without changes.

t/boilerplate.t → DBIx-Custom/t/boilerplate.t

View

File renamed without changes.

+18

DBIx-Custom/t/pod-coverage.t

View

...	...	@@ -0,0 +1,18 @@
	1	+use strict;
	2	+use warnings;
	3	+use Test::More;
	4	+
	5	+# Ensure a recent version of Test::Pod::Coverage
	6	+my $min_tpc = 1.08;
	7	+eval "use Test::Pod::Coverage $min_tpc";
	8	+plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage"
	9	+ if $@;
	10	+
	11	+# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version,
	12	+# but older versions don't recognize some common documentation styles
	13	+my $min_pc = 0.18;
	14	+eval "use Pod::Coverage $min_pc";
	15	+plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage"
	16	+ if $@;
	17	+
	18	+all_pod_coverage_ok();

+12

DBIx-Custom/t/pod.t

View

...	...	@@ -0,0 +1,12 @@
	1	+#!perl -T
	2	+
	3	+use strict;
	4	+use warnings;
	5	+use Test::More;
	6	+
	7	+# Ensure a recent version of Test::Pod
	8	+my $min_tp = 1.22;
	9	+eval "use Test::Pod $min_tp";
	10	+plan skip_all => "Test::Pod $min_tp required for testing POD" if $@;
	11	+
	12	+all_pod_files_ok();