add test ・ be76c8e ・ Gitprep

- add test;
- Browse files
- yuki-kimoto commited on 2009-10-16
- 1 parent ab1e6c5
  
  commit be76c8efee97356dbed7268670bbfd18e3bfdc8b

Showing 4 changed files with 226 additions and 152 deletions

.gitignore

...	...	@@ -8,3 +8,4 @@ _build/*
8	8	blib/*
9	9	*.tar.gz
10	10	cover_db/*
	11	+*.tmp

+15

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/

+34 -152

lib/DBI/Custom.pm

View

@@ -1,14 +1,17 @@
 package DBI::Custom;
 use Object::Simple;
+
+our $VERSION = '0.0101';
+
+use Carp 'croak';
 use DBI;
-use SQL::Abstract;
 
 # Model
 sub model : ClassAttr { auto_build => \&_inherit_model }
 
 # Inherit super class model
 sub _inherit_model {
-    $class = shict;
+    my $class = shift;
     my $super = do {
         no strict 'refs';
         ${"${class}::ISA"}[0];
@@ -39,62 +42,35 @@ sub initialize_model {
 sub clone {
     my $self = shift;
     my $new = $self->Object::Simple::new;
-    $new->connect_infos(%{$self->connect_infos || {}});
+    $new->connect_info(%{$self->connect_info || {}});
     $new->filters(%{$self->filters || {}});
-    
-    $new->global_bind_rules(@{$self->global_bind_rules || []});
-    $new->global_fetch_rules(@{$self->global_fetch_rules || []});
-    
-    foreach my $method (qw/bind_rules fetch_rules/) {
-        my $new_rules = [];
-        foreach my $rule (@{$self->method}) {
-            my $new_rule = {};
-            foreach my $key ($rule) {
-                if ($key eq 'filter') {
-                    my $new_filters = [];
-                    foreach my $filter (@{$rule->{$key} || []}) {
-                        push @$new_filters, $filter
-                    }
-                    $new_rule->{$key} = $new_filters;
-                }
-                else {
-                     $new_rule->{$key} = $rule->{$key};
-                }
-            }
-            push @$new_rules, $new_rule;
-        }
-        $self->$method($new_rules);
-    }
+    $new->bind_filter($self->bind_filter);
+    $new->fetch_filter($self->fetch_filter);
 }
 
 # Attribute
 sub connect_info       : Attr { type => 'hash',  auto_build => sub { shift->connect_info({}) } }
 
-sub global_bind_rules  : Attr { type => 'array', auto_build => sub { shift->global_bind_rules([]) } }
-sub add_global_bind_rule { shift->global_bind_rules(@_) }
+sub bind_filter : Attr {}
+sub fetch_filter : Attr {}
 
-sub global_fetch_rules : Attr { type => 'array', auto_build => sub { shift->global_fetch_rules([]) } }
-sub add_global_fetch_rules { shift->global_fetch_rules(@_) }
-
-sub bind_rules : Attr { type => 'hash',  auto_build => sub { shift->bind_rules({}) }
-sub add_bind_rule { shift->bind_rules(@_) }
-
-sub fetch_rules : Attr { type => 'hash',  auto_build => sub { shift->fetch_rules({}) }
-sub add_fetch_rule { shift->fetch_rules(@_) }
-
-sub filters : Attr { type => 'hash', deref => 1, default => sub { {} } }
+sub filters : Attr { type => 'hash', deref => 1, auto_build => sub { shift->filters({}) } }
 sub add_filter { shift->filters(@_) }
 
-
 sub dbh          : Attr { auto_build => sub { shift->connect } }
-sub sql_abstract : Attr { auto_build => sub { shift->sql_abstract(SQL::Abstract->new) }}
+
+our %VALID_CONNECT_INFO = map {$_ => 1} qw/data_source user password options/;
 
 sub connect {
     my $self = shift;
     my $connect_info = $self->connect_info;
     
+    foreach my $key (keys %{$self->connect_info}) {
+        
+    }
+    
     my $dbh = DBI->connect(
-        $connect_info->{dsn},
+        $connect_info->{data_source},
         $connect_info->{user},
         $connect_info->{password},
         {
@@ -108,99 +84,10 @@ sub connect {
     $self->dbh($dbh);
 }
 
-sub reconnect {
-    my $self = shift;
-    $self->dbh(undef);
-    $self->connect;
-}
-
-sub query {
-    my ($self, $query, @binds) = @_;
-    $self->{success} = 0;
-
-    $self->_replace_omniholder(\$query, \@binds);
-
-    my $st;
-    my $sth;
-
-    my $old = $old_statements{$self};
-
-    if (my $i = (grep $old->[$_][0] eq $query, 0..$#$old)[0]) {
-        $st = splice(@$old, $i, 1)->[1];
-        $sth = $st->{sth};
-    } else {
-        eval { $sth = $self->{dbh}->prepare($query) } or do {
-            if ($@) {
-                $@ =~ s/ at \S+ line \d+\.\n\z//;
-                Carp::croak($@);
-            }
-            $self->{reason} = "Prepare failed ($DBI::errstr)";
-            return _dummy;
-        };
-
-        # $self is quoted on purpose, to pass along the stringified version,
-        # and avoid increasing reference count.
-        $st = bless {
-            db    => "$self",
-            sth   => $sth,
-            query => $query
-        }, 'DBIx::Simple::Statement';
-        $statements{$self}{$st} = $st;
-    }
-
-    eval { $sth->execute(@binds) } or do {
-        if ($@) {
-            $@ =~ s/ at \S+ line \d+\.\n\z//;
-            Carp::croak($@);
-        }
-
-        $self->{reason} = "Execute failed ($DBI::errstr)";
-	return _dummy;
-    };
-
-    $self->{success} = 1;
-
-    return bless { st => $st, lc_columns => $self->{lc_columns} }, $self->{result_class};
-}
-
 sub query {
-    my ($self, $sql) = @_;
-    my $sth = $self->dbh->prepare($sql);
-    $sth->execute(@bind);
-}
-
-sub select {
-    my ($table, $column_names, $where, $order) = @_;
     
-    my ($stmt, @bind) = $self->sql_abstract->select($table, $column_names, $where, $order);
-    my $sth = $self->dbh->prepare($stmt);
-    $sth->execute(@bind);
-}
-
-sub insert {
-    my ($self, $table, $values) = @_;
-    
-    my ($stmt, @bind) = $self->sql_abstract->insert($table, $values);
-    my $sth = $self->dbh->prepare($stmt);
-    $sth->execute(@bind);
-}
-
-sub update {
-    my ($self, $values, $where) = @_;
-    my ($stmt, @bind) = $self->sql_abstract->update($table, $values, $where);
-    my $sth = $self->dbh->prepare($stmt);
-    $sth->execute(@bind);
 }
 
-sub delete {
-    my ($self, $where) = @_;
-    my ($stmt, @bind) = $self->sql_abstract->delete($table, $where);
-    my $sth = $self->dbh->prepare($stmt);
-    $sth->execute(@bind);
-}
-
-
-
 Object::Simple->build_class;
 
 =head1 NAME
@@ -209,44 +96,39 @@ DBI::Custom - The great new DBI::Custom!
 
 =head1 VERSION
 
-Version 0.01
+Version 0.0101
 
 =cut
 
-our $VERSION = '0.01';
-
-
 =head1 SYNOPSIS
 
-Quick summary of what the module does.
+  my $dbi = DBI::Custom->new;
 
-Perhaps a little code snippet.
+=head1 METHODS
 
-    use DBI::Custom;
+=head2 add_filter
 
-    my $foo = DBI::Custom->new();
-    ...
+=head2 bind_filter
 
-=head1 EXPORT
+=head2 clone
 
-A list of functions that can be exported.  You can delete this section
-if you don't export anything, such as for a purely object-oriented module.
+=head2 connect
 
-=head1 FUNCTIONS
+=head2 connect_info
 
-=head2 function1
+=head2 dbh
 
-=cut
+=head2 fetch_filter
 
-sub function1 {
-}
+=head2 filters
 
-=head2 function2
+=head2 initialize_model
 
-=cut
+=head2 model
 
-sub function2 {
-}
+=head2 new
+
+=head2 query
 
 =head1 AUTHOR
 

+176

t/01-core.t

View

...	...	@@ -0,0 +1,176 @@
	1	+use Test::More 'no_plan';
	2	+use strict;
	3	+use warnings;
	4	+
	5	+use DBI::Custom;
	6	+use Scalar::Util qw/blessed/;
	7	+
	8	+# user password database
	9	+our ($U, $P, $D) = connect_info();
	10	+
	11	+
	12	+{
	13	+ my $dbi = DBI::Custom->new(
	14	+ connect_info => {
	15	+ user => 'a',
	16	+ password => 'b',
	17	+ data_source => 'c',
	18	+ options => {d => 1, e => 2}
	19	+ },
	20	+ filters => {
	21	+ f => 3,
	22	+ },
	23	+ bind_filter => 'f',
	24	+ fetch_filter => 'g',
	25	+ dbh => 'e',
	26	+ );
	27	+
	28	+ is_deeply($dbi,{connect_info => {user => 'a', password => 'b', data_source => 'c', options => {d => 1, e => 2}} ,filters => {f => 3}, bind_filter => 'f', fetch_filter => 'g', dbh => 'e'}, 'new');
	29	+
	30	+ isa_ok($dbi, 'DBI::Custom');
	31	+}
	32	+
	33	+{
	34	+ package DBI::Custom::T1;
	35	+ use base 'DBI::Custom';
	36	+
	37	+ __PACKAGE__->initialize_model(sub {
	38	+ my $model = shift;
	39	+
	40	+ $model
	41	+ ->connect_info(
	42	+ user => 'a',
	43	+ password => 'b',
	44	+ data_source => 'c',
	45	+ options => {d => 1, e => 2}
	46	+ )
	47	+ ->filters(
	48	+ f => 3
	49	+ )
	50	+ ->bind_filter('f')
	51	+ ->fetch_filter('g')
	52	+ ->dbh('e')
	53	+ });
	54	+}
	55	+{
	56	+ my $dbi = DBI::Custom::T1->new(
	57	+ connect_info => {
	58	+ user => 'ao',
	59	+ password => 'bo',
	60	+ data_source => 'co',
	61	+ options => {do => 10, eo => 20}
	62	+ },
	63	+ filters => {
	64	+ fo => 30,
	65	+ },
	66	+ bind_filter => 'fo',
	67	+ fetch_filter => 'go',
	68	+ );
	69	+
	70	+ is_deeply($dbi,{connect_info => {user => 'ao', password => 'bo', data_source => 'co', options => {do => 10, eo => 20}} ,filters => {fo => 30}, bind_filter => 'fo', fetch_filter => 'go'}, 'new arguments');
	71	+
	72	+ isa_ok($dbi, 'DBI::Custom::T1');
	73	+}
	74	+
	75	+{
	76	+ my $dbi = DBI::Custom::T1->new;
	77	+
	78	+ is_deeply($dbi,{connect_info => {user => 'a', password => 'b', data_source => 'c', options => {d => 1, e => 2}} ,filters => {f => 3}, bind_filter => 'f', fetch_filter => 'g'}, 'new custom class');
	79	+
	80	+ isa_ok($dbi, 'DBI::Custom::T1');
	81	+
	82	+}
	83	+
	84	+{
	85	+ package DBI::Custom::T1_2;
	86	+ use base 'DBI::Custom::T1';
	87	+}
	88	+
	89	+{
	90	+ my $dbi = DBI::Custom::T1_2->new;
	91	+
	92	+ is_deeply($dbi,{connect_info => {user => 'a', password => 'b', data_source => 'c', options => {d => 1, e => 2}} ,filters => {f => 3}, bind_filter => 'f', fetch_filter => 'g'}, 'new custom class inherit');
	93	+
	94	+ isa_ok($dbi, 'DBI::Custom::T1_2');
	95	+}
	96	+
	97	+{
	98	+ package DBI::Custom::T1_3;
	99	+ use base 'DBI::Custom::T1';
	100	+
	101	+ __PACKAGE__->initialize_model(sub {
	102	+ my $model = shift;
	103	+
	104	+ $model
	105	+ ->connect_info(
	106	+ user => 'ao',
	107	+ password => 'bo',
	108	+ data_source => 'co',
	109	+ options => {do => 10, eo => 20}
	110	+ )
	111	+ ->filters(
	112	+ fo => 30
	113	+ )
	114	+ ->bind_filter('fo')
	115	+ ->fetch_filter('go')
	116	+ ->dbh('eo')
	117	+ });
	118	+
	119	+}
	120	+
	121	+{
	122	+ my $dbi = DBI::Custom::T1_3->new;
	123	+
	124	+ is_deeply($dbi,{connect_info => {user => 'ao', password => 'bo', data_source => 'co', options => {do => 10, eo => 20}} ,filters => {fo => 30}, bind_filter => 'fo', fetch_filter => 'go'}, 'new custom class');
	125	+
	126	+ isa_ok($dbi, 'DBI::Custom::T1_3');
	127	+}
	128	+
	129	+{
	130	+ my $dbi = DBI::Custom::T1_3->new(
	131	+ connect_info => {
	132	+ user => 'a',
	133	+ password => 'b',
	134	+ data_source => 'c',
	135	+ options => {d => 1, e => 2}
	136	+ },
	137	+ filters => {
	138	+ f => 3,
	139	+ },
	140	+ bind_filter => 'f',
	141	+ fetch_filter => 'g',
	142	+ dbh => 'e',
	143	+ );
	144	+
	145	+ is_deeply($dbi,{connect_info => {user => 'a', password => 'b', data_source => 'c', options => {d => 1, e => 2}} ,filters => {f => 3}, bind_filter => 'f', fetch_filter => 'g', dbh => 'e'}, 'new');
	146	+
	147	+ isa_ok($dbi, 'DBI::Custom');
	148	+}
	149	+
	150	+{
	151	+ my $dbi = DBI::Custom->new(
	152	+ connect_info => {
	153	+ user => $U,
	154	+ password => $P,
	155	+ data_source => "dbi:mysql:$D"
	156	+ }
	157	+ );
	158	+ $dbi->connect;
	159	+
	160	+ ok(blessed $dbi->dbh);
	161	+ can_ok($dbi->dbh, qw/prepare/);
	162	+
	163	+
	164	+}
	165	+
	166	+sub connect_info {
	167	+ my $file = 'password.tmp';
	168	+ open my $fh, '<', $file
	169	+ or return;
	170	+
	171	+ my ($user, $password, $database) = split(/\s/, (<$fh>)[0]);
	172	+
	173	+ close $fh;
	174	+
	175	+ return ($user, $password, $database);
	176	+}

...	...	@@ -1,14 +1,17 @@
1	1	package DBI::Custom;
2	2	use Object::Simple;
	3	+
	4	+our $VERSION = '0.0101';
	5	+
	6	+use Carp 'croak';
3	7	use DBI;
4		-use SQL::Abstract;
5	8
6	9	# Model
7	10	sub model : ClassAttr { auto_build => \&_inherit_model }
8	11
9	12	# Inherit super class model
10	13	sub _inherit_model {
11		- $class = shict;
	14	+ my $class = shift;
12	15	my $super = do {
13	16	no strict 'refs';
14	17	${"${class}::ISA"}[0];
...	...	@@ -39,62 +42,35 @@ sub initialize_model {
39	42	sub clone {
40	43	my $self = shift;
41	44	my $new = $self->Object::Simple::new;
42		- $new->connect_infos(%{$self->connect_infos \|\| {}});
	45	+ $new->connect_info(%{$self->connect_info \|\| {}});
43	46	$new->filters(%{$self->filters \|\| {}});
44		-
45		- $new->global_bind_rules(@{$self->global_bind_rules \|\| []});
46		- $new->global_fetch_rules(@{$self->global_fetch_rules \|\| []});
47		-
48		- foreach my $method (qw/bind_rules fetch_rules/) {
49		- my $new_rules = [];
50		- foreach my $rule (@{$self->method}) {
51		- my $new_rule = {};
52		- foreach my $key ($rule) {
53		- if ($key eq 'filter') {
54		- my $new_filters = [];
55		- foreach my $filter (@{$rule->{$key} \|\| []}) {
56		- push @$new_filters, $filter
57		- }
58		- $new_rule->{$key} = $new_filters;
59		- }
60		- else {
61		- $new_rule->{$key} = $rule->{$key};
62		- }
63		- }
64		- push @$new_rules, $new_rule;
65		- }
66		- $self->$method($new_rules);
67		- }
	47	+ $new->bind_filter($self->bind_filter);
	48	+ $new->fetch_filter($self->fetch_filter);
68	49	}
69	50
70	51	# Attribute
71	52	sub connect_info : Attr { type => 'hash', auto_build => sub { shift->connect_info({}) } }
72	53
73		-sub global_bind_rules : Attr { type => 'array', auto_build => sub { shift->global_bind_rules([]) } }
74		-sub add_global_bind_rule { shift->global_bind_rules(@_) }
	54	+sub bind_filter : Attr {}
	55	+sub fetch_filter : Attr {}
75	56
76		-sub global_fetch_rules : Attr { type => 'array', auto_build => sub { shift->global_fetch_rules([]) } }
77		-sub add_global_fetch_rules { shift->global_fetch_rules(@_) }
78		-
79		-sub bind_rules : Attr { type => 'hash', auto_build => sub { shift->bind_rules({}) }
80		-sub add_bind_rule { shift->bind_rules(@_) }
81		-
82		-sub fetch_rules : Attr { type => 'hash', auto_build => sub { shift->fetch_rules({}) }
83		-sub add_fetch_rule { shift->fetch_rules(@_) }
84		-
85		-sub filters : Attr { type => 'hash', deref => 1, default => sub { {} } }
	57	+sub filters : Attr { type => 'hash', deref => 1, auto_build => sub { shift->filters({}) } }
86	58	sub add_filter { shift->filters(@_) }
87	59
88		-
89	60	sub dbh : Attr { auto_build => sub { shift->connect } }
90		-sub sql_abstract : Attr { auto_build => sub { shift->sql_abstract(SQL::Abstract->new) }}
	61	+
	62	+our %VALID_CONNECT_INFO = map {$_ => 1} qw/data_source user password options/;
91	63
92	64	sub connect {
93	65	my $self = shift;
94	66	my $connect_info = $self->connect_info;
95	67
	68	+ foreach my $key (keys %{$self->connect_info}) {
	69	+
	70	+ }
	71	+
96	72	my $dbh = DBI->connect(
97		- $connect_info->{dsn},
	73	+ $connect_info->{data_source},
98	74	$connect_info->{user},
99	75	$connect_info->{password},
100	76	{
...	...	@@ -108,99 +84,10 @@ sub connect {
108	84	$self->dbh($dbh);
109	85	}
110	86
111		-sub reconnect {
112		- my $self = shift;
113		- $self->dbh(undef);
114		- $self->connect;
115		-}
116		-
117		-sub query {
118		- my ($self, $query, @binds) = @_;
119		- $self->{success} = 0;
120		-
121		- $self->_replace_omniholder(\$query, \@binds);
122		-
123		- my $st;
124		- my $sth;
125		-
126		- my $old = $old_statements{$self};
127		-
128		- if (my $i = (grep $old->[$_][0] eq $query, 0..$#$old)[0]) {
129		- $st = splice(@$old, $i, 1)->[1];
130		- $sth = $st->{sth};
131		- } else {
132		- eval { $sth = $self->{dbh}->prepare($query) } or do {
133		- if ($@) {
134		- $@ =~ s/ at \S+ line \d+\.\n\z//;
135		- Carp::croak($@);
136		- }
137		- $self->{reason} = "Prepare failed ($DBI::errstr)";
138		- return _dummy;
139		- };
140		-
141		- # $self is quoted on purpose, to pass along the stringified version,
142		- # and avoid increasing reference count.
143		- $st = bless {
144		- db => "$self",
145		- sth => $sth,
146		- query => $query
147		- }, 'DBIx::Simple::Statement';
148		- $statements{$self}{$st} = $st;
149		- }
150		-
151		- eval { $sth->execute(@binds) } or do {
152		- if ($@) {
153		- $@ =~ s/ at \S+ line \d+\.\n\z//;
154		- Carp::croak($@);
155		- }
156		-
157		- $self->{reason} = "Execute failed ($DBI::errstr)";
158		- return _dummy;
159		- };
160		-
161		- $self->{success} = 1;
162		-
163		- return bless { st => $st, lc_columns => $self->{lc_columns} }, $self->{result_class};
164		-}
165		-
166	87	sub query {
167		- my ($self, $sql) = @_;
168		- my $sth = $self->dbh->prepare($sql);
169		- $sth->execute(@bind);
170		-}
171		-
172		-sub select {
173		- my ($table, $column_names, $where, $order) = @_;
174	88
175		- my ($stmt, @bind) = $self->sql_abstract->select($table, $column_names, $where, $order);
176		- my $sth = $self->dbh->prepare($stmt);
177		- $sth->execute(@bind);
178		-}
179		-
180		-sub insert {
181		- my ($self, $table, $values) = @_;
182		-
183		- my ($stmt, @bind) = $self->sql_abstract->insert($table, $values);
184		- my $sth = $self->dbh->prepare($stmt);
185		- $sth->execute(@bind);
186		-}
187		-
188		-sub update {
189		- my ($self, $values, $where) = @_;
190		- my ($stmt, @bind) = $self->sql_abstract->update($table, $values, $where);
191		- my $sth = $self->dbh->prepare($stmt);
192		- $sth->execute(@bind);
193	89	}
194	90
195		-sub delete {
196		- my ($self, $where) = @_;
197		- my ($stmt, @bind) = $self->sql_abstract->delete($table, $where);
198		- my $sth = $self->dbh->prepare($stmt);
199		- $sth->execute(@bind);
200		-}
201		-
202		-
203		-
204	91	Object::Simple->build_class;
205	92
206	93	=head1 NAME
...	...	@@ -209,44 +96,39 @@ DBI::Custom - The great new DBI::Custom!
209	96
210	97	=head1 VERSION
211	98
212		-Version 0.01
	99	+Version 0.0101
213	100
214	101	=cut
215	102
216		-our $VERSION = '0.01';
217		-
218		-
219	103	=head1 SYNOPSIS
220	104
221		-Quick summary of what the module does.
	105	+ my $dbi = DBI::Custom->new;
222	106
223		-Perhaps a little code snippet.
	107	+=head1 METHODS
224	108
225		- use DBI::Custom;
	109	+=head2 add_filter
226	110
227		- my $foo = DBI::Custom->new();
228		- ...
	111	+=head2 bind_filter
229	112
230		-=head1 EXPORT
	113	+=head2 clone
231	114
232		-A list of functions that can be exported. You can delete this section
233		-if you don't export anything, such as for a purely object-oriented module.
	115	+=head2 connect
234	116
235		-=head1 FUNCTIONS
	117	+=head2 connect_info
236	118
237		-=head2 function1
	119	+=head2 dbh
238	120
239		-=cut
	121	+=head2 fetch_filter
240	122
241		-sub function1 {
242		-}
	123	+=head2 filters
243	124
244		-=head2 function2
	125	+=head2 initialize_model
245	126
246		-=cut
	127	+=head2 model
247	128
248		-sub function2 {
249		-}
	129	+=head2 new
	130	+
	131	+=head2 query
250	132
251	133	=head1 AUTHOR
252	134