| ... | ... |
@@ -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 |
| ... | ... |
@@ -0,0 +1,25 @@ |
| 1 |
+use strict; |
|
| 2 |
+use warnings; |
|
| 3 |
+use Module::Build; |
|
| 4 |
+ |
|
| 5 |
+my $builder = Module::Build->new( |
|
| 6 |
+ module_name => 'DBIx::Custom', |
|
| 7 |
+ license => 'perl', |
|
| 8 |
+ dist_author => 'Yuki Kimoto <kimoto.yuki@gmail.com>', |
|
| 9 |
+ dist_version_from => 'lib/DBIx/Custom.pm', |
|
| 10 |
+ build_requires => {
|
|
| 11 |
+ 'Test::More' => 0, |
|
| 12 |
+ }, |
|
| 13 |
+ recommends => {
|
|
| 14 |
+ 'DBD::SQLite' => 1.25, |
|
| 15 |
+ 'Time::Piece' => 1.15 |
|
| 16 |
+ }, |
|
| 17 |
+ requires => {
|
|
| 18 |
+ 'Object::Simple' => 2.0702, |
|
| 19 |
+ 'DBI' => 1.605, |
|
| 20 |
+ }, |
|
| 21 |
+ add_to_cleanup => [ 'DBIx-Custom-*' ], |
|
| 22 |
+ create_makefile_pl => 'traditional', |
|
| 23 |
+); |
|
| 24 |
+ |
|
| 25 |
+$builder->create_build_script(); |
| ... | ... |
@@ -0,0 +1,11 @@ |
| 1 |
+0.0501 |
|
| 2 |
+ packaging DBIx::Custom::Result DBIx::Custom::Query DBIx::Custom::MySQL DBIx::Custom::SQLite DBIx::Custom::SQL::Template |
|
| 3 |
+0.0401 |
|
| 4 |
+ catch up with DBIx::Custom::Result version up |
|
| 5 |
+0.0301 |
|
| 6 |
+ exchange filter argument 'key', 'value' (not backword compatible) |
|
| 7 |
+0.0201 |
|
| 8 |
+ rename tranzaction to transaction |
|
| 9 |
+ add filter_off |
|
| 10 |
+0.0101 |
|
| 11 |
+ First release |
| ... | ... |
@@ -0,0 +1,25 @@ |
| 1 |
+use strict; |
|
| 2 |
+use warnings; |
|
| 3 |
+use Module::Build; |
|
| 4 |
+ |
|
| 5 |
+my $builder = Module::Build->new( |
|
| 6 |
+ module_name => 'DBIx::Custom', |
|
| 7 |
+ license => 'perl', |
|
| 8 |
+ dist_author => 'Yuki Kimoto <kimoto.yuki@gmail.com>', |
|
| 9 |
+ dist_version_from => 'lib/DBIx/Custom.pm', |
|
| 10 |
+ build_requires => {
|
|
| 11 |
+ 'Test::More' => 0, |
|
| 12 |
+ }, |
|
| 13 |
+ recommends => {
|
|
| 14 |
+ 'DBD::SQLite' => 1.25, |
|
| 15 |
+ 'Time::Piece' => 1.15 |
|
| 16 |
+ }, |
|
| 17 |
+ requires => {
|
|
| 18 |
+ 'Object::Simple' => 2.0702, |
|
| 19 |
+ 'DBI' => 1.605, |
|
| 20 |
+ }, |
|
| 21 |
+ add_to_cleanup => [ 'DBIx-Custom-*' ], |
|
| 22 |
+ create_makefile_pl => 'traditional', |
|
| 23 |
+); |
|
| 24 |
+ |
|
| 25 |
+$builder->create_build_script(); |
| ... | ... |
@@ -0,0 +1,11 @@ |
| 1 |
+0.0501 |
|
| 2 |
+ packaging DBIx::Custom::Result DBIx::Custom::Query DBIx::Custom::MySQL DBIx::Custom::SQLite DBIx::Custom::SQL::Template |
|
| 3 |
+0.0401 |
|
| 4 |
+ catch up with DBIx::Custom::Result version up |
|
| 5 |
+0.0301 |
|
| 6 |
+ exchange filter argument 'key', 'value' (not backword compatible) |
|
| 7 |
+0.0201 |
|
| 8 |
+ rename tranzaction to transaction |
|
| 9 |
+ add filter_off |
|
| 10 |
+0.0101 |
|
| 11 |
+ First release |
| ... | ... |
@@ -0,0 +1,15 @@ |
| 1 |
+DBIx-Custom |
|
| 2 |
+ |
|
| 3 |
+Custamizable DBI |
|
| 4 |
+ |
|
| 5 |
+INSTALLATION |
|
| 6 |
+ |
|
| 7 |
+cpan DBIx::Custom |
|
| 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 |
+ |
| ... | ... |
@@ -0,0 +1,2 @@ |
| 1 |
+do{ my $x = {};
|
|
| 2 |
+$x; } |
| ... | ... |
@@ -0,0 +1,280 @@ |
| 1 |
+do{ my $x = [
|
|
| 2 |
+ {
|
|
| 3 |
+ 'ARGV' => [] |
|
| 4 |
+ }, |
|
| 5 |
+ {},
|
|
| 6 |
+ {
|
|
| 7 |
+ 'verbose' => undef, |
|
| 8 |
+ 'PL_files' => undef, |
|
| 9 |
+ 'pollute' => undef, |
|
| 10 |
+ 'bindoc_dirs' => [ |
|
| 11 |
+ 'blib/script' |
|
| 12 |
+ ], |
|
| 13 |
+ 'conflicts' => {},
|
|
| 14 |
+ 'scripts' => undef, |
|
| 15 |
+ 'recommends' => {
|
|
| 16 |
+ 'DBD::SQLite' => '1.25', |
|
| 17 |
+ 'Time::Piece' => '1.15' |
|
| 18 |
+ }, |
|
| 19 |
+ 'dist_version' => bless( {
|
|
| 20 |
+ 'original' => '0.0501', |
|
| 21 |
+ 'version' => [ |
|
| 22 |
+ 0, |
|
| 23 |
+ 50, |
|
| 24 |
+ 100 |
|
| 25 |
+ ] |
|
| 26 |
+ }, 'Module::Build::Version' ), |
|
| 27 |
+ 'pod_files' => undef, |
|
| 28 |
+ 'config_dir' => '_build', |
|
| 29 |
+ 'sign' => undef, |
|
| 30 |
+ 'recurse_into' => [], |
|
| 31 |
+ 'build_bat' => 0, |
|
| 32 |
+ 'extra_linker_flags' => [], |
|
| 33 |
+ 'build_class' => 'Module::Build', |
|
| 34 |
+ 'prereq_action_types' => [ |
|
| 35 |
+ 'requires', |
|
| 36 |
+ 'build_requires', |
|
| 37 |
+ 'conflicts', |
|
| 38 |
+ 'recommends' |
|
| 39 |
+ ], |
|
| 40 |
+ 'base_dir' => '/root/labo/DBIx-Custom/DBIx-Custom-0.0501', |
|
| 41 |
+ 'allow_mb_mismatch' => 0, |
|
| 42 |
+ 'xs_files' => undef, |
|
| 43 |
+ 'destdir' => undef, |
|
| 44 |
+ 'metafile' => 'META.yml', |
|
| 45 |
+ 'mb_version' => '0.31012', |
|
| 46 |
+ 'use_tap_harness' => 0, |
|
| 47 |
+ 'test_file_exts' => [ |
|
| 48 |
+ '.t' |
|
| 49 |
+ ], |
|
| 50 |
+ 'dist_name' => 'DBIx-Custom', |
|
| 51 |
+ 'has_config_data' => undef, |
|
| 52 |
+ 'install_base' => undef, |
|
| 53 |
+ 'module_name' => 'DBIx::Custom', |
|
| 54 |
+ 'recursive_test_files' => undef, |
|
| 55 |
+ 'libdoc_dirs' => [ |
|
| 56 |
+ 'blib/lib', |
|
| 57 |
+ 'blib/arch' |
|
| 58 |
+ ], |
|
| 59 |
+ 'perl' => '/usr/bin/perl', |
|
| 60 |
+ 'dist_author' => [ |
|
| 61 |
+ 'Yuki Kimoto <kimoto.yuki@gmail.com>' |
|
| 62 |
+ ], |
|
| 63 |
+ 'use_rcfile' => 1, |
|
| 64 |
+ 'configure_requires' => {},
|
|
| 65 |
+ 'test_files' => undef, |
|
| 66 |
+ 'dist_abstract' => undef, |
|
| 67 |
+ 'create_readme' => undef, |
|
| 68 |
+ 'prefix_relpaths' => {
|
|
| 69 |
+ 'core' => {
|
|
| 70 |
+ 'libdoc' => [ |
|
| 71 |
+ 'man', |
|
| 72 |
+ 'man3' |
|
| 73 |
+ ], |
|
| 74 |
+ 'script' => [ |
|
| 75 |
+ 'bin' |
|
| 76 |
+ ], |
|
| 77 |
+ 'libhtml' => [ |
|
| 78 |
+ 'html' |
|
| 79 |
+ ], |
|
| 80 |
+ 'bindoc' => [ |
|
| 81 |
+ 'man', |
|
| 82 |
+ 'man1' |
|
| 83 |
+ ], |
|
| 84 |
+ 'bin' => [ |
|
| 85 |
+ 'bin' |
|
| 86 |
+ ], |
|
| 87 |
+ 'arch' => [ |
|
| 88 |
+ 'lib', |
|
| 89 |
+ 'perl5', |
|
| 90 |
+ '5.8.8', |
|
| 91 |
+ 'i386-linux-thread-multi' |
|
| 92 |
+ ], |
|
| 93 |
+ 'binhtml' => [ |
|
| 94 |
+ 'html' |
|
| 95 |
+ ], |
|
| 96 |
+ 'lib' => [ |
|
| 97 |
+ 'lib', |
|
| 98 |
+ 'perl5' |
|
| 99 |
+ ] |
|
| 100 |
+ }, |
|
| 101 |
+ 'site' => {
|
|
| 102 |
+ 'libdoc' => [ |
|
| 103 |
+ 'man', |
|
| 104 |
+ 'man3' |
|
| 105 |
+ ], |
|
| 106 |
+ 'script' => [ |
|
| 107 |
+ 'bin' |
|
| 108 |
+ ], |
|
| 109 |
+ 'libhtml' => [ |
|
| 110 |
+ 'html' |
|
| 111 |
+ ], |
|
| 112 |
+ 'bindoc' => [ |
|
| 113 |
+ 'man', |
|
| 114 |
+ 'man1' |
|
| 115 |
+ ], |
|
| 116 |
+ 'bin' => [ |
|
| 117 |
+ 'bin' |
|
| 118 |
+ ], |
|
| 119 |
+ 'arch' => [ |
|
| 120 |
+ 'lib', |
|
| 121 |
+ 'perl5', |
|
| 122 |
+ 'site_perl', |
|
| 123 |
+ '5.8.8', |
|
| 124 |
+ 'i386-linux-thread-multi' |
|
| 125 |
+ ], |
|
| 126 |
+ 'binhtml' => [ |
|
| 127 |
+ 'html' |
|
| 128 |
+ ], |
|
| 129 |
+ 'lib' => [ |
|
| 130 |
+ 'lib', |
|
| 131 |
+ 'perl5', |
|
| 132 |
+ 'site_perl' |
|
| 133 |
+ ] |
|
| 134 |
+ }, |
|
| 135 |
+ 'vendor' => {
|
|
| 136 |
+ 'libdoc' => [ |
|
| 137 |
+ 'man', |
|
| 138 |
+ 'man3' |
|
| 139 |
+ ], |
|
| 140 |
+ 'script' => [ |
|
| 141 |
+ 'bin' |
|
| 142 |
+ ], |
|
| 143 |
+ 'libhtml' => [ |
|
| 144 |
+ 'html' |
|
| 145 |
+ ], |
|
| 146 |
+ 'bindoc' => [ |
|
| 147 |
+ 'man', |
|
| 148 |
+ 'man1' |
|
| 149 |
+ ], |
|
| 150 |
+ 'bin' => [ |
|
| 151 |
+ 'bin' |
|
| 152 |
+ ], |
|
| 153 |
+ 'arch' => [ |
|
| 154 |
+ 'lib', |
|
| 155 |
+ 'perl5', |
|
| 156 |
+ '5.8.8', |
|
| 157 |
+ 'i386-linux-thread-multi' |
|
| 158 |
+ ], |
|
| 159 |
+ 'binhtml' => [ |
|
| 160 |
+ 'html' |
|
| 161 |
+ ], |
|
| 162 |
+ 'lib' => [ |
|
| 163 |
+ 'lib', |
|
| 164 |
+ 'perl5' |
|
| 165 |
+ ] |
|
| 166 |
+ } |
|
| 167 |
+ }, |
|
| 168 |
+ 'meta_merge' => {},
|
|
| 169 |
+ 'get_options' => {},
|
|
| 170 |
+ 'dist_version_from' => 'lib/DBIx/Custom.pm', |
|
| 171 |
+ 'create_license' => undef, |
|
| 172 |
+ 'debugger' => undef, |
|
| 173 |
+ 'html_css' => '', |
|
| 174 |
+ 'build_elements' => [ |
|
| 175 |
+ 'PL', |
|
| 176 |
+ 'support', |
|
| 177 |
+ 'pm', |
|
| 178 |
+ 'xs', |
|
| 179 |
+ 'pod', |
|
| 180 |
+ 'script' |
|
| 181 |
+ ], |
|
| 182 |
+ 'orig_dir' => '/root/labo/DBIx-Custom/DBIx-Custom-0.0501', |
|
| 183 |
+ 'include_dirs' => [], |
|
| 184 |
+ 'installdirs' => 'site', |
|
| 185 |
+ 'create_makefile_pl' => 'traditional', |
|
| 186 |
+ 'magic_number' => undef, |
|
| 187 |
+ 'install_sets' => {
|
|
| 188 |
+ 'core' => {
|
|
| 189 |
+ 'libdoc' => '/usr/share/man/man3', |
|
| 190 |
+ 'script' => '/usr/bin', |
|
| 191 |
+ 'libhtml' => undef, |
|
| 192 |
+ 'bindoc' => '/usr/share/man/man1', |
|
| 193 |
+ 'bin' => '/usr/bin', |
|
| 194 |
+ 'arch' => '/usr/lib/perl5/5.8.8/i386-linux-thread-multi', |
|
| 195 |
+ 'binhtml' => undef, |
|
| 196 |
+ 'lib' => '/usr/lib/perl5/5.8.8' |
|
| 197 |
+ }, |
|
| 198 |
+ 'site' => {
|
|
| 199 |
+ 'libdoc' => '/usr/share/man/man3', |
|
| 200 |
+ 'script' => '/usr/bin', |
|
| 201 |
+ 'libhtml' => undef, |
|
| 202 |
+ 'bindoc' => '/usr/share/man/man1', |
|
| 203 |
+ 'bin' => '/usr/bin', |
|
| 204 |
+ 'arch' => '/usr/lib/perl5/site_perl/5.8.8/i386-linux-thread-multi', |
|
| 205 |
+ 'binhtml' => undef, |
|
| 206 |
+ 'lib' => '/usr/lib/perl5/site_perl/5.8.8' |
|
| 207 |
+ }, |
|
| 208 |
+ 'vendor' => {
|
|
| 209 |
+ 'libdoc' => '/usr/share/man/man3', |
|
| 210 |
+ 'script' => '/usr/bin', |
|
| 211 |
+ 'libhtml' => undef, |
|
| 212 |
+ 'bindoc' => '/usr/share/man/man1', |
|
| 213 |
+ 'bin' => '/usr/bin', |
|
| 214 |
+ 'arch' => '/usr/lib/perl5/vendor_perl/5.8.8/i386-linux-thread-multi', |
|
| 215 |
+ 'binhtml' => undef, |
|
| 216 |
+ 'lib' => '/usr/lib/perl5/vendor_perl/5.8.8' |
|
| 217 |
+ } |
|
| 218 |
+ }, |
|
| 219 |
+ 'tap_harness_args' => {},
|
|
| 220 |
+ 'install_base_relpaths' => {
|
|
| 221 |
+ 'libdoc' => [ |
|
| 222 |
+ 'man', |
|
| 223 |
+ 'man3' |
|
| 224 |
+ ], |
|
| 225 |
+ 'script' => [ |
|
| 226 |
+ 'bin' |
|
| 227 |
+ ], |
|
| 228 |
+ 'libhtml' => [ |
|
| 229 |
+ 'html' |
|
| 230 |
+ ], |
|
| 231 |
+ 'bindoc' => [ |
|
| 232 |
+ 'man', |
|
| 233 |
+ 'man1' |
|
| 234 |
+ ], |
|
| 235 |
+ 'bin' => [ |
|
| 236 |
+ 'bin' |
|
| 237 |
+ ], |
|
| 238 |
+ 'arch' => [ |
|
| 239 |
+ 'lib', |
|
| 240 |
+ 'perl5', |
|
| 241 |
+ 'i386-linux-thread-multi' |
|
| 242 |
+ ], |
|
| 243 |
+ 'binhtml' => [ |
|
| 244 |
+ 'html' |
|
| 245 |
+ ], |
|
| 246 |
+ 'lib' => [ |
|
| 247 |
+ 'lib', |
|
| 248 |
+ 'perl5' |
|
| 249 |
+ ] |
|
| 250 |
+ }, |
|
| 251 |
+ 'meta_add' => {},
|
|
| 252 |
+ 'create_packlist' => 1, |
|
| 253 |
+ 'requires' => {
|
|
| 254 |
+ 'Object::Simple' => '2.0702', |
|
| 255 |
+ 'DBI' => '1.605' |
|
| 256 |
+ }, |
|
| 257 |
+ 'install_path' => {},
|
|
| 258 |
+ 'pm_files' => undef, |
|
| 259 |
+ 'quiet' => undef, |
|
| 260 |
+ 'script_files' => undef, |
|
| 261 |
+ 'extra_compiler_flags' => [], |
|
| 262 |
+ 'build_script' => 'Build', |
|
| 263 |
+ 'original_prefix' => {
|
|
| 264 |
+ 'core' => '/usr', |
|
| 265 |
+ 'site' => '/usr', |
|
| 266 |
+ 'vendor' => '/usr' |
|
| 267 |
+ }, |
|
| 268 |
+ 'c_source' => undef, |
|
| 269 |
+ 'autosplit' => undef, |
|
| 270 |
+ 'program_name' => undef, |
|
| 271 |
+ 'license' => 'perl', |
|
| 272 |
+ 'build_requires' => {
|
|
| 273 |
+ 'Test::More' => 0 |
|
| 274 |
+ }, |
|
| 275 |
+ 'config' => undef, |
|
| 276 |
+ 'blib' => 'blib', |
|
| 277 |
+ 'prefix' => undef |
|
| 278 |
+ } |
|
| 279 |
+ ]; |
|
| 280 |
+$x; } |
| ... | ... |
@@ -0,0 +1,5 @@ |
| 1 |
+do{ my $x = {
|
|
| 2 |
+ 'blib' => 1, |
|
| 3 |
+ 'DBIx-Custom-*' => 1 |
|
| 4 |
+ }; |
|
| 5 |
+$x; } |
| ... | ... |
@@ -0,0 +1,2 @@ |
| 1 |
+do{ my $x = {};
|
|
| 2 |
+$x; } |
| ... | ... |
@@ -0,0 +1,2 @@ |
| 1 |
+do{ my $x = {};
|
|
| 2 |
+$x; } |
| ... | ... |
@@ -0,0 +1 @@ |
| 1 |
+793374 |
| ... | ... |
@@ -0,0 +1,2 @@ |
| 1 |
+do{ my $x = {};
|
|
| 2 |
+$x; } |
| ... | ... |
@@ -0,0 +1,15 @@ |
| 1 |
+do{ my $x = {
|
|
| 2 |
+ 'build_requires' => {
|
|
| 3 |
+ 'Test::More' => 0 |
|
| 4 |
+ }, |
|
| 5 |
+ 'conflicts' => {},
|
|
| 6 |
+ 'requires' => {
|
|
| 7 |
+ 'Object::Simple' => '2.0702', |
|
| 8 |
+ 'DBI' => '1.605' |
|
| 9 |
+ }, |
|
| 10 |
+ 'recommends' => {
|
|
| 11 |
+ 'DBD::SQLite' => '1.25', |
|
| 12 |
+ 'Time::Piece' => '1.15' |
|
| 13 |
+ } |
|
| 14 |
+ }; |
|
| 15 |
+$x; } |
| ... | ... |
@@ -0,0 +1,2 @@ |
| 1 |
+do{ my $x = {};
|
|
| 2 |
+$x; } |
| ... | ... |
@@ -0,0 +1,1127 @@ |
| 1 |
+use 5.008001; |
|
| 2 |
+ |
|
| 3 |
+package DBIx::Custom; |
|
| 4 |
+use Object::Simple; |
|
| 5 |
+ |
|
| 6 |
+our $VERSION = '0.0501'; |
|
| 7 |
+ |
|
| 8 |
+use Carp 'croak'; |
|
| 9 |
+use DBI; |
|
| 10 |
+use DBIx::Custom::Query; |
|
| 11 |
+use DBIx::Custom::Result; |
|
| 12 |
+use DBIx::Custom::SQL::Template; |
|
| 13 |
+ |
|
| 14 |
+ |
|
| 15 |
+### Class-Object Accessors |
|
| 16 |
+sub user : ClassObjectAttr { initialize => {clone => 'scalar'} }
|
|
| 17 |
+sub password : ClassObjectAttr { initialize => {clone => 'scalar'} }
|
|
| 18 |
+sub data_source : ClassObjectAttr { initialize => {clone => 'scalar'} }
|
|
| 19 |
+sub dbi_options : ClassObjectAttr { initialize => {clone => 'hash',
|
|
| 20 |
+ default => sub { {} } } }
|
|
| 21 |
+sub database : ClassObjectAttr { initialize => {clone => 'scalar'} }
|
|
| 22 |
+ |
|
| 23 |
+sub bind_filter : ClassObjectAttr { initialize => {clone => 'scalar'} }
|
|
| 24 |
+sub fetch_filter : ClassObjectAttr { initialize => {clone => 'scalar'} }
|
|
| 25 |
+ |
|
| 26 |
+sub no_bind_filters : ClassObjectAttr { initialize => {clone => 'array'} }
|
|
| 27 |
+sub no_fetch_filters : ClassObjectAttr { initialize => {clone => 'array'} }
|
|
| 28 |
+ |
|
| 29 |
+sub filters : ClassObjectAttr {
|
|
| 30 |
+ type => 'hash', |
|
| 31 |
+ deref => 1, |
|
| 32 |
+ initialize => {
|
|
| 33 |
+ clone => 'hash', |
|
| 34 |
+ default => sub { {} }
|
|
| 35 |
+ } |
|
| 36 |
+} |
|
| 37 |
+ |
|
| 38 |
+sub formats : ClassObjectAttr {
|
|
| 39 |
+ type => 'hash', |
|
| 40 |
+ deref => 1, |
|
| 41 |
+ initialize => {
|
|
| 42 |
+ clone => 'hash', |
|
| 43 |
+ default => sub { {} }
|
|
| 44 |
+ } |
|
| 45 |
+} |
|
| 46 |
+ |
|
| 47 |
+sub result_class : ClassObjectAttr {
|
|
| 48 |
+ initialize => {
|
|
| 49 |
+ clone => 'scalar', |
|
| 50 |
+ default => 'DBIx::Custom::Result' |
|
| 51 |
+ } |
|
| 52 |
+} |
|
| 53 |
+ |
|
| 54 |
+sub sql_template : ClassObjectAttr {
|
|
| 55 |
+ initialize => {
|
|
| 56 |
+ clone => sub {$_[0] ? $_[0]->clone : undef},
|
|
| 57 |
+ default => sub {DBIx::Custom::SQL::Template->new}
|
|
| 58 |
+ } |
|
| 59 |
+} |
|
| 60 |
+ |
|
| 61 |
+### Object Accessor |
|
| 62 |
+sub dbh : Attr {}
|
|
| 63 |
+ |
|
| 64 |
+ |
|
| 65 |
+### Methods |
|
| 66 |
+ |
|
| 67 |
+# Add filter |
|
| 68 |
+sub add_filter {
|
|
| 69 |
+ my $invocant = shift; |
|
| 70 |
+ |
|
| 71 |
+ my %old_filters = $invocant->filters; |
|
| 72 |
+ my %new_filters = ref $_[0] eq 'HASH' ? %{$_[0]} : @_;
|
|
| 73 |
+ $invocant->filters(%old_filters, %new_filters); |
|
| 74 |
+ return $invocant; |
|
| 75 |
+} |
|
| 76 |
+ |
|
| 77 |
+# Add format |
|
| 78 |
+sub add_format{
|
|
| 79 |
+ my $invocant = shift; |
|
| 80 |
+ |
|
| 81 |
+ my %old_formats = $invocant->formats; |
|
| 82 |
+ my %new_formats = ref $_[0] eq 'HASH' ? %{$_[0]} : @_;
|
|
| 83 |
+ $invocant->formats(%old_formats, %new_formats); |
|
| 84 |
+ return $invocant; |
|
| 85 |
+} |
|
| 86 |
+ |
|
| 87 |
+# Auto commit |
|
| 88 |
+sub _auto_commit {
|
|
| 89 |
+ my $self = shift; |
|
| 90 |
+ |
|
| 91 |
+ croak("Not yet connect to database") unless $self->dbh;
|
|
| 92 |
+ |
|
| 93 |
+ if (@_) {
|
|
| 94 |
+ $self->dbh->{AutoCommit} = $_[0];
|
|
| 95 |
+ return $self; |
|
| 96 |
+ } |
|
| 97 |
+ return $self->dbh->{AutoCommit};
|
|
| 98 |
+} |
|
| 99 |
+ |
|
| 100 |
+# Connect |
|
| 101 |
+sub connect {
|
|
| 102 |
+ my $self = shift; |
|
| 103 |
+ my $data_source = $self->data_source; |
|
| 104 |
+ my $user = $self->user; |
|
| 105 |
+ my $password = $self->password; |
|
| 106 |
+ my $dbi_options = $self->dbi_options; |
|
| 107 |
+ |
|
| 108 |
+ my $dbh = eval{DBI->connect(
|
|
| 109 |
+ $data_source, |
|
| 110 |
+ $user, |
|
| 111 |
+ $password, |
|
| 112 |
+ {
|
|
| 113 |
+ RaiseError => 1, |
|
| 114 |
+ PrintError => 0, |
|
| 115 |
+ AutoCommit => 1, |
|
| 116 |
+ %{$dbi_options || {} }
|
|
| 117 |
+ } |
|
| 118 |
+ )}; |
|
| 119 |
+ |
|
| 120 |
+ croak $@ if $@; |
|
| 121 |
+ |
|
| 122 |
+ $self->dbh($dbh); |
|
| 123 |
+ return $self; |
|
| 124 |
+} |
|
| 125 |
+ |
|
| 126 |
+# DESTROY |
|
| 127 |
+sub DESTROY {
|
|
| 128 |
+ my $self = shift; |
|
| 129 |
+ $self->disconnect if $self->connected; |
|
| 130 |
+} |
|
| 131 |
+ |
|
| 132 |
+# Is connected? |
|
| 133 |
+sub connected {
|
|
| 134 |
+ my $self = shift; |
|
| 135 |
+ return ref $self->{dbh} eq 'DBI::db';
|
|
| 136 |
+} |
|
| 137 |
+ |
|
| 138 |
+# Disconnect |
|
| 139 |
+sub disconnect {
|
|
| 140 |
+ my $self = shift; |
|
| 141 |
+ if ($self->connected) {
|
|
| 142 |
+ $self->dbh->disconnect; |
|
| 143 |
+ delete $self->{dbh};
|
|
| 144 |
+ } |
|
| 145 |
+} |
|
| 146 |
+ |
|
| 147 |
+# Reconnect |
|
| 148 |
+sub reconnect {
|
|
| 149 |
+ my $self = shift; |
|
| 150 |
+ $self->disconnect if $self->connected; |
|
| 151 |
+ $self->connect; |
|
| 152 |
+} |
|
| 153 |
+ |
|
| 154 |
+# Prepare statement handle |
|
| 155 |
+sub prepare {
|
|
| 156 |
+ my ($self, $sql) = @_; |
|
| 157 |
+ |
|
| 158 |
+ # Connect if not |
|
| 159 |
+ $self->connect unless $self->connected; |
|
| 160 |
+ |
|
| 161 |
+ # Prepare |
|
| 162 |
+ my $sth = eval{$self->dbh->prepare($sql)};
|
|
| 163 |
+ |
|
| 164 |
+ # Error |
|
| 165 |
+ croak("$@<Your SQL>\n$sql") if $@;
|
|
| 166 |
+ |
|
| 167 |
+ return $sth; |
|
| 168 |
+} |
|
| 169 |
+ |
|
| 170 |
+# Execute SQL directly |
|
| 171 |
+sub do{
|
|
| 172 |
+ my ($self, $sql, @bind_values) = @_; |
|
| 173 |
+ |
|
| 174 |
+ # Connect if not |
|
| 175 |
+ $self->connect unless $self->connected; |
|
| 176 |
+ |
|
| 177 |
+ # Do |
|
| 178 |
+ my $ret_val = eval{$self->dbh->do($sql, @bind_values)};
|
|
| 179 |
+ |
|
| 180 |
+ # Error |
|
| 181 |
+ if ($@) {
|
|
| 182 |
+ my $error = $@; |
|
| 183 |
+ require Data::Dumper; |
|
| 184 |
+ |
|
| 185 |
+ my $bind_value_dump |
|
| 186 |
+ = Data::Dumper->Dump([\@bind_values], ['*bind_valuds']); |
|
| 187 |
+ |
|
| 188 |
+ croak("$error<Your SQL>\n$sql\n<Your bind values>\n$bind_value_dump\n");
|
|
| 189 |
+ } |
|
| 190 |
+} |
|
| 191 |
+ |
|
| 192 |
+# Create query |
|
| 193 |
+sub create_query {
|
|
| 194 |
+ my ($self, $template) = @_; |
|
| 195 |
+ my $class = ref $self; |
|
| 196 |
+ |
|
| 197 |
+ # Create query from SQL template |
|
| 198 |
+ my $sql_template = $self->sql_template; |
|
| 199 |
+ |
|
| 200 |
+ # Try to get cached query |
|
| 201 |
+ my $query = $class->_query_caches->{$template};
|
|
| 202 |
+ |
|
| 203 |
+ # Create query |
|
| 204 |
+ unless ($query) {
|
|
| 205 |
+ $query = eval{$sql_template->create_query($template)};
|
|
| 206 |
+ croak($@) if $@; |
|
| 207 |
+ |
|
| 208 |
+ $query = DBIx::Custom::Query->new($query); |
|
| 209 |
+ |
|
| 210 |
+ $class->_add_query_cache($template, $query); |
|
| 211 |
+ } |
|
| 212 |
+ |
|
| 213 |
+ # Connect if not |
|
| 214 |
+ $self->connect unless $self->connected; |
|
| 215 |
+ |
|
| 216 |
+ # Prepare statement handle |
|
| 217 |
+ my $sth = $self->prepare($query->{sql});
|
|
| 218 |
+ |
|
| 219 |
+ # Set statement handle |
|
| 220 |
+ $query->sth($sth); |
|
| 221 |
+ |
|
| 222 |
+ # Set bind filter |
|
| 223 |
+ $query->bind_filter($self->bind_filter); |
|
| 224 |
+ |
|
| 225 |
+ # Set no filter keys when binding |
|
| 226 |
+ $query->no_bind_filters($self->no_bind_filters); |
|
| 227 |
+ |
|
| 228 |
+ # Set fetch filter |
|
| 229 |
+ $query->fetch_filter($self->fetch_filter); |
|
| 230 |
+ |
|
| 231 |
+ # Set no filter keys when fetching |
|
| 232 |
+ $query->no_fetch_filters($self->no_fetch_filters); |
|
| 233 |
+ |
|
| 234 |
+ return $query; |
|
| 235 |
+} |
|
| 236 |
+ |
|
| 237 |
+# Execute query |
|
| 238 |
+sub execute {
|
|
| 239 |
+ my ($self, $query, $params) = @_; |
|
| 240 |
+ $params ||= {};
|
|
| 241 |
+ |
|
| 242 |
+ # First argument is SQL template |
|
| 243 |
+ if (!ref $query) {
|
|
| 244 |
+ my $template = $query; |
|
| 245 |
+ $query = $self->create_query($template); |
|
| 246 |
+ my $query_edit_cb = $_[3]; |
|
| 247 |
+ $query_edit_cb->($query) if ref $query_edit_cb eq 'CODE'; |
|
| 248 |
+ } |
|
| 249 |
+ |
|
| 250 |
+ # Create bind value |
|
| 251 |
+ my $bind_values = $self->_build_bind_values($query, $params); |
|
| 252 |
+ |
|
| 253 |
+ # Execute |
|
| 254 |
+ my $sth = $query->sth; |
|
| 255 |
+ my $ret_val = eval{$sth->execute(@$bind_values)};
|
|
| 256 |
+ |
|
| 257 |
+ # Execute error |
|
| 258 |
+ if (my $execute_error = $@) {
|
|
| 259 |
+ require Data::Dumper; |
|
| 260 |
+ my $sql = $query->{sql} || '';
|
|
| 261 |
+ my $key_infos_dump = Data::Dumper->Dump([$query->key_infos], ['*key_infos']); |
|
| 262 |
+ my $params_dump = Data::Dumper->Dump([$params], ['*params']); |
|
| 263 |
+ |
|
| 264 |
+ croak("$execute_error" .
|
|
| 265 |
+ "<Your SQL>\n$sql\n" . |
|
| 266 |
+ "<Your parameters>\n$params_dump"); |
|
| 267 |
+ } |
|
| 268 |
+ |
|
| 269 |
+ # Return resultset if select statement is executed |
|
| 270 |
+ if ($sth->{NUM_OF_FIELDS}) {
|
|
| 271 |
+ |
|
| 272 |
+ # Get result class |
|
| 273 |
+ my $result_class = $self->result_class; |
|
| 274 |
+ |
|
| 275 |
+ # Create result |
|
| 276 |
+ my $result = $result_class->new({
|
|
| 277 |
+ sth => $sth, |
|
| 278 |
+ fetch_filter => $query->fetch_filter, |
|
| 279 |
+ no_fetch_filters => $query->no_fetch_filters |
|
| 280 |
+ }); |
|
| 281 |
+ return $result; |
|
| 282 |
+ } |
|
| 283 |
+ return $ret_val; |
|
| 284 |
+} |
|
| 285 |
+ |
|
| 286 |
+# Build binding values |
|
| 287 |
+sub _build_bind_values {
|
|
| 288 |
+ my ($self, $query, $params) = @_; |
|
| 289 |
+ my $key_infos = $query->key_infos; |
|
| 290 |
+ my $bind_filter = $query->bind_filter; |
|
| 291 |
+ my $no_bind_filters_map = $query->_no_bind_filters_map || {};
|
|
| 292 |
+ |
|
| 293 |
+ # binding values |
|
| 294 |
+ my @bind_values; |
|
| 295 |
+ |
|
| 296 |
+ # Create bind values |
|
| 297 |
+ KEY_INFOS : |
|
| 298 |
+ foreach my $key_info (@$key_infos) {
|
|
| 299 |
+ # Set variable |
|
| 300 |
+ my $access_keys = $key_info->{access_keys};
|
|
| 301 |
+ my $original_key = $key_info->{original_key} || '';
|
|
| 302 |
+ my $table = $key_info->{table} || '';
|
|
| 303 |
+ my $column = $key_info->{column} || '';
|
|
| 304 |
+ |
|
| 305 |
+ # Key is found? |
|
| 306 |
+ my $found; |
|
| 307 |
+ |
|
| 308 |
+ # Build bind values |
|
| 309 |
+ ACCESS_KEYS : |
|
| 310 |
+ foreach my $access_key (@$access_keys) {
|
|
| 311 |
+ # Root parameter |
|
| 312 |
+ my $root_params = $params; |
|
| 313 |
+ |
|
| 314 |
+ # Search corresponding value |
|
| 315 |
+ for (my $i = 0; $i < @$access_key; $i++) {
|
|
| 316 |
+ # Current key |
|
| 317 |
+ my $current_key = $access_key->[$i]; |
|
| 318 |
+ |
|
| 319 |
+ # Last key |
|
| 320 |
+ if ($i == @$access_key - 1) {
|
|
| 321 |
+ # Key is array reference |
|
| 322 |
+ if (ref $current_key eq 'ARRAY') {
|
|
| 323 |
+ # Filtering |
|
| 324 |
+ if ($bind_filter && |
|
| 325 |
+ !$no_bind_filters_map->{$original_key})
|
|
| 326 |
+ {
|
|
| 327 |
+ push @bind_values, |
|
| 328 |
+ $bind_filter->($root_params->[$current_key->[0]], |
|
| 329 |
+ $original_key, |
|
| 330 |
+ $table, $column); |
|
| 331 |
+ } |
|
| 332 |
+ # Not filtering |
|
| 333 |
+ else {
|
|
| 334 |
+ push @bind_values, |
|
| 335 |
+ scalar $root_params->[$current_key->[0]]; |
|
| 336 |
+ } |
|
| 337 |
+ } |
|
| 338 |
+ # Key is string |
|
| 339 |
+ else {
|
|
| 340 |
+ # Key is not found |
|
| 341 |
+ next ACCESS_KEYS |
|
| 342 |
+ unless exists $root_params->{$current_key};
|
|
| 343 |
+ |
|
| 344 |
+ # Filtering |
|
| 345 |
+ if ($bind_filter && |
|
| 346 |
+ !$no_bind_filters_map->{$original_key})
|
|
| 347 |
+ {
|
|
| 348 |
+ push @bind_values, |
|
| 349 |
+ $bind_filter->($root_params->{$current_key},
|
|
| 350 |
+ $original_key, |
|
| 351 |
+ $table, $column); |
|
| 352 |
+ } |
|
| 353 |
+ # Not filtering |
|
| 354 |
+ else {
|
|
| 355 |
+ push @bind_values, |
|
| 356 |
+ scalar $root_params->{$current_key};
|
|
| 357 |
+ } |
|
| 358 |
+ } |
|
| 359 |
+ |
|
| 360 |
+ # Key is found |
|
| 361 |
+ $found = 1; |
|
| 362 |
+ next KEY_INFOS; |
|
| 363 |
+ } |
|
| 364 |
+ # First or middle key |
|
| 365 |
+ else {
|
|
| 366 |
+ # Key is array reference |
|
| 367 |
+ if (ref $current_key eq 'ARRAY') {
|
|
| 368 |
+ # Go next key |
|
| 369 |
+ $root_params = $root_params->[$current_key->[0]]; |
|
| 370 |
+ } |
|
| 371 |
+ # Key is string |
|
| 372 |
+ else {
|
|
| 373 |
+ # Not found |
|
| 374 |
+ next ACCESS_KEYS |
|
| 375 |
+ unless exists $root_params->{$current_key};
|
|
| 376 |
+ |
|
| 377 |
+ # Go next key |
|
| 378 |
+ $root_params = $root_params->{$current_key};
|
|
| 379 |
+ } |
|
| 380 |
+ } |
|
| 381 |
+ } |
|
| 382 |
+ } |
|
| 383 |
+ |
|
| 384 |
+ # Key is not found |
|
| 385 |
+ unless ($found) {
|
|
| 386 |
+ require Data::Dumper; |
|
| 387 |
+ my $key_info_dump = Data::Dumper->Dump([$key_info], ['*key_info']); |
|
| 388 |
+ my $params_dump = Data::Dumper->Dump([$params], ['*params']); |
|
| 389 |
+ croak("Corresponding key is not found in your parameters\n" .
|
|
| 390 |
+ "<Key information>\n$key_info_dump\n\n" . |
|
| 391 |
+ "<Your parameters>\n$params_dump\n"); |
|
| 392 |
+ } |
|
| 393 |
+ } |
|
| 394 |
+ return \@bind_values; |
|
| 395 |
+} |
|
| 396 |
+ |
|
| 397 |
+# Run transaction |
|
| 398 |
+sub run_transaction {
|
|
| 399 |
+ my ($self, $transaction) = @_; |
|
| 400 |
+ |
|
| 401 |
+ # Check auto commit |
|
| 402 |
+ croak("AutoCommit must be true before transaction start")
|
|
| 403 |
+ unless $self->_auto_commit; |
|
| 404 |
+ |
|
| 405 |
+ # Auto commit off |
|
| 406 |
+ $self->_auto_commit(0); |
|
| 407 |
+ |
|
| 408 |
+ # Run transaction |
|
| 409 |
+ eval {$transaction->()};
|
|
| 410 |
+ |
|
| 411 |
+ # Tranzaction error |
|
| 412 |
+ my $transaction_error = $@; |
|
| 413 |
+ |
|
| 414 |
+ # Tranzaction is failed. |
|
| 415 |
+ if ($transaction_error) {
|
|
| 416 |
+ # Rollback |
|
| 417 |
+ eval{$self->dbh->rollback};
|
|
| 418 |
+ |
|
| 419 |
+ # Rollback error |
|
| 420 |
+ my $rollback_error = $@; |
|
| 421 |
+ |
|
| 422 |
+ # Auto commit on |
|
| 423 |
+ $self->_auto_commit(1); |
|
| 424 |
+ |
|
| 425 |
+ if ($rollback_error) {
|
|
| 426 |
+ # Rollback is failed |
|
| 427 |
+ croak("${transaction_error}Rollback is failed : $rollback_error");
|
|
| 428 |
+ } |
|
| 429 |
+ else {
|
|
| 430 |
+ # Rollback is success |
|
| 431 |
+ croak("${transaction_error}Rollback is success");
|
|
| 432 |
+ } |
|
| 433 |
+ } |
|
| 434 |
+ # Tranzaction is success |
|
| 435 |
+ else {
|
|
| 436 |
+ # Commit |
|
| 437 |
+ eval{$self->dbh->commit};
|
|
| 438 |
+ my $commit_error = $@; |
|
| 439 |
+ |
|
| 440 |
+ # Auto commit on |
|
| 441 |
+ $self->_auto_commit(1); |
|
| 442 |
+ |
|
| 443 |
+ # Commit is failed |
|
| 444 |
+ croak($commit_error) if $commit_error; |
|
| 445 |
+ } |
|
| 446 |
+} |
|
| 447 |
+ |
|
| 448 |
+# Get last insert id |
|
| 449 |
+sub last_insert_id {
|
|
| 450 |
+ my $self = shift; |
|
| 451 |
+ |
|
| 452 |
+ # Not connected |
|
| 453 |
+ croak("Not yet connect to database")
|
|
| 454 |
+ unless $self->connected; |
|
| 455 |
+ |
|
| 456 |
+ return $self->dbh->last_insert_id(@_); |
|
| 457 |
+} |
|
| 458 |
+ |
|
| 459 |
+# Insert |
|
| 460 |
+sub insert {
|
|
| 461 |
+ my ($self, $table, $insert_params, $query_edit_cb) = @_; |
|
| 462 |
+ $table ||= ''; |
|
| 463 |
+ $insert_params ||= {};
|
|
| 464 |
+ |
|
| 465 |
+ # Insert keys |
|
| 466 |
+ my @insert_keys = keys %$insert_params; |
|
| 467 |
+ |
|
| 468 |
+ # Not exists insert keys |
|
| 469 |
+ croak("Key-value pairs for insert must be specified to 'insert' second argument")
|
|
| 470 |
+ unless @insert_keys; |
|
| 471 |
+ |
|
| 472 |
+ # Templte for insert |
|
| 473 |
+ my $template = "insert into $table {insert " . join(' ', @insert_keys) . '}';
|
|
| 474 |
+ |
|
| 475 |
+ # Create query |
|
| 476 |
+ my $query = $self->create_query($template); |
|
| 477 |
+ |
|
| 478 |
+ # Query edit callback must be code reference |
|
| 479 |
+ croak("Query edit callback must be code reference")
|
|
| 480 |
+ if $query_edit_cb && ref $query_edit_cb ne 'CODE'; |
|
| 481 |
+ |
|
| 482 |
+ # Query edit if need |
|
| 483 |
+ $query_edit_cb->($query) if $query_edit_cb; |
|
| 484 |
+ |
|
| 485 |
+ # Execute query |
|
| 486 |
+ my $ret_val = $self->execute($query, $insert_params); |
|
| 487 |
+ |
|
| 488 |
+ return $ret_val; |
|
| 489 |
+} |
|
| 490 |
+ |
|
| 491 |
+# Update |
|
| 492 |
+sub update {
|
|
| 493 |
+ my ($self, $table, $update_params, |
|
| 494 |
+ $where_params, $query_edit_cb, $options) = @_; |
|
| 495 |
+ |
|
| 496 |
+ $table ||= ''; |
|
| 497 |
+ $update_params ||= {};
|
|
| 498 |
+ $where_params ||= {};
|
|
| 499 |
+ |
|
| 500 |
+ # Update keys |
|
| 501 |
+ my @update_keys = keys %$update_params; |
|
| 502 |
+ |
|
| 503 |
+ # Not exists update kyes |
|
| 504 |
+ croak("Key-value pairs for update must be specified to 'update' second argument")
|
|
| 505 |
+ unless @update_keys; |
|
| 506 |
+ |
|
| 507 |
+ # Where keys |
|
| 508 |
+ my @where_keys = keys %$where_params; |
|
| 509 |
+ |
|
| 510 |
+ # Not exists where keys |
|
| 511 |
+ croak("Key-value pairs for where clause must be specified to 'update' third argument")
|
|
| 512 |
+ if !@where_keys && !$options->{allow_update_all};
|
|
| 513 |
+ |
|
| 514 |
+ # Update clause |
|
| 515 |
+ my $update_clause = '{update ' . join(' ', @update_keys) . '}';
|
|
| 516 |
+ |
|
| 517 |
+ # Where clause |
|
| 518 |
+ my $where_clause = ''; |
|
| 519 |
+ if (@where_keys) {
|
|
| 520 |
+ $where_clause = 'where '; |
|
| 521 |
+ foreach my $where_key (@where_keys) {
|
|
| 522 |
+ $where_clause .= "{= $where_key} and ";
|
|
| 523 |
+ } |
|
| 524 |
+ $where_clause =~ s/ and $//; |
|
| 525 |
+ } |
|
| 526 |
+ |
|
| 527 |
+ # Template for update |
|
| 528 |
+ my $template = "update $table $update_clause $where_clause"; |
|
| 529 |
+ |
|
| 530 |
+ # Create query |
|
| 531 |
+ my $query = $self->create_query($template); |
|
| 532 |
+ |
|
| 533 |
+ # Query edit callback must be code reference |
|
| 534 |
+ croak("Query edit callback must be code reference")
|
|
| 535 |
+ if $query_edit_cb && ref $query_edit_cb ne 'CODE'; |
|
| 536 |
+ |
|
| 537 |
+ # Query edit if need |
|
| 538 |
+ $query_edit_cb->($query) if $query_edit_cb; |
|
| 539 |
+ |
|
| 540 |
+ # Rearrange parammeters |
|
| 541 |
+ my $params = {'#update' => $update_params, %$where_params};
|
|
| 542 |
+ |
|
| 543 |
+ # Execute query |
|
| 544 |
+ my $ret_val = $self->execute($query, $params); |
|
| 545 |
+ |
|
| 546 |
+ return $ret_val; |
|
| 547 |
+} |
|
| 548 |
+ |
|
| 549 |
+# Update all rows |
|
| 550 |
+sub update_all {
|
|
| 551 |
+ my ($self, $table, $update_params, $query_edit_cb) = @_; |
|
| 552 |
+ |
|
| 553 |
+ return $self->update($table, $update_params, {}, $query_edit_cb,
|
|
| 554 |
+ {allow_update_all => 1});
|
|
| 555 |
+} |
|
| 556 |
+ |
|
| 557 |
+# Delete |
|
| 558 |
+sub delete {
|
|
| 559 |
+ my ($self, $table, $where_params, $query_edit_cb, $options) = @_; |
|
| 560 |
+ $table ||= ''; |
|
| 561 |
+ $where_params ||= {};
|
|
| 562 |
+ |
|
| 563 |
+ # Where keys |
|
| 564 |
+ my @where_keys = keys %$where_params; |
|
| 565 |
+ |
|
| 566 |
+ # Not exists where keys |
|
| 567 |
+ croak("Key-value pairs for where clause must be specified to 'delete' second argument")
|
|
| 568 |
+ if !@where_keys && !$options->{allow_delete_all};
|
|
| 569 |
+ |
|
| 570 |
+ # Where clause |
|
| 571 |
+ my $where_clause = ''; |
|
| 572 |
+ if (@where_keys) {
|
|
| 573 |
+ $where_clause = 'where '; |
|
| 574 |
+ foreach my $where_key (@where_keys) {
|
|
| 575 |
+ $where_clause .= "{= $where_key} and ";
|
|
| 576 |
+ } |
|
| 577 |
+ $where_clause =~ s/ and $//; |
|
| 578 |
+ } |
|
| 579 |
+ |
|
| 580 |
+ # Template for delete |
|
| 581 |
+ my $template = "delete from $table $where_clause"; |
|
| 582 |
+ |
|
| 583 |
+ # Create query |
|
| 584 |
+ my $query = $self->create_query($template); |
|
| 585 |
+ |
|
| 586 |
+ # Query edit callback must be code reference |
|
| 587 |
+ croak("Query edit callback must be code reference")
|
|
| 588 |
+ if $query_edit_cb && ref $query_edit_cb ne 'CODE'; |
|
| 589 |
+ |
|
| 590 |
+ # Query edit if need |
|
| 591 |
+ $query_edit_cb->($query) if $query_edit_cb; |
|
| 592 |
+ |
|
| 593 |
+ # Execute query |
|
| 594 |
+ my $ret_val = $self->execute($query, $where_params); |
|
| 595 |
+ |
|
| 596 |
+ return $ret_val; |
|
| 597 |
+} |
|
| 598 |
+ |
|
| 599 |
+# Delete all rows |
|
| 600 |
+sub delete_all {
|
|
| 601 |
+ my ($self, $table) = @_; |
|
| 602 |
+ return $self->delete($table, {}, undef, {allow_delete_all => 1});
|
|
| 603 |
+} |
|
| 604 |
+ |
|
| 605 |
+sub _select_usage { return << 'EOS' }
|
|
| 606 |
+Your select arguments is wrong. |
|
| 607 |
+select usage: |
|
| 608 |
+$dbi->select( |
|
| 609 |
+ $table, # must be string or array ref |
|
| 610 |
+ [@$columns], # must be array reference. this is optional |
|
| 611 |
+ {%$where_params}, # must be hash reference. this is optional
|
|
| 612 |
+ $append_statement, # must be string. this is optional |
|
| 613 |
+ $query_edit_callback # must be code reference. this is optional |
|
| 614 |
+); |
|
| 615 |
+EOS |
|
| 616 |
+ |
|
| 617 |
+sub select {
|
|
| 618 |
+ my $self = shift; |
|
| 619 |
+ |
|
| 620 |
+ # Check argument |
|
| 621 |
+ croak($self->_select_usage) unless @_; |
|
| 622 |
+ |
|
| 623 |
+ # Arguments |
|
| 624 |
+ my $tables = shift || ''; |
|
| 625 |
+ $tables = [$tables] unless ref $tables; |
|
| 626 |
+ |
|
| 627 |
+ my $columns = ref $_[0] eq 'ARRAY' ? shift : []; |
|
| 628 |
+ my $where_params = ref $_[0] eq 'HASH' ? shift : {};
|
|
| 629 |
+ my $append_statement = $_[0] && !ref $_[0] ? shift : ''; |
|
| 630 |
+ my $query_edit_cb = shift if ref $_[0] eq 'CODE'; |
|
| 631 |
+ |
|
| 632 |
+ # Check rest argument |
|
| 633 |
+ croak($self->_select_usage) if @_; |
|
| 634 |
+ |
|
| 635 |
+ # SQL template for select statement |
|
| 636 |
+ my $template = 'select '; |
|
| 637 |
+ |
|
| 638 |
+ # Join column clause |
|
| 639 |
+ if (@$columns) {
|
|
| 640 |
+ foreach my $column (@$columns) {
|
|
| 641 |
+ $template .= "$column, "; |
|
| 642 |
+ } |
|
| 643 |
+ $template =~ s/, $/ /; |
|
| 644 |
+ } |
|
| 645 |
+ else {
|
|
| 646 |
+ $template .= '* '; |
|
| 647 |
+ } |
|
| 648 |
+ |
|
| 649 |
+ # Join table |
|
| 650 |
+ $template .= 'from '; |
|
| 651 |
+ foreach my $table (@$tables) {
|
|
| 652 |
+ $template .= "$table, "; |
|
| 653 |
+ } |
|
| 654 |
+ $template =~ s/, $/ /; |
|
| 655 |
+ |
|
| 656 |
+ # Where clause keys |
|
| 657 |
+ my @where_keys = keys %$where_params; |
|
| 658 |
+ |
|
| 659 |
+ # Join where clause |
|
| 660 |
+ if (@where_keys) {
|
|
| 661 |
+ $template .= 'where '; |
|
| 662 |
+ foreach my $where_key (@where_keys) {
|
|
| 663 |
+ $template .= "{= $where_key} and ";
|
|
| 664 |
+ } |
|
| 665 |
+ } |
|
| 666 |
+ $template =~ s/ and $//; |
|
| 667 |
+ |
|
| 668 |
+ # Append something to last of statement |
|
| 669 |
+ if ($append_statement =~ s/^where //) {
|
|
| 670 |
+ if (@where_keys) {
|
|
| 671 |
+ $template .= " and $append_statement"; |
|
| 672 |
+ } |
|
| 673 |
+ else {
|
|
| 674 |
+ $template .= " where $append_statement"; |
|
| 675 |
+ } |
|
| 676 |
+ } |
|
| 677 |
+ else {
|
|
| 678 |
+ $template .= " $append_statement"; |
|
| 679 |
+ } |
|
| 680 |
+ |
|
| 681 |
+ # Create query |
|
| 682 |
+ my $query = $self->create_query($template); |
|
| 683 |
+ |
|
| 684 |
+ # Query edit |
|
| 685 |
+ $query_edit_cb->($query) if $query_edit_cb; |
|
| 686 |
+ |
|
| 687 |
+ # Execute query |
|
| 688 |
+ my $result = $self->execute($query, $where_params); |
|
| 689 |
+ |
|
| 690 |
+ return $result; |
|
| 691 |
+} |
|
| 692 |
+ |
|
| 693 |
+sub _query_caches : ClassAttr { type => 'hash',
|
|
| 694 |
+ auto_build => sub {shift->_query_caches({}) } }
|
|
| 695 |
+ |
|
| 696 |
+sub _query_cache_keys : ClassAttr { type => 'array',
|
|
| 697 |
+ auto_build => sub {shift->_query_cache_keys([])} }
|
|
| 698 |
+ |
|
| 699 |
+sub query_cache_max : ClassAttr { auto_build => sub {shift->query_cache_max(50)} }
|
|
| 700 |
+ |
|
| 701 |
+# Add query cahce |
|
| 702 |
+sub _add_query_cache {
|
|
| 703 |
+ my ($class, $template, $query) = @_; |
|
| 704 |
+ my $query_cache_keys = $class->_query_cache_keys; |
|
| 705 |
+ my $query_caches = $class->_query_caches; |
|
| 706 |
+ |
|
| 707 |
+ return $class if $query_caches->{$template};
|
|
| 708 |
+ |
|
| 709 |
+ $query_caches->{$template} = $query;
|
|
| 710 |
+ push @$query_cache_keys, $template; |
|
| 711 |
+ |
|
| 712 |
+ my $overflow = @$query_cache_keys - $class->query_cache_max; |
|
| 713 |
+ |
|
| 714 |
+ for (my $i = 0; $i < $overflow; $i++) {
|
|
| 715 |
+ my $template = shift @$query_cache_keys; |
|
| 716 |
+ delete $query_caches->{$template};
|
|
| 717 |
+ } |
|
| 718 |
+ |
|
| 719 |
+ return $class; |
|
| 720 |
+} |
|
| 721 |
+ |
|
| 722 |
+# Both bind_filter and fetch_filter off |
|
| 723 |
+sub filter_off {
|
|
| 724 |
+ my $self = shift; |
|
| 725 |
+ |
|
| 726 |
+ # filter off |
|
| 727 |
+ $self->bind_filter(undef); |
|
| 728 |
+ $self->fetch_filter(undef); |
|
| 729 |
+ |
|
| 730 |
+ return $self; |
|
| 731 |
+} |
|
| 732 |
+ |
|
| 733 |
+Object::Simple->build_class; |
|
| 734 |
+ |
|
| 735 |
+=head1 NAME |
|
| 736 |
+ |
|
| 737 |
+DBIx::Custom - Customizable simple DBI |
|
| 738 |
+ |
|
| 739 |
+=head1 VERSION |
|
| 740 |
+ |
|
| 741 |
+Version 0.0501 |
|
| 742 |
+ |
|
| 743 |
+=head1 CAUTION |
|
| 744 |
+ |
|
| 745 |
+This module is now experimental stage. |
|
| 746 |
+ |
|
| 747 |
+I want you to try this module |
|
| 748 |
+because I want this module stable, and not to damage your DB data by this module bug. |
|
| 749 |
+ |
|
| 750 |
+Please tell me bug if you find |
|
| 751 |
+ |
|
| 752 |
+=head1 SYNOPSIS |
|
| 753 |
+ |
|
| 754 |
+ my $dbi = DBIx::Custom->new; |
|
| 755 |
+ |
|
| 756 |
+ my $query = $dbi->create_query($template); |
|
| 757 |
+ $dbi->execute($query); |
|
| 758 |
+ |
|
| 759 |
+=head1 CLASS-OBJECT ACCESSORS |
|
| 760 |
+ |
|
| 761 |
+=head2 user |
|
| 762 |
+ |
|
| 763 |
+ # Set and get database user name |
|
| 764 |
+ $self = $dbi->user($user); |
|
| 765 |
+ $user = $dbi->user; |
|
| 766 |
+ |
|
| 767 |
+ # Sample |
|
| 768 |
+ $dbi->user('taro');
|
|
| 769 |
+ |
|
| 770 |
+=head2 password |
|
| 771 |
+ |
|
| 772 |
+ # Set and get database password |
|
| 773 |
+ $self = $dbi->password($password); |
|
| 774 |
+ $password = $dbi->password; |
|
| 775 |
+ |
|
| 776 |
+ # Sample |
|
| 777 |
+ $dbi->password('lkj&le`@s');
|
|
| 778 |
+ |
|
| 779 |
+=head2 data_source |
|
| 780 |
+ |
|
| 781 |
+ # Set and get database data source |
|
| 782 |
+ $self = $dbi->data_source($data_soruce); |
|
| 783 |
+ $data_source = $dbi->data_source; |
|
| 784 |
+ |
|
| 785 |
+ # Sample(SQLite) |
|
| 786 |
+ $dbi->data_source(dbi:SQLite:dbname=$database); |
|
| 787 |
+ |
|
| 788 |
+ # Sample(MySQL); |
|
| 789 |
+ $dbi->data_source("dbi:mysql:dbname=$database");
|
|
| 790 |
+ |
|
| 791 |
+ # Sample(PostgreSQL) |
|
| 792 |
+ $dbi->data_source("dbi:Pg:dbname=$database");
|
|
| 793 |
+ |
|
| 794 |
+=head2 database |
|
| 795 |
+ |
|
| 796 |
+ # Set and get database name |
|
| 797 |
+ $self = $dbi->database($database); |
|
| 798 |
+ $database = $dbi->database; |
|
| 799 |
+ |
|
| 800 |
+This method will be used in subclass connect method. |
|
| 801 |
+ |
|
| 802 |
+=head2 dbi_options |
|
| 803 |
+ |
|
| 804 |
+ # Set and get DBI option |
|
| 805 |
+ $self = $dbi->dbi_options({$options => $value, ...});
|
|
| 806 |
+ $dbi_options = $dbi->dbi_options; |
|
| 807 |
+ |
|
| 808 |
+ # Sample |
|
| 809 |
+ $dbi->dbi_options({PrintError => 0, RaiseError => 1});
|
|
| 810 |
+ |
|
| 811 |
+dbi_options is used when you connect database by using connect. |
|
| 812 |
+ |
|
| 813 |
+=head2 prepare |
|
| 814 |
+ |
|
| 815 |
+ $sth = $dbi->prepare($sql); |
|
| 816 |
+ |
|
| 817 |
+This method is same as DBI::prepare |
|
| 818 |
+ |
|
| 819 |
+=head2 do |
|
| 820 |
+ |
|
| 821 |
+ $dbi->do($sql, @bind_values); |
|
| 822 |
+ |
|
| 823 |
+This method is same as DBI::do |
|
| 824 |
+ |
|
| 825 |
+=head2 sql_template |
|
| 826 |
+ |
|
| 827 |
+ # Set and get SQL::Template object |
|
| 828 |
+ $self = $dbi->sql_template($sql_template); |
|
| 829 |
+ $sql_template = $dbi->sql_template; |
|
| 830 |
+ |
|
| 831 |
+ # Sample |
|
| 832 |
+ $dbi->sql_template(DBI::Cutom::SQL::Template->new); |
|
| 833 |
+ |
|
| 834 |
+=head2 filters |
|
| 835 |
+ |
|
| 836 |
+ # Set and get filters |
|
| 837 |
+ $self = $dbi->filters($filters); |
|
| 838 |
+ $filters = $dbi->filters; |
|
| 839 |
+ |
|
| 840 |
+=head2 formats |
|
| 841 |
+ |
|
| 842 |
+ # Set and get formats |
|
| 843 |
+ $self = $dbi->formats($formats); |
|
| 844 |
+ $formats = $dbi->formats; |
|
| 845 |
+ |
|
| 846 |
+=head2 bind_filter |
|
| 847 |
+ |
|
| 848 |
+ # Set and get binding filter |
|
| 849 |
+ $self = $dbi->bind_filter($bind_filter); |
|
| 850 |
+ $bind_filter = $dbi->bind_filter |
|
| 851 |
+ |
|
| 852 |
+ # Sample |
|
| 853 |
+ $dbi->bind_filter($self->filters->{default_bind_filter});
|
|
| 854 |
+ |
|
| 855 |
+ |
|
| 856 |
+you can get DBI database handle if you need. |
|
| 857 |
+ |
|
| 858 |
+=head2 fetch_filter |
|
| 859 |
+ |
|
| 860 |
+ # Set and get Fetch filter |
|
| 861 |
+ $self = $dbi->fetch_filter($fetch_filter); |
|
| 862 |
+ $fetch_filter = $dbi->fetch_filter; |
|
| 863 |
+ |
|
| 864 |
+ # Sample |
|
| 865 |
+ $dbi->fetch_filter($self->filters->{default_fetch_filter});
|
|
| 866 |
+ |
|
| 867 |
+=head2 no_bind_filters |
|
| 868 |
+ |
|
| 869 |
+ # Set and get no filter keys when binding |
|
| 870 |
+ $self = $dbi->no_bind_filters($no_bind_filters); |
|
| 871 |
+ $no_bind_filters = $dbi->no_bind_filters; |
|
| 872 |
+ |
|
| 873 |
+=head2 no_fetch_filters |
|
| 874 |
+ |
|
| 875 |
+ # Set and get no filter keys when fetching |
|
| 876 |
+ $self = $dbi->no_fetch_filters($no_fetch_filters); |
|
| 877 |
+ $no_fetch_filters = $dbi->no_fetch_filters; |
|
| 878 |
+ |
|
| 879 |
+=head2 result_class |
|
| 880 |
+ |
|
| 881 |
+ # Set and get resultset class |
|
| 882 |
+ $self = $dbi->result_class($result_class); |
|
| 883 |
+ $result_class = $dbi->result_class; |
|
| 884 |
+ |
|
| 885 |
+ # Sample |
|
| 886 |
+ $dbi->result_class('DBIx::Custom::Result');
|
|
| 887 |
+ |
|
| 888 |
+=head2 dbh |
|
| 889 |
+ |
|
| 890 |
+ # Get database handle |
|
| 891 |
+ $dbh = $self->dbh; |
|
| 892 |
+ |
|
| 893 |
+=head1 METHODS |
|
| 894 |
+ |
|
| 895 |
+=head2 connect |
|
| 896 |
+ |
|
| 897 |
+ # Connect to database |
|
| 898 |
+ $self = $dbi->connect; |
|
| 899 |
+ |
|
| 900 |
+ # Sample |
|
| 901 |
+ $dbi = DBIx::Custom->new(user => 'taro', password => 'lji8(',
|
|
| 902 |
+ data_soruce => "dbi:mysql:dbname=$database"); |
|
| 903 |
+ $dbi->connect; |
|
| 904 |
+ |
|
| 905 |
+=head2 disconnect |
|
| 906 |
+ |
|
| 907 |
+ # Disconnect database |
|
| 908 |
+ $dbi->disconnect; |
|
| 909 |
+ |
|
| 910 |
+If database is already disconnected, this method do noting. |
|
| 911 |
+ |
|
| 912 |
+=head2 reconnect |
|
| 913 |
+ |
|
| 914 |
+ # Reconnect |
|
| 915 |
+ $dbi->reconnect; |
|
| 916 |
+ |
|
| 917 |
+=head2 connected |
|
| 918 |
+ |
|
| 919 |
+ # Check connected |
|
| 920 |
+ $dbi->connected |
|
| 921 |
+ |
|
| 922 |
+=head2 filter_off |
|
| 923 |
+ |
|
| 924 |
+ # bind_filter and fitch_filter off |
|
| 925 |
+ $self->filter_off; |
|
| 926 |
+ |
|
| 927 |
+This is equeal to |
|
| 928 |
+ |
|
| 929 |
+ $self->bind_filter(undef); |
|
| 930 |
+ $self->fetch_filter(undef); |
|
| 931 |
+ |
|
| 932 |
+=head2 add_filter |
|
| 933 |
+ |
|
| 934 |
+ # Add filter (hash ref or hash can be recieve) |
|
| 935 |
+ $self = $dbi->add_filter({$filter_name => $filter, ...});
|
|
| 936 |
+ $self = $dbi->add_filter($filetr_name => $filter, ...); |
|
| 937 |
+ |
|
| 938 |
+ # Sample |
|
| 939 |
+ $dbi->add_filter( |
|
| 940 |
+ decode_utf8 => sub {
|
|
| 941 |
+ my ($key, $value, $table, $column) = @_; |
|
| 942 |
+ return Encode::decode('UTF-8', $value);
|
|
| 943 |
+ }, |
|
| 944 |
+ datetime_to_string => sub {
|
|
| 945 |
+ my ($key, $value, $table, $column) = @_; |
|
| 946 |
+ return $value->strftime('%Y-%m-%d %H:%M:%S')
|
|
| 947 |
+ }, |
|
| 948 |
+ default_bind_filter => sub {
|
|
| 949 |
+ my ($key, $value, $table, $column) = @_; |
|
| 950 |
+ if (ref $value eq 'Time::Piece') {
|
|
| 951 |
+ return $dbi->filters->{datetime_to_string}->($value);
|
|
| 952 |
+ } |
|
| 953 |
+ else {
|
|
| 954 |
+ return $dbi->filters->{decode_utf8}->($value);
|
|
| 955 |
+ } |
|
| 956 |
+ }, |
|
| 957 |
+ |
|
| 958 |
+ encode_utf8 => sub {
|
|
| 959 |
+ my ($key, $value) = @_; |
|
| 960 |
+ return Encode::encode('UTF-8', $value);
|
|
| 961 |
+ }, |
|
| 962 |
+ string_to_datetime => sub {
|
|
| 963 |
+ my ($key, $value) = @_; |
|
| 964 |
+ return DateTime::Format::MySQL->parse_datetime($value); |
|
| 965 |
+ }, |
|
| 966 |
+ default_fetch_filter => sub {
|
|
| 967 |
+ my ($key, $value, $type, $sth, $i) = @_; |
|
| 968 |
+ if ($type eq 'DATETIME') {
|
|
| 969 |
+ return $dbi->filters->{string_to_datetime}->($value);
|
|
| 970 |
+ } |
|
| 971 |
+ else {
|
|
| 972 |
+ return $dbi->filters->{encode_utf8}->($value);
|
|
| 973 |
+ } |
|
| 974 |
+ } |
|
| 975 |
+ ); |
|
| 976 |
+ |
|
| 977 |
+add_filter add filter to filters |
|
| 978 |
+ |
|
| 979 |
+=head2 add_format |
|
| 980 |
+ |
|
| 981 |
+ $dbi->add_format(date => '%Y:%m:%d'); |
|
| 982 |
+ |
|
| 983 |
+=head2 create_query |
|
| 984 |
+ |
|
| 985 |
+ # Create Query object from SQL template |
|
| 986 |
+ my $query = $dbi->create_query($template); |
|
| 987 |
+ |
|
| 988 |
+=head2 execute |
|
| 989 |
+ |
|
| 990 |
+ # Parse SQL template and execute SQL |
|
| 991 |
+ $result = $dbi->query($query, $params); |
|
| 992 |
+ $result = $dbi->query($template, $params); # Shorcut |
|
| 993 |
+ |
|
| 994 |
+ # Sample |
|
| 995 |
+ $result = $dbi->query("select * from authors where {= name} and {= age}",
|
|
| 996 |
+ {author => 'taro', age => 19});
|
|
| 997 |
+ |
|
| 998 |
+ while (my @row = $result->fetch) {
|
|
| 999 |
+ # do something |
|
| 1000 |
+ } |
|
| 1001 |
+ |
|
| 1002 |
+See also L<DBIx::Custom::SQL::Template> |
|
| 1003 |
+ |
|
| 1004 |
+=head2 run_transaction |
|
| 1005 |
+ |
|
| 1006 |
+ # Run transaction |
|
| 1007 |
+ $dbi->run_transaction(sub {
|
|
| 1008 |
+ # do something |
|
| 1009 |
+ }); |
|
| 1010 |
+ |
|
| 1011 |
+If transaction is success, commit is execute. |
|
| 1012 |
+If tranzation is died, rollback is execute. |
|
| 1013 |
+ |
|
| 1014 |
+=head2 insert |
|
| 1015 |
+ |
|
| 1016 |
+ # Insert |
|
| 1017 |
+ $dbi->insert($table, $insert_values); |
|
| 1018 |
+ |
|
| 1019 |
+ # Sample |
|
| 1020 |
+ $dbi->insert('books', {title => 'Perl', author => 'Taro'});
|
|
| 1021 |
+ |
|
| 1022 |
+=head2 update |
|
| 1023 |
+ |
|
| 1024 |
+ # Update |
|
| 1025 |
+ $dbi->update($table, $update_values, $where); |
|
| 1026 |
+ |
|
| 1027 |
+ # Sample |
|
| 1028 |
+ $dbi->update('books', {title => 'Perl', author => 'Taro'}, {id => 5});
|
|
| 1029 |
+ |
|
| 1030 |
+=head2 update_all |
|
| 1031 |
+ |
|
| 1032 |
+ # Update all rows |
|
| 1033 |
+ $dbi->update($table, $updat_values); |
|
| 1034 |
+ |
|
| 1035 |
+=head2 delete |
|
| 1036 |
+ |
|
| 1037 |
+ # Delete |
|
| 1038 |
+ $dbi->delete($table, $where); |
|
| 1039 |
+ |
|
| 1040 |
+ # Sample |
|
| 1041 |
+ $dbi->delete('Books', {id => 5});
|
|
| 1042 |
+ |
|
| 1043 |
+=head2 delete_all |
|
| 1044 |
+ |
|
| 1045 |
+ # Delete all rows |
|
| 1046 |
+ $dbi->delete_all($table); |
|
| 1047 |
+ |
|
| 1048 |
+=head2 last_insert_id |
|
| 1049 |
+ |
|
| 1050 |
+ # Get last insert id |
|
| 1051 |
+ $last_insert_id = $dbi->last_insert_id; |
|
| 1052 |
+ |
|
| 1053 |
+This method is same as DBI last_insert_id; |
|
| 1054 |
+ |
|
| 1055 |
+=head2 select |
|
| 1056 |
+ |
|
| 1057 |
+ # Select |
|
| 1058 |
+ $dbi->select( |
|
| 1059 |
+ $table, # must be string or array; |
|
| 1060 |
+ [@$columns], # must be array reference. this is optional |
|
| 1061 |
+ {%$where_params}, # must be hash reference. this is optional
|
|
| 1062 |
+ $append_statement, # must be string. this is optional |
|
| 1063 |
+ $query_edit_callback # must be code reference. this is optional |
|
| 1064 |
+ ); |
|
| 1065 |
+ |
|
| 1066 |
+ # Sample |
|
| 1067 |
+ $dbi->select( |
|
| 1068 |
+ 'Books', |
|
| 1069 |
+ ['title', 'author'], |
|
| 1070 |
+ {id => 1},
|
|
| 1071 |
+ "for update", |
|
| 1072 |
+ sub {
|
|
| 1073 |
+ my $query = shift; |
|
| 1074 |
+ $query->bind_filter(sub {
|
|
| 1075 |
+ # ... |
|
| 1076 |
+ }); |
|
| 1077 |
+ } |
|
| 1078 |
+ ); |
|
| 1079 |
+ |
|
| 1080 |
+ # The way to join multi tables |
|
| 1081 |
+ $dbi->select( |
|
| 1082 |
+ ['table1', 'table2'], |
|
| 1083 |
+ ['table1.id as table1_id', 'title'], |
|
| 1084 |
+ {table1.id => 1},
|
|
| 1085 |
+ "where table1.id = table2.id", |
|
| 1086 |
+ ); |
|
| 1087 |
+ |
|
| 1088 |
+=head1 Class Accessors |
|
| 1089 |
+ |
|
| 1090 |
+=head2 query_cache_max |
|
| 1091 |
+ |
|
| 1092 |
+ # Max query cache count |
|
| 1093 |
+ $class = $class->query_cache_max($query_cache_max); |
|
| 1094 |
+ $query_cache_max = $class->query_cache_max; |
|
| 1095 |
+ |
|
| 1096 |
+ # Sample |
|
| 1097 |
+ DBIx::Custom->query_cache_max(50); |
|
| 1098 |
+ |
|
| 1099 |
+=head1 CAUTION |
|
| 1100 |
+ |
|
| 1101 |
+DBIx::Custom have DIB object internal. |
|
| 1102 |
+This module is work well in the following DBI condition. |
|
| 1103 |
+ |
|
| 1104 |
+ 1. AutoCommit is true |
|
| 1105 |
+ 2. RaiseError is true |
|
| 1106 |
+ |
|
| 1107 |
+By default, Both AutoCommit and RaiseError is true. |
|
| 1108 |
+You must not change these mode not to damage your data. |
|
| 1109 |
+ |
|
| 1110 |
+If you change these mode, |
|
| 1111 |
+you cannot get correct error message, |
|
| 1112 |
+or run_transaction may fail. |
|
| 1113 |
+ |
|
| 1114 |
+=head1 AUTHOR |
|
| 1115 |
+ |
|
| 1116 |
+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >> |
|
| 1117 |
+ |
|
| 1118 |
+Github L<http://github.com/yuki-kimoto> |
|
| 1119 |
+ |
|
| 1120 |
+=head1 COPYRIGHT & LICENSE |
|
| 1121 |
+ |
|
| 1122 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 1123 |
+ |
|
| 1124 |
+This program is free software; you can redistribute it and/or modify it |
|
| 1125 |
+under the same terms as Perl itself. |
|
| 1126 |
+ |
|
| 1127 |
+=cut |
| ... | ... |
@@ -0,0 +1,117 @@ |
| 1 |
+package DBIx::Custom::Basic; |
|
| 2 |
+use 5.008001; |
|
| 3 |
+use base 'DBIx::Custom'; |
|
| 4 |
+use Encode qw/decode encode/; |
|
| 5 |
+ |
|
| 6 |
+use warnings; |
|
| 7 |
+use strict; |
|
| 8 |
+ |
|
| 9 |
+my $class = __PACKAGE__; |
|
| 10 |
+ |
|
| 11 |
+$class->add_filter( |
|
| 12 |
+ encode_utf8 => sub {
|
|
| 13 |
+ my $value = shift; |
|
| 14 |
+ utf8::upgrade($value) unless Encode::is_utf8($value); |
|
| 15 |
+ return encode('UTF-8', $value);
|
|
| 16 |
+ }, |
|
| 17 |
+ decode_utf8 => sub { decode('UTF-8', shift) }
|
|
| 18 |
+); |
|
| 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 |
+# Methods |
|
| 30 |
+sub utf8_filter_on {
|
|
| 31 |
+ my $self = shift; |
|
| 32 |
+ $self->bind_filter($self->filters->{encode_utf8});
|
|
| 33 |
+ $self->fetch_filter($self->filters->{decode_utf8});
|
|
| 34 |
+} |
|
| 35 |
+ |
|
| 36 |
+1; |
|
| 37 |
+ |
|
| 38 |
+=head1 NAME |
|
| 39 |
+ |
|
| 40 |
+DBIx::Custom::Basic - DBIx::Custom basic implementation |
|
| 41 |
+ |
|
| 42 |
+=head1 Version |
|
| 43 |
+ |
|
| 44 |
+Version 0.0201 |
|
| 45 |
+ |
|
| 46 |
+=head1 See DBIx::Custom documentation |
|
| 47 |
+ |
|
| 48 |
+This class is L<DBIx::Custom> subclass. |
|
| 49 |
+ |
|
| 50 |
+You can use all methods of L<DBIx::Custom> |
|
| 51 |
+ |
|
| 52 |
+Please see L<DBIx::Custom> documentation |
|
| 53 |
+ |
|
| 54 |
+=head1 Filters |
|
| 55 |
+ |
|
| 56 |
+=head2 encode_utf8 |
|
| 57 |
+ |
|
| 58 |
+ # Encode to UTF-8 byte stream (utf8::upgrade is done if need) |
|
| 59 |
+ $dbi->filters->{encode_utf8}->($value);
|
|
| 60 |
+ |
|
| 61 |
+This filter is generally used as bind filter |
|
| 62 |
+ |
|
| 63 |
+ $dbi->bind_filter($dbi->filters->{encode_utf8});
|
|
| 64 |
+ |
|
| 65 |
+=head2 decode_utf8 |
|
| 66 |
+ |
|
| 67 |
+ # Decode to perl internal string |
|
| 68 |
+ $dbi->filters->{decode_utf8}->($value);
|
|
| 69 |
+ |
|
| 70 |
+This filter is generally used as fetch filter |
|
| 71 |
+ |
|
| 72 |
+ $dbi->fetch_filter($dbi->filters->{decode_utf8});
|
|
| 73 |
+ |
|
| 74 |
+=head2 Formats |
|
| 75 |
+ |
|
| 76 |
+strptime formats is available |
|
| 77 |
+ |
|
| 78 |
+ # format name format |
|
| 79 |
+ 'SQL99_date' '%Y-%m-%d', |
|
| 80 |
+ 'SQL99_datetime' '%Y-%m-%d %H:%M:%S', |
|
| 81 |
+ 'SQL99_time' '%H:%M:%S', |
|
| 82 |
+ 'ISO-8601_date' '%Y-%m-%d', |
|
| 83 |
+ 'ISO-8601_datetime' '%Y-%m-%dT%H:%M:%S', |
|
| 84 |
+ 'ISO-8601_time' '%H:%M:%S', |
|
| 85 |
+ |
|
| 86 |
+You get format as the following |
|
| 87 |
+ |
|
| 88 |
+ my $format = $dbi->formats->{$format_name};
|
|
| 89 |
+ |
|
| 90 |
+=head1 Methods |
|
| 91 |
+ |
|
| 92 |
+=head2 utf8_filter_on |
|
| 93 |
+ |
|
| 94 |
+ # Encode and decode utf8 filter on |
|
| 95 |
+ $dbi->utf8_filter_on; |
|
| 96 |
+ |
|
| 97 |
+This equel to |
|
| 98 |
+ |
|
| 99 |
+ $dbi->bind_filter($dbi->filters->{encode_utf8});
|
|
| 100 |
+ $dbi->fetch_filter($dbi->filters->{decode_utf8});
|
|
| 101 |
+ |
|
| 102 |
+=head1 AUTHOR |
|
| 103 |
+ |
|
| 104 |
+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >> |
|
| 105 |
+ |
|
| 106 |
+Github L<http://github.com/yuki-kimoto> |
|
| 107 |
+ |
|
| 108 |
+I develope this module L<http://github.com/yuki-kimoto/DBIx-Custom> |
|
| 109 |
+ |
|
| 110 |
+=head1 COPYRIGHT & LICENSE |
|
| 111 |
+ |
|
| 112 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 113 |
+ |
|
| 114 |
+This program is free software; you can redistribute it and/or modify it |
|
| 115 |
+under the same terms as Perl itself. |
|
| 116 |
+ |
|
| 117 |
+=cut |
| ... | ... |
@@ -0,0 +1,86 @@ |
| 1 |
+package DBIx::Custom::MySQL; |
|
| 2 |
+use base 'DBIx::Custom::Basic'; |
|
| 3 |
+ |
|
| 4 |
+use warnings; |
|
| 5 |
+use strict; |
|
| 6 |
+ |
|
| 7 |
+my $class = __PACKAGE__; |
|
| 8 |
+ |
|
| 9 |
+$class->add_format( |
|
| 10 |
+ datetime => $class->formats->{SQL99_datetime},
|
|
| 11 |
+ date => $class->formats->{SQL99_date},
|
|
| 12 |
+ time => $class->formats->{SQL99_time},
|
|
| 13 |
+); |
|
| 14 |
+ |
|
| 15 |
+ |
|
| 16 |
+sub connect {
|
|
| 17 |
+ my $self = shift; |
|
| 18 |
+ |
|
| 19 |
+ if (!$self->data_source && (my $database = $self->database)) {
|
|
| 20 |
+ $self->data_source("dbi:mysql:dbname=$database");
|
|
| 21 |
+ } |
|
| 22 |
+ |
|
| 23 |
+ return $self->SUPER::connect; |
|
| 24 |
+} |
|
| 25 |
+ |
|
| 26 |
+=head1 NAME |
|
| 27 |
+ |
|
| 28 |
+DBIx::Custom::MySQL - DBIx::Custom MySQL implementation |
|
| 29 |
+ |
|
| 30 |
+=head1 Version |
|
| 31 |
+ |
|
| 32 |
+Version 0.0102 |
|
| 33 |
+ |
|
| 34 |
+=head1 Synopsys |
|
| 35 |
+ |
|
| 36 |
+ # New |
|
| 37 |
+ my $dbi = DBIx::Custom::MySQL->new(user => 'taro', $password => 'kliej&@K', |
|
| 38 |
+ database => 'sample_db'); |
|
| 39 |
+ # Insert |
|
| 40 |
+ $dbi->insert('books', {title => 'perl', author => 'taro'});
|
|
| 41 |
+ |
|
| 42 |
+ # Update |
|
| 43 |
+ # same as 'update books set (title = 'aaa', author = 'ken') where id = 5; |
|
| 44 |
+ $dbi->update('books', {title => 'aaa', author => 'ken'}, {id => 5});
|
|
| 45 |
+ |
|
| 46 |
+ # Delete |
|
| 47 |
+ $dbi->delete('books', {author => 'taro'});
|
|
| 48 |
+ |
|
| 49 |
+ # select * from books; |
|
| 50 |
+ $dbi->select('books');
|
|
| 51 |
+ |
|
| 52 |
+ # select * from books where ahthor = 'taro'; |
|
| 53 |
+ $dbi->select('books', {author => 'taro'});
|
|
| 54 |
+ |
|
| 55 |
+=head1 See DBIx::Custom and DBI::Custom::Basic documentation |
|
| 56 |
+ |
|
| 57 |
+This class is L<DBIx::Custom::Basic> subclass, |
|
| 58 |
+and L<DBIx::Custom::Basic> is L<DBIx::Custom> subclass. |
|
| 59 |
+ |
|
| 60 |
+You can use all methods of L<DBIx::Custom::Basic> and <DBIx::Custom> |
|
| 61 |
+Please see L<DBIx::Custom::Basic> and <DBIx::Custom> documentation. |
|
| 62 |
+ |
|
| 63 |
+=head1 Object methods |
|
| 64 |
+ |
|
| 65 |
+=head2 connect |
|
| 66 |
+ |
|
| 67 |
+ This method override DBIx::Custom::connect |
|
| 68 |
+ |
|
| 69 |
+ If database attribute is set, automatically data source is created and connect |
|
| 70 |
+ |
|
| 71 |
+=head1 Author |
|
| 72 |
+ |
|
| 73 |
+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >> |
|
| 74 |
+ |
|
| 75 |
+Github L<http://github.com/yuki-kimoto> |
|
| 76 |
+ |
|
| 77 |
+I develope this module L<http://github.com/yuki-kimoto/DBIx-Custom> |
|
| 78 |
+ |
|
| 79 |
+=head1 Copyright & license |
|
| 80 |
+ |
|
| 81 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 82 |
+ |
|
| 83 |
+This program is free software; you can redistribute it and/or modify it |
|
| 84 |
+under the same terms as Perl itself. |
|
| 85 |
+ |
|
| 86 |
+ |
| ... | ... |
@@ -0,0 +1,101 @@ |
| 1 |
+package DBIx::Custom::Query; |
|
| 2 |
+use Object::Simple; |
|
| 3 |
+ |
|
| 4 |
+sub sql : Attr {}
|
|
| 5 |
+sub key_infos : Attr {}
|
|
| 6 |
+sub bind_filter : Attr {}
|
|
| 7 |
+sub fetch_filter : Attr {}
|
|
| 8 |
+sub sth : Attr {}
|
|
| 9 |
+ |
|
| 10 |
+sub no_bind_filters : Attr { type => 'array', trigger => sub {
|
|
| 11 |
+ my $self = shift; |
|
| 12 |
+ my $no_bind_filters = $self->no_bind_filters || []; |
|
| 13 |
+ my %no_bind_filters_map = map {$_ => 1} @{$no_bind_filters};
|
|
| 14 |
+ $self->_no_bind_filters_map(\%no_bind_filters_map); |
|
| 15 |
+}} |
|
| 16 |
+sub _no_bind_filters_map : Attr {default => sub { {} }}
|
|
| 17 |
+ |
|
| 18 |
+sub no_fetch_filters : Attr { type => 'array', default => sub { [] } }
|
|
| 19 |
+ |
|
| 20 |
+Object::Simple->build_class; |
|
| 21 |
+ |
|
| 22 |
+=head1 NAME |
|
| 23 |
+ |
|
| 24 |
+DBIx::Custom::Query - Query object for DBIx::Custom |
|
| 25 |
+ |
|
| 26 |
+=head1 VERSION |
|
| 27 |
+ |
|
| 28 |
+Version 0.0101 |
|
| 29 |
+ |
|
| 30 |
+=head1 SYNOPSIS |
|
| 31 |
+ |
|
| 32 |
+ # Create query |
|
| 33 |
+ my $dbi = DBIx::Custom->new; |
|
| 34 |
+ my $query = $dbi->create_query($template); |
|
| 35 |
+ |
|
| 36 |
+ # Set query attributes |
|
| 37 |
+ $query->bind_filter($dbi->filters->{default_bind_filter});
|
|
| 38 |
+ $query->no_bind_filters('title', 'author');
|
|
| 39 |
+ |
|
| 40 |
+ $query->fetch_filter($dbi->filters->{default_fetch_filter});
|
|
| 41 |
+ $query->no_fetch_filters('title', 'author');
|
|
| 42 |
+ |
|
| 43 |
+ # Execute query |
|
| 44 |
+ $dbi->execute($query, $params); |
|
| 45 |
+ |
|
| 46 |
+=head1 OBJECT ACCESSORS |
|
| 47 |
+ |
|
| 48 |
+=head2 sth |
|
| 49 |
+ |
|
| 50 |
+ # Set and get statement handle |
|
| 51 |
+ $self = $query->sth($sql); |
|
| 52 |
+ $sth = $query->sth; |
|
| 53 |
+ |
|
| 54 |
+=head2 sql |
|
| 55 |
+ |
|
| 56 |
+ # Set and get SQL |
|
| 57 |
+ $self = $query->sql($sql); |
|
| 58 |
+ $sql = $query->sql; |
|
| 59 |
+ |
|
| 60 |
+=head2 bind_filter |
|
| 61 |
+ |
|
| 62 |
+ # Set and get bind filter |
|
| 63 |
+ $self = $query->bind_filter($bind_filter); |
|
| 64 |
+ $bind_filter = $query->bind_filter; |
|
| 65 |
+ |
|
| 66 |
+=head2 no_bind_filters |
|
| 67 |
+ |
|
| 68 |
+ # Set and get keys of no filtering |
|
| 69 |
+ $self = $query->no_bind_filters($no_filters); |
|
| 70 |
+ $no_bind_filters = $query->no_bind_filters; |
|
| 71 |
+ |
|
| 72 |
+=head2 fetch_filter |
|
| 73 |
+ |
|
| 74 |
+ # Set and get fetch filter |
|
| 75 |
+ $self = $query->fetch_filter($fetch_filter); |
|
| 76 |
+ $fetch_filter = $query->fetch_filter; |
|
| 77 |
+ |
|
| 78 |
+=head2 no_fetch_filters |
|
| 79 |
+ |
|
| 80 |
+ # Set and get keys of no filtering |
|
| 81 |
+ $self = $query->no_fetch_filters($no_filters); |
|
| 82 |
+ $no_fetch_filters = $query->no_fetch_filters; |
|
| 83 |
+ |
|
| 84 |
+=head2 key_infos |
|
| 85 |
+ |
|
| 86 |
+ # Set and get key informations |
|
| 87 |
+ $self = $query->key_infos($key_infos); |
|
| 88 |
+ $key_infos = $query->key_infos; |
|
| 89 |
+ |
|
| 90 |
+=head1 AUTHOR |
|
| 91 |
+ |
|
| 92 |
+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >> |
|
| 93 |
+ |
|
| 94 |
+Github L<http://github.com/yuki-kimoto> |
|
| 95 |
+ |
|
| 96 |
+=head1 COPYRIGHT & LICENSE |
|
| 97 |
+ |
|
| 98 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 99 |
+ |
|
| 100 |
+This program is free software; you can redistribute it and/or modify it |
|
| 101 |
+under the same terms as Perl itself. |
| ... | ... |
@@ -0,0 +1,384 @@ |
| 1 |
+package DBIx::Custom::Result; |
|
| 2 |
+use Object::Simple; |
|
| 3 |
+use strict; |
|
| 4 |
+use warnings; |
|
| 5 |
+use Carp 'croak'; |
|
| 6 |
+ |
|
| 7 |
+# Attributes |
|
| 8 |
+sub sth : Attr {}
|
|
| 9 |
+sub fetch_filter : Attr {}
|
|
| 10 |
+sub no_fetch_filters : Attr { type => 'array', trigger => sub {
|
|
| 11 |
+ my $self = shift; |
|
| 12 |
+ my $no_fetch_filters = $self->no_fetch_filters || []; |
|
| 13 |
+ my %no_fetch_filters_map = map {$_ => 1} @{$no_fetch_filters};
|
|
| 14 |
+ $self->_no_fetch_filters_map(\%no_fetch_filters_map); |
|
| 15 |
+}} |
|
| 16 |
+sub _no_fetch_filters_map : Attr {default => sub { {} }}
|
|
| 17 |
+ |
|
| 18 |
+# Fetch (array) |
|
| 19 |
+sub fetch {
|
|
| 20 |
+ my ($self, $type) = @_; |
|
| 21 |
+ my $sth = $self->sth; |
|
| 22 |
+ my $fetch_filter = $self->fetch_filter; |
|
| 23 |
+ |
|
| 24 |
+ # Fetch |
|
| 25 |
+ my $row = $sth->fetchrow_arrayref; |
|
| 26 |
+ |
|
| 27 |
+ # Cannot fetch |
|
| 28 |
+ return unless $row; |
|
| 29 |
+ |
|
| 30 |
+ # Filter |
|
| 31 |
+ if ($fetch_filter) {
|
|
| 32 |
+ my $keys = $sth->{NAME_lc};
|
|
| 33 |
+ my $types = $sth->{TYPE};
|
|
| 34 |
+ for (my $i = 0; $i < @$keys; $i++) {
|
|
| 35 |
+ next if $self->_no_fetch_filters_map->{$keys->[$i]};
|
|
| 36 |
+ $row->[$i]= $fetch_filter->($row->[$i], $keys->[$i], $types->[$i], |
|
| 37 |
+ $sth, $i); |
|
| 38 |
+ } |
|
| 39 |
+ } |
|
| 40 |
+ return wantarray ? @$row : $row; |
|
| 41 |
+} |
|
| 42 |
+ |
|
| 43 |
+# Fetch (hash) |
|
| 44 |
+sub fetch_hash {
|
|
| 45 |
+ my $self = shift; |
|
| 46 |
+ my $sth = $self->sth; |
|
| 47 |
+ my $fetch_filter = $self->fetch_filter; |
|
| 48 |
+ |
|
| 49 |
+ # Fetch |
|
| 50 |
+ my $row = $sth->fetchrow_arrayref; |
|
| 51 |
+ |
|
| 52 |
+ # Cannot fetch |
|
| 53 |
+ return unless $row; |
|
| 54 |
+ |
|
| 55 |
+ # Keys |
|
| 56 |
+ my $keys = $sth->{NAME_lc};
|
|
| 57 |
+ |
|
| 58 |
+ # Filter |
|
| 59 |
+ my $row_hash = {};
|
|
| 60 |
+ if ($fetch_filter) {
|
|
| 61 |
+ my $types = $sth->{TYPE};
|
|
| 62 |
+ for (my $i = 0; $i < @$keys; $i++) {
|
|
| 63 |
+ if ($self->_no_fetch_filters_map->{$keys->[$i]}) {
|
|
| 64 |
+ $row_hash->{$keys->[$i]} = $row->[$i];
|
|
| 65 |
+ } |
|
| 66 |
+ else {
|
|
| 67 |
+ $row_hash->{$keys->[$i]}
|
|
| 68 |
+ = $fetch_filter->($row->[$i], $keys->[$i], |
|
| 69 |
+ $types->[$i], $sth, $i); |
|
| 70 |
+ } |
|
| 71 |
+ } |
|
| 72 |
+ } |
|
| 73 |
+ |
|
| 74 |
+ # No filter |
|
| 75 |
+ else {
|
|
| 76 |
+ for (my $i = 0; $i < @$keys; $i++) {
|
|
| 77 |
+ $row_hash->{$keys->[$i]} = $row->[$i];
|
|
| 78 |
+ } |
|
| 79 |
+ } |
|
| 80 |
+ return wantarray ? %$row_hash : $row_hash; |
|
| 81 |
+} |
|
| 82 |
+ |
|
| 83 |
+# Fetch only first (array) |
|
| 84 |
+sub fetch_first {
|
|
| 85 |
+ my $self = shift; |
|
| 86 |
+ |
|
| 87 |
+ # Fetch |
|
| 88 |
+ my $row = $self->fetch; |
|
| 89 |
+ |
|
| 90 |
+ # Not exist |
|
| 91 |
+ return unless $row; |
|
| 92 |
+ |
|
| 93 |
+ # Finish statement handle |
|
| 94 |
+ $self->finish; |
|
| 95 |
+ |
|
| 96 |
+ return wantarray ? @$row : $row; |
|
| 97 |
+} |
|
| 98 |
+ |
|
| 99 |
+# Fetch only first (hash) |
|
| 100 |
+sub fetch_hash_first {
|
|
| 101 |
+ my $self = shift; |
|
| 102 |
+ |
|
| 103 |
+ # Fetch hash |
|
| 104 |
+ my $row = $self->fetch_hash; |
|
| 105 |
+ |
|
| 106 |
+ # Not exist |
|
| 107 |
+ return unless $row; |
|
| 108 |
+ |
|
| 109 |
+ # Finish statement handle |
|
| 110 |
+ $self->finish; |
|
| 111 |
+ |
|
| 112 |
+ return wantarray ? %$row : $row; |
|
| 113 |
+} |
|
| 114 |
+ |
|
| 115 |
+# Fetch multi rows (array) |
|
| 116 |
+sub fetch_rows {
|
|
| 117 |
+ my ($self, $count) = @_; |
|
| 118 |
+ |
|
| 119 |
+ # Not specified Row count |
|
| 120 |
+ croak("Row count must be specified")
|
|
| 121 |
+ unless $count; |
|
| 122 |
+ |
|
| 123 |
+ # Fetch multi rows |
|
| 124 |
+ my $rows = []; |
|
| 125 |
+ for (my $i = 0; $i < $count; $i++) {
|
|
| 126 |
+ my @row = $self->fetch; |
|
| 127 |
+ |
|
| 128 |
+ last unless @row; |
|
| 129 |
+ |
|
| 130 |
+ push @$rows, \@row; |
|
| 131 |
+ } |
|
| 132 |
+ |
|
| 133 |
+ return unless @$rows; |
|
| 134 |
+ return wantarray ? @$rows : $rows; |
|
| 135 |
+} |
|
| 136 |
+ |
|
| 137 |
+# Fetch multi rows (hash) |
|
| 138 |
+sub fetch_hash_rows {
|
|
| 139 |
+ my ($self, $count) = @_; |
|
| 140 |
+ |
|
| 141 |
+ # Not specified Row count |
|
| 142 |
+ croak("Row count must be specified")
|
|
| 143 |
+ unless $count; |
|
| 144 |
+ |
|
| 145 |
+ # Fetch multi rows |
|
| 146 |
+ my $rows = []; |
|
| 147 |
+ for (my $i = 0; $i < $count; $i++) {
|
|
| 148 |
+ my %row = $self->fetch_hash; |
|
| 149 |
+ |
|
| 150 |
+ last unless %row; |
|
| 151 |
+ |
|
| 152 |
+ push @$rows, \%row; |
|
| 153 |
+ } |
|
| 154 |
+ |
|
| 155 |
+ return unless @$rows; |
|
| 156 |
+ return wantarray ? @$rows : $rows; |
|
| 157 |
+} |
|
| 158 |
+ |
|
| 159 |
+ |
|
| 160 |
+# Fetch all (array) |
|
| 161 |
+sub fetch_all {
|
|
| 162 |
+ my $self = shift; |
|
| 163 |
+ |
|
| 164 |
+ my $rows = []; |
|
| 165 |
+ while(my @row = $self->fetch) {
|
|
| 166 |
+ push @$rows, [@row]; |
|
| 167 |
+ } |
|
| 168 |
+ return wantarray ? @$rows : $rows; |
|
| 169 |
+} |
|
| 170 |
+ |
|
| 171 |
+# Fetch all (hash) |
|
| 172 |
+sub fetch_hash_all {
|
|
| 173 |
+ my $self = shift; |
|
| 174 |
+ |
|
| 175 |
+ my $rows = []; |
|
| 176 |
+ while(my %row = $self->fetch_hash) {
|
|
| 177 |
+ push @$rows, {%row};
|
|
| 178 |
+ } |
|
| 179 |
+ return wantarray ? @$rows : $rows; |
|
| 180 |
+} |
|
| 181 |
+ |
|
| 182 |
+# Finish |
|
| 183 |
+sub finish { shift->sth->finish }
|
|
| 184 |
+ |
|
| 185 |
+# Error |
|
| 186 |
+sub error {
|
|
| 187 |
+ my $self = shift; |
|
| 188 |
+ my $sth = $self->sth; |
|
| 189 |
+ return wantarray ? ($sth->errstr, $sth->err, $sth->state) : $sth->errstr; |
|
| 190 |
+} |
|
| 191 |
+ |
|
| 192 |
+Object::Simple->build_class; |
|
| 193 |
+ |
|
| 194 |
+=head1 NAME |
|
| 195 |
+ |
|
| 196 |
+DBIx::Custom::Result - Resultset for DBIx::Custom |
|
| 197 |
+ |
|
| 198 |
+=head1 VERSION |
|
| 199 |
+ |
|
| 200 |
+Version 0.0301 |
|
| 201 |
+ |
|
| 202 |
+=head1 SYNOPSIS |
|
| 203 |
+ |
|
| 204 |
+ # $result is DBIx::Custom::Result object |
|
| 205 |
+ my $dbi = DBIx::Custom->new; |
|
| 206 |
+ my $result = $dbi->query($sql_template, $param); |
|
| 207 |
+ |
|
| 208 |
+ while (my ($val1, $val2) = $result->fetch) {
|
|
| 209 |
+ # do something |
|
| 210 |
+ } |
|
| 211 |
+ |
|
| 212 |
+=head1 OBJECT ACCESSORS |
|
| 213 |
+ |
|
| 214 |
+=head2 sth |
|
| 215 |
+ |
|
| 216 |
+ # Set and Get statement handle |
|
| 217 |
+ $self = $result->sth($sth); |
|
| 218 |
+ $sth = $reuslt->sth |
|
| 219 |
+ |
|
| 220 |
+Statement handle is automatically set by DBIx::Custom. |
|
| 221 |
+so you do not set statement handle. |
|
| 222 |
+ |
|
| 223 |
+If you need statement handle, you can get statement handle by using this method. |
|
| 224 |
+ |
|
| 225 |
+=head2 fetch_filter |
|
| 226 |
+ |
|
| 227 |
+ # Set and Get fetch filter |
|
| 228 |
+ $self = $result->fetch_filter($sth); |
|
| 229 |
+ $fetch_filter = $result->fech_filter; |
|
| 230 |
+ |
|
| 231 |
+Statement handle is automatically set by DBIx::Custom. |
|
| 232 |
+If you want to set your fetch filter, you set it. |
|
| 233 |
+ |
|
| 234 |
+=head2 no_fetch_filters |
|
| 235 |
+ |
|
| 236 |
+ # Set and Get no filter keys when fetching |
|
| 237 |
+ $self = $result->no_fetch_filters($no_fetch_filters); |
|
| 238 |
+ $no_fetch_filters = $result->no_fetch_filters; |
|
| 239 |
+ |
|
| 240 |
+=head1 METHODS |
|
| 241 |
+ |
|
| 242 |
+=head2 fetch |
|
| 243 |
+ |
|
| 244 |
+ # Fetch row as array reference (Scalar context) |
|
| 245 |
+ $row = $result->fetch; |
|
| 246 |
+ |
|
| 247 |
+ # Fetch row as array (List context) |
|
| 248 |
+ @row = $result->fecth |
|
| 249 |
+ |
|
| 250 |
+ # Sample |
|
| 251 |
+ while (my $row = $result->fetch) {
|
|
| 252 |
+ # do something |
|
| 253 |
+ my $val1 = $row->[0]; |
|
| 254 |
+ my $val2 = $row->[1]; |
|
| 255 |
+ } |
|
| 256 |
+ |
|
| 257 |
+fetch method is fetch resultset and get row as array or array reference. |
|
| 258 |
+ |
|
| 259 |
+=head2 fetch_hash |
|
| 260 |
+ |
|
| 261 |
+ # Fetch row as hash reference (Scalar context) |
|
| 262 |
+ $row = $result->fetch_hash; |
|
| 263 |
+ |
|
| 264 |
+ # Fetch row as hash (List context) |
|
| 265 |
+ %row = $result->fecth_hash |
|
| 266 |
+ |
|
| 267 |
+ # Sample |
|
| 268 |
+ while (my $row = $result->fetch_hash) {
|
|
| 269 |
+ # do something |
|
| 270 |
+ my $val1 = $row->{key1};
|
|
| 271 |
+ my $val2 = $row->{key2};
|
|
| 272 |
+ } |
|
| 273 |
+ |
|
| 274 |
+fetch_hash method is fetch resultset and get row as hash or hash reference. |
|
| 275 |
+ |
|
| 276 |
+=head2 fetch_first |
|
| 277 |
+ |
|
| 278 |
+ # Fetch only first (Scalar context) |
|
| 279 |
+ $row = $result->fetch_first; |
|
| 280 |
+ |
|
| 281 |
+ # Fetch only first (List context) |
|
| 282 |
+ @row = $result->fetch_first; |
|
| 283 |
+ |
|
| 284 |
+This method fetch only first and finish statement handle |
|
| 285 |
+ |
|
| 286 |
+=head2 fetch_hash_first |
|
| 287 |
+ |
|
| 288 |
+ # Fetch only first as hash (Scalar context) |
|
| 289 |
+ $row = $result->fetch_hash_first; |
|
| 290 |
+ |
|
| 291 |
+ # Fetch only first as hash (Scalar context) |
|
| 292 |
+ @row = $result->fetch_hash_first; |
|
| 293 |
+ |
|
| 294 |
+This method fetch only first and finish statement handle |
|
| 295 |
+ |
|
| 296 |
+=head2 fetch_rows |
|
| 297 |
+ |
|
| 298 |
+ # Fetch multi rows (Scalar context) |
|
| 299 |
+ $rows = $result->fetch_rows($row_count); |
|
| 300 |
+ |
|
| 301 |
+ # Fetch multi rows (List context) |
|
| 302 |
+ @rows = $result->fetch_rows($row_count); |
|
| 303 |
+ |
|
| 304 |
+ # Sapmle |
|
| 305 |
+ $rows = $result->fetch_rows(10); |
|
| 306 |
+ |
|
| 307 |
+=head2 fetch_hash_rows |
|
| 308 |
+ |
|
| 309 |
+ # Fetch multi rows as hash (Scalar context) |
|
| 310 |
+ $rows = $result->fetch_hash_rows($row_count); |
|
| 311 |
+ |
|
| 312 |
+ # Fetch multi rows as hash (List context) |
|
| 313 |
+ @rows = $result->fetch_hash_rows($row_count); |
|
| 314 |
+ |
|
| 315 |
+ # Sapmle |
|
| 316 |
+ $rows = $result->fetch_hash_rows(10); |
|
| 317 |
+ |
|
| 318 |
+=head2 fetch_all |
|
| 319 |
+ |
|
| 320 |
+ # Fetch all row as array ref of array ref (Scalar context) |
|
| 321 |
+ $rows = $result->fetch_all; |
|
| 322 |
+ |
|
| 323 |
+ # Fetch all row as array of array ref (List context) |
|
| 324 |
+ @rows = $result->fecth_all; |
|
| 325 |
+ |
|
| 326 |
+ # Sample |
|
| 327 |
+ my $rows = $result->fetch_all; |
|
| 328 |
+ my $val0_0 = $rows->[0][0]; |
|
| 329 |
+ my $val1_1 = $rows->[1][1]; |
|
| 330 |
+ |
|
| 331 |
+fetch_all method is fetch resultset and get all rows as array or array reference. |
|
| 332 |
+ |
|
| 333 |
+=head2 fetch_hash_all |
|
| 334 |
+ |
|
| 335 |
+ # Fetch all row as array ref of hash ref (Scalar context) |
|
| 336 |
+ $rows = $result->fetch_hash_all; |
|
| 337 |
+ |
|
| 338 |
+ # Fetch all row as array of hash ref (List context) |
|
| 339 |
+ @rows = $result->fecth_all_hash; |
|
| 340 |
+ |
|
| 341 |
+ # Sample |
|
| 342 |
+ my $rows = $result->fetch_hash_all; |
|
| 343 |
+ my $val0_key1 = $rows->[0]{key1};
|
|
| 344 |
+ my $val1_key2 = $rows->[1]{key2};
|
|
| 345 |
+ |
|
| 346 |
+=head2 error |
|
| 347 |
+ |
|
| 348 |
+ # Get error infomation |
|
| 349 |
+ $error_messege = $result->error; |
|
| 350 |
+ ($error_message, $error_number, $error_state) = $result->error; |
|
| 351 |
+ |
|
| 352 |
+You can get get information. This is crenspond to the following. |
|
| 353 |
+ |
|
| 354 |
+ $error_message : $result->sth->errstr |
|
| 355 |
+ $error_number : $result->sth->err |
|
| 356 |
+ $error_state : $result->sth->state |
|
| 357 |
+ |
|
| 358 |
+=head2 finish |
|
| 359 |
+ |
|
| 360 |
+ # Finish statement handle |
|
| 361 |
+ $result->finish |
|
| 362 |
+ |
|
| 363 |
+ # Sample |
|
| 364 |
+ my $row = $reuslt->fetch; # fetch only one row |
|
| 365 |
+ $result->finish |
|
| 366 |
+ |
|
| 367 |
+You can finish statement handle.This is equel to |
|
| 368 |
+ |
|
| 369 |
+ $result->sth->finish; |
|
| 370 |
+ |
|
| 371 |
+=head1 AUTHOR |
|
| 372 |
+ |
|
| 373 |
+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >> |
|
| 374 |
+ |
|
| 375 |
+Github L<http://github.com/yuki-kimoto> |
|
| 376 |
+ |
|
| 377 |
+=head1 COPYRIGHT & LICENSE |
|
| 378 |
+ |
|
| 379 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 380 |
+ |
|
| 381 |
+This program is free software; you can redistribute it and/or modify it |
|
| 382 |
+under the same terms as Perl itself. |
|
| 383 |
+ |
|
| 384 |
+=cut |
| ... | ... |
@@ -0,0 +1,694 @@ |
| 1 |
+package DBIx::Custom::SQL::Template; |
|
| 2 |
+use Object::Simple; |
|
| 3 |
+ |
|
| 4 |
+use Carp 'croak'; |
|
| 5 |
+ |
|
| 6 |
+# Accessor is created by Object::Simple. Please read Object::Simple document |
|
| 7 |
+ |
|
| 8 |
+### Class-Object accessors |
|
| 9 |
+ |
|
| 10 |
+# Tag start |
|
| 11 |
+sub tag_start : ClassObjectAttr {
|
|
| 12 |
+ initialize => {default => '{', clone => 'scalar'}
|
|
| 13 |
+} |
|
| 14 |
+ |
|
| 15 |
+# Tag end |
|
| 16 |
+sub tag_end : ClassObjectAttr {
|
|
| 17 |
+ initialize => {default => '}', clone => 'scalar'}
|
|
| 18 |
+} |
|
| 19 |
+ |
|
| 20 |
+# Tag syntax |
|
| 21 |
+sub tag_syntax : ClassObjectAttr {
|
|
| 22 |
+ initialize => {default => <<'EOS', clone => 'scalar'}}
|
|
| 23 |
+[tag] [expand] |
|
| 24 |
+{? name} ?
|
|
| 25 |
+{= name} name = ?
|
|
| 26 |
+{<> name} name <> ?
|
|
| 27 |
+ |
|
| 28 |
+{< name} name < ?
|
|
| 29 |
+{> name} name > ?
|
|
| 30 |
+{>= name} name >= ?
|
|
| 31 |
+{<= name} name <= ?
|
|
| 32 |
+ |
|
| 33 |
+{like name} name like ?
|
|
| 34 |
+{in name number} name in [?, ?, ..]
|
|
| 35 |
+ |
|
| 36 |
+{insert key1 key2} (key1, key2) values (?, ?)
|
|
| 37 |
+{update key1 key2} set key1 = ?, key2 = ?
|
|
| 38 |
+EOS |
|
| 39 |
+ |
|
| 40 |
+# Tag processors |
|
| 41 |
+sub tag_processors : ClassObjectAttr {
|
|
| 42 |
+ type => 'hash', |
|
| 43 |
+ deref => 1, |
|
| 44 |
+ initialize => {
|
|
| 45 |
+ clone => 'hash', |
|
| 46 |
+ default => sub {{
|
|
| 47 |
+ '?' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_basic_tag, |
|
| 48 |
+ '=' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_basic_tag, |
|
| 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 |
+ 'like' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_basic_tag, |
|
| 55 |
+ 'in' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_in_tag, |
|
| 56 |
+ 'insert' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_insert_tag, |
|
| 57 |
+ 'update' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_update_tag |
|
| 58 |
+ }} |
|
| 59 |
+ } |
|
| 60 |
+} |
|
| 61 |
+ |
|
| 62 |
+# Add Tag processor |
|
| 63 |
+sub add_tag_processor {
|
|
| 64 |
+ my $invocant = shift; |
|
| 65 |
+ my $tag_processors = ref $_[0] eq 'HASH' ? $_[0] : {@_};
|
|
| 66 |
+ $invocant->tag_processors(%{$invocant->tag_processors}, %{$tag_processors});
|
|
| 67 |
+ return $invocant; |
|
| 68 |
+} |
|
| 69 |
+ |
|
| 70 |
+# Clone |
|
| 71 |
+sub clone {
|
|
| 72 |
+ my $self = shift; |
|
| 73 |
+ my $new = $self->new; |
|
| 74 |
+ |
|
| 75 |
+ $new->tag_start($self->tag_start); |
|
| 76 |
+ $new->tag_end($self->tag_end); |
|
| 77 |
+ $new->tag_syntax($self->tag_syntax); |
|
| 78 |
+ $new->tag_processors({%{$self->tag_processors || {}}});
|
|
| 79 |
+ |
|
| 80 |
+ return $new; |
|
| 81 |
+} |
|
| 82 |
+ |
|
| 83 |
+ |
|
| 84 |
+### Object Methods |
|
| 85 |
+ |
|
| 86 |
+# Create Query |
|
| 87 |
+sub create_query {
|
|
| 88 |
+ my ($self, $template) = @_; |
|
| 89 |
+ |
|
| 90 |
+ # Parse template |
|
| 91 |
+ my $tree = $self->_parse_template($template); |
|
| 92 |
+ |
|
| 93 |
+ # Build query |
|
| 94 |
+ my $query = $self->_build_query($tree); |
|
| 95 |
+ |
|
| 96 |
+ return $query; |
|
| 97 |
+} |
|
| 98 |
+ |
|
| 99 |
+# Parse template |
|
| 100 |
+sub _parse_template {
|
|
| 101 |
+ my ($self, $template) = @_; |
|
| 102 |
+ $template ||= ''; |
|
| 103 |
+ |
|
| 104 |
+ my $tree = []; |
|
| 105 |
+ |
|
| 106 |
+ # Tags |
|
| 107 |
+ my $tag_start = quotemeta $self->tag_start; |
|
| 108 |
+ my $tag_end = quotemeta $self->tag_end; |
|
| 109 |
+ |
|
| 110 |
+ # Tokenize |
|
| 111 |
+ my $state = 'text'; |
|
| 112 |
+ |
|
| 113 |
+ # Save original template |
|
| 114 |
+ my $original_template = $template; |
|
| 115 |
+ |
|
| 116 |
+ # Parse template |
|
| 117 |
+ while ($template =~ s/([^$tag_start]*?)$tag_start([^$tag_end].*?)$tag_end//sm) {
|
|
| 118 |
+ my $text = $1; |
|
| 119 |
+ my $tag = $2; |
|
| 120 |
+ |
|
| 121 |
+ # Parse tree |
|
| 122 |
+ push @$tree, {type => 'text', tag_args => [$text]} if $text;
|
|
| 123 |
+ |
|
| 124 |
+ if ($tag) {
|
|
| 125 |
+ # Get tag name and arguments |
|
| 126 |
+ my ($tag_name, @tag_args) = split /\s+/, $tag; |
|
| 127 |
+ |
|
| 128 |
+ # Tag processor is exist? |
|
| 129 |
+ unless ($self->tag_processors->{$tag_name}) {
|
|
| 130 |
+ my $tag_syntax = $self->tag_syntax; |
|
| 131 |
+ croak("Tag '{$tag}' in SQL template is not exist.\n\n" .
|
|
| 132 |
+ "<SQL template tag syntax>\n" . |
|
| 133 |
+ "$tag_syntax\n" . |
|
| 134 |
+ "<Your SQL template>\n" . |
|
| 135 |
+ "$original_template\n\n"); |
|
| 136 |
+ } |
|
| 137 |
+ |
|
| 138 |
+ # Check tag arguments |
|
| 139 |
+ foreach my $tag_arg (@tag_args) {
|
|
| 140 |
+ # Cannot cantain placehosder '?' |
|
| 141 |
+ croak("Tag '{t }' arguments cannot contain '?'")
|
|
| 142 |
+ if $tag_arg =~ /\?/; |
|
| 143 |
+ } |
|
| 144 |
+ |
|
| 145 |
+ # Add tag to parsing tree |
|
| 146 |
+ push @$tree, {type => 'tag', tag_name => $tag_name, tag_args => [@tag_args]};
|
|
| 147 |
+ } |
|
| 148 |
+ } |
|
| 149 |
+ |
|
| 150 |
+ # Add text to parsing tree |
|
| 151 |
+ push @$tree, {type => 'text', tag_args => [$template]} if $template;
|
|
| 152 |
+ |
|
| 153 |
+ return $tree; |
|
| 154 |
+} |
|
| 155 |
+ |
|
| 156 |
+# Build SQL from parsing tree |
|
| 157 |
+sub _build_query {
|
|
| 158 |
+ my ($self, $tree) = @_; |
|
| 159 |
+ |
|
| 160 |
+ # SQL |
|
| 161 |
+ my $sql = ''; |
|
| 162 |
+ |
|
| 163 |
+ # All parameter key infomation |
|
| 164 |
+ my $all_key_infos = []; |
|
| 165 |
+ |
|
| 166 |
+ # Build SQL |
|
| 167 |
+ foreach my $node (@$tree) {
|
|
| 168 |
+ |
|
| 169 |
+ # Get type, tag name, and arguments |
|
| 170 |
+ my $type = $node->{type};
|
|
| 171 |
+ my $tag_name = $node->{tag_name};
|
|
| 172 |
+ my $tag_args = $node->{tag_args};
|
|
| 173 |
+ |
|
| 174 |
+ # Text |
|
| 175 |
+ if ($type eq 'text') {
|
|
| 176 |
+ # Join text |
|
| 177 |
+ $sql .= $tag_args->[0]; |
|
| 178 |
+ } |
|
| 179 |
+ |
|
| 180 |
+ # Tag |
|
| 181 |
+ elsif ($type eq 'tag') {
|
|
| 182 |
+ |
|
| 183 |
+ # Get tag processor |
|
| 184 |
+ my $tag_processor = $self->tag_processors->{$tag_name};
|
|
| 185 |
+ |
|
| 186 |
+ # Tag processor is code ref? |
|
| 187 |
+ croak("Tag processor '$tag_name' must be code reference")
|
|
| 188 |
+ unless ref $tag_processor eq 'CODE'; |
|
| 189 |
+ |
|
| 190 |
+ # Expand tag using tag processor |
|
| 191 |
+ my ($expand, $key_infos) |
|
| 192 |
+ = $tag_processor->($tag_name, $tag_args); |
|
| 193 |
+ |
|
| 194 |
+ # Check tag processor return value |
|
| 195 |
+ croak("Tag processor '$tag_name' must return (\$expand, \$key_infos)")
|
|
| 196 |
+ if !defined $expand || ref $key_infos ne 'ARRAY'; |
|
| 197 |
+ |
|
| 198 |
+ # Check placeholder count |
|
| 199 |
+ croak("Placeholder count in SQL created by tag processor '$tag_name' " .
|
|
| 200 |
+ "must be same as key informations count") |
|
| 201 |
+ unless $self->_placeholder_count($expand) eq @$key_infos; |
|
| 202 |
+ |
|
| 203 |
+ # Add key information |
|
| 204 |
+ push @$all_key_infos, @$key_infos; |
|
| 205 |
+ |
|
| 206 |
+ # Join expand tag to SQL |
|
| 207 |
+ $sql .= $expand; |
|
| 208 |
+ } |
|
| 209 |
+ } |
|
| 210 |
+ |
|
| 211 |
+ # Add semicolon |
|
| 212 |
+ $sql .= ';' unless $sql =~ /;$/; |
|
| 213 |
+ |
|
| 214 |
+ # Query |
|
| 215 |
+ my $query = {sql => $sql, key_infos => $all_key_infos};
|
|
| 216 |
+ |
|
| 217 |
+ return $query; |
|
| 218 |
+} |
|
| 219 |
+ |
|
| 220 |
+# Get placeholder count |
|
| 221 |
+sub _placeholder_count {
|
|
| 222 |
+ my ($self, $expand) = @_; |
|
| 223 |
+ $expand ||= ''; |
|
| 224 |
+ |
|
| 225 |
+ my $count = 0; |
|
| 226 |
+ my $pos = -1; |
|
| 227 |
+ while (($pos = index($expand, '?', $pos + 1)) != -1) {
|
|
| 228 |
+ $count++; |
|
| 229 |
+ } |
|
| 230 |
+ return $count; |
|
| 231 |
+} |
|
| 232 |
+ |
|
| 233 |
+Object::Simple->build_class; |
|
| 234 |
+ |
|
| 235 |
+ |
|
| 236 |
+package DBIx::Custom::SQL::Template::TagProcessor; |
|
| 237 |
+use strict; |
|
| 238 |
+use warnings; |
|
| 239 |
+use Carp 'croak'; |
|
| 240 |
+ |
|
| 241 |
+# Expand tag '?', '=', '<>', '>', '<', '>=', '<=', 'like' |
|
| 242 |
+sub expand_basic_tag {
|
|
| 243 |
+ my ($tag_name, $tag_args) = @_; |
|
| 244 |
+ my $original_key = $tag_args->[0]; |
|
| 245 |
+ |
|
| 246 |
+ # Key is not exist |
|
| 247 |
+ croak("You must be pass key as argument to tag '{$tag_name }'")
|
|
| 248 |
+ if !$original_key; |
|
| 249 |
+ |
|
| 250 |
+ # Expanded tag |
|
| 251 |
+ my $expand = $tag_name eq '?' |
|
| 252 |
+ ? '?' |
|
| 253 |
+ : "$original_key $tag_name ?"; |
|
| 254 |
+ |
|
| 255 |
+ # Get table and clumn name |
|
| 256 |
+ my ($table, $column) = get_table_and_column($original_key); |
|
| 257 |
+ |
|
| 258 |
+ # Parameter key infomation |
|
| 259 |
+ my $key_info = {};
|
|
| 260 |
+ |
|
| 261 |
+ # Original key |
|
| 262 |
+ $key_info->{original_key} = $original_key;
|
|
| 263 |
+ |
|
| 264 |
+ # Table |
|
| 265 |
+ $key_info->{table} = $table;
|
|
| 266 |
+ |
|
| 267 |
+ # Column name |
|
| 268 |
+ $key_info->{column} = $column;
|
|
| 269 |
+ |
|
| 270 |
+ # Access keys |
|
| 271 |
+ my $access_keys = []; |
|
| 272 |
+ push @$access_keys, [$original_key]; |
|
| 273 |
+ push @$access_keys, [$table, $column] if $table && $column; |
|
| 274 |
+ $key_info->{access_keys} = $access_keys;
|
|
| 275 |
+ |
|
| 276 |
+ # Add parameter key information |
|
| 277 |
+ my $key_infos = []; |
|
| 278 |
+ push @$key_infos, $key_info; |
|
| 279 |
+ |
|
| 280 |
+ return ($expand, $key_infos); |
|
| 281 |
+} |
|
| 282 |
+ |
|
| 283 |
+# Expand tag 'in' |
|
| 284 |
+sub expand_in_tag {
|
|
| 285 |
+ my ($tag_name, $tag_args) = @_; |
|
| 286 |
+ my ($original_key, $placeholder_count) = @$tag_args; |
|
| 287 |
+ |
|
| 288 |
+ # Key must be specified |
|
| 289 |
+ croak("You must be pass key as first argument of tag '{$tag_name }'\n" .
|
|
| 290 |
+ "Usage: {$tag_name \$key \$placeholder_count}")
|
|
| 291 |
+ unless $original_key; |
|
| 292 |
+ |
|
| 293 |
+ |
|
| 294 |
+ # Place holder count must be specified |
|
| 295 |
+ croak("You must be pass placeholder count as second argument of tag '{$tag_name }'\n" .
|
|
| 296 |
+ "Usage: {$tag_name \$key \$placeholder_count}")
|
|
| 297 |
+ if !$placeholder_count || $placeholder_count =~ /\D/; |
|
| 298 |
+ |
|
| 299 |
+ # Expand tag |
|
| 300 |
+ my $expand = "$original_key $tag_name (";
|
|
| 301 |
+ for (my $i = 0; $i < $placeholder_count; $i++) {
|
|
| 302 |
+ $expand .= '?, '; |
|
| 303 |
+ } |
|
| 304 |
+ |
|
| 305 |
+ $expand =~ s/, $//; |
|
| 306 |
+ $expand .= ')'; |
|
| 307 |
+ |
|
| 308 |
+ # Get table and clumn name |
|
| 309 |
+ my ($table, $column) = get_table_and_column($original_key); |
|
| 310 |
+ |
|
| 311 |
+ # Create parameter key infomations |
|
| 312 |
+ my $key_infos = []; |
|
| 313 |
+ for (my $i = 0; $i < $placeholder_count; $i++) {
|
|
| 314 |
+ # Parameter key infomation |
|
| 315 |
+ my $key_info = {};
|
|
| 316 |
+ |
|
| 317 |
+ # Original key |
|
| 318 |
+ $key_info->{original_key} = $original_key;
|
|
| 319 |
+ |
|
| 320 |
+ # Table |
|
| 321 |
+ $key_info->{table} = $table;
|
|
| 322 |
+ |
|
| 323 |
+ # Column name |
|
| 324 |
+ $key_info->{column} = $column;
|
|
| 325 |
+ |
|
| 326 |
+ # Access keys |
|
| 327 |
+ my $access_keys = []; |
|
| 328 |
+ push @$access_keys, [$original_key, [$i]]; |
|
| 329 |
+ push @$access_keys, [$table, $column, [$i]] if $table && $column; |
|
| 330 |
+ $key_info->{access_keys} = $access_keys;
|
|
| 331 |
+ |
|
| 332 |
+ # Add parameter key infos |
|
| 333 |
+ push @$key_infos, $key_info; |
|
| 334 |
+ } |
|
| 335 |
+ |
|
| 336 |
+ return ($expand, $key_infos); |
|
| 337 |
+} |
|
| 338 |
+ |
|
| 339 |
+# Get table and column |
|
| 340 |
+sub get_table_and_column {
|
|
| 341 |
+ my $key = shift; |
|
| 342 |
+ $key ||= ''; |
|
| 343 |
+ |
|
| 344 |
+ return ('', $key) unless $key =~ /\./;
|
|
| 345 |
+ |
|
| 346 |
+ my ($table, $column) = split /\./, $key; |
|
| 347 |
+ |
|
| 348 |
+ return ($table, $column); |
|
| 349 |
+} |
|
| 350 |
+ |
|
| 351 |
+# Expand tag 'insert' |
|
| 352 |
+sub expand_insert_tag {
|
|
| 353 |
+ my ($tag_name, $tag_args) = @_; |
|
| 354 |
+ my $original_keys = $tag_args; |
|
| 355 |
+ |
|
| 356 |
+ # Insert key (k1, k2, k3, ..) |
|
| 357 |
+ my $insert_keys = '(';
|
|
| 358 |
+ |
|
| 359 |
+ # placeholder (?, ?, ?, ..) |
|
| 360 |
+ my $place_holders = '(';
|
|
| 361 |
+ |
|
| 362 |
+ foreach my $original_key (@$original_keys) {
|
|
| 363 |
+ # Get table and column |
|
| 364 |
+ my ($table, $column) = get_table_and_column($original_key); |
|
| 365 |
+ |
|
| 366 |
+ # Join insert column |
|
| 367 |
+ $insert_keys .= "$column, "; |
|
| 368 |
+ |
|
| 369 |
+ # Join place holder |
|
| 370 |
+ $place_holders .= "?, "; |
|
| 371 |
+ } |
|
| 372 |
+ |
|
| 373 |
+ # Delete last ', ' |
|
| 374 |
+ $insert_keys =~ s/, $//; |
|
| 375 |
+ |
|
| 376 |
+ # Close |
|
| 377 |
+ $insert_keys .= ')'; |
|
| 378 |
+ $place_holders =~ s/, $//; |
|
| 379 |
+ $place_holders .= ')'; |
|
| 380 |
+ |
|
| 381 |
+ # Expand tag |
|
| 382 |
+ my $expand = "$insert_keys values $place_holders"; |
|
| 383 |
+ |
|
| 384 |
+ # Create parameter key infomations |
|
| 385 |
+ my $key_infos = []; |
|
| 386 |
+ foreach my $original_key (@$original_keys) {
|
|
| 387 |
+ # Get table and clumn name |
|
| 388 |
+ my ($table, $column) = get_table_and_column($original_key); |
|
| 389 |
+ |
|
| 390 |
+ # Parameter key infomation |
|
| 391 |
+ my $key_info = {};
|
|
| 392 |
+ |
|
| 393 |
+ # Original key |
|
| 394 |
+ $key_info->{original_key} = $original_key;
|
|
| 395 |
+ |
|
| 396 |
+ # Table |
|
| 397 |
+ $key_info->{table} = $table;
|
|
| 398 |
+ |
|
| 399 |
+ # Column name |
|
| 400 |
+ $key_info->{column} = $column;
|
|
| 401 |
+ |
|
| 402 |
+ # Access keys |
|
| 403 |
+ my $access_keys = []; |
|
| 404 |
+ push @$access_keys, ['#insert', $original_key]; |
|
| 405 |
+ push @$access_keys, ['#insert', $table, $column] if $table && $column; |
|
| 406 |
+ push @$access_keys, [$original_key]; |
|
| 407 |
+ push @$access_keys, [$table, $column] if $table && $column; |
|
| 408 |
+ $key_info->{access_keys} = $access_keys;
|
|
| 409 |
+ |
|
| 410 |
+ # Add parameter key infos |
|
| 411 |
+ push @$key_infos, $key_info; |
|
| 412 |
+ } |
|
| 413 |
+ |
|
| 414 |
+ return ($expand, $key_infos); |
|
| 415 |
+} |
|
| 416 |
+ |
|
| 417 |
+# Expand tag 'update' |
|
| 418 |
+sub expand_update_tag {
|
|
| 419 |
+ my ($tag_name, $tag_args) = @_; |
|
| 420 |
+ my $original_keys = $tag_args; |
|
| 421 |
+ |
|
| 422 |
+ # Expanded tag |
|
| 423 |
+ my $expand = 'set '; |
|
| 424 |
+ |
|
| 425 |
+ # |
|
| 426 |
+ foreach my $original_key (@$original_keys) {
|
|
| 427 |
+ # Get table and clumn name |
|
| 428 |
+ my ($table, $column) = get_table_and_column($original_key); |
|
| 429 |
+ |
|
| 430 |
+ # Join key and placeholder |
|
| 431 |
+ $expand .= "$column = ?, "; |
|
| 432 |
+ } |
|
| 433 |
+ |
|
| 434 |
+ # Delete last ', ' |
|
| 435 |
+ $expand =~ s/, $//; |
|
| 436 |
+ |
|
| 437 |
+ # Create parameter key infomations |
|
| 438 |
+ my $key_infos = []; |
|
| 439 |
+ foreach my $original_key (@$original_keys) {
|
|
| 440 |
+ # Get table and clumn name |
|
| 441 |
+ my ($table, $column) = get_table_and_column($original_key); |
|
| 442 |
+ |
|
| 443 |
+ # Parameter key infomation |
|
| 444 |
+ my $key_info = {};
|
|
| 445 |
+ |
|
| 446 |
+ # Original key |
|
| 447 |
+ $key_info->{original_key} = $original_key;
|
|
| 448 |
+ |
|
| 449 |
+ # Table |
|
| 450 |
+ $key_info->{table} = $table;
|
|
| 451 |
+ |
|
| 452 |
+ # Column name |
|
| 453 |
+ $key_info->{column} = $column;
|
|
| 454 |
+ |
|
| 455 |
+ # Access keys |
|
| 456 |
+ my $access_keys = []; |
|
| 457 |
+ push @$access_keys, ['#update', $original_key]; |
|
| 458 |
+ push @$access_keys, ['#update', $table, $column] if $table && $column; |
|
| 459 |
+ push @$access_keys, [$original_key]; |
|
| 460 |
+ push @$access_keys, [$table, $column] if $table && $column; |
|
| 461 |
+ $key_info->{access_keys} = $access_keys;
|
|
| 462 |
+ |
|
| 463 |
+ # Add parameter key infos |
|
| 464 |
+ push @$key_infos, $key_info; |
|
| 465 |
+ } |
|
| 466 |
+ |
|
| 467 |
+ return ($expand, $key_infos); |
|
| 468 |
+} |
|
| 469 |
+ |
|
| 470 |
+1; |
|
| 471 |
+ |
|
| 472 |
+=head1 NAME |
|
| 473 |
+ |
|
| 474 |
+DBIx::Custom::SQL::Template - Custamizable SQL Template for DBIx::Custom |
|
| 475 |
+ |
|
| 476 |
+=head1 VERSION |
|
| 477 |
+ |
|
| 478 |
+Version 0.0101 |
|
| 479 |
+ |
|
| 480 |
+=cut |
|
| 481 |
+ |
|
| 482 |
+=head1 SYNOPSIS |
|
| 483 |
+ |
|
| 484 |
+ my $sql_tmpl = DBIx::Custom::SQL::Template->new; |
|
| 485 |
+ |
|
| 486 |
+ my $tmpl = "select from table {= k1} && {<> k2} || {like k3}";
|
|
| 487 |
+ my $param = {k1 => 1, k2 => 2, k3 => 3};
|
|
| 488 |
+ |
|
| 489 |
+ my $query = $sql_template->create_query($tmpl); |
|
| 490 |
+ |
|
| 491 |
+ |
|
| 492 |
+ # Using query from DBIx::Custom |
|
| 493 |
+ use DBIx::Custom; |
|
| 494 |
+ my $dbi = DBI->new( |
|
| 495 |
+ data_source => $data_source, |
|
| 496 |
+ user => $user, |
|
| 497 |
+ password => $password, |
|
| 498 |
+ dbi_options => {PrintError => 0, RaiseError => 1}
|
|
| 499 |
+ ); |
|
| 500 |
+ |
|
| 501 |
+ $query = $dbi->create_query($tmpl); # This is SQL::Template create_query |
|
| 502 |
+ $dbi->query($query, $param); |
|
| 503 |
+ |
|
| 504 |
+=head1 CLASS-OBJECT ACCESSORS |
|
| 505 |
+ |
|
| 506 |
+Class-Object accessor is used from both object and class |
|
| 507 |
+ |
|
| 508 |
+ $class->$accessor # call from class |
|
| 509 |
+ $self->$accessor # call form object |
|
| 510 |
+ |
|
| 511 |
+=head2 tag_processors |
|
| 512 |
+ |
|
| 513 |
+ # Set and get |
|
| 514 |
+ $self = $sql_tmpl->tag_processors($tag_processors); |
|
| 515 |
+ $tag_processors = $sql_tmpl->tag_processors; |
|
| 516 |
+ |
|
| 517 |
+ # Sample |
|
| 518 |
+ $sql_tmpl->tag_processors( |
|
| 519 |
+ '?' => \&expand_question, |
|
| 520 |
+ '=' => \&expand_equel |
|
| 521 |
+ ); |
|
| 522 |
+ |
|
| 523 |
+You can use add_tag_processor to add tag processor |
|
| 524 |
+ |
|
| 525 |
+=head2 tag_start |
|
| 526 |
+ |
|
| 527 |
+ # Set and get |
|
| 528 |
+ $self = $sql_tmpl->tag_start($tag_start); |
|
| 529 |
+ $tag_start = $sql_tmpl->tag_start; |
|
| 530 |
+ |
|
| 531 |
+ # Sample |
|
| 532 |
+ $sql_tmpl->tag_start('{');
|
|
| 533 |
+ |
|
| 534 |
+Default is '{'
|
|
| 535 |
+ |
|
| 536 |
+=head2 tag_end |
|
| 537 |
+ |
|
| 538 |
+ # Set and get |
|
| 539 |
+ $self = $sql_tmpl->tag_start($tag_end); |
|
| 540 |
+ $tag_end = $sql_tmpl->tag_start; |
|
| 541 |
+ |
|
| 542 |
+ # Sample |
|
| 543 |
+ $sql_tmpl->tag_start('}');
|
|
| 544 |
+ |
|
| 545 |
+Default is '}' |
|
| 546 |
+ |
|
| 547 |
+=head2 tag_syntax |
|
| 548 |
+ |
|
| 549 |
+ # Set and get |
|
| 550 |
+ $self = $sql_tmpl->tag_syntax($tag_syntax); |
|
| 551 |
+ $tag_syntax = $sql_tmpl->tag_syntax; |
|
| 552 |
+ |
|
| 553 |
+ # Sample |
|
| 554 |
+ $sql_tmpl->tag_syntax( |
|
| 555 |
+ "[Tag] [Expand]\n" . |
|
| 556 |
+ "{? name} ?\n" .
|
|
| 557 |
+ "{= name} name = ?\n" .
|
|
| 558 |
+ "{<> name} name <> ?\n"
|
|
| 559 |
+ ); |
|
| 560 |
+ |
|
| 561 |
+=head1 METHODS |
|
| 562 |
+ |
|
| 563 |
+=head2 create_query |
|
| 564 |
+ |
|
| 565 |
+ # Create SQL form SQL template |
|
| 566 |
+ $query = $sql_tmpl->create_query($tmpl); |
|
| 567 |
+ |
|
| 568 |
+ # Sample |
|
| 569 |
+ $query = $sql_tmpl->create_sql( |
|
| 570 |
+ "select * from table where {= title} && {like author} || {<= price}")
|
|
| 571 |
+ |
|
| 572 |
+ # Result |
|
| 573 |
+ $qeury->{sql} : "select * from table where title = ? && author like ? price <= ?;"
|
|
| 574 |
+ $query->{key_infos} : [['title'], ['author'], ['price']]
|
|
| 575 |
+ |
|
| 576 |
+ # Sample2 (with table name) |
|
| 577 |
+ ($sql, @bind_values) = $sql_tmpl->create_sql( |
|
| 578 |
+ "select * from table where {= table.title} && {like table.author}",
|
|
| 579 |
+ {table => {title => 'Perl', author => '%Taro%'}}
|
|
| 580 |
+ ) |
|
| 581 |
+ |
|
| 582 |
+ # Result2 |
|
| 583 |
+ $query->{sql} : "select * from table where table.title = ? && table.title like ?;"
|
|
| 584 |
+ $query->{key_infos} :[ [['table.title'],['table', 'title']],
|
|
| 585 |
+ [['table.author'],['table', 'author']] ] |
|
| 586 |
+ |
|
| 587 |
+This method create query using by DBIx::Custom. |
|
| 588 |
+query is two infomation |
|
| 589 |
+ |
|
| 590 |
+ 1.sql : SQL |
|
| 591 |
+ 2.key_infos : Parameter access key information |
|
| 592 |
+ |
|
| 593 |
+=head2 add_tag_processor |
|
| 594 |
+ |
|
| 595 |
+Add tag processor |
|
| 596 |
+ |
|
| 597 |
+ # Add |
|
| 598 |
+ $self = $sql_tmpl->add_tag_processor($tag_processor); |
|
| 599 |
+ |
|
| 600 |
+ # Sample |
|
| 601 |
+ $sql_tmpl->add_tag_processor( |
|
| 602 |
+ '?' => sub {
|
|
| 603 |
+ my ($tag_name, $tag_args) = @_; |
|
| 604 |
+ |
|
| 605 |
+ my $key1 = $tag_args->[0]; |
|
| 606 |
+ my $key2 = $tag_args->[1]; |
|
| 607 |
+ |
|
| 608 |
+ my $key_infos = []; |
|
| 609 |
+ |
|
| 610 |
+ # Expand tag and create key informations |
|
| 611 |
+ |
|
| 612 |
+ # Return expand tags and key informations |
|
| 613 |
+ return ($expand, $key_infos); |
|
| 614 |
+ } |
|
| 615 |
+ ); |
|
| 616 |
+ |
|
| 617 |
+Tag processor recieve 2 argument |
|
| 618 |
+ |
|
| 619 |
+ 1. Tag name (?, =, <>, or etc) |
|
| 620 |
+ 2. Tag arguments (arg1 and arg2 in {tag_name arg1 arg2})
|
|
| 621 |
+ |
|
| 622 |
+Tag processor return 2 value |
|
| 623 |
+ |
|
| 624 |
+ 1. Expanded Tag (For exsample, '{= title}' is expanded to 'title = ?')
|
|
| 625 |
+ 2. Key infomations |
|
| 626 |
+ |
|
| 627 |
+You must be return expanded tag and key infomations. |
|
| 628 |
+ |
|
| 629 |
+Key information is a little complex. so I will explan this in future. |
|
| 630 |
+ |
|
| 631 |
+If you want to know more, Please see DBIx::Custom::SQL::Template source code. |
|
| 632 |
+ |
|
| 633 |
+=head2 clone |
|
| 634 |
+ |
|
| 635 |
+ # Clone DBIx::Custom::SQL::Template object |
|
| 636 |
+ $clone = $self->clone; |
|
| 637 |
+ |
|
| 638 |
+=head1 Available Tags |
|
| 639 |
+ |
|
| 640 |
+ # Available Tags |
|
| 641 |
+ [tag] [expand] |
|
| 642 |
+ {? name} ?
|
|
| 643 |
+ {= name} name = ?
|
|
| 644 |
+ {<> name} name <> ?
|
|
| 645 |
+ |
|
| 646 |
+ {< name} name < ?
|
|
| 647 |
+ {> name} name > ?
|
|
| 648 |
+ {>= name} name >= ?
|
|
| 649 |
+ {<= name} name <= ?
|
|
| 650 |
+ |
|
| 651 |
+ {like name} name like ?
|
|
| 652 |
+ {in name} name in [?, ?, ..]
|
|
| 653 |
+ |
|
| 654 |
+ {insert} (key1, key2, key3) values (?, ?, ?)
|
|
| 655 |
+ {update} set key1 = ?, key2 = ?, key3 = ?
|
|
| 656 |
+ |
|
| 657 |
+ # Sample1 |
|
| 658 |
+ $query = $sql_tmpl->create_sql( |
|
| 659 |
+ "insert into table {insert key1 key2}"
|
|
| 660 |
+ ); |
|
| 661 |
+ # Result1 |
|
| 662 |
+ $sql : "insert into table (key1, key2) values (?, ?)" |
|
| 663 |
+ |
|
| 664 |
+ |
|
| 665 |
+ # Sample2 |
|
| 666 |
+ $query = $sql_tmpl->create_sql( |
|
| 667 |
+ "update table {update key1 key2} where {= key3}"
|
|
| 668 |
+ ); |
|
| 669 |
+ |
|
| 670 |
+ # Result2 |
|
| 671 |
+ $query->{sql} : "update table set key1 = ?, key2 = ? where key3 = ?;"
|
|
| 672 |
+ |
|
| 673 |
+=head1 AUTHOR |
|
| 674 |
+ |
|
| 675 |
+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >> |
|
| 676 |
+ |
|
| 677 |
+Github |
|
| 678 |
+L<http://github.com/yuki-kimoto> |
|
| 679 |
+L<http://github.com/yuki-kimoto/DBIx-Custom-SQL-Template> |
|
| 680 |
+ |
|
| 681 |
+Please let know me bag if you find |
|
| 682 |
+Please request me if you want to do something |
|
| 683 |
+ |
|
| 684 |
+=head1 COPYRIGHT & LICENSE |
|
| 685 |
+ |
|
| 686 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 687 |
+ |
|
| 688 |
+This program is free software; you can redistribute it and/or modify it |
|
| 689 |
+under the same terms as Perl itself. |
|
| 690 |
+ |
|
| 691 |
+ |
|
| 692 |
+=cut |
|
| 693 |
+ |
|
| 694 |
+1; # End of DBIx::Custom::SQL::Template |
| ... | ... |
@@ -0,0 +1,136 @@ |
| 1 |
+package DBIx::Custom::SQLite; |
|
| 2 |
+use base 'DBIx::Custom::Basic'; |
|
| 3 |
+ |
|
| 4 |
+use warnings; |
|
| 5 |
+use strict; |
|
| 6 |
+use Carp 'croak'; |
|
| 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 |
+sub connect {
|
|
| 17 |
+ my $self = shift; |
|
| 18 |
+ |
|
| 19 |
+ if (!$self->data_source && (my $database = $self->database)) {
|
|
| 20 |
+ $self->data_source("dbi:SQLite:dbname=$database");
|
|
| 21 |
+ } |
|
| 22 |
+ |
|
| 23 |
+ return $self->SUPER::connect; |
|
| 24 |
+} |
|
| 25 |
+ |
|
| 26 |
+sub connect_memory {
|
|
| 27 |
+ my $self = shift; |
|
| 28 |
+ |
|
| 29 |
+ # Data source for memory database |
|
| 30 |
+ $self->data_source('dbi:SQLite:dbname=:memory:');
|
|
| 31 |
+ |
|
| 32 |
+ # Already connected |
|
| 33 |
+ croak("Already connected") if $self->connected;
|
|
| 34 |
+ |
|
| 35 |
+ # Connect |
|
| 36 |
+ $self->connect; |
|
| 37 |
+ |
|
| 38 |
+ return $self; |
|
| 39 |
+} |
|
| 40 |
+ |
|
| 41 |
+sub reconnect_memory {
|
|
| 42 |
+ my $self = shift; |
|
| 43 |
+ |
|
| 44 |
+ # Data source for memory database |
|
| 45 |
+ $self->data_source('dbi:SQLite:dbname=:memory:');
|
|
| 46 |
+ |
|
| 47 |
+ # Reconnect |
|
| 48 |
+ $self->reconnect; |
|
| 49 |
+ |
|
| 50 |
+ return $self; |
|
| 51 |
+} |
|
| 52 |
+ |
|
| 53 |
+ |
|
| 54 |
+=head1 NAME |
|
| 55 |
+ |
|
| 56 |
+DBIx::Custom::SQLite - DBIx::Custom SQLite implementation |
|
| 57 |
+ |
|
| 58 |
+=head1 Version |
|
| 59 |
+ |
|
| 60 |
+Version 0.0201 |
|
| 61 |
+ |
|
| 62 |
+=head1 Synopsys |
|
| 63 |
+ |
|
| 64 |
+ use DBIx::Custom::SQLite; |
|
| 65 |
+ |
|
| 66 |
+ # New |
|
| 67 |
+ my $dbi = DBIx::Custom::SQLite->new(user => 'taro', $password => 'kliej&@K', |
|
| 68 |
+ database => 'sample.db'); |
|
| 69 |
+ |
|
| 70 |
+ # Insert |
|
| 71 |
+ $dbi->insert('books', {title => 'perl', author => 'taro'});
|
|
| 72 |
+ |
|
| 73 |
+ # Update |
|
| 74 |
+ # same as 'update books set (title = 'aaa', author = 'ken') where id = 5; |
|
| 75 |
+ $dbi->update('books', {title => 'aaa', author => 'ken'}, {id => 5});
|
|
| 76 |
+ |
|
| 77 |
+ # Delete |
|
| 78 |
+ $dbi->delete('books', {author => 'taro'});
|
|
| 79 |
+ |
|
| 80 |
+ # select * from books; |
|
| 81 |
+ $dbi->select('books');
|
|
| 82 |
+ |
|
| 83 |
+ # select * from books where ahthor = 'taro'; |
|
| 84 |
+ $dbi->select('books', {author => 'taro'});
|
|
| 85 |
+ |
|
| 86 |
+ # select author, title from books where author = 'taro' |
|
| 87 |
+ $dbi->select('books', [qw/author title/], {author => 'taro'});
|
|
| 88 |
+ |
|
| 89 |
+ # select author, title from books where author = 'taro' order by id limit 1; |
|
| 90 |
+ $dbi->select('books', [qw/author title/], {author => 'taro'},
|
|
| 91 |
+ 'order by id limit 1'); |
|
| 92 |
+ |
|
| 93 |
+=head1 See DBIx::Custom and DBI::Custom::Basic documentation |
|
| 94 |
+ |
|
| 95 |
+This class is L<DBIx::Custom::Basic> subclass. |
|
| 96 |
+and L<DBIx::Custom::Basic> is L<DBIx::Custom> subclass |
|
| 97 |
+ |
|
| 98 |
+You can use all methods of L<DBIx::Custom::Basic> and <DBIx::Custom> |
|
| 99 |
+Please see L<DBIx::Custom::Basic> and <DBIx::Custom> documentation |
|
| 100 |
+ |
|
| 101 |
+=head1 Object methods |
|
| 102 |
+ |
|
| 103 |
+=head2 connect |
|
| 104 |
+ |
|
| 105 |
+This override L<DBIx::Custom> connect. |
|
| 106 |
+ |
|
| 107 |
+ # Connect to database |
|
| 108 |
+ $dbi->connect; |
|
| 109 |
+ |
|
| 110 |
+If database attribute is set, automatically data source is created and connect |
|
| 111 |
+ |
|
| 112 |
+=head2 connect_memory |
|
| 113 |
+ |
|
| 114 |
+ # Connect memory database |
|
| 115 |
+ $self = $dbi->connect_memory; |
|
| 116 |
+ |
|
| 117 |
+=head2 reconnect_memory |
|
| 118 |
+ |
|
| 119 |
+ # Reconnect memory database |
|
| 120 |
+ $self = $dbi->reconnect_memory; |
|
| 121 |
+ |
|
| 122 |
+=head1 Author |
|
| 123 |
+ |
|
| 124 |
+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >> |
|
| 125 |
+ |
|
| 126 |
+Github L<http://github.com/yuki-kimoto> |
|
| 127 |
+ |
|
| 128 |
+I develope this module L<http://github.com/yuki-kimoto/DBIx-Custom> |
|
| 129 |
+ |
|
| 130 |
+=head1 Copyright & lisence |
|
| 131 |
+ |
|
| 132 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 133 |
+ |
|
| 134 |
+This program is free software; you can redistribute it and/or modify it |
|
| 135 |
+under the same terms as Perl itself. |
|
| 136 |
+ |
| ... | ... |
@@ -0,0 +1,599 @@ |
| 1 |
+.\" Automatically generated by Pod::Man v1.37, Pod::Parser v1.32 |
|
| 2 |
+.\" |
|
| 3 |
+.\" Standard preamble: |
|
| 4 |
+.\" ======================================================================== |
|
| 5 |
+.de Sh \" Subsection heading |
|
| 6 |
+.br |
|
| 7 |
+.if t .Sp |
|
| 8 |
+.ne 5 |
|
| 9 |
+.PP |
|
| 10 |
+\fB\\$1\fR |
|
| 11 |
+.PP |
|
| 12 |
+.. |
|
| 13 |
+.de Sp \" Vertical space (when we can't use .PP) |
|
| 14 |
+.if t .sp .5v |
|
| 15 |
+.if n .sp |
|
| 16 |
+.. |
|
| 17 |
+.de Vb \" Begin verbatim text |
|
| 18 |
+.ft CW |
|
| 19 |
+.nf |
|
| 20 |
+.ne \\$1 |
|
| 21 |
+.. |
|
| 22 |
+.de Ve \" End verbatim text |
|
| 23 |
+.ft R |
|
| 24 |
+.fi |
|
| 25 |
+.. |
|
| 26 |
+.\" Set up some character translations and predefined strings. \*(-- will |
|
| 27 |
+.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left |
|
| 28 |
+.\" double quote, and \*(R" will give a right double quote. | will give a |
|
| 29 |
+.\" real vertical bar. \*(C+ will give a nicer C++. Capital omega is used to |
|
| 30 |
+.\" do unbreakable dashes and therefore won't be available. \*(C` and \*(C' |
|
| 31 |
+.\" expand to `' in nroff, nothing in troff, for use with C<>. |
|
| 32 |
+.tr \(*W-|\(bv\*(Tr |
|
| 33 |
+.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p' |
|
| 34 |
+.ie n \{\
|
|
| 35 |
+. ds -- \(*W- |
|
| 36 |
+. ds PI pi |
|
| 37 |
+. if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch |
|
| 38 |
+. if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch |
|
| 39 |
+. ds L" "" |
|
| 40 |
+. ds R" "" |
|
| 41 |
+. ds C` "" |
|
| 42 |
+. ds C' "" |
|
| 43 |
+'br\} |
|
| 44 |
+.el\{\
|
|
| 45 |
+. ds -- \|\(em\| |
|
| 46 |
+. ds PI \(*p |
|
| 47 |
+. ds L" `` |
|
| 48 |
+. ds R" '' |
|
| 49 |
+'br\} |
|
| 50 |
+.\" |
|
| 51 |
+.\" If the F register is turned on, we'll generate index entries on stderr for |
|
| 52 |
+.\" titles (.TH), headers (.SH), subsections (.Sh), items (.Ip), and index |
|
| 53 |
+.\" entries marked with X<> in POD. Of course, you'll have to process the |
|
| 54 |
+.\" output yourself in some meaningful fashion. |
|
| 55 |
+.if \nF \{\
|
|
| 56 |
+. de IX |
|
| 57 |
+. tm Index:\\$1\t\\n%\t"\\$2" |
|
| 58 |
+.. |
|
| 59 |
+. nr % 0 |
|
| 60 |
+. rr F |
|
| 61 |
+.\} |
|
| 62 |
+.\" |
|
| 63 |
+.\" For nroff, turn off justification. Always turn off hyphenation; it makes |
|
| 64 |
+.\" way too many mistakes in technical documents. |
|
| 65 |
+.hy 0 |
|
| 66 |
+.if n .na |
|
| 67 |
+.\" |
|
| 68 |
+.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2). |
|
| 69 |
+.\" Fear. Run. Save yourself. No user-serviceable parts. |
|
| 70 |
+. \" fudge factors for nroff and troff |
|
| 71 |
+.if n \{\
|
|
| 72 |
+. ds #H 0 |
|
| 73 |
+. ds #V .8m |
|
| 74 |
+. ds #F .3m |
|
| 75 |
+. ds #[ \f1 |
|
| 76 |
+. ds #] \fP |
|
| 77 |
+.\} |
|
| 78 |
+.if t \{\
|
|
| 79 |
+. ds #H ((1u-(\\\\n(.fu%2u))*.13m) |
|
| 80 |
+. ds #V .6m |
|
| 81 |
+. ds #F 0 |
|
| 82 |
+. ds #[ \& |
|
| 83 |
+. ds #] \& |
|
| 84 |
+.\} |
|
| 85 |
+. \" simple accents for nroff and troff |
|
| 86 |
+.if n \{\
|
|
| 87 |
+. ds ' \& |
|
| 88 |
+. ds ` \& |
|
| 89 |
+. ds ^ \& |
|
| 90 |
+. ds , \& |
|
| 91 |
+. ds ~ ~ |
|
| 92 |
+. ds / |
|
| 93 |
+.\} |
|
| 94 |
+.if t \{\
|
|
| 95 |
+. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u" |
|
| 96 |
+. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u' |
|
| 97 |
+. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u' |
|
| 98 |
+. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u' |
|
| 99 |
+. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u' |
|
| 100 |
+. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u' |
|
| 101 |
+.\} |
|
| 102 |
+. \" troff and (daisy-wheel) nroff accents |
|
| 103 |
+.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V' |
|
| 104 |
+.ds 8 \h'\*(#H'\(*b\h'-\*(#H' |
|
| 105 |
+.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#] |
|
| 106 |
+.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H' |
|
| 107 |
+.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u' |
|
| 108 |
+.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#] |
|
| 109 |
+.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#] |
|
| 110 |
+.ds ae a\h'-(\w'a'u*4/10)'e |
|
| 111 |
+.ds Ae A\h'-(\w'A'u*4/10)'E |
|
| 112 |
+. \" corrections for vroff |
|
| 113 |
+.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u' |
|
| 114 |
+.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u' |
|
| 115 |
+. \" for low resolution devices (crt and lpr) |
|
| 116 |
+.if \n(.H>23 .if \n(.V>19 \ |
|
| 117 |
+\{\
|
|
| 118 |
+. ds : e |
|
| 119 |
+. ds 8 ss |
|
| 120 |
+. ds o a |
|
| 121 |
+. ds d- d\h'-1'\(ga |
|
| 122 |
+. ds D- D\h'-1'\(hy |
|
| 123 |
+. ds th \o'bp' |
|
| 124 |
+. ds Th \o'LP' |
|
| 125 |
+. ds ae ae |
|
| 126 |
+. ds Ae AE |
|
| 127 |
+.\} |
|
| 128 |
+.rm #[ #] #H #V #F C |
|
| 129 |
+.\" ======================================================================== |
|
| 130 |
+.\" |
|
| 131 |
+.IX Title "DBIx::Custom 3" |
|
| 132 |
+.TH DBIx::Custom 3 "2009-11-16" "perl v5.8.8" "User Contributed Perl Documentation" |
|
| 133 |
+.SH "NAME" |
|
| 134 |
+DBIx::Custom \- Customizable simple DBI |
|
| 135 |
+.SH "VERSION" |
|
| 136 |
+.IX Header "VERSION" |
|
| 137 |
+Version 0.0501 |
|
| 138 |
+.SH "CAUTION" |
|
| 139 |
+.IX Header "CAUTION" |
|
| 140 |
+This module is now experimental stage. |
|
| 141 |
+.PP |
|
| 142 |
+I want you to try this module |
|
| 143 |
+because I want this module stable, and not to damage your \s-1DB\s0 data by this module bug. |
|
| 144 |
+.PP |
|
| 145 |
+Please tell me bug if you find |
|
| 146 |
+.SH "SYNOPSIS" |
|
| 147 |
+.IX Header "SYNOPSIS" |
|
| 148 |
+.Vb 1 |
|
| 149 |
+\& my $dbi = DBIx::Custom->new; |
|
| 150 |
+.Ve |
|
| 151 |
+.PP |
|
| 152 |
+.Vb 2 |
|
| 153 |
+\& my $query = $dbi->create_query($template); |
|
| 154 |
+\& $dbi->execute($query); |
|
| 155 |
+.Ve |
|
| 156 |
+.SH "CLASS-OBJECT ACCESSORS" |
|
| 157 |
+.IX Header "CLASS-OBJECT ACCESSORS" |
|
| 158 |
+.Sh "user" |
|
| 159 |
+.IX Subsection "user" |
|
| 160 |
+.Vb 3 |
|
| 161 |
+\& # Set and get database user name |
|
| 162 |
+\& $self = $dbi->user($user); |
|
| 163 |
+\& $user = $dbi->user; |
|
| 164 |
+.Ve |
|
| 165 |
+.PP |
|
| 166 |
+.Vb 2 |
|
| 167 |
+\& # Sample |
|
| 168 |
+\& $dbi->user('taro');
|
|
| 169 |
+.Ve |
|
| 170 |
+.Sh "password" |
|
| 171 |
+.IX Subsection "password" |
|
| 172 |
+.Vb 3 |
|
| 173 |
+\& # Set and get database password |
|
| 174 |
+\& $self = $dbi->password($password); |
|
| 175 |
+\& $password = $dbi->password; |
|
| 176 |
+.Ve |
|
| 177 |
+.PP |
|
| 178 |
+.Vb 2 |
|
| 179 |
+\& # Sample |
|
| 180 |
+\& $dbi->password('lkj&le`@s');
|
|
| 181 |
+.Ve |
|
| 182 |
+.Sh "data_source" |
|
| 183 |
+.IX Subsection "data_source" |
|
| 184 |
+.Vb 3 |
|
| 185 |
+\& # Set and get database data source |
|
| 186 |
+\& $self = $dbi->data_source($data_soruce); |
|
| 187 |
+\& $data_source = $dbi->data_source; |
|
| 188 |
+.Ve |
|
| 189 |
+.PP |
|
| 190 |
+.Vb 2 |
|
| 191 |
+\& # Sample(SQLite) |
|
| 192 |
+\& $dbi->data_source(dbi:SQLite:dbname=$database); |
|
| 193 |
+.Ve |
|
| 194 |
+.PP |
|
| 195 |
+.Vb 2 |
|
| 196 |
+\& # Sample(MySQL); |
|
| 197 |
+\& $dbi->data_source("dbi:mysql:dbname=$database");
|
|
| 198 |
+.Ve |
|
| 199 |
+.PP |
|
| 200 |
+.Vb 2 |
|
| 201 |
+\& # Sample(PostgreSQL) |
|
| 202 |
+\& $dbi->data_source("dbi:Pg:dbname=$database");
|
|
| 203 |
+.Ve |
|
| 204 |
+.Sh "database" |
|
| 205 |
+.IX Subsection "database" |
|
| 206 |
+.Vb 3 |
|
| 207 |
+\& # Set and get database name |
|
| 208 |
+\& $self = $dbi->database($database); |
|
| 209 |
+\& $database = $dbi->database; |
|
| 210 |
+.Ve |
|
| 211 |
+.PP |
|
| 212 |
+This method will be used in subclass connect method. |
|
| 213 |
+.Sh "dbi_options" |
|
| 214 |
+.IX Subsection "dbi_options" |
|
| 215 |
+.Vb 3 |
|
| 216 |
+\& # Set and get DBI option |
|
| 217 |
+\& $self = $dbi->dbi_options({$options => $value, ...});
|
|
| 218 |
+\& $dbi_options = $dbi->dbi_options; |
|
| 219 |
+.Ve |
|
| 220 |
+.PP |
|
| 221 |
+.Vb 2 |
|
| 222 |
+\& # Sample |
|
| 223 |
+\& $dbi->dbi_options({PrintError => 0, RaiseError => 1});
|
|
| 224 |
+.Ve |
|
| 225 |
+.PP |
|
| 226 |
+dbi_options is used when you connect database by using connect. |
|
| 227 |
+.Sh "prepare" |
|
| 228 |
+.IX Subsection "prepare" |
|
| 229 |
+.Vb 1 |
|
| 230 |
+\& $sth = $dbi->prepare($sql); |
|
| 231 |
+.Ve |
|
| 232 |
+.PP |
|
| 233 |
+This method is same as DBI::prepare |
|
| 234 |
+.Sh "do" |
|
| 235 |
+.IX Subsection "do" |
|
| 236 |
+.Vb 1 |
|
| 237 |
+\& $dbi->do($sql, @bind_values); |
|
| 238 |
+.Ve |
|
| 239 |
+.PP |
|
| 240 |
+This method is same as DBI::do |
|
| 241 |
+.Sh "sql_template" |
|
| 242 |
+.IX Subsection "sql_template" |
|
| 243 |
+.Vb 3 |
|
| 244 |
+\& # Set and get SQL::Template object |
|
| 245 |
+\& $self = $dbi->sql_template($sql_template); |
|
| 246 |
+\& $sql_template = $dbi->sql_template; |
|
| 247 |
+.Ve |
|
| 248 |
+.PP |
|
| 249 |
+.Vb 2 |
|
| 250 |
+\& # Sample |
|
| 251 |
+\& $dbi->sql_template(DBI::Cutom::SQL::Template->new); |
|
| 252 |
+.Ve |
|
| 253 |
+.Sh "filters" |
|
| 254 |
+.IX Subsection "filters" |
|
| 255 |
+.Vb 3 |
|
| 256 |
+\& # Set and get filters |
|
| 257 |
+\& $self = $dbi->filters($filters); |
|
| 258 |
+\& $filters = $dbi->filters; |
|
| 259 |
+.Ve |
|
| 260 |
+.Sh "formats" |
|
| 261 |
+.IX Subsection "formats" |
|
| 262 |
+.Vb 3 |
|
| 263 |
+\& # Set and get formats |
|
| 264 |
+\& $self = $dbi->formats($formats); |
|
| 265 |
+\& $formats = $dbi->formats; |
|
| 266 |
+.Ve |
|
| 267 |
+.Sh "bind_filter" |
|
| 268 |
+.IX Subsection "bind_filter" |
|
| 269 |
+.Vb 3 |
|
| 270 |
+\& # Set and get binding filter |
|
| 271 |
+\& $self = $dbi->bind_filter($bind_filter); |
|
| 272 |
+\& $bind_filter = $dbi->bind_filter |
|
| 273 |
+.Ve |
|
| 274 |
+.PP |
|
| 275 |
+.Vb 2 |
|
| 276 |
+\& # Sample |
|
| 277 |
+\& $dbi->bind_filter($self->filters->{default_bind_filter});
|
|
| 278 |
+.Ve |
|
| 279 |
+.PP |
|
| 280 |
+you can get \s-1DBI\s0 database handle if you need. |
|
| 281 |
+.Sh "fetch_filter" |
|
| 282 |
+.IX Subsection "fetch_filter" |
|
| 283 |
+.Vb 3 |
|
| 284 |
+\& # Set and get Fetch filter |
|
| 285 |
+\& $self = $dbi->fetch_filter($fetch_filter); |
|
| 286 |
+\& $fetch_filter = $dbi->fetch_filter; |
|
| 287 |
+.Ve |
|
| 288 |
+.PP |
|
| 289 |
+.Vb 2 |
|
| 290 |
+\& # Sample |
|
| 291 |
+\& $dbi->fetch_filter($self->filters->{default_fetch_filter});
|
|
| 292 |
+.Ve |
|
| 293 |
+.Sh "no_bind_filters" |
|
| 294 |
+.IX Subsection "no_bind_filters" |
|
| 295 |
+.Vb 3 |
|
| 296 |
+\& # Set and get no filter keys when binding |
|
| 297 |
+\& $self = $dbi->no_bind_filters($no_bind_filters); |
|
| 298 |
+\& $no_bind_filters = $dbi->no_bind_filters; |
|
| 299 |
+.Ve |
|
| 300 |
+.Sh "no_fetch_filters" |
|
| 301 |
+.IX Subsection "no_fetch_filters" |
|
| 302 |
+.Vb 3 |
|
| 303 |
+\& # Set and get no filter keys when fetching |
|
| 304 |
+\& $self = $dbi->no_fetch_filters($no_fetch_filters); |
|
| 305 |
+\& $no_fetch_filters = $dbi->no_fetch_filters; |
|
| 306 |
+.Ve |
|
| 307 |
+.Sh "result_class" |
|
| 308 |
+.IX Subsection "result_class" |
|
| 309 |
+.Vb 3 |
|
| 310 |
+\& # Set and get resultset class |
|
| 311 |
+\& $self = $dbi->result_class($result_class); |
|
| 312 |
+\& $result_class = $dbi->result_class; |
|
| 313 |
+.Ve |
|
| 314 |
+.PP |
|
| 315 |
+.Vb 2 |
|
| 316 |
+\& # Sample |
|
| 317 |
+\& $dbi->result_class('DBIx::Custom::Result');
|
|
| 318 |
+.Ve |
|
| 319 |
+.Sh "dbh" |
|
| 320 |
+.IX Subsection "dbh" |
|
| 321 |
+.Vb 2 |
|
| 322 |
+\& # Get database handle |
|
| 323 |
+\& $dbh = $self->dbh; |
|
| 324 |
+.Ve |
|
| 325 |
+.SH "METHODS" |
|
| 326 |
+.IX Header "METHODS" |
|
| 327 |
+.Sh "connect" |
|
| 328 |
+.IX Subsection "connect" |
|
| 329 |
+.Vb 2 |
|
| 330 |
+\& # Connect to database |
|
| 331 |
+\& $self = $dbi->connect; |
|
| 332 |
+.Ve |
|
| 333 |
+.PP |
|
| 334 |
+.Vb 4 |
|
| 335 |
+\& # Sample |
|
| 336 |
+\& $dbi = DBIx::Custom->new(user => 'taro', password => 'lji8(',
|
|
| 337 |
+\& data_soruce => "dbi:mysql:dbname=$database"); |
|
| 338 |
+\& $dbi->connect; |
|
| 339 |
+.Ve |
|
| 340 |
+.Sh "disconnect" |
|
| 341 |
+.IX Subsection "disconnect" |
|
| 342 |
+.Vb 2 |
|
| 343 |
+\& # Disconnect database |
|
| 344 |
+\& $dbi->disconnect; |
|
| 345 |
+.Ve |
|
| 346 |
+.PP |
|
| 347 |
+If database is already disconnected, this method do noting. |
|
| 348 |
+.Sh "reconnect" |
|
| 349 |
+.IX Subsection "reconnect" |
|
| 350 |
+.Vb 2 |
|
| 351 |
+\& # Reconnect |
|
| 352 |
+\& $dbi->reconnect; |
|
| 353 |
+.Ve |
|
| 354 |
+.Sh "connected" |
|
| 355 |
+.IX Subsection "connected" |
|
| 356 |
+.Vb 2 |
|
| 357 |
+\& # Check connected |
|
| 358 |
+\& $dbi->connected |
|
| 359 |
+.Ve |
|
| 360 |
+.Sh "filter_off" |
|
| 361 |
+.IX Subsection "filter_off" |
|
| 362 |
+.Vb 2 |
|
| 363 |
+\& # bind_filter and fitch_filter off |
|
| 364 |
+\& $self->filter_off; |
|
| 365 |
+.Ve |
|
| 366 |
+.PP |
|
| 367 |
+This is equeal to |
|
| 368 |
+.PP |
|
| 369 |
+.Vb 2 |
|
| 370 |
+\& $self->bind_filter(undef); |
|
| 371 |
+\& $self->fetch_filter(undef); |
|
| 372 |
+.Ve |
|
| 373 |
+.Sh "add_filter" |
|
| 374 |
+.IX Subsection "add_filter" |
|
| 375 |
+.Vb 3 |
|
| 376 |
+\& # Add filter (hash ref or hash can be recieve) |
|
| 377 |
+\& $self = $dbi->add_filter({$filter_name => $filter, ...});
|
|
| 378 |
+\& $self = $dbi->add_filter($filetr_name => $filter, ...); |
|
| 379 |
+.Ve |
|
| 380 |
+.PP |
|
| 381 |
+.Vb 19 |
|
| 382 |
+\& # Sample |
|
| 383 |
+\& $dbi->add_filter( |
|
| 384 |
+\& decode_utf8 => sub {
|
|
| 385 |
+\& my ($key, $value, $table, $column) = @_; |
|
| 386 |
+\& return Encode::decode('UTF-8', $value);
|
|
| 387 |
+\& }, |
|
| 388 |
+\& datetime_to_string => sub {
|
|
| 389 |
+\& my ($key, $value, $table, $column) = @_; |
|
| 390 |
+\& return $value->strftime('%Y-%m-%d %H:%M:%S')
|
|
| 391 |
+\& }, |
|
| 392 |
+\& default_bind_filter => sub {
|
|
| 393 |
+\& my ($key, $value, $table, $column) = @_; |
|
| 394 |
+\& if (ref $value eq 'Time::Piece') {
|
|
| 395 |
+\& return $dbi->filters->{datetime_to_string}->($value);
|
|
| 396 |
+\& } |
|
| 397 |
+\& else {
|
|
| 398 |
+\& return $dbi->filters->{decode_utf8}->($value);
|
|
| 399 |
+\& } |
|
| 400 |
+\& }, |
|
| 401 |
+.Ve |
|
| 402 |
+.PP |
|
| 403 |
+.Vb 18 |
|
| 404 |
+\& encode_utf8 => sub {
|
|
| 405 |
+\& my ($key, $value) = @_; |
|
| 406 |
+\& return Encode::encode('UTF-8', $value);
|
|
| 407 |
+\& }, |
|
| 408 |
+\& string_to_datetime => sub {
|
|
| 409 |
+\& my ($key, $value) = @_; |
|
| 410 |
+\& return DateTime::Format::MySQL->parse_datetime($value); |
|
| 411 |
+\& }, |
|
| 412 |
+\& default_fetch_filter => sub {
|
|
| 413 |
+\& my ($key, $value, $type, $sth, $i) = @_; |
|
| 414 |
+\& if ($type eq 'DATETIME') {
|
|
| 415 |
+\& return $dbi->filters->{string_to_datetime}->($value);
|
|
| 416 |
+\& } |
|
| 417 |
+\& else {
|
|
| 418 |
+\& return $dbi->filters->{encode_utf8}->($value);
|
|
| 419 |
+\& } |
|
| 420 |
+\& } |
|
| 421 |
+\& ); |
|
| 422 |
+.Ve |
|
| 423 |
+.PP |
|
| 424 |
+add_filter add filter to filters |
|
| 425 |
+.Sh "add_format" |
|
| 426 |
+.IX Subsection "add_format" |
|
| 427 |
+.Vb 1 |
|
| 428 |
+\& $dbi->add_format(date => '%Y:%m:%d'); |
|
| 429 |
+.Ve |
|
| 430 |
+.Sh "create_query" |
|
| 431 |
+.IX Subsection "create_query" |
|
| 432 |
+.Vb 2 |
|
| 433 |
+\& # Create Query object from SQL template |
|
| 434 |
+\& my $query = $dbi->create_query($template); |
|
| 435 |
+.Ve |
|
| 436 |
+.Sh "execute" |
|
| 437 |
+.IX Subsection "execute" |
|
| 438 |
+.Vb 3 |
|
| 439 |
+\& # Parse SQL template and execute SQL |
|
| 440 |
+\& $result = $dbi->query($query, $params); |
|
| 441 |
+\& $result = $dbi->query($template, $params); # Shorcut |
|
| 442 |
+.Ve |
|
| 443 |
+.PP |
|
| 444 |
+.Vb 3 |
|
| 445 |
+\& # Sample |
|
| 446 |
+\& $result = $dbi->query("select * from authors where {= name} and {= age}",
|
|
| 447 |
+\& {author => 'taro', age => 19});
|
|
| 448 |
+.Ve |
|
| 449 |
+.PP |
|
| 450 |
+.Vb 3 |
|
| 451 |
+\& while (my @row = $result->fetch) {
|
|
| 452 |
+\& # do something |
|
| 453 |
+\& } |
|
| 454 |
+.Ve |
|
| 455 |
+.PP |
|
| 456 |
+See also DBIx::Custom::SQL::Template |
|
| 457 |
+.Sh "run_transaction" |
|
| 458 |
+.IX Subsection "run_transaction" |
|
| 459 |
+.Vb 4 |
|
| 460 |
+\& # Run transaction |
|
| 461 |
+\& $dbi->run_transaction(sub {
|
|
| 462 |
+\& # do something |
|
| 463 |
+\& }); |
|
| 464 |
+.Ve |
|
| 465 |
+.PP |
|
| 466 |
+If transaction is success, commit is execute. |
|
| 467 |
+If tranzation is died, rollback is execute. |
|
| 468 |
+.Sh "insert" |
|
| 469 |
+.IX Subsection "insert" |
|
| 470 |
+.Vb 2 |
|
| 471 |
+\& # Insert |
|
| 472 |
+\& $dbi->insert($table, $insert_values); |
|
| 473 |
+.Ve |
|
| 474 |
+.PP |
|
| 475 |
+.Vb 2 |
|
| 476 |
+\& # Sample |
|
| 477 |
+\& $dbi->insert('books', {title => 'Perl', author => 'Taro'});
|
|
| 478 |
+.Ve |
|
| 479 |
+.Sh "update" |
|
| 480 |
+.IX Subsection "update" |
|
| 481 |
+.Vb 2 |
|
| 482 |
+\& # Update |
|
| 483 |
+\& $dbi->update($table, $update_values, $where); |
|
| 484 |
+.Ve |
|
| 485 |
+.PP |
|
| 486 |
+.Vb 2 |
|
| 487 |
+\& # Sample |
|
| 488 |
+\& $dbi->update('books', {title => 'Perl', author => 'Taro'}, {id => 5});
|
|
| 489 |
+.Ve |
|
| 490 |
+.Sh "update_all" |
|
| 491 |
+.IX Subsection "update_all" |
|
| 492 |
+.Vb 2 |
|
| 493 |
+\& # Update all rows |
|
| 494 |
+\& $dbi->update($table, $updat_values); |
|
| 495 |
+.Ve |
|
| 496 |
+.Sh "delete" |
|
| 497 |
+.IX Subsection "delete" |
|
| 498 |
+.Vb 2 |
|
| 499 |
+\& # Delete |
|
| 500 |
+\& $dbi->delete($table, $where); |
|
| 501 |
+.Ve |
|
| 502 |
+.PP |
|
| 503 |
+.Vb 2 |
|
| 504 |
+\& # Sample |
|
| 505 |
+\& $dbi->delete('Books', {id => 5});
|
|
| 506 |
+.Ve |
|
| 507 |
+.Sh "delete_all" |
|
| 508 |
+.IX Subsection "delete_all" |
|
| 509 |
+.Vb 2 |
|
| 510 |
+\& # Delete all rows |
|
| 511 |
+\& $dbi->delete_all($table); |
|
| 512 |
+.Ve |
|
| 513 |
+.Sh "last_insert_id" |
|
| 514 |
+.IX Subsection "last_insert_id" |
|
| 515 |
+.Vb 2 |
|
| 516 |
+\& # Get last insert id |
|
| 517 |
+\& $last_insert_id = $dbi->last_insert_id; |
|
| 518 |
+.Ve |
|
| 519 |
+.PP |
|
| 520 |
+This method is same as \s-1DBI\s0 last_insert_id; |
|
| 521 |
+.Sh "select" |
|
| 522 |
+.IX Subsection "select" |
|
| 523 |
+.Vb 8 |
|
| 524 |
+\& # Select |
|
| 525 |
+\& $dbi->select( |
|
| 526 |
+\& $table, # must be string or array; |
|
| 527 |
+\& [@$columns], # must be array reference. this is optional |
|
| 528 |
+\& {%$where_params}, # must be hash reference. this is optional
|
|
| 529 |
+\& $append_statement, # must be string. this is optional |
|
| 530 |
+\& $query_edit_callback # must be code reference. this is optional |
|
| 531 |
+\& ); |
|
| 532 |
+.Ve |
|
| 533 |
+.PP |
|
| 534 |
+.Vb 13 |
|
| 535 |
+\& # Sample |
|
| 536 |
+\& $dbi->select( |
|
| 537 |
+\& 'Books', |
|
| 538 |
+\& ['title', 'author'], |
|
| 539 |
+\& {id => 1},
|
|
| 540 |
+\& "for update", |
|
| 541 |
+\& sub {
|
|
| 542 |
+\& my $query = shift; |
|
| 543 |
+\& $query->bind_filter(sub {
|
|
| 544 |
+\& # ... |
|
| 545 |
+\& }); |
|
| 546 |
+\& } |
|
| 547 |
+\& ); |
|
| 548 |
+.Ve |
|
| 549 |
+.PP |
|
| 550 |
+.Vb 7 |
|
| 551 |
+\& # The way to join multi tables |
|
| 552 |
+\& $dbi->select( |
|
| 553 |
+\& ['table1', 'table2'], |
|
| 554 |
+\& ['table1.id as table1_id', 'title'], |
|
| 555 |
+\& {table1.id => 1},
|
|
| 556 |
+\& "where table1.id = table2.id", |
|
| 557 |
+\& ); |
|
| 558 |
+.Ve |
|
| 559 |
+.SH "Class Accessors" |
|
| 560 |
+.IX Header "Class Accessors" |
|
| 561 |
+.Sh "query_cache_max" |
|
| 562 |
+.IX Subsection "query_cache_max" |
|
| 563 |
+.Vb 3 |
|
| 564 |
+\& # Max query cache count |
|
| 565 |
+\& $class = $class->query_cache_max($query_cache_max); |
|
| 566 |
+\& $query_cache_max = $class->query_cache_max; |
|
| 567 |
+.Ve |
|
| 568 |
+.PP |
|
| 569 |
+.Vb 2 |
|
| 570 |
+\& # Sample |
|
| 571 |
+\& DBIx::Custom->query_cache_max(50); |
|
| 572 |
+.Ve |
|
| 573 |
+.SH "CAUTION" |
|
| 574 |
+.IX Header "CAUTION" |
|
| 575 |
+DBIx::Custom have \s-1DIB\s0 object internal. |
|
| 576 |
+This module is work well in the following \s-1DBI\s0 condition. |
|
| 577 |
+.PP |
|
| 578 |
+.Vb 2 |
|
| 579 |
+\& 1. AutoCommit is true |
|
| 580 |
+\& 2. RaiseError is true |
|
| 581 |
+.Ve |
|
| 582 |
+.PP |
|
| 583 |
+By default, Both AutoCommit and RaiseError is true. |
|
| 584 |
+You must not change these mode not to damage your data. |
|
| 585 |
+.PP |
|
| 586 |
+If you change these mode, |
|
| 587 |
+you cannot get correct error message, |
|
| 588 |
+or run_transaction may fail. |
|
| 589 |
+.SH "AUTHOR" |
|
| 590 |
+.IX Header "AUTHOR" |
|
| 591 |
+Yuki Kimoto, \f(CW\*(C`<kimoto.yuki at gmail.com>\*(C'\fR |
|
| 592 |
+.PP |
|
| 593 |
+Github <http://github.com/yuki\-kimoto> |
|
| 594 |
+.SH "COPYRIGHT & LICENSE" |
|
| 595 |
+.IX Header "COPYRIGHT & LICENSE" |
|
| 596 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 597 |
+.PP |
|
| 598 |
+This program is free software; you can redistribute it and/or modify it |
|
| 599 |
+under the same terms as Perl itself. |
| ... | ... |
@@ -0,0 +1,217 @@ |
| 1 |
+.\" Automatically generated by Pod::Man v1.37, Pod::Parser v1.32 |
|
| 2 |
+.\" |
|
| 3 |
+.\" Standard preamble: |
|
| 4 |
+.\" ======================================================================== |
|
| 5 |
+.de Sh \" Subsection heading |
|
| 6 |
+.br |
|
| 7 |
+.if t .Sp |
|
| 8 |
+.ne 5 |
|
| 9 |
+.PP |
|
| 10 |
+\fB\\$1\fR |
|
| 11 |
+.PP |
|
| 12 |
+.. |
|
| 13 |
+.de Sp \" Vertical space (when we can't use .PP) |
|
| 14 |
+.if t .sp .5v |
|
| 15 |
+.if n .sp |
|
| 16 |
+.. |
|
| 17 |
+.de Vb \" Begin verbatim text |
|
| 18 |
+.ft CW |
|
| 19 |
+.nf |
|
| 20 |
+.ne \\$1 |
|
| 21 |
+.. |
|
| 22 |
+.de Ve \" End verbatim text |
|
| 23 |
+.ft R |
|
| 24 |
+.fi |
|
| 25 |
+.. |
|
| 26 |
+.\" Set up some character translations and predefined strings. \*(-- will |
|
| 27 |
+.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left |
|
| 28 |
+.\" double quote, and \*(R" will give a right double quote. | will give a |
|
| 29 |
+.\" real vertical bar. \*(C+ will give a nicer C++. Capital omega is used to |
|
| 30 |
+.\" do unbreakable dashes and therefore won't be available. \*(C` and \*(C' |
|
| 31 |
+.\" expand to `' in nroff, nothing in troff, for use with C<>. |
|
| 32 |
+.tr \(*W-|\(bv\*(Tr |
|
| 33 |
+.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p' |
|
| 34 |
+.ie n \{\
|
|
| 35 |
+. ds -- \(*W- |
|
| 36 |
+. ds PI pi |
|
| 37 |
+. if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch |
|
| 38 |
+. if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch |
|
| 39 |
+. ds L" "" |
|
| 40 |
+. ds R" "" |
|
| 41 |
+. ds C` "" |
|
| 42 |
+. ds C' "" |
|
| 43 |
+'br\} |
|
| 44 |
+.el\{\
|
|
| 45 |
+. ds -- \|\(em\| |
|
| 46 |
+. ds PI \(*p |
|
| 47 |
+. ds L" `` |
|
| 48 |
+. ds R" '' |
|
| 49 |
+'br\} |
|
| 50 |
+.\" |
|
| 51 |
+.\" If the F register is turned on, we'll generate index entries on stderr for |
|
| 52 |
+.\" titles (.TH), headers (.SH), subsections (.Sh), items (.Ip), and index |
|
| 53 |
+.\" entries marked with X<> in POD. Of course, you'll have to process the |
|
| 54 |
+.\" output yourself in some meaningful fashion. |
|
| 55 |
+.if \nF \{\
|
|
| 56 |
+. de IX |
|
| 57 |
+. tm Index:\\$1\t\\n%\t"\\$2" |
|
| 58 |
+.. |
|
| 59 |
+. nr % 0 |
|
| 60 |
+. rr F |
|
| 61 |
+.\} |
|
| 62 |
+.\" |
|
| 63 |
+.\" For nroff, turn off justification. Always turn off hyphenation; it makes |
|
| 64 |
+.\" way too many mistakes in technical documents. |
|
| 65 |
+.hy 0 |
|
| 66 |
+.if n .na |
|
| 67 |
+.\" |
|
| 68 |
+.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2). |
|
| 69 |
+.\" Fear. Run. Save yourself. No user-serviceable parts. |
|
| 70 |
+. \" fudge factors for nroff and troff |
|
| 71 |
+.if n \{\
|
|
| 72 |
+. ds #H 0 |
|
| 73 |
+. ds #V .8m |
|
| 74 |
+. ds #F .3m |
|
| 75 |
+. ds #[ \f1 |
|
| 76 |
+. ds #] \fP |
|
| 77 |
+.\} |
|
| 78 |
+.if t \{\
|
|
| 79 |
+. ds #H ((1u-(\\\\n(.fu%2u))*.13m) |
|
| 80 |
+. ds #V .6m |
|
| 81 |
+. ds #F 0 |
|
| 82 |
+. ds #[ \& |
|
| 83 |
+. ds #] \& |
|
| 84 |
+.\} |
|
| 85 |
+. \" simple accents for nroff and troff |
|
| 86 |
+.if n \{\
|
|
| 87 |
+. ds ' \& |
|
| 88 |
+. ds ` \& |
|
| 89 |
+. ds ^ \& |
|
| 90 |
+. ds , \& |
|
| 91 |
+. ds ~ ~ |
|
| 92 |
+. ds / |
|
| 93 |
+.\} |
|
| 94 |
+.if t \{\
|
|
| 95 |
+. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u" |
|
| 96 |
+. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u' |
|
| 97 |
+. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u' |
|
| 98 |
+. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u' |
|
| 99 |
+. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u' |
|
| 100 |
+. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u' |
|
| 101 |
+.\} |
|
| 102 |
+. \" troff and (daisy-wheel) nroff accents |
|
| 103 |
+.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V' |
|
| 104 |
+.ds 8 \h'\*(#H'\(*b\h'-\*(#H' |
|
| 105 |
+.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#] |
|
| 106 |
+.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H' |
|
| 107 |
+.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u' |
|
| 108 |
+.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#] |
|
| 109 |
+.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#] |
|
| 110 |
+.ds ae a\h'-(\w'a'u*4/10)'e |
|
| 111 |
+.ds Ae A\h'-(\w'A'u*4/10)'E |
|
| 112 |
+. \" corrections for vroff |
|
| 113 |
+.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u' |
|
| 114 |
+.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u' |
|
| 115 |
+. \" for low resolution devices (crt and lpr) |
|
| 116 |
+.if \n(.H>23 .if \n(.V>19 \ |
|
| 117 |
+\{\
|
|
| 118 |
+. ds : e |
|
| 119 |
+. ds 8 ss |
|
| 120 |
+. ds o a |
|
| 121 |
+. ds d- d\h'-1'\(ga |
|
| 122 |
+. ds D- D\h'-1'\(hy |
|
| 123 |
+. ds th \o'bp' |
|
| 124 |
+. ds Th \o'LP' |
|
| 125 |
+. ds ae ae |
|
| 126 |
+. ds Ae AE |
|
| 127 |
+.\} |
|
| 128 |
+.rm #[ #] #H #V #F C |
|
| 129 |
+.\" ======================================================================== |
|
| 130 |
+.\" |
|
| 131 |
+.IX Title "DBIx::Custom::Basic 3" |
|
| 132 |
+.TH DBIx::Custom::Basic 3 "2009-11-16" "perl v5.8.8" "User Contributed Perl Documentation" |
|
| 133 |
+.SH "NAME" |
|
| 134 |
+DBIx::Custom::Basic \- DBIx::Custom basic implementation |
|
| 135 |
+.SH "Version" |
|
| 136 |
+.IX Header "Version" |
|
| 137 |
+Version 0.0201 |
|
| 138 |
+.SH "See DBIx::Custom documentation" |
|
| 139 |
+.IX Header "See DBIx::Custom documentation" |
|
| 140 |
+This class is DBIx::Custom subclass. |
|
| 141 |
+.PP |
|
| 142 |
+You can use all methods of DBIx::Custom |
|
| 143 |
+.PP |
|
| 144 |
+Please see DBIx::Custom documentation |
|
| 145 |
+.SH "Filters" |
|
| 146 |
+.IX Header "Filters" |
|
| 147 |
+.Sh "encode_utf8" |
|
| 148 |
+.IX Subsection "encode_utf8" |
|
| 149 |
+.Vb 2 |
|
| 150 |
+\& # Encode to UTF-8 byte stream (utf8::upgrade is done if need) |
|
| 151 |
+\& $dbi->filters->{encode_utf8}->($value);
|
|
| 152 |
+.Ve |
|
| 153 |
+.PP |
|
| 154 |
+This filter is generally used as bind filter |
|
| 155 |
+.PP |
|
| 156 |
+.Vb 1 |
|
| 157 |
+\& $dbi->bind_filter($dbi->filters->{encode_utf8});
|
|
| 158 |
+.Ve |
|
| 159 |
+.Sh "decode_utf8" |
|
| 160 |
+.IX Subsection "decode_utf8" |
|
| 161 |
+.Vb 2 |
|
| 162 |
+\& # Decode to perl internal string |
|
| 163 |
+\& $dbi->filters->{decode_utf8}->($value);
|
|
| 164 |
+.Ve |
|
| 165 |
+.PP |
|
| 166 |
+This filter is generally used as fetch filter |
|
| 167 |
+.PP |
|
| 168 |
+.Vb 1 |
|
| 169 |
+\& $dbi->fetch_filter($dbi->filters->{decode_utf8});
|
|
| 170 |
+.Ve |
|
| 171 |
+.Sh "Formats" |
|
| 172 |
+.IX Subsection "Formats" |
|
| 173 |
+strptime formats is available |
|
| 174 |
+.PP |
|
| 175 |
+.Vb 7 |
|
| 176 |
+\& # format name format |
|
| 177 |
+\& 'SQL99_date' '%Y-%m-%d', |
|
| 178 |
+\& 'SQL99_datetime' '%Y-%m-%d %H:%M:%S', |
|
| 179 |
+\& 'SQL99_time' '%H:%M:%S', |
|
| 180 |
+\& 'ISO-8601_date' '%Y-%m-%d', |
|
| 181 |
+\& 'ISO-8601_datetime' '%Y-%m-%dT%H:%M:%S', |
|
| 182 |
+\& 'ISO-8601_time' '%H:%M:%S', |
|
| 183 |
+.Ve |
|
| 184 |
+.PP |
|
| 185 |
+You get format as the following |
|
| 186 |
+.PP |
|
| 187 |
+.Vb 1 |
|
| 188 |
+\& my $format = $dbi->formats->{$format_name};
|
|
| 189 |
+.Ve |
|
| 190 |
+.SH "Methods" |
|
| 191 |
+.IX Header "Methods" |
|
| 192 |
+.Sh "utf8_filter_on" |
|
| 193 |
+.IX Subsection "utf8_filter_on" |
|
| 194 |
+.Vb 2 |
|
| 195 |
+\& # Encode and decode utf8 filter on |
|
| 196 |
+\& $dbi->utf8_filter_on; |
|
| 197 |
+.Ve |
|
| 198 |
+.PP |
|
| 199 |
+This equel to |
|
| 200 |
+.PP |
|
| 201 |
+.Vb 2 |
|
| 202 |
+\& $dbi->bind_filter($dbi->filters->{encode_utf8});
|
|
| 203 |
+\& $dbi->fetch_filter($dbi->filters->{decode_utf8});
|
|
| 204 |
+.Ve |
|
| 205 |
+.SH "AUTHOR" |
|
| 206 |
+.IX Header "AUTHOR" |
|
| 207 |
+Yuki Kimoto, \f(CW\*(C`<kimoto.yuki at gmail.com>\*(C'\fR |
|
| 208 |
+.PP |
|
| 209 |
+Github <http://github.com/yuki\-kimoto> |
|
| 210 |
+.PP |
|
| 211 |
+I develope this module <http://github.com/yuki\-kimoto/DBIx\-Custom> |
|
| 212 |
+.SH "COPYRIGHT & LICENSE" |
|
| 213 |
+.IX Header "COPYRIGHT & LICENSE" |
|
| 214 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 215 |
+.PP |
|
| 216 |
+This program is free software; you can redistribute it and/or modify it |
|
| 217 |
+under the same terms as Perl itself. |
| ... | ... |
@@ -0,0 +1,198 @@ |
| 1 |
+.\" Automatically generated by Pod::Man v1.37, Pod::Parser v1.32 |
|
| 2 |
+.\" |
|
| 3 |
+.\" Standard preamble: |
|
| 4 |
+.\" ======================================================================== |
|
| 5 |
+.de Sh \" Subsection heading |
|
| 6 |
+.br |
|
| 7 |
+.if t .Sp |
|
| 8 |
+.ne 5 |
|
| 9 |
+.PP |
|
| 10 |
+\fB\\$1\fR |
|
| 11 |
+.PP |
|
| 12 |
+.. |
|
| 13 |
+.de Sp \" Vertical space (when we can't use .PP) |
|
| 14 |
+.if t .sp .5v |
|
| 15 |
+.if n .sp |
|
| 16 |
+.. |
|
| 17 |
+.de Vb \" Begin verbatim text |
|
| 18 |
+.ft CW |
|
| 19 |
+.nf |
|
| 20 |
+.ne \\$1 |
|
| 21 |
+.. |
|
| 22 |
+.de Ve \" End verbatim text |
|
| 23 |
+.ft R |
|
| 24 |
+.fi |
|
| 25 |
+.. |
|
| 26 |
+.\" Set up some character translations and predefined strings. \*(-- will |
|
| 27 |
+.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left |
|
| 28 |
+.\" double quote, and \*(R" will give a right double quote. | will give a |
|
| 29 |
+.\" real vertical bar. \*(C+ will give a nicer C++. Capital omega is used to |
|
| 30 |
+.\" do unbreakable dashes and therefore won't be available. \*(C` and \*(C' |
|
| 31 |
+.\" expand to `' in nroff, nothing in troff, for use with C<>. |
|
| 32 |
+.tr \(*W-|\(bv\*(Tr |
|
| 33 |
+.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p' |
|
| 34 |
+.ie n \{\
|
|
| 35 |
+. ds -- \(*W- |
|
| 36 |
+. ds PI pi |
|
| 37 |
+. if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch |
|
| 38 |
+. if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch |
|
| 39 |
+. ds L" "" |
|
| 40 |
+. ds R" "" |
|
| 41 |
+. ds C` "" |
|
| 42 |
+. ds C' "" |
|
| 43 |
+'br\} |
|
| 44 |
+.el\{\
|
|
| 45 |
+. ds -- \|\(em\| |
|
| 46 |
+. ds PI \(*p |
|
| 47 |
+. ds L" `` |
|
| 48 |
+. ds R" '' |
|
| 49 |
+'br\} |
|
| 50 |
+.\" |
|
| 51 |
+.\" If the F register is turned on, we'll generate index entries on stderr for |
|
| 52 |
+.\" titles (.TH), headers (.SH), subsections (.Sh), items (.Ip), and index |
|
| 53 |
+.\" entries marked with X<> in POD. Of course, you'll have to process the |
|
| 54 |
+.\" output yourself in some meaningful fashion. |
|
| 55 |
+.if \nF \{\
|
|
| 56 |
+. de IX |
|
| 57 |
+. tm Index:\\$1\t\\n%\t"\\$2" |
|
| 58 |
+.. |
|
| 59 |
+. nr % 0 |
|
| 60 |
+. rr F |
|
| 61 |
+.\} |
|
| 62 |
+.\" |
|
| 63 |
+.\" For nroff, turn off justification. Always turn off hyphenation; it makes |
|
| 64 |
+.\" way too many mistakes in technical documents. |
|
| 65 |
+.hy 0 |
|
| 66 |
+.if n .na |
|
| 67 |
+.\" |
|
| 68 |
+.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2). |
|
| 69 |
+.\" Fear. Run. Save yourself. No user-serviceable parts. |
|
| 70 |
+. \" fudge factors for nroff and troff |
|
| 71 |
+.if n \{\
|
|
| 72 |
+. ds #H 0 |
|
| 73 |
+. ds #V .8m |
|
| 74 |
+. ds #F .3m |
|
| 75 |
+. ds #[ \f1 |
|
| 76 |
+. ds #] \fP |
|
| 77 |
+.\} |
|
| 78 |
+.if t \{\
|
|
| 79 |
+. ds #H ((1u-(\\\\n(.fu%2u))*.13m) |
|
| 80 |
+. ds #V .6m |
|
| 81 |
+. ds #F 0 |
|
| 82 |
+. ds #[ \& |
|
| 83 |
+. ds #] \& |
|
| 84 |
+.\} |
|
| 85 |
+. \" simple accents for nroff and troff |
|
| 86 |
+.if n \{\
|
|
| 87 |
+. ds ' \& |
|
| 88 |
+. ds ` \& |
|
| 89 |
+. ds ^ \& |
|
| 90 |
+. ds , \& |
|
| 91 |
+. ds ~ ~ |
|
| 92 |
+. ds / |
|
| 93 |
+.\} |
|
| 94 |
+.if t \{\
|
|
| 95 |
+. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u" |
|
| 96 |
+. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u' |
|
| 97 |
+. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u' |
|
| 98 |
+. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u' |
|
| 99 |
+. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u' |
|
| 100 |
+. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u' |
|
| 101 |
+.\} |
|
| 102 |
+. \" troff and (daisy-wheel) nroff accents |
|
| 103 |
+.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V' |
|
| 104 |
+.ds 8 \h'\*(#H'\(*b\h'-\*(#H' |
|
| 105 |
+.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#] |
|
| 106 |
+.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H' |
|
| 107 |
+.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u' |
|
| 108 |
+.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#] |
|
| 109 |
+.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#] |
|
| 110 |
+.ds ae a\h'-(\w'a'u*4/10)'e |
|
| 111 |
+.ds Ae A\h'-(\w'A'u*4/10)'E |
|
| 112 |
+. \" corrections for vroff |
|
| 113 |
+.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u' |
|
| 114 |
+.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u' |
|
| 115 |
+. \" for low resolution devices (crt and lpr) |
|
| 116 |
+.if \n(.H>23 .if \n(.V>19 \ |
|
| 117 |
+\{\
|
|
| 118 |
+. ds : e |
|
| 119 |
+. ds 8 ss |
|
| 120 |
+. ds o a |
|
| 121 |
+. ds d- d\h'-1'\(ga |
|
| 122 |
+. ds D- D\h'-1'\(hy |
|
| 123 |
+. ds th \o'bp' |
|
| 124 |
+. ds Th \o'LP' |
|
| 125 |
+. ds ae ae |
|
| 126 |
+. ds Ae AE |
|
| 127 |
+.\} |
|
| 128 |
+.rm #[ #] #H #V #F C |
|
| 129 |
+.\" ======================================================================== |
|
| 130 |
+.\" |
|
| 131 |
+.IX Title "DBIx::Custom::MySQL 3" |
|
| 132 |
+.TH DBIx::Custom::MySQL 3 "2009-11-16" "perl v5.8.8" "User Contributed Perl Documentation" |
|
| 133 |
+.SH "NAME" |
|
| 134 |
+DBIx::Custom::MySQL \- DBIx::Custom MySQL implementation |
|
| 135 |
+.SH "Version" |
|
| 136 |
+.IX Header "Version" |
|
| 137 |
+Version 0.0102 |
|
| 138 |
+.SH "Synopsys" |
|
| 139 |
+.IX Header "Synopsys" |
|
| 140 |
+.Vb 5 |
|
| 141 |
+\& # New |
|
| 142 |
+\& my $dbi = DBIx::Custom::MySQL->new(user => 'taro', $password => 'kliej&@K', |
|
| 143 |
+\& database => 'sample_db'); |
|
| 144 |
+\& # Insert |
|
| 145 |
+\& $dbi->insert('books', {title => 'perl', author => 'taro'});
|
|
| 146 |
+.Ve |
|
| 147 |
+.PP |
|
| 148 |
+.Vb 3 |
|
| 149 |
+\& # Update |
|
| 150 |
+\& # same as 'update books set (title = 'aaa', author = 'ken') where id = 5; |
|
| 151 |
+\& $dbi->update('books', {title => 'aaa', author => 'ken'}, {id => 5});
|
|
| 152 |
+.Ve |
|
| 153 |
+.PP |
|
| 154 |
+.Vb 2 |
|
| 155 |
+\& # Delete |
|
| 156 |
+\& $dbi->delete('books', {author => 'taro'});
|
|
| 157 |
+.Ve |
|
| 158 |
+.PP |
|
| 159 |
+.Vb 2 |
|
| 160 |
+\& # select * from books; |
|
| 161 |
+\& $dbi->select('books');
|
|
| 162 |
+.Ve |
|
| 163 |
+.PP |
|
| 164 |
+.Vb 2 |
|
| 165 |
+\& # select * from books where ahthor = 'taro'; |
|
| 166 |
+\& $dbi->select('books', {author => 'taro'});
|
|
| 167 |
+.Ve |
|
| 168 |
+.SH "See DBIx::Custom and DBI::Custom::Basic documentation" |
|
| 169 |
+.IX Header "See DBIx::Custom and DBI::Custom::Basic documentation" |
|
| 170 |
+This class is DBIx::Custom::Basic subclass, |
|
| 171 |
+and DBIx::Custom::Basic is DBIx::Custom subclass. |
|
| 172 |
+.PP |
|
| 173 |
+You can use all methods of DBIx::Custom::Basic and <DBIx::Custom> |
|
| 174 |
+Please see DBIx::Custom::Basic and <DBIx::Custom> documentation. |
|
| 175 |
+.SH "Object methods" |
|
| 176 |
+.IX Header "Object methods" |
|
| 177 |
+.Sh "connect" |
|
| 178 |
+.IX Subsection "connect" |
|
| 179 |
+.Vb 1 |
|
| 180 |
+\& This method override DBIx::Custom::connect |
|
| 181 |
+.Ve |
|
| 182 |
+.PP |
|
| 183 |
+.Vb 1 |
|
| 184 |
+\& If database attribute is set, automatically data source is created and connect |
|
| 185 |
+.Ve |
|
| 186 |
+.SH "Author" |
|
| 187 |
+.IX Header "Author" |
|
| 188 |
+Yuki Kimoto, \f(CW\*(C`<kimoto.yuki at gmail.com>\*(C'\fR |
|
| 189 |
+.PP |
|
| 190 |
+Github <http://github.com/yuki\-kimoto> |
|
| 191 |
+.PP |
|
| 192 |
+I develope this module <http://github.com/yuki\-kimoto/DBIx\-Custom> |
|
| 193 |
+.SH "Copyright & license" |
|
| 194 |
+.IX Header "Copyright & license" |
|
| 195 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 196 |
+.PP |
|
| 197 |
+This program is free software; you can redistribute it and/or modify it |
|
| 198 |
+under the same terms as Perl itself. |
| ... | ... |
@@ -0,0 +1,222 @@ |
| 1 |
+.\" Automatically generated by Pod::Man v1.37, Pod::Parser v1.32 |
|
| 2 |
+.\" |
|
| 3 |
+.\" Standard preamble: |
|
| 4 |
+.\" ======================================================================== |
|
| 5 |
+.de Sh \" Subsection heading |
|
| 6 |
+.br |
|
| 7 |
+.if t .Sp |
|
| 8 |
+.ne 5 |
|
| 9 |
+.PP |
|
| 10 |
+\fB\\$1\fR |
|
| 11 |
+.PP |
|
| 12 |
+.. |
|
| 13 |
+.de Sp \" Vertical space (when we can't use .PP) |
|
| 14 |
+.if t .sp .5v |
|
| 15 |
+.if n .sp |
|
| 16 |
+.. |
|
| 17 |
+.de Vb \" Begin verbatim text |
|
| 18 |
+.ft CW |
|
| 19 |
+.nf |
|
| 20 |
+.ne \\$1 |
|
| 21 |
+.. |
|
| 22 |
+.de Ve \" End verbatim text |
|
| 23 |
+.ft R |
|
| 24 |
+.fi |
|
| 25 |
+.. |
|
| 26 |
+.\" Set up some character translations and predefined strings. \*(-- will |
|
| 27 |
+.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left |
|
| 28 |
+.\" double quote, and \*(R" will give a right double quote. | will give a |
|
| 29 |
+.\" real vertical bar. \*(C+ will give a nicer C++. Capital omega is used to |
|
| 30 |
+.\" do unbreakable dashes and therefore won't be available. \*(C` and \*(C' |
|
| 31 |
+.\" expand to `' in nroff, nothing in troff, for use with C<>. |
|
| 32 |
+.tr \(*W-|\(bv\*(Tr |
|
| 33 |
+.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p' |
|
| 34 |
+.ie n \{\
|
|
| 35 |
+. ds -- \(*W- |
|
| 36 |
+. ds PI pi |
|
| 37 |
+. if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch |
|
| 38 |
+. if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch |
|
| 39 |
+. ds L" "" |
|
| 40 |
+. ds R" "" |
|
| 41 |
+. ds C` "" |
|
| 42 |
+. ds C' "" |
|
| 43 |
+'br\} |
|
| 44 |
+.el\{\
|
|
| 45 |
+. ds -- \|\(em\| |
|
| 46 |
+. ds PI \(*p |
|
| 47 |
+. ds L" `` |
|
| 48 |
+. ds R" '' |
|
| 49 |
+'br\} |
|
| 50 |
+.\" |
|
| 51 |
+.\" If the F register is turned on, we'll generate index entries on stderr for |
|
| 52 |
+.\" titles (.TH), headers (.SH), subsections (.Sh), items (.Ip), and index |
|
| 53 |
+.\" entries marked with X<> in POD. Of course, you'll have to process the |
|
| 54 |
+.\" output yourself in some meaningful fashion. |
|
| 55 |
+.if \nF \{\
|
|
| 56 |
+. de IX |
|
| 57 |
+. tm Index:\\$1\t\\n%\t"\\$2" |
|
| 58 |
+.. |
|
| 59 |
+. nr % 0 |
|
| 60 |
+. rr F |
|
| 61 |
+.\} |
|
| 62 |
+.\" |
|
| 63 |
+.\" For nroff, turn off justification. Always turn off hyphenation; it makes |
|
| 64 |
+.\" way too many mistakes in technical documents. |
|
| 65 |
+.hy 0 |
|
| 66 |
+.if n .na |
|
| 67 |
+.\" |
|
| 68 |
+.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2). |
|
| 69 |
+.\" Fear. Run. Save yourself. No user-serviceable parts. |
|
| 70 |
+. \" fudge factors for nroff and troff |
|
| 71 |
+.if n \{\
|
|
| 72 |
+. ds #H 0 |
|
| 73 |
+. ds #V .8m |
|
| 74 |
+. ds #F .3m |
|
| 75 |
+. ds #[ \f1 |
|
| 76 |
+. ds #] \fP |
|
| 77 |
+.\} |
|
| 78 |
+.if t \{\
|
|
| 79 |
+. ds #H ((1u-(\\\\n(.fu%2u))*.13m) |
|
| 80 |
+. ds #V .6m |
|
| 81 |
+. ds #F 0 |
|
| 82 |
+. ds #[ \& |
|
| 83 |
+. ds #] \& |
|
| 84 |
+.\} |
|
| 85 |
+. \" simple accents for nroff and troff |
|
| 86 |
+.if n \{\
|
|
| 87 |
+. ds ' \& |
|
| 88 |
+. ds ` \& |
|
| 89 |
+. ds ^ \& |
|
| 90 |
+. ds , \& |
|
| 91 |
+. ds ~ ~ |
|
| 92 |
+. ds / |
|
| 93 |
+.\} |
|
| 94 |
+.if t \{\
|
|
| 95 |
+. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u" |
|
| 96 |
+. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u' |
|
| 97 |
+. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u' |
|
| 98 |
+. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u' |
|
| 99 |
+. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u' |
|
| 100 |
+. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u' |
|
| 101 |
+.\} |
|
| 102 |
+. \" troff and (daisy-wheel) nroff accents |
|
| 103 |
+.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V' |
|
| 104 |
+.ds 8 \h'\*(#H'\(*b\h'-\*(#H' |
|
| 105 |
+.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#] |
|
| 106 |
+.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H' |
|
| 107 |
+.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u' |
|
| 108 |
+.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#] |
|
| 109 |
+.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#] |
|
| 110 |
+.ds ae a\h'-(\w'a'u*4/10)'e |
|
| 111 |
+.ds Ae A\h'-(\w'A'u*4/10)'E |
|
| 112 |
+. \" corrections for vroff |
|
| 113 |
+.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u' |
|
| 114 |
+.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u' |
|
| 115 |
+. \" for low resolution devices (crt and lpr) |
|
| 116 |
+.if \n(.H>23 .if \n(.V>19 \ |
|
| 117 |
+\{\
|
|
| 118 |
+. ds : e |
|
| 119 |
+. ds 8 ss |
|
| 120 |
+. ds o a |
|
| 121 |
+. ds d- d\h'-1'\(ga |
|
| 122 |
+. ds D- D\h'-1'\(hy |
|
| 123 |
+. ds th \o'bp' |
|
| 124 |
+. ds Th \o'LP' |
|
| 125 |
+. ds ae ae |
|
| 126 |
+. ds Ae AE |
|
| 127 |
+.\} |
|
| 128 |
+.rm #[ #] #H #V #F C |
|
| 129 |
+.\" ======================================================================== |
|
| 130 |
+.\" |
|
| 131 |
+.IX Title "DBIx::Custom::Query 3" |
|
| 132 |
+.TH DBIx::Custom::Query 3 "2009-11-16" "perl v5.8.8" "User Contributed Perl Documentation" |
|
| 133 |
+.SH "NAME" |
|
| 134 |
+DBIx::Custom::Query \- Query object for DBIx::Custom |
|
| 135 |
+.SH "VERSION" |
|
| 136 |
+.IX Header "VERSION" |
|
| 137 |
+Version 0.0101 |
|
| 138 |
+.SH "SYNOPSIS" |
|
| 139 |
+.IX Header "SYNOPSIS" |
|
| 140 |
+.Vb 3 |
|
| 141 |
+\& # Create query |
|
| 142 |
+\& my $dbi = DBIx::Custom->new; |
|
| 143 |
+\& my $query = $dbi->create_query($template); |
|
| 144 |
+.Ve |
|
| 145 |
+.PP |
|
| 146 |
+.Vb 3 |
|
| 147 |
+\& # Set query attributes |
|
| 148 |
+\& $query->bind_filter($dbi->filters->{default_bind_filter});
|
|
| 149 |
+\& $query->no_bind_filters('title', 'author');
|
|
| 150 |
+.Ve |
|
| 151 |
+.PP |
|
| 152 |
+.Vb 2 |
|
| 153 |
+\& $query->fetch_filter($dbi->filters->{default_fetch_filter});
|
|
| 154 |
+\& $query->no_fetch_filters('title', 'author');
|
|
| 155 |
+.Ve |
|
| 156 |
+.PP |
|
| 157 |
+.Vb 2 |
|
| 158 |
+\& # Execute query |
|
| 159 |
+\& $dbi->execute($query, $params); |
|
| 160 |
+.Ve |
|
| 161 |
+.SH "OBJECT ACCESSORS" |
|
| 162 |
+.IX Header "OBJECT ACCESSORS" |
|
| 163 |
+.Sh "sth" |
|
| 164 |
+.IX Subsection "sth" |
|
| 165 |
+.Vb 3 |
|
| 166 |
+\& # Set and get statement handle |
|
| 167 |
+\& $self = $query->sth($sql); |
|
| 168 |
+\& $sth = $query->sth; |
|
| 169 |
+.Ve |
|
| 170 |
+.Sh "sql" |
|
| 171 |
+.IX Subsection "sql" |
|
| 172 |
+.Vb 3 |
|
| 173 |
+\& # Set and get SQL |
|
| 174 |
+\& $self = $query->sql($sql); |
|
| 175 |
+\& $sql = $query->sql; |
|
| 176 |
+.Ve |
|
| 177 |
+.Sh "bind_filter" |
|
| 178 |
+.IX Subsection "bind_filter" |
|
| 179 |
+.Vb 3 |
|
| 180 |
+\& # Set and get bind filter |
|
| 181 |
+\& $self = $query->bind_filter($bind_filter); |
|
| 182 |
+\& $bind_filter = $query->bind_filter; |
|
| 183 |
+.Ve |
|
| 184 |
+.Sh "no_bind_filters" |
|
| 185 |
+.IX Subsection "no_bind_filters" |
|
| 186 |
+.Vb 3 |
|
| 187 |
+\& # Set and get keys of no filtering |
|
| 188 |
+\& $self = $query->no_bind_filters($no_filters); |
|
| 189 |
+\& $no_bind_filters = $query->no_bind_filters; |
|
| 190 |
+.Ve |
|
| 191 |
+.Sh "fetch_filter" |
|
| 192 |
+.IX Subsection "fetch_filter" |
|
| 193 |
+.Vb 3 |
|
| 194 |
+\& # Set and get fetch filter |
|
| 195 |
+\& $self = $query->fetch_filter($fetch_filter); |
|
| 196 |
+\& $fetch_filter = $query->fetch_filter; |
|
| 197 |
+.Ve |
|
| 198 |
+.Sh "no_fetch_filters" |
|
| 199 |
+.IX Subsection "no_fetch_filters" |
|
| 200 |
+.Vb 3 |
|
| 201 |
+\& # Set and get keys of no filtering |
|
| 202 |
+\& $self = $query->no_fetch_filters($no_filters); |
|
| 203 |
+\& $no_fetch_filters = $query->no_fetch_filters; |
|
| 204 |
+.Ve |
|
| 205 |
+.Sh "key_infos" |
|
| 206 |
+.IX Subsection "key_infos" |
|
| 207 |
+.Vb 3 |
|
| 208 |
+\& # Set and get key informations |
|
| 209 |
+\& $self = $query->key_infos($key_infos); |
|
| 210 |
+\& $key_infos = $query->key_infos; |
|
| 211 |
+.Ve |
|
| 212 |
+.SH "AUTHOR" |
|
| 213 |
+.IX Header "AUTHOR" |
|
| 214 |
+Yuki Kimoto, \f(CW\*(C`<kimoto.yuki at gmail.com>\*(C'\fR |
|
| 215 |
+.PP |
|
| 216 |
+Github <http://github.com/yuki\-kimoto> |
|
| 217 |
+.SH "COPYRIGHT & LICENSE" |
|
| 218 |
+.IX Header "COPYRIGHT & LICENSE" |
|
| 219 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 220 |
+.PP |
|
| 221 |
+This program is free software; you can redistribute it and/or modify it |
|
| 222 |
+under the same terms as Perl itself. |
| ... | ... |
@@ -0,0 +1,367 @@ |
| 1 |
+.\" Automatically generated by Pod::Man v1.37, Pod::Parser v1.32 |
|
| 2 |
+.\" |
|
| 3 |
+.\" Standard preamble: |
|
| 4 |
+.\" ======================================================================== |
|
| 5 |
+.de Sh \" Subsection heading |
|
| 6 |
+.br |
|
| 7 |
+.if t .Sp |
|
| 8 |
+.ne 5 |
|
| 9 |
+.PP |
|
| 10 |
+\fB\\$1\fR |
|
| 11 |
+.PP |
|
| 12 |
+.. |
|
| 13 |
+.de Sp \" Vertical space (when we can't use .PP) |
|
| 14 |
+.if t .sp .5v |
|
| 15 |
+.if n .sp |
|
| 16 |
+.. |
|
| 17 |
+.de Vb \" Begin verbatim text |
|
| 18 |
+.ft CW |
|
| 19 |
+.nf |
|
| 20 |
+.ne \\$1 |
|
| 21 |
+.. |
|
| 22 |
+.de Ve \" End verbatim text |
|
| 23 |
+.ft R |
|
| 24 |
+.fi |
|
| 25 |
+.. |
|
| 26 |
+.\" Set up some character translations and predefined strings. \*(-- will |
|
| 27 |
+.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left |
|
| 28 |
+.\" double quote, and \*(R" will give a right double quote. | will give a |
|
| 29 |
+.\" real vertical bar. \*(C+ will give a nicer C++. Capital omega is used to |
|
| 30 |
+.\" do unbreakable dashes and therefore won't be available. \*(C` and \*(C' |
|
| 31 |
+.\" expand to `' in nroff, nothing in troff, for use with C<>. |
|
| 32 |
+.tr \(*W-|\(bv\*(Tr |
|
| 33 |
+.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p' |
|
| 34 |
+.ie n \{\
|
|
| 35 |
+. ds -- \(*W- |
|
| 36 |
+. ds PI pi |
|
| 37 |
+. if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch |
|
| 38 |
+. if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch |
|
| 39 |
+. ds L" "" |
|
| 40 |
+. ds R" "" |
|
| 41 |
+. ds C` "" |
|
| 42 |
+. ds C' "" |
|
| 43 |
+'br\} |
|
| 44 |
+.el\{\
|
|
| 45 |
+. ds -- \|\(em\| |
|
| 46 |
+. ds PI \(*p |
|
| 47 |
+. ds L" `` |
|
| 48 |
+. ds R" '' |
|
| 49 |
+'br\} |
|
| 50 |
+.\" |
|
| 51 |
+.\" If the F register is turned on, we'll generate index entries on stderr for |
|
| 52 |
+.\" titles (.TH), headers (.SH), subsections (.Sh), items (.Ip), and index |
|
| 53 |
+.\" entries marked with X<> in POD. Of course, you'll have to process the |
|
| 54 |
+.\" output yourself in some meaningful fashion. |
|
| 55 |
+.if \nF \{\
|
|
| 56 |
+. de IX |
|
| 57 |
+. tm Index:\\$1\t\\n%\t"\\$2" |
|
| 58 |
+.. |
|
| 59 |
+. nr % 0 |
|
| 60 |
+. rr F |
|
| 61 |
+.\} |
|
| 62 |
+.\" |
|
| 63 |
+.\" For nroff, turn off justification. Always turn off hyphenation; it makes |
|
| 64 |
+.\" way too many mistakes in technical documents. |
|
| 65 |
+.hy 0 |
|
| 66 |
+.if n .na |
|
| 67 |
+.\" |
|
| 68 |
+.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2). |
|
| 69 |
+.\" Fear. Run. Save yourself. No user-serviceable parts. |
|
| 70 |
+. \" fudge factors for nroff and troff |
|
| 71 |
+.if n \{\
|
|
| 72 |
+. ds #H 0 |
|
| 73 |
+. ds #V .8m |
|
| 74 |
+. ds #F .3m |
|
| 75 |
+. ds #[ \f1 |
|
| 76 |
+. ds #] \fP |
|
| 77 |
+.\} |
|
| 78 |
+.if t \{\
|
|
| 79 |
+. ds #H ((1u-(\\\\n(.fu%2u))*.13m) |
|
| 80 |
+. ds #V .6m |
|
| 81 |
+. ds #F 0 |
|
| 82 |
+. ds #[ \& |
|
| 83 |
+. ds #] \& |
|
| 84 |
+.\} |
|
| 85 |
+. \" simple accents for nroff and troff |
|
| 86 |
+.if n \{\
|
|
| 87 |
+. ds ' \& |
|
| 88 |
+. ds ` \& |
|
| 89 |
+. ds ^ \& |
|
| 90 |
+. ds , \& |
|
| 91 |
+. ds ~ ~ |
|
| 92 |
+. ds / |
|
| 93 |
+.\} |
|
| 94 |
+.if t \{\
|
|
| 95 |
+. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u" |
|
| 96 |
+. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u' |
|
| 97 |
+. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u' |
|
| 98 |
+. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u' |
|
| 99 |
+. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u' |
|
| 100 |
+. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u' |
|
| 101 |
+.\} |
|
| 102 |
+. \" troff and (daisy-wheel) nroff accents |
|
| 103 |
+.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V' |
|
| 104 |
+.ds 8 \h'\*(#H'\(*b\h'-\*(#H' |
|
| 105 |
+.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#] |
|
| 106 |
+.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H' |
|
| 107 |
+.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u' |
|
| 108 |
+.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#] |
|
| 109 |
+.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#] |
|
| 110 |
+.ds ae a\h'-(\w'a'u*4/10)'e |
|
| 111 |
+.ds Ae A\h'-(\w'A'u*4/10)'E |
|
| 112 |
+. \" corrections for vroff |
|
| 113 |
+.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u' |
|
| 114 |
+.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u' |
|
| 115 |
+. \" for low resolution devices (crt and lpr) |
|
| 116 |
+.if \n(.H>23 .if \n(.V>19 \ |
|
| 117 |
+\{\
|
|
| 118 |
+. ds : e |
|
| 119 |
+. ds 8 ss |
|
| 120 |
+. ds o a |
|
| 121 |
+. ds d- d\h'-1'\(ga |
|
| 122 |
+. ds D- D\h'-1'\(hy |
|
| 123 |
+. ds th \o'bp' |
|
| 124 |
+. ds Th \o'LP' |
|
| 125 |
+. ds ae ae |
|
| 126 |
+. ds Ae AE |
|
| 127 |
+.\} |
|
| 128 |
+.rm #[ #] #H #V #F C |
|
| 129 |
+.\" ======================================================================== |
|
| 130 |
+.\" |
|
| 131 |
+.IX Title "DBIx::Custom::Result 3" |
|
| 132 |
+.TH DBIx::Custom::Result 3 "2009-11-16" "perl v5.8.8" "User Contributed Perl Documentation" |
|
| 133 |
+.SH "NAME" |
|
| 134 |
+DBIx::Custom::Result \- Resultset for DBIx::Custom |
|
| 135 |
+.SH "VERSION" |
|
| 136 |
+.IX Header "VERSION" |
|
| 137 |
+Version 0.0301 |
|
| 138 |
+.SH "SYNOPSIS" |
|
| 139 |
+.IX Header "SYNOPSIS" |
|
| 140 |
+.Vb 3 |
|
| 141 |
+\& # $result is DBIx::Custom::Result object |
|
| 142 |
+\& my $dbi = DBIx::Custom->new; |
|
| 143 |
+\& my $result = $dbi->query($sql_template, $param); |
|
| 144 |
+.Ve |
|
| 145 |
+.PP |
|
| 146 |
+.Vb 3 |
|
| 147 |
+\& while (my ($val1, $val2) = $result->fetch) {
|
|
| 148 |
+\& # do something |
|
| 149 |
+\& } |
|
| 150 |
+.Ve |
|
| 151 |
+.SH "OBJECT ACCESSORS" |
|
| 152 |
+.IX Header "OBJECT ACCESSORS" |
|
| 153 |
+.Sh "sth" |
|
| 154 |
+.IX Subsection "sth" |
|
| 155 |
+.Vb 3 |
|
| 156 |
+\& # Set and Get statement handle |
|
| 157 |
+\& $self = $result->sth($sth); |
|
| 158 |
+\& $sth = $reuslt->sth |
|
| 159 |
+.Ve |
|
| 160 |
+.PP |
|
| 161 |
+Statement handle is automatically set by DBIx::Custom. |
|
| 162 |
+so you do not set statement handle. |
|
| 163 |
+.PP |
|
| 164 |
+If you need statement handle, you can get statement handle by using this method. |
|
| 165 |
+.Sh "fetch_filter" |
|
| 166 |
+.IX Subsection "fetch_filter" |
|
| 167 |
+.Vb 3 |
|
| 168 |
+\& # Set and Get fetch filter |
|
| 169 |
+\& $self = $result->fetch_filter($sth); |
|
| 170 |
+\& $fetch_filter = $result->fech_filter; |
|
| 171 |
+.Ve |
|
| 172 |
+.PP |
|
| 173 |
+Statement handle is automatically set by DBIx::Custom. |
|
| 174 |
+If you want to set your fetch filter, you set it. |
|
| 175 |
+.Sh "no_fetch_filters" |
|
| 176 |
+.IX Subsection "no_fetch_filters" |
|
| 177 |
+.Vb 3 |
|
| 178 |
+\& # Set and Get no filter keys when fetching |
|
| 179 |
+\& $self = $result->no_fetch_filters($no_fetch_filters); |
|
| 180 |
+\& $no_fetch_filters = $result->no_fetch_filters; |
|
| 181 |
+.Ve |
|
| 182 |
+.SH "METHODS" |
|
| 183 |
+.IX Header "METHODS" |
|
| 184 |
+.Sh "fetch" |
|
| 185 |
+.IX Subsection "fetch" |
|
| 186 |
+.Vb 2 |
|
| 187 |
+\& # Fetch row as array reference (Scalar context) |
|
| 188 |
+\& $row = $result->fetch; |
|
| 189 |
+.Ve |
|
| 190 |
+.PP |
|
| 191 |
+.Vb 2 |
|
| 192 |
+\& # Fetch row as array (List context) |
|
| 193 |
+\& @row = $result->fecth |
|
| 194 |
+.Ve |
|
| 195 |
+.PP |
|
| 196 |
+.Vb 6 |
|
| 197 |
+\& # Sample |
|
| 198 |
+\& while (my $row = $result->fetch) {
|
|
| 199 |
+\& # do something |
|
| 200 |
+\& my $val1 = $row->[0]; |
|
| 201 |
+\& my $val2 = $row->[1]; |
|
| 202 |
+\& } |
|
| 203 |
+.Ve |
|
| 204 |
+.PP |
|
| 205 |
+fetch method is fetch resultset and get row as array or array reference. |
|
| 206 |
+.Sh "fetch_hash" |
|
| 207 |
+.IX Subsection "fetch_hash" |
|
| 208 |
+.Vb 2 |
|
| 209 |
+\& # Fetch row as hash reference (Scalar context) |
|
| 210 |
+\& $row = $result->fetch_hash; |
|
| 211 |
+.Ve |
|
| 212 |
+.PP |
|
| 213 |
+.Vb 2 |
|
| 214 |
+\& # Fetch row as hash (List context) |
|
| 215 |
+\& %row = $result->fecth_hash |
|
| 216 |
+.Ve |
|
| 217 |
+.PP |
|
| 218 |
+.Vb 6 |
|
| 219 |
+\& # Sample |
|
| 220 |
+\& while (my $row = $result->fetch_hash) {
|
|
| 221 |
+\& # do something |
|
| 222 |
+\& my $val1 = $row->{key1};
|
|
| 223 |
+\& my $val2 = $row->{key2};
|
|
| 224 |
+\& } |
|
| 225 |
+.Ve |
|
| 226 |
+.PP |
|
| 227 |
+fetch_hash method is fetch resultset and get row as hash or hash reference. |
|
| 228 |
+.Sh "fetch_first" |
|
| 229 |
+.IX Subsection "fetch_first" |
|
| 230 |
+.Vb 2 |
|
| 231 |
+\& # Fetch only first (Scalar context) |
|
| 232 |
+\& $row = $result->fetch_first; |
|
| 233 |
+.Ve |
|
| 234 |
+.PP |
|
| 235 |
+.Vb 2 |
|
| 236 |
+\& # Fetch only first (List context) |
|
| 237 |
+\& @row = $result->fetch_first; |
|
| 238 |
+.Ve |
|
| 239 |
+.PP |
|
| 240 |
+This method fetch only first and finish statement handle |
|
| 241 |
+.Sh "fetch_hash_first" |
|
| 242 |
+.IX Subsection "fetch_hash_first" |
|
| 243 |
+.Vb 2 |
|
| 244 |
+\& # Fetch only first as hash (Scalar context) |
|
| 245 |
+\& $row = $result->fetch_hash_first; |
|
| 246 |
+.Ve |
|
| 247 |
+.PP |
|
| 248 |
+.Vb 2 |
|
| 249 |
+\& # Fetch only first as hash (Scalar context) |
|
| 250 |
+\& @row = $result->fetch_hash_first; |
|
| 251 |
+.Ve |
|
| 252 |
+.PP |
|
| 253 |
+This method fetch only first and finish statement handle |
|
| 254 |
+.Sh "fetch_rows" |
|
| 255 |
+.IX Subsection "fetch_rows" |
|
| 256 |
+.Vb 2 |
|
| 257 |
+\& # Fetch multi rows (Scalar context) |
|
| 258 |
+\& $rows = $result->fetch_rows($row_count); |
|
| 259 |
+.Ve |
|
| 260 |
+.PP |
|
| 261 |
+.Vb 2 |
|
| 262 |
+\& # Fetch multi rows (List context) |
|
| 263 |
+\& @rows = $result->fetch_rows($row_count); |
|
| 264 |
+.Ve |
|
| 265 |
+.PP |
|
| 266 |
+.Vb 2 |
|
| 267 |
+\& # Sapmle |
|
| 268 |
+\& $rows = $result->fetch_rows(10); |
|
| 269 |
+.Ve |
|
| 270 |
+.Sh "fetch_hash_rows" |
|
| 271 |
+.IX Subsection "fetch_hash_rows" |
|
| 272 |
+.Vb 2 |
|
| 273 |
+\& # Fetch multi rows as hash (Scalar context) |
|
| 274 |
+\& $rows = $result->fetch_hash_rows($row_count); |
|
| 275 |
+.Ve |
|
| 276 |
+.PP |
|
| 277 |
+.Vb 2 |
|
| 278 |
+\& # Fetch multi rows as hash (List context) |
|
| 279 |
+\& @rows = $result->fetch_hash_rows($row_count); |
|
| 280 |
+.Ve |
|
| 281 |
+.PP |
|
| 282 |
+.Vb 2 |
|
| 283 |
+\& # Sapmle |
|
| 284 |
+\& $rows = $result->fetch_hash_rows(10); |
|
| 285 |
+.Ve |
|
| 286 |
+.Sh "fetch_all" |
|
| 287 |
+.IX Subsection "fetch_all" |
|
| 288 |
+.Vb 2 |
|
| 289 |
+\& # Fetch all row as array ref of array ref (Scalar context) |
|
| 290 |
+\& $rows = $result->fetch_all; |
|
| 291 |
+.Ve |
|
| 292 |
+.PP |
|
| 293 |
+.Vb 2 |
|
| 294 |
+\& # Fetch all row as array of array ref (List context) |
|
| 295 |
+\& @rows = $result->fecth_all; |
|
| 296 |
+.Ve |
|
| 297 |
+.PP |
|
| 298 |
+.Vb 4 |
|
| 299 |
+\& # Sample |
|
| 300 |
+\& my $rows = $result->fetch_all; |
|
| 301 |
+\& my $val0_0 = $rows->[0][0]; |
|
| 302 |
+\& my $val1_1 = $rows->[1][1]; |
|
| 303 |
+.Ve |
|
| 304 |
+.PP |
|
| 305 |
+fetch_all method is fetch resultset and get all rows as array or array reference. |
|
| 306 |
+.Sh "fetch_hash_all" |
|
| 307 |
+.IX Subsection "fetch_hash_all" |
|
| 308 |
+.Vb 2 |
|
| 309 |
+\& # Fetch all row as array ref of hash ref (Scalar context) |
|
| 310 |
+\& $rows = $result->fetch_hash_all; |
|
| 311 |
+.Ve |
|
| 312 |
+.PP |
|
| 313 |
+.Vb 2 |
|
| 314 |
+\& # Fetch all row as array of hash ref (List context) |
|
| 315 |
+\& @rows = $result->fecth_all_hash; |
|
| 316 |
+.Ve |
|
| 317 |
+.PP |
|
| 318 |
+.Vb 4 |
|
| 319 |
+\& # Sample |
|
| 320 |
+\& my $rows = $result->fetch_hash_all; |
|
| 321 |
+\& my $val0_key1 = $rows->[0]{key1};
|
|
| 322 |
+\& my $val1_key2 = $rows->[1]{key2};
|
|
| 323 |
+.Ve |
|
| 324 |
+.Sh "error" |
|
| 325 |
+.IX Subsection "error" |
|
| 326 |
+.Vb 3 |
|
| 327 |
+\& # Get error infomation |
|
| 328 |
+\& $error_messege = $result->error; |
|
| 329 |
+\& ($error_message, $error_number, $error_state) = $result->error; |
|
| 330 |
+.Ve |
|
| 331 |
+.PP |
|
| 332 |
+You can get get information. This is crenspond to the following. |
|
| 333 |
+.PP |
|
| 334 |
+.Vb 3 |
|
| 335 |
+\& $error_message : $result->sth->errstr |
|
| 336 |
+\& $error_number : $result->sth->err |
|
| 337 |
+\& $error_state : $result->sth->state |
|
| 338 |
+.Ve |
|
| 339 |
+.Sh "finish" |
|
| 340 |
+.IX Subsection "finish" |
|
| 341 |
+.Vb 2 |
|
| 342 |
+\& # Finish statement handle |
|
| 343 |
+\& $result->finish |
|
| 344 |
+.Ve |
|
| 345 |
+.PP |
|
| 346 |
+.Vb 3 |
|
| 347 |
+\& # Sample |
|
| 348 |
+\& my $row = $reuslt->fetch; # fetch only one row |
|
| 349 |
+\& $result->finish |
|
| 350 |
+.Ve |
|
| 351 |
+.PP |
|
| 352 |
+You can finish statement handle.This is equel to |
|
| 353 |
+.PP |
|
| 354 |
+.Vb 1 |
|
| 355 |
+\& $result->sth->finish; |
|
| 356 |
+.Ve |
|
| 357 |
+.SH "AUTHOR" |
|
| 358 |
+.IX Header "AUTHOR" |
|
| 359 |
+Yuki Kimoto, \f(CW\*(C`<kimoto.yuki at gmail.com>\*(C'\fR |
|
| 360 |
+.PP |
|
| 361 |
+Github <http://github.com/yuki\-kimoto> |
|
| 362 |
+.SH "COPYRIGHT & LICENSE" |
|
| 363 |
+.IX Header "COPYRIGHT & LICENSE" |
|
| 364 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 365 |
+.PP |
|
| 366 |
+This program is free software; you can redistribute it and/or modify it |
|
| 367 |
+under the same terms as Perl itself. |
| ... | ... |
@@ -0,0 +1,404 @@ |
| 1 |
+.\" Automatically generated by Pod::Man v1.37, Pod::Parser v1.32 |
|
| 2 |
+.\" |
|
| 3 |
+.\" Standard preamble: |
|
| 4 |
+.\" ======================================================================== |
|
| 5 |
+.de Sh \" Subsection heading |
|
| 6 |
+.br |
|
| 7 |
+.if t .Sp |
|
| 8 |
+.ne 5 |
|
| 9 |
+.PP |
|
| 10 |
+\fB\\$1\fR |
|
| 11 |
+.PP |
|
| 12 |
+.. |
|
| 13 |
+.de Sp \" Vertical space (when we can't use .PP) |
|
| 14 |
+.if t .sp .5v |
|
| 15 |
+.if n .sp |
|
| 16 |
+.. |
|
| 17 |
+.de Vb \" Begin verbatim text |
|
| 18 |
+.ft CW |
|
| 19 |
+.nf |
|
| 20 |
+.ne \\$1 |
|
| 21 |
+.. |
|
| 22 |
+.de Ve \" End verbatim text |
|
| 23 |
+.ft R |
|
| 24 |
+.fi |
|
| 25 |
+.. |
|
| 26 |
+.\" Set up some character translations and predefined strings. \*(-- will |
|
| 27 |
+.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left |
|
| 28 |
+.\" double quote, and \*(R" will give a right double quote. | will give a |
|
| 29 |
+.\" real vertical bar. \*(C+ will give a nicer C++. Capital omega is used to |
|
| 30 |
+.\" do unbreakable dashes and therefore won't be available. \*(C` and \*(C' |
|
| 31 |
+.\" expand to `' in nroff, nothing in troff, for use with C<>. |
|
| 32 |
+.tr \(*W-|\(bv\*(Tr |
|
| 33 |
+.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p' |
|
| 34 |
+.ie n \{\
|
|
| 35 |
+. ds -- \(*W- |
|
| 36 |
+. ds PI pi |
|
| 37 |
+. if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch |
|
| 38 |
+. if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch |
|
| 39 |
+. ds L" "" |
|
| 40 |
+. ds R" "" |
|
| 41 |
+. ds C` "" |
|
| 42 |
+. ds C' "" |
|
| 43 |
+'br\} |
|
| 44 |
+.el\{\
|
|
| 45 |
+. ds -- \|\(em\| |
|
| 46 |
+. ds PI \(*p |
|
| 47 |
+. ds L" `` |
|
| 48 |
+. ds R" '' |
|
| 49 |
+'br\} |
|
| 50 |
+.\" |
|
| 51 |
+.\" If the F register is turned on, we'll generate index entries on stderr for |
|
| 52 |
+.\" titles (.TH), headers (.SH), subsections (.Sh), items (.Ip), and index |
|
| 53 |
+.\" entries marked with X<> in POD. Of course, you'll have to process the |
|
| 54 |
+.\" output yourself in some meaningful fashion. |
|
| 55 |
+.if \nF \{\
|
|
| 56 |
+. de IX |
|
| 57 |
+. tm Index:\\$1\t\\n%\t"\\$2" |
|
| 58 |
+.. |
|
| 59 |
+. nr % 0 |
|
| 60 |
+. rr F |
|
| 61 |
+.\} |
|
| 62 |
+.\" |
|
| 63 |
+.\" For nroff, turn off justification. Always turn off hyphenation; it makes |
|
| 64 |
+.\" way too many mistakes in technical documents. |
|
| 65 |
+.hy 0 |
|
| 66 |
+.if n .na |
|
| 67 |
+.\" |
|
| 68 |
+.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2). |
|
| 69 |
+.\" Fear. Run. Save yourself. No user-serviceable parts. |
|
| 70 |
+. \" fudge factors for nroff and troff |
|
| 71 |
+.if n \{\
|
|
| 72 |
+. ds #H 0 |
|
| 73 |
+. ds #V .8m |
|
| 74 |
+. ds #F .3m |
|
| 75 |
+. ds #[ \f1 |
|
| 76 |
+. ds #] \fP |
|
| 77 |
+.\} |
|
| 78 |
+.if t \{\
|
|
| 79 |
+. ds #H ((1u-(\\\\n(.fu%2u))*.13m) |
|
| 80 |
+. ds #V .6m |
|
| 81 |
+. ds #F 0 |
|
| 82 |
+. ds #[ \& |
|
| 83 |
+. ds #] \& |
|
| 84 |
+.\} |
|
| 85 |
+. \" simple accents for nroff and troff |
|
| 86 |
+.if n \{\
|
|
| 87 |
+. ds ' \& |
|
| 88 |
+. ds ` \& |
|
| 89 |
+. ds ^ \& |
|
| 90 |
+. ds , \& |
|
| 91 |
+. ds ~ ~ |
|
| 92 |
+. ds / |
|
| 93 |
+.\} |
|
| 94 |
+.if t \{\
|
|
| 95 |
+. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u" |
|
| 96 |
+. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u' |
|
| 97 |
+. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u' |
|
| 98 |
+. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u' |
|
| 99 |
+. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u' |
|
| 100 |
+. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u' |
|
| 101 |
+.\} |
|
| 102 |
+. \" troff and (daisy-wheel) nroff accents |
|
| 103 |
+.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V' |
|
| 104 |
+.ds 8 \h'\*(#H'\(*b\h'-\*(#H' |
|
| 105 |
+.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#] |
|
| 106 |
+.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H' |
|
| 107 |
+.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u' |
|
| 108 |
+.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#] |
|
| 109 |
+.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#] |
|
| 110 |
+.ds ae a\h'-(\w'a'u*4/10)'e |
|
| 111 |
+.ds Ae A\h'-(\w'A'u*4/10)'E |
|
| 112 |
+. \" corrections for vroff |
|
| 113 |
+.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u' |
|
| 114 |
+.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u' |
|
| 115 |
+. \" for low resolution devices (crt and lpr) |
|
| 116 |
+.if \n(.H>23 .if \n(.V>19 \ |
|
| 117 |
+\{\
|
|
| 118 |
+. ds : e |
|
| 119 |
+. ds 8 ss |
|
| 120 |
+. ds o a |
|
| 121 |
+. ds d- d\h'-1'\(ga |
|
| 122 |
+. ds D- D\h'-1'\(hy |
|
| 123 |
+. ds th \o'bp' |
|
| 124 |
+. ds Th \o'LP' |
|
| 125 |
+. ds ae ae |
|
| 126 |
+. ds Ae AE |
|
| 127 |
+.\} |
|
| 128 |
+.rm #[ #] #H #V #F C |
|
| 129 |
+.\" ======================================================================== |
|
| 130 |
+.\" |
|
| 131 |
+.IX Title "DBIx::Custom::SQL::Template 3" |
|
| 132 |
+.TH DBIx::Custom::SQL::Template 3 "2009-11-16" "perl v5.8.8" "User Contributed Perl Documentation" |
|
| 133 |
+.SH "NAME" |
|
| 134 |
+DBIx::Custom::SQL::Template \- Custamizable SQL Template for DBIx::Custom |
|
| 135 |
+.SH "VERSION" |
|
| 136 |
+.IX Header "VERSION" |
|
| 137 |
+Version 0.0101 |
|
| 138 |
+.SH "SYNOPSIS" |
|
| 139 |
+.IX Header "SYNOPSIS" |
|
| 140 |
+.Vb 1 |
|
| 141 |
+\& my $sql_tmpl = DBIx::Custom::SQL::Template->new; |
|
| 142 |
+.Ve |
|
| 143 |
+.PP |
|
| 144 |
+.Vb 2 |
|
| 145 |
+\& my $tmpl = "select from table {= k1} && {<> k2} || {like k3}";
|
|
| 146 |
+\& my $param = {k1 => 1, k2 => 2, k3 => 3};
|
|
| 147 |
+.Ve |
|
| 148 |
+.PP |
|
| 149 |
+.Vb 1 |
|
| 150 |
+\& my $query = $sql_template->create_query($tmpl); |
|
| 151 |
+.Ve |
|
| 152 |
+.PP |
|
| 153 |
+.Vb 8 |
|
| 154 |
+\& # Using query from DBIx::Custom |
|
| 155 |
+\& use DBIx::Custom; |
|
| 156 |
+\& my $dbi = DBI->new( |
|
| 157 |
+\& data_source => $data_source, |
|
| 158 |
+\& user => $user, |
|
| 159 |
+\& password => $password, |
|
| 160 |
+\& dbi_options => {PrintError => 0, RaiseError => 1}
|
|
| 161 |
+\& ); |
|
| 162 |
+.Ve |
|
| 163 |
+.PP |
|
| 164 |
+.Vb 2 |
|
| 165 |
+\& $query = $dbi->create_query($tmpl); # This is SQL::Template create_query |
|
| 166 |
+\& $dbi->query($query, $param); |
|
| 167 |
+.Ve |
|
| 168 |
+.SH "CLASS-OBJECT ACCESSORS" |
|
| 169 |
+.IX Header "CLASS-OBJECT ACCESSORS" |
|
| 170 |
+Class-Object accessor is used from both object and class |
|
| 171 |
+.PP |
|
| 172 |
+.Vb 2 |
|
| 173 |
+\& $class->$accessor # call from class |
|
| 174 |
+\& $self->$accessor # call form object |
|
| 175 |
+.Ve |
|
| 176 |
+.Sh "tag_processors" |
|
| 177 |
+.IX Subsection "tag_processors" |
|
| 178 |
+.Vb 3 |
|
| 179 |
+\& # Set and get |
|
| 180 |
+\& $self = $sql_tmpl->tag_processors($tag_processors); |
|
| 181 |
+\& $tag_processors = $sql_tmpl->tag_processors; |
|
| 182 |
+.Ve |
|
| 183 |
+.PP |
|
| 184 |
+.Vb 5 |
|
| 185 |
+\& # Sample |
|
| 186 |
+\& $sql_tmpl->tag_processors( |
|
| 187 |
+\& '?' => \e&expand_question, |
|
| 188 |
+\& '=' => \e&expand_equel |
|
| 189 |
+\& ); |
|
| 190 |
+.Ve |
|
| 191 |
+.PP |
|
| 192 |
+You can use add_tag_processor to add tag processor |
|
| 193 |
+.Sh "tag_start" |
|
| 194 |
+.IX Subsection "tag_start" |
|
| 195 |
+.Vb 3 |
|
| 196 |
+\& # Set and get |
|
| 197 |
+\& $self = $sql_tmpl->tag_start($tag_start); |
|
| 198 |
+\& $tag_start = $sql_tmpl->tag_start; |
|
| 199 |
+.Ve |
|
| 200 |
+.PP |
|
| 201 |
+.Vb 2 |
|
| 202 |
+\& # Sample |
|
| 203 |
+\& $sql_tmpl->tag_start('{');
|
|
| 204 |
+.Ve |
|
| 205 |
+.PP |
|
| 206 |
+Default is '{'
|
|
| 207 |
+.Sh "tag_end" |
|
| 208 |
+.IX Subsection "tag_end" |
|
| 209 |
+.Vb 3 |
|
| 210 |
+\& # Set and get |
|
| 211 |
+\& $self = $sql_tmpl->tag_start($tag_end); |
|
| 212 |
+\& $tag_end = $sql_tmpl->tag_start; |
|
| 213 |
+.Ve |
|
| 214 |
+.PP |
|
| 215 |
+.Vb 2 |
|
| 216 |
+\& # Sample |
|
| 217 |
+\& $sql_tmpl->tag_start('}');
|
|
| 218 |
+.Ve |
|
| 219 |
+.PP |
|
| 220 |
+Default is '}' |
|
| 221 |
+.Sh "tag_syntax" |
|
| 222 |
+.IX Subsection "tag_syntax" |
|
| 223 |
+.Vb 3 |
|
| 224 |
+\& # Set and get |
|
| 225 |
+\& $self = $sql_tmpl->tag_syntax($tag_syntax); |
|
| 226 |
+\& $tag_syntax = $sql_tmpl->tag_syntax; |
|
| 227 |
+.Ve |
|
| 228 |
+.PP |
|
| 229 |
+.Vb 7 |
|
| 230 |
+\& # Sample |
|
| 231 |
+\& $sql_tmpl->tag_syntax( |
|
| 232 |
+\& "[Tag] [Expand]\en" . |
|
| 233 |
+\& "{? name} ?\en" .
|
|
| 234 |
+\& "{= name} name = ?\en" .
|
|
| 235 |
+\& "{<> name} name <> ?\en"
|
|
| 236 |
+\& ); |
|
| 237 |
+.Ve |
|
| 238 |
+.SH "METHODS" |
|
| 239 |
+.IX Header "METHODS" |
|
| 240 |
+.Sh "create_query" |
|
| 241 |
+.IX Subsection "create_query" |
|
| 242 |
+.Vb 2 |
|
| 243 |
+\& # Create SQL form SQL template |
|
| 244 |
+\& $query = $sql_tmpl->create_query($tmpl); |
|
| 245 |
+.Ve |
|
| 246 |
+.PP |
|
| 247 |
+.Vb 3 |
|
| 248 |
+\& # Sample |
|
| 249 |
+\& $query = $sql_tmpl->create_sql( |
|
| 250 |
+\& "select * from table where {= title} && {like author} || {<= price}")
|
|
| 251 |
+.Ve |
|
| 252 |
+.PP |
|
| 253 |
+.Vb 3 |
|
| 254 |
+\& # Result |
|
| 255 |
+\& $qeury->{sql} : "select * from table where title = ? && author like ? price <= ?;"
|
|
| 256 |
+\& $query->{key_infos} : [['title'], ['author'], ['price']]
|
|
| 257 |
+.Ve |
|
| 258 |
+.PP |
|
| 259 |
+.Vb 5 |
|
| 260 |
+\& # Sample2 (with table name) |
|
| 261 |
+\& ($sql, @bind_values) = $sql_tmpl->create_sql( |
|
| 262 |
+\& "select * from table where {= table.title} && {like table.author}",
|
|
| 263 |
+\& {table => {title => 'Perl', author => '%Taro%'}}
|
|
| 264 |
+\& ) |
|
| 265 |
+.Ve |
|
| 266 |
+.PP |
|
| 267 |
+.Vb 4 |
|
| 268 |
+\& # Result2 |
|
| 269 |
+\& $query->{sql} : "select * from table where table.title = ? && table.title like ?;"
|
|
| 270 |
+\& $query->{key_infos} :[ [['table.title'],['table', 'title']],
|
|
| 271 |
+\& [['table.author'],['table', 'author']] ] |
|
| 272 |
+.Ve |
|
| 273 |
+.PP |
|
| 274 |
+This method create query using by DBIx::Custom. |
|
| 275 |
+query is two infomation |
|
| 276 |
+.PP |
|
| 277 |
+.Vb 2 |
|
| 278 |
+\& 1.sql : SQL |
|
| 279 |
+\& 2.key_infos : Parameter access key information |
|
| 280 |
+.Ve |
|
| 281 |
+.Sh "add_tag_processor" |
|
| 282 |
+.IX Subsection "add_tag_processor" |
|
| 283 |
+Add tag processor |
|
| 284 |
+.PP |
|
| 285 |
+.Vb 2 |
|
| 286 |
+\& # Add |
|
| 287 |
+\& $self = $sql_tmpl->add_tag_processor($tag_processor); |
|
| 288 |
+.Ve |
|
| 289 |
+.PP |
|
| 290 |
+.Vb 4 |
|
| 291 |
+\& # Sample |
|
| 292 |
+\& $sql_tmpl->add_tag_processor( |
|
| 293 |
+\& '?' => sub {
|
|
| 294 |
+\& my ($tag_name, $tag_args) = @_; |
|
| 295 |
+.Ve |
|
| 296 |
+.PP |
|
| 297 |
+.Vb 2 |
|
| 298 |
+\& my $key1 = $tag_args->[0]; |
|
| 299 |
+\& my $key2 = $tag_args->[1]; |
|
| 300 |
+.Ve |
|
| 301 |
+.PP |
|
| 302 |
+.Vb 1 |
|
| 303 |
+\& my $key_infos = []; |
|
| 304 |
+.Ve |
|
| 305 |
+.PP |
|
| 306 |
+.Vb 1 |
|
| 307 |
+\& # Expand tag and create key informations |
|
| 308 |
+.Ve |
|
| 309 |
+.PP |
|
| 310 |
+.Vb 4 |
|
| 311 |
+\& # Return expand tags and key informations |
|
| 312 |
+\& return ($expand, $key_infos); |
|
| 313 |
+\& } |
|
| 314 |
+\& ); |
|
| 315 |
+.Ve |
|
| 316 |
+.PP |
|
| 317 |
+Tag processor recieve 2 argument |
|
| 318 |
+.PP |
|
| 319 |
+.Vb 2 |
|
| 320 |
+\& 1. Tag name (?, =, <>, or etc) |
|
| 321 |
+\& 2. Tag arguments (arg1 and arg2 in {tag_name arg1 arg2})
|
|
| 322 |
+.Ve |
|
| 323 |
+.PP |
|
| 324 |
+Tag processor return 2 value |
|
| 325 |
+.PP |
|
| 326 |
+.Vb 2 |
|
| 327 |
+\& 1. Expanded Tag (For exsample, '{= title}' is expanded to 'title = ?')
|
|
| 328 |
+\& 2. Key infomations |
|
| 329 |
+.Ve |
|
| 330 |
+.PP |
|
| 331 |
+You must be return expanded tag and key infomations. |
|
| 332 |
+.PP |
|
| 333 |
+Key information is a little complex. so I will explan this in future. |
|
| 334 |
+.PP |
|
| 335 |
+If you want to know more, Please see DBIx::Custom::SQL::Template source code. |
|
| 336 |
+.Sh "clone" |
|
| 337 |
+.IX Subsection "clone" |
|
| 338 |
+.Vb 2 |
|
| 339 |
+\& # Clone DBIx::Custom::SQL::Template object |
|
| 340 |
+\& $clone = $self->clone; |
|
| 341 |
+.Ve |
|
| 342 |
+.SH "Available Tags" |
|
| 343 |
+.IX Header "Available Tags" |
|
| 344 |
+.Vb 5 |
|
| 345 |
+\& # Available Tags |
|
| 346 |
+\& [tag] [expand] |
|
| 347 |
+\& {? name} ?
|
|
| 348 |
+\& {= name} name = ?
|
|
| 349 |
+\& {<> name} name <> ?
|
|
| 350 |
+.Ve |
|
| 351 |
+.PP |
|
| 352 |
+.Vb 4 |
|
| 353 |
+\& {< name} name < ?
|
|
| 354 |
+\& {> name} name > ?
|
|
| 355 |
+\& {>= name} name >= ?
|
|
| 356 |
+\& {<= name} name <= ?
|
|
| 357 |
+.Ve |
|
| 358 |
+.PP |
|
| 359 |
+.Vb 2 |
|
| 360 |
+\& {like name} name like ?
|
|
| 361 |
+\& {in name} name in [?, ?, ..]
|
|
| 362 |
+.Ve |
|
| 363 |
+.PP |
|
| 364 |
+.Vb 2 |
|
| 365 |
+\& {insert} (key1, key2, key3) values (?, ?, ?)
|
|
| 366 |
+\& {update} set key1 = ?, key2 = ?, key3 = ?
|
|
| 367 |
+.Ve |
|
| 368 |
+.PP |
|
| 369 |
+.Vb 6 |
|
| 370 |
+\& # Sample1 |
|
| 371 |
+\& $query = $sql_tmpl->create_sql( |
|
| 372 |
+\& "insert into table {insert key1 key2}"
|
|
| 373 |
+\& ); |
|
| 374 |
+\& # Result1 |
|
| 375 |
+\& $sql : "insert into table (key1, key2) values (?, ?)" |
|
| 376 |
+.Ve |
|
| 377 |
+.PP |
|
| 378 |
+.Vb 4 |
|
| 379 |
+\& # Sample2 |
|
| 380 |
+\& $query = $sql_tmpl->create_sql( |
|
| 381 |
+\& "update table {update key1 key2} where {= key3}"
|
|
| 382 |
+\& ); |
|
| 383 |
+.Ve |
|
| 384 |
+.PP |
|
| 385 |
+.Vb 2 |
|
| 386 |
+\& # Result2 |
|
| 387 |
+\& $query->{sql} : "update table set key1 = ?, key2 = ? where key3 = ?;"
|
|
| 388 |
+.Ve |
|
| 389 |
+.SH "AUTHOR" |
|
| 390 |
+.IX Header "AUTHOR" |
|
| 391 |
+Yuki Kimoto, \f(CW\*(C`<kimoto.yuki at gmail.com>\*(C'\fR |
|
| 392 |
+.PP |
|
| 393 |
+Github |
|
| 394 |
+<http://github.com/yuki\-kimoto> |
|
| 395 |
+<http://github.com/yuki\-kimoto/DBIx\-Custom\-SQL\-Template> |
|
| 396 |
+.PP |
|
| 397 |
+Please let know me bag if you find |
|
| 398 |
+Please request me if you want to do something |
|
| 399 |
+.SH "COPYRIGHT & LICENSE" |
|
| 400 |
+.IX Header "COPYRIGHT & LICENSE" |
|
| 401 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 402 |
+.PP |
|
| 403 |
+This program is free software; you can redistribute it and/or modify it |
|
| 404 |
+under the same terms as Perl itself. |
| ... | ... |
@@ -0,0 +1,229 @@ |
| 1 |
+.\" Automatically generated by Pod::Man v1.37, Pod::Parser v1.32 |
|
| 2 |
+.\" |
|
| 3 |
+.\" Standard preamble: |
|
| 4 |
+.\" ======================================================================== |
|
| 5 |
+.de Sh \" Subsection heading |
|
| 6 |
+.br |
|
| 7 |
+.if t .Sp |
|
| 8 |
+.ne 5 |
|
| 9 |
+.PP |
|
| 10 |
+\fB\\$1\fR |
|
| 11 |
+.PP |
|
| 12 |
+.. |
|
| 13 |
+.de Sp \" Vertical space (when we can't use .PP) |
|
| 14 |
+.if t .sp .5v |
|
| 15 |
+.if n .sp |
|
| 16 |
+.. |
|
| 17 |
+.de Vb \" Begin verbatim text |
|
| 18 |
+.ft CW |
|
| 19 |
+.nf |
|
| 20 |
+.ne \\$1 |
|
| 21 |
+.. |
|
| 22 |
+.de Ve \" End verbatim text |
|
| 23 |
+.ft R |
|
| 24 |
+.fi |
|
| 25 |
+.. |
|
| 26 |
+.\" Set up some character translations and predefined strings. \*(-- will |
|
| 27 |
+.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left |
|
| 28 |
+.\" double quote, and \*(R" will give a right double quote. | will give a |
|
| 29 |
+.\" real vertical bar. \*(C+ will give a nicer C++. Capital omega is used to |
|
| 30 |
+.\" do unbreakable dashes and therefore won't be available. \*(C` and \*(C' |
|
| 31 |
+.\" expand to `' in nroff, nothing in troff, for use with C<>. |
|
| 32 |
+.tr \(*W-|\(bv\*(Tr |
|
| 33 |
+.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p' |
|
| 34 |
+.ie n \{\
|
|
| 35 |
+. ds -- \(*W- |
|
| 36 |
+. ds PI pi |
|
| 37 |
+. if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch |
|
| 38 |
+. if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch |
|
| 39 |
+. ds L" "" |
|
| 40 |
+. ds R" "" |
|
| 41 |
+. ds C` "" |
|
| 42 |
+. ds C' "" |
|
| 43 |
+'br\} |
|
| 44 |
+.el\{\
|
|
| 45 |
+. ds -- \|\(em\| |
|
| 46 |
+. ds PI \(*p |
|
| 47 |
+. ds L" `` |
|
| 48 |
+. ds R" '' |
|
| 49 |
+'br\} |
|
| 50 |
+.\" |
|
| 51 |
+.\" If the F register is turned on, we'll generate index entries on stderr for |
|
| 52 |
+.\" titles (.TH), headers (.SH), subsections (.Sh), items (.Ip), and index |
|
| 53 |
+.\" entries marked with X<> in POD. Of course, you'll have to process the |
|
| 54 |
+.\" output yourself in some meaningful fashion. |
|
| 55 |
+.if \nF \{\
|
|
| 56 |
+. de IX |
|
| 57 |
+. tm Index:\\$1\t\\n%\t"\\$2" |
|
| 58 |
+.. |
|
| 59 |
+. nr % 0 |
|
| 60 |
+. rr F |
|
| 61 |
+.\} |
|
| 62 |
+.\" |
|
| 63 |
+.\" For nroff, turn off justification. Always turn off hyphenation; it makes |
|
| 64 |
+.\" way too many mistakes in technical documents. |
|
| 65 |
+.hy 0 |
|
| 66 |
+.if n .na |
|
| 67 |
+.\" |
|
| 68 |
+.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2). |
|
| 69 |
+.\" Fear. Run. Save yourself. No user-serviceable parts. |
|
| 70 |
+. \" fudge factors for nroff and troff |
|
| 71 |
+.if n \{\
|
|
| 72 |
+. ds #H 0 |
|
| 73 |
+. ds #V .8m |
|
| 74 |
+. ds #F .3m |
|
| 75 |
+. ds #[ \f1 |
|
| 76 |
+. ds #] \fP |
|
| 77 |
+.\} |
|
| 78 |
+.if t \{\
|
|
| 79 |
+. ds #H ((1u-(\\\\n(.fu%2u))*.13m) |
|
| 80 |
+. ds #V .6m |
|
| 81 |
+. ds #F 0 |
|
| 82 |
+. ds #[ \& |
|
| 83 |
+. ds #] \& |
|
| 84 |
+.\} |
|
| 85 |
+. \" simple accents for nroff and troff |
|
| 86 |
+.if n \{\
|
|
| 87 |
+. ds ' \& |
|
| 88 |
+. ds ` \& |
|
| 89 |
+. ds ^ \& |
|
| 90 |
+. ds , \& |
|
| 91 |
+. ds ~ ~ |
|
| 92 |
+. ds / |
|
| 93 |
+.\} |
|
| 94 |
+.if t \{\
|
|
| 95 |
+. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u" |
|
| 96 |
+. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u' |
|
| 97 |
+. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u' |
|
| 98 |
+. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u' |
|
| 99 |
+. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u' |
|
| 100 |
+. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u' |
|
| 101 |
+.\} |
|
| 102 |
+. \" troff and (daisy-wheel) nroff accents |
|
| 103 |
+.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V' |
|
| 104 |
+.ds 8 \h'\*(#H'\(*b\h'-\*(#H' |
|
| 105 |
+.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#] |
|
| 106 |
+.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H' |
|
| 107 |
+.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u' |
|
| 108 |
+.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#] |
|
| 109 |
+.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#] |
|
| 110 |
+.ds ae a\h'-(\w'a'u*4/10)'e |
|
| 111 |
+.ds Ae A\h'-(\w'A'u*4/10)'E |
|
| 112 |
+. \" corrections for vroff |
|
| 113 |
+.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u' |
|
| 114 |
+.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u' |
|
| 115 |
+. \" for low resolution devices (crt and lpr) |
|
| 116 |
+.if \n(.H>23 .if \n(.V>19 \ |
|
| 117 |
+\{\
|
|
| 118 |
+. ds : e |
|
| 119 |
+. ds 8 ss |
|
| 120 |
+. ds o a |
|
| 121 |
+. ds d- d\h'-1'\(ga |
|
| 122 |
+. ds D- D\h'-1'\(hy |
|
| 123 |
+. ds th \o'bp' |
|
| 124 |
+. ds Th \o'LP' |
|
| 125 |
+. ds ae ae |
|
| 126 |
+. ds Ae AE |
|
| 127 |
+.\} |
|
| 128 |
+.rm #[ #] #H #V #F C |
|
| 129 |
+.\" ======================================================================== |
|
| 130 |
+.\" |
|
| 131 |
+.IX Title "DBIx::Custom::SQLite 3" |
|
| 132 |
+.TH DBIx::Custom::SQLite 3 "2009-11-16" "perl v5.8.8" "User Contributed Perl Documentation" |
|
| 133 |
+.SH "NAME" |
|
| 134 |
+DBIx::Custom::SQLite \- DBIx::Custom SQLite implementation |
|
| 135 |
+.SH "Version" |
|
| 136 |
+.IX Header "Version" |
|
| 137 |
+Version 0.0201 |
|
| 138 |
+.SH "Synopsys" |
|
| 139 |
+.IX Header "Synopsys" |
|
| 140 |
+.Vb 1 |
|
| 141 |
+\& use DBIx::Custom::SQLite; |
|
| 142 |
+.Ve |
|
| 143 |
+.PP |
|
| 144 |
+.Vb 3 |
|
| 145 |
+\& # New |
|
| 146 |
+\& my $dbi = DBIx::Custom::SQLite->new(user => 'taro', $password => 'kliej&@K', |
|
| 147 |
+\& database => 'sample.db'); |
|
| 148 |
+.Ve |
|
| 149 |
+.PP |
|
| 150 |
+.Vb 2 |
|
| 151 |
+\& # Insert |
|
| 152 |
+\& $dbi->insert('books', {title => 'perl', author => 'taro'});
|
|
| 153 |
+.Ve |
|
| 154 |
+.PP |
|
| 155 |
+.Vb 3 |
|
| 156 |
+\& # Update |
|
| 157 |
+\& # same as 'update books set (title = 'aaa', author = 'ken') where id = 5; |
|
| 158 |
+\& $dbi->update('books', {title => 'aaa', author => 'ken'}, {id => 5});
|
|
| 159 |
+.Ve |
|
| 160 |
+.PP |
|
| 161 |
+.Vb 2 |
|
| 162 |
+\& # Delete |
|
| 163 |
+\& $dbi->delete('books', {author => 'taro'});
|
|
| 164 |
+.Ve |
|
| 165 |
+.PP |
|
| 166 |
+.Vb 2 |
|
| 167 |
+\& # select * from books; |
|
| 168 |
+\& $dbi->select('books');
|
|
| 169 |
+.Ve |
|
| 170 |
+.PP |
|
| 171 |
+.Vb 2 |
|
| 172 |
+\& # select * from books where ahthor = 'taro'; |
|
| 173 |
+\& $dbi->select('books', {author => 'taro'});
|
|
| 174 |
+.Ve |
|
| 175 |
+.PP |
|
| 176 |
+.Vb 2 |
|
| 177 |
+\& # select author, title from books where author = 'taro' |
|
| 178 |
+\& $dbi->select('books', [qw/author title/], {author => 'taro'});
|
|
| 179 |
+.Ve |
|
| 180 |
+.PP |
|
| 181 |
+.Vb 3 |
|
| 182 |
+\& # select author, title from books where author = 'taro' order by id limit 1; |
|
| 183 |
+\& $dbi->select('books', [qw/author title/], {author => 'taro'},
|
|
| 184 |
+\& 'order by id limit 1'); |
|
| 185 |
+.Ve |
|
| 186 |
+.SH "See DBIx::Custom and DBI::Custom::Basic documentation" |
|
| 187 |
+.IX Header "See DBIx::Custom and DBI::Custom::Basic documentation" |
|
| 188 |
+This class is DBIx::Custom::Basic subclass. |
|
| 189 |
+and DBIx::Custom::Basic is DBIx::Custom subclass |
|
| 190 |
+.PP |
|
| 191 |
+You can use all methods of DBIx::Custom::Basic and <DBIx::Custom> |
|
| 192 |
+Please see DBIx::Custom::Basic and <DBIx::Custom> documentation |
|
| 193 |
+.SH "Object methods" |
|
| 194 |
+.IX Header "Object methods" |
|
| 195 |
+.Sh "connect" |
|
| 196 |
+.IX Subsection "connect" |
|
| 197 |
+This override DBIx::Custom connect. |
|
| 198 |
+.PP |
|
| 199 |
+.Vb 2 |
|
| 200 |
+\& # Connect to database |
|
| 201 |
+\& $dbi->connect; |
|
| 202 |
+.Ve |
|
| 203 |
+.PP |
|
| 204 |
+If database attribute is set, automatically data source is created and connect |
|
| 205 |
+.Sh "connect_memory" |
|
| 206 |
+.IX Subsection "connect_memory" |
|
| 207 |
+.Vb 2 |
|
| 208 |
+\& # Connect memory database |
|
| 209 |
+\& $self = $dbi->connect_memory; |
|
| 210 |
+.Ve |
|
| 211 |
+.Sh "reconnect_memory" |
|
| 212 |
+.IX Subsection "reconnect_memory" |
|
| 213 |
+.Vb 2 |
|
| 214 |
+\& # Reconnect memory database |
|
| 215 |
+\& $self = $dbi->reconnect_memory; |
|
| 216 |
+.Ve |
|
| 217 |
+.SH "Author" |
|
| 218 |
+.IX Header "Author" |
|
| 219 |
+Yuki Kimoto, \f(CW\*(C`<kimoto.yuki at gmail.com>\*(C'\fR |
|
| 220 |
+.PP |
|
| 221 |
+Github <http://github.com/yuki\-kimoto> |
|
| 222 |
+.PP |
|
| 223 |
+I develope this module <http://github.com/yuki\-kimoto/DBIx\-Custom> |
|
| 224 |
+.SH "Copyright & lisence" |
|
| 225 |
+.IX Header "Copyright & lisence" |
|
| 226 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 227 |
+.PP |
|
| 228 |
+This program is free software; you can redistribute it and/or modify it |
|
| 229 |
+under the same terms as Perl itself. |
| ... | ... |
@@ -0,0 +1,1127 @@ |
| 1 |
+use 5.008001; |
|
| 2 |
+ |
|
| 3 |
+package DBIx::Custom; |
|
| 4 |
+use Object::Simple; |
|
| 5 |
+ |
|
| 6 |
+our $VERSION = '0.0501'; |
|
| 7 |
+ |
|
| 8 |
+use Carp 'croak'; |
|
| 9 |
+use DBI; |
|
| 10 |
+use DBIx::Custom::Query; |
|
| 11 |
+use DBIx::Custom::Result; |
|
| 12 |
+use DBIx::Custom::SQL::Template; |
|
| 13 |
+ |
|
| 14 |
+ |
|
| 15 |
+### Class-Object Accessors |
|
| 16 |
+sub user : ClassObjectAttr { initialize => {clone => 'scalar'} }
|
|
| 17 |
+sub password : ClassObjectAttr { initialize => {clone => 'scalar'} }
|
|
| 18 |
+sub data_source : ClassObjectAttr { initialize => {clone => 'scalar'} }
|
|
| 19 |
+sub dbi_options : ClassObjectAttr { initialize => {clone => 'hash',
|
|
| 20 |
+ default => sub { {} } } }
|
|
| 21 |
+sub database : ClassObjectAttr { initialize => {clone => 'scalar'} }
|
|
| 22 |
+ |
|
| 23 |
+sub bind_filter : ClassObjectAttr { initialize => {clone => 'scalar'} }
|
|
| 24 |
+sub fetch_filter : ClassObjectAttr { initialize => {clone => 'scalar'} }
|
|
| 25 |
+ |
|
| 26 |
+sub no_bind_filters : ClassObjectAttr { initialize => {clone => 'array'} }
|
|
| 27 |
+sub no_fetch_filters : ClassObjectAttr { initialize => {clone => 'array'} }
|
|
| 28 |
+ |
|
| 29 |
+sub filters : ClassObjectAttr {
|
|
| 30 |
+ type => 'hash', |
|
| 31 |
+ deref => 1, |
|
| 32 |
+ initialize => {
|
|
| 33 |
+ clone => 'hash', |
|
| 34 |
+ default => sub { {} }
|
|
| 35 |
+ } |
|
| 36 |
+} |
|
| 37 |
+ |
|
| 38 |
+sub formats : ClassObjectAttr {
|
|
| 39 |
+ type => 'hash', |
|
| 40 |
+ deref => 1, |
|
| 41 |
+ initialize => {
|
|
| 42 |
+ clone => 'hash', |
|
| 43 |
+ default => sub { {} }
|
|
| 44 |
+ } |
|
| 45 |
+} |
|
| 46 |
+ |
|
| 47 |
+sub result_class : ClassObjectAttr {
|
|
| 48 |
+ initialize => {
|
|
| 49 |
+ clone => 'scalar', |
|
| 50 |
+ default => 'DBIx::Custom::Result' |
|
| 51 |
+ } |
|
| 52 |
+} |
|
| 53 |
+ |
|
| 54 |
+sub sql_template : ClassObjectAttr {
|
|
| 55 |
+ initialize => {
|
|
| 56 |
+ clone => sub {$_[0] ? $_[0]->clone : undef},
|
|
| 57 |
+ default => sub {DBIx::Custom::SQL::Template->new}
|
|
| 58 |
+ } |
|
| 59 |
+} |
|
| 60 |
+ |
|
| 61 |
+### Object Accessor |
|
| 62 |
+sub dbh : Attr {}
|
|
| 63 |
+ |
|
| 64 |
+ |
|
| 65 |
+### Methods |
|
| 66 |
+ |
|
| 67 |
+# Add filter |
|
| 68 |
+sub add_filter {
|
|
| 69 |
+ my $invocant = shift; |
|
| 70 |
+ |
|
| 71 |
+ my %old_filters = $invocant->filters; |
|
| 72 |
+ my %new_filters = ref $_[0] eq 'HASH' ? %{$_[0]} : @_;
|
|
| 73 |
+ $invocant->filters(%old_filters, %new_filters); |
|
| 74 |
+ return $invocant; |
|
| 75 |
+} |
|
| 76 |
+ |
|
| 77 |
+# Add format |
|
| 78 |
+sub add_format{
|
|
| 79 |
+ my $invocant = shift; |
|
| 80 |
+ |
|
| 81 |
+ my %old_formats = $invocant->formats; |
|
| 82 |
+ my %new_formats = ref $_[0] eq 'HASH' ? %{$_[0]} : @_;
|
|
| 83 |
+ $invocant->formats(%old_formats, %new_formats); |
|
| 84 |
+ return $invocant; |
|
| 85 |
+} |
|
| 86 |
+ |
|
| 87 |
+# Auto commit |
|
| 88 |
+sub _auto_commit {
|
|
| 89 |
+ my $self = shift; |
|
| 90 |
+ |
|
| 91 |
+ croak("Not yet connect to database") unless $self->dbh;
|
|
| 92 |
+ |
|
| 93 |
+ if (@_) {
|
|
| 94 |
+ $self->dbh->{AutoCommit} = $_[0];
|
|
| 95 |
+ return $self; |
|
| 96 |
+ } |
|
| 97 |
+ return $self->dbh->{AutoCommit};
|
|
| 98 |
+} |
|
| 99 |
+ |
|
| 100 |
+# Connect |
|
| 101 |
+sub connect {
|
|
| 102 |
+ my $self = shift; |
|
| 103 |
+ my $data_source = $self->data_source; |
|
| 104 |
+ my $user = $self->user; |
|
| 105 |
+ my $password = $self->password; |
|
| 106 |
+ my $dbi_options = $self->dbi_options; |
|
| 107 |
+ |
|
| 108 |
+ my $dbh = eval{DBI->connect(
|
|
| 109 |
+ $data_source, |
|
| 110 |
+ $user, |
|
| 111 |
+ $password, |
|
| 112 |
+ {
|
|
| 113 |
+ RaiseError => 1, |
|
| 114 |
+ PrintError => 0, |
|
| 115 |
+ AutoCommit => 1, |
|
| 116 |
+ %{$dbi_options || {} }
|
|
| 117 |
+ } |
|
| 118 |
+ )}; |
|
| 119 |
+ |
|
| 120 |
+ croak $@ if $@; |
|
| 121 |
+ |
|
| 122 |
+ $self->dbh($dbh); |
|
| 123 |
+ return $self; |
|
| 124 |
+} |
|
| 125 |
+ |
|
| 126 |
+# DESTROY |
|
| 127 |
+sub DESTROY {
|
|
| 128 |
+ my $self = shift; |
|
| 129 |
+ $self->disconnect if $self->connected; |
|
| 130 |
+} |
|
| 131 |
+ |
|
| 132 |
+# Is connected? |
|
| 133 |
+sub connected {
|
|
| 134 |
+ my $self = shift; |
|
| 135 |
+ return ref $self->{dbh} eq 'DBI::db';
|
|
| 136 |
+} |
|
| 137 |
+ |
|
| 138 |
+# Disconnect |
|
| 139 |
+sub disconnect {
|
|
| 140 |
+ my $self = shift; |
|
| 141 |
+ if ($self->connected) {
|
|
| 142 |
+ $self->dbh->disconnect; |
|
| 143 |
+ delete $self->{dbh};
|
|
| 144 |
+ } |
|
| 145 |
+} |
|
| 146 |
+ |
|
| 147 |
+# Reconnect |
|
| 148 |
+sub reconnect {
|
|
| 149 |
+ my $self = shift; |
|
| 150 |
+ $self->disconnect if $self->connected; |
|
| 151 |
+ $self->connect; |
|
| 152 |
+} |
|
| 153 |
+ |
|
| 154 |
+# Prepare statement handle |
|
| 155 |
+sub prepare {
|
|
| 156 |
+ my ($self, $sql) = @_; |
|
| 157 |
+ |
|
| 158 |
+ # Connect if not |
|
| 159 |
+ $self->connect unless $self->connected; |
|
| 160 |
+ |
|
| 161 |
+ # Prepare |
|
| 162 |
+ my $sth = eval{$self->dbh->prepare($sql)};
|
|
| 163 |
+ |
|
| 164 |
+ # Error |
|
| 165 |
+ croak("$@<Your SQL>\n$sql") if $@;
|
|
| 166 |
+ |
|
| 167 |
+ return $sth; |
|
| 168 |
+} |
|
| 169 |
+ |
|
| 170 |
+# Execute SQL directly |
|
| 171 |
+sub do{
|
|
| 172 |
+ my ($self, $sql, @bind_values) = @_; |
|
| 173 |
+ |
|
| 174 |
+ # Connect if not |
|
| 175 |
+ $self->connect unless $self->connected; |
|
| 176 |
+ |
|
| 177 |
+ # Do |
|
| 178 |
+ my $ret_val = eval{$self->dbh->do($sql, @bind_values)};
|
|
| 179 |
+ |
|
| 180 |
+ # Error |
|
| 181 |
+ if ($@) {
|
|
| 182 |
+ my $error = $@; |
|
| 183 |
+ require Data::Dumper; |
|
| 184 |
+ |
|
| 185 |
+ my $bind_value_dump |
|
| 186 |
+ = Data::Dumper->Dump([\@bind_values], ['*bind_valuds']); |
|
| 187 |
+ |
|
| 188 |
+ croak("$error<Your SQL>\n$sql\n<Your bind values>\n$bind_value_dump\n");
|
|
| 189 |
+ } |
|
| 190 |
+} |
|
| 191 |
+ |
|
| 192 |
+# Create query |
|
| 193 |
+sub create_query {
|
|
| 194 |
+ my ($self, $template) = @_; |
|
| 195 |
+ my $class = ref $self; |
|
| 196 |
+ |
|
| 197 |
+ # Create query from SQL template |
|
| 198 |
+ my $sql_template = $self->sql_template; |
|
| 199 |
+ |
|
| 200 |
+ # Try to get cached query |
|
| 201 |
+ my $query = $class->_query_caches->{$template};
|
|
| 202 |
+ |
|
| 203 |
+ # Create query |
|
| 204 |
+ unless ($query) {
|
|
| 205 |
+ $query = eval{$sql_template->create_query($template)};
|
|
| 206 |
+ croak($@) if $@; |
|
| 207 |
+ |
|
| 208 |
+ $query = DBIx::Custom::Query->new($query); |
|
| 209 |
+ |
|
| 210 |
+ $class->_add_query_cache($template, $query); |
|
| 211 |
+ } |
|
| 212 |
+ |
|
| 213 |
+ # Connect if not |
|
| 214 |
+ $self->connect unless $self->connected; |
|
| 215 |
+ |
|
| 216 |
+ # Prepare statement handle |
|
| 217 |
+ my $sth = $self->prepare($query->{sql});
|
|
| 218 |
+ |
|
| 219 |
+ # Set statement handle |
|
| 220 |
+ $query->sth($sth); |
|
| 221 |
+ |
|
| 222 |
+ # Set bind filter |
|
| 223 |
+ $query->bind_filter($self->bind_filter); |
|
| 224 |
+ |
|
| 225 |
+ # Set no filter keys when binding |
|
| 226 |
+ $query->no_bind_filters($self->no_bind_filters); |
|
| 227 |
+ |
|
| 228 |
+ # Set fetch filter |
|
| 229 |
+ $query->fetch_filter($self->fetch_filter); |
|
| 230 |
+ |
|
| 231 |
+ # Set no filter keys when fetching |
|
| 232 |
+ $query->no_fetch_filters($self->no_fetch_filters); |
|
| 233 |
+ |
|
| 234 |
+ return $query; |
|
| 235 |
+} |
|
| 236 |
+ |
|
| 237 |
+# Execute query |
|
| 238 |
+sub execute {
|
|
| 239 |
+ my ($self, $query, $params) = @_; |
|
| 240 |
+ $params ||= {};
|
|
| 241 |
+ |
|
| 242 |
+ # First argument is SQL template |
|
| 243 |
+ if (!ref $query) {
|
|
| 244 |
+ my $template = $query; |
|
| 245 |
+ $query = $self->create_query($template); |
|
| 246 |
+ my $query_edit_cb = $_[3]; |
|
| 247 |
+ $query_edit_cb->($query) if ref $query_edit_cb eq 'CODE'; |
|
| 248 |
+ } |
|
| 249 |
+ |
|
| 250 |
+ # Create bind value |
|
| 251 |
+ my $bind_values = $self->_build_bind_values($query, $params); |
|
| 252 |
+ |
|
| 253 |
+ # Execute |
|
| 254 |
+ my $sth = $query->sth; |
|
| 255 |
+ my $ret_val = eval{$sth->execute(@$bind_values)};
|
|
| 256 |
+ |
|
| 257 |
+ # Execute error |
|
| 258 |
+ if (my $execute_error = $@) {
|
|
| 259 |
+ require Data::Dumper; |
|
| 260 |
+ my $sql = $query->{sql} || '';
|
|
| 261 |
+ my $key_infos_dump = Data::Dumper->Dump([$query->key_infos], ['*key_infos']); |
|
| 262 |
+ my $params_dump = Data::Dumper->Dump([$params], ['*params']); |
|
| 263 |
+ |
|
| 264 |
+ croak("$execute_error" .
|
|
| 265 |
+ "<Your SQL>\n$sql\n" . |
|
| 266 |
+ "<Your parameters>\n$params_dump"); |
|
| 267 |
+ } |
|
| 268 |
+ |
|
| 269 |
+ # Return resultset if select statement is executed |
|
| 270 |
+ if ($sth->{NUM_OF_FIELDS}) {
|
|
| 271 |
+ |
|
| 272 |
+ # Get result class |
|
| 273 |
+ my $result_class = $self->result_class; |
|
| 274 |
+ |
|
| 275 |
+ # Create result |
|
| 276 |
+ my $result = $result_class->new({
|
|
| 277 |
+ sth => $sth, |
|
| 278 |
+ fetch_filter => $query->fetch_filter, |
|
| 279 |
+ no_fetch_filters => $query->no_fetch_filters |
|
| 280 |
+ }); |
|
| 281 |
+ return $result; |
|
| 282 |
+ } |
|
| 283 |
+ return $ret_val; |
|
| 284 |
+} |
|
| 285 |
+ |
|
| 286 |
+# Build binding values |
|
| 287 |
+sub _build_bind_values {
|
|
| 288 |
+ my ($self, $query, $params) = @_; |
|
| 289 |
+ my $key_infos = $query->key_infos; |
|
| 290 |
+ my $bind_filter = $query->bind_filter; |
|
| 291 |
+ my $no_bind_filters_map = $query->_no_bind_filters_map || {};
|
|
| 292 |
+ |
|
| 293 |
+ # binding values |
|
| 294 |
+ my @bind_values; |
|
| 295 |
+ |
|
| 296 |
+ # Create bind values |
|
| 297 |
+ KEY_INFOS : |
|
| 298 |
+ foreach my $key_info (@$key_infos) {
|
|
| 299 |
+ # Set variable |
|
| 300 |
+ my $access_keys = $key_info->{access_keys};
|
|
| 301 |
+ my $original_key = $key_info->{original_key} || '';
|
|
| 302 |
+ my $table = $key_info->{table} || '';
|
|
| 303 |
+ my $column = $key_info->{column} || '';
|
|
| 304 |
+ |
|
| 305 |
+ # Key is found? |
|
| 306 |
+ my $found; |
|
| 307 |
+ |
|
| 308 |
+ # Build bind values |
|
| 309 |
+ ACCESS_KEYS : |
|
| 310 |
+ foreach my $access_key (@$access_keys) {
|
|
| 311 |
+ # Root parameter |
|
| 312 |
+ my $root_params = $params; |
|
| 313 |
+ |
|
| 314 |
+ # Search corresponding value |
|
| 315 |
+ for (my $i = 0; $i < @$access_key; $i++) {
|
|
| 316 |
+ # Current key |
|
| 317 |
+ my $current_key = $access_key->[$i]; |
|
| 318 |
+ |
|
| 319 |
+ # Last key |
|
| 320 |
+ if ($i == @$access_key - 1) {
|
|
| 321 |
+ # Key is array reference |
|
| 322 |
+ if (ref $current_key eq 'ARRAY') {
|
|
| 323 |
+ # Filtering |
|
| 324 |
+ if ($bind_filter && |
|
| 325 |
+ !$no_bind_filters_map->{$original_key})
|
|
| 326 |
+ {
|
|
| 327 |
+ push @bind_values, |
|
| 328 |
+ $bind_filter->($root_params->[$current_key->[0]], |
|
| 329 |
+ $original_key, |
|
| 330 |
+ $table, $column); |
|
| 331 |
+ } |
|
| 332 |
+ # Not filtering |
|
| 333 |
+ else {
|
|
| 334 |
+ push @bind_values, |
|
| 335 |
+ scalar $root_params->[$current_key->[0]]; |
|
| 336 |
+ } |
|
| 337 |
+ } |
|
| 338 |
+ # Key is string |
|
| 339 |
+ else {
|
|
| 340 |
+ # Key is not found |
|
| 341 |
+ next ACCESS_KEYS |
|
| 342 |
+ unless exists $root_params->{$current_key};
|
|
| 343 |
+ |
|
| 344 |
+ # Filtering |
|
| 345 |
+ if ($bind_filter && |
|
| 346 |
+ !$no_bind_filters_map->{$original_key})
|
|
| 347 |
+ {
|
|
| 348 |
+ push @bind_values, |
|
| 349 |
+ $bind_filter->($root_params->{$current_key},
|
|
| 350 |
+ $original_key, |
|
| 351 |
+ $table, $column); |
|
| 352 |
+ } |
|
| 353 |
+ # Not filtering |
|
| 354 |
+ else {
|
|
| 355 |
+ push @bind_values, |
|
| 356 |
+ scalar $root_params->{$current_key};
|
|
| 357 |
+ } |
|
| 358 |
+ } |
|
| 359 |
+ |
|
| 360 |
+ # Key is found |
|
| 361 |
+ $found = 1; |
|
| 362 |
+ next KEY_INFOS; |
|
| 363 |
+ } |
|
| 364 |
+ # First or middle key |
|
| 365 |
+ else {
|
|
| 366 |
+ # Key is array reference |
|
| 367 |
+ if (ref $current_key eq 'ARRAY') {
|
|
| 368 |
+ # Go next key |
|
| 369 |
+ $root_params = $root_params->[$current_key->[0]]; |
|
| 370 |
+ } |
|
| 371 |
+ # Key is string |
|
| 372 |
+ else {
|
|
| 373 |
+ # Not found |
|
| 374 |
+ next ACCESS_KEYS |
|
| 375 |
+ unless exists $root_params->{$current_key};
|
|
| 376 |
+ |
|
| 377 |
+ # Go next key |
|
| 378 |
+ $root_params = $root_params->{$current_key};
|
|
| 379 |
+ } |
|
| 380 |
+ } |
|
| 381 |
+ } |
|
| 382 |
+ } |
|
| 383 |
+ |
|
| 384 |
+ # Key is not found |
|
| 385 |
+ unless ($found) {
|
|
| 386 |
+ require Data::Dumper; |
|
| 387 |
+ my $key_info_dump = Data::Dumper->Dump([$key_info], ['*key_info']); |
|
| 388 |
+ my $params_dump = Data::Dumper->Dump([$params], ['*params']); |
|
| 389 |
+ croak("Corresponding key is not found in your parameters\n" .
|
|
| 390 |
+ "<Key information>\n$key_info_dump\n\n" . |
|
| 391 |
+ "<Your parameters>\n$params_dump\n"); |
|
| 392 |
+ } |
|
| 393 |
+ } |
|
| 394 |
+ return \@bind_values; |
|
| 395 |
+} |
|
| 396 |
+ |
|
| 397 |
+# Run transaction |
|
| 398 |
+sub run_transaction {
|
|
| 399 |
+ my ($self, $transaction) = @_; |
|
| 400 |
+ |
|
| 401 |
+ # Check auto commit |
|
| 402 |
+ croak("AutoCommit must be true before transaction start")
|
|
| 403 |
+ unless $self->_auto_commit; |
|
| 404 |
+ |
|
| 405 |
+ # Auto commit off |
|
| 406 |
+ $self->_auto_commit(0); |
|
| 407 |
+ |
|
| 408 |
+ # Run transaction |
|
| 409 |
+ eval {$transaction->()};
|
|
| 410 |
+ |
|
| 411 |
+ # Tranzaction error |
|
| 412 |
+ my $transaction_error = $@; |
|
| 413 |
+ |
|
| 414 |
+ # Tranzaction is failed. |
|
| 415 |
+ if ($transaction_error) {
|
|
| 416 |
+ # Rollback |
|
| 417 |
+ eval{$self->dbh->rollback};
|
|
| 418 |
+ |
|
| 419 |
+ # Rollback error |
|
| 420 |
+ my $rollback_error = $@; |
|
| 421 |
+ |
|
| 422 |
+ # Auto commit on |
|
| 423 |
+ $self->_auto_commit(1); |
|
| 424 |
+ |
|
| 425 |
+ if ($rollback_error) {
|
|
| 426 |
+ # Rollback is failed |
|
| 427 |
+ croak("${transaction_error}Rollback is failed : $rollback_error");
|
|
| 428 |
+ } |
|
| 429 |
+ else {
|
|
| 430 |
+ # Rollback is success |
|
| 431 |
+ croak("${transaction_error}Rollback is success");
|
|
| 432 |
+ } |
|
| 433 |
+ } |
|
| 434 |
+ # Tranzaction is success |
|
| 435 |
+ else {
|
|
| 436 |
+ # Commit |
|
| 437 |
+ eval{$self->dbh->commit};
|
|
| 438 |
+ my $commit_error = $@; |
|
| 439 |
+ |
|
| 440 |
+ # Auto commit on |
|
| 441 |
+ $self->_auto_commit(1); |
|
| 442 |
+ |
|
| 443 |
+ # Commit is failed |
|
| 444 |
+ croak($commit_error) if $commit_error; |
|
| 445 |
+ } |
|
| 446 |
+} |
|
| 447 |
+ |
|
| 448 |
+# Get last insert id |
|
| 449 |
+sub last_insert_id {
|
|
| 450 |
+ my $self = shift; |
|
| 451 |
+ |
|
| 452 |
+ # Not connected |
|
| 453 |
+ croak("Not yet connect to database")
|
|
| 454 |
+ unless $self->connected; |
|
| 455 |
+ |
|
| 456 |
+ return $self->dbh->last_insert_id(@_); |
|
| 457 |
+} |
|
| 458 |
+ |
|
| 459 |
+# Insert |
|
| 460 |
+sub insert {
|
|
| 461 |
+ my ($self, $table, $insert_params, $query_edit_cb) = @_; |
|
| 462 |
+ $table ||= ''; |
|
| 463 |
+ $insert_params ||= {};
|
|
| 464 |
+ |
|
| 465 |
+ # Insert keys |
|
| 466 |
+ my @insert_keys = keys %$insert_params; |
|
| 467 |
+ |
|
| 468 |
+ # Not exists insert keys |
|
| 469 |
+ croak("Key-value pairs for insert must be specified to 'insert' second argument")
|
|
| 470 |
+ unless @insert_keys; |
|
| 471 |
+ |
|
| 472 |
+ # Templte for insert |
|
| 473 |
+ my $template = "insert into $table {insert " . join(' ', @insert_keys) . '}';
|
|
| 474 |
+ |
|
| 475 |
+ # Create query |
|
| 476 |
+ my $query = $self->create_query($template); |
|
| 477 |
+ |
|
| 478 |
+ # Query edit callback must be code reference |
|
| 479 |
+ croak("Query edit callback must be code reference")
|
|
| 480 |
+ if $query_edit_cb && ref $query_edit_cb ne 'CODE'; |
|
| 481 |
+ |
|
| 482 |
+ # Query edit if need |
|
| 483 |
+ $query_edit_cb->($query) if $query_edit_cb; |
|
| 484 |
+ |
|
| 485 |
+ # Execute query |
|
| 486 |
+ my $ret_val = $self->execute($query, $insert_params); |
|
| 487 |
+ |
|
| 488 |
+ return $ret_val; |
|
| 489 |
+} |
|
| 490 |
+ |
|
| 491 |
+# Update |
|
| 492 |
+sub update {
|
|
| 493 |
+ my ($self, $table, $update_params, |
|
| 494 |
+ $where_params, $query_edit_cb, $options) = @_; |
|
| 495 |
+ |
|
| 496 |
+ $table ||= ''; |
|
| 497 |
+ $update_params ||= {};
|
|
| 498 |
+ $where_params ||= {};
|
|
| 499 |
+ |
|
| 500 |
+ # Update keys |
|
| 501 |
+ my @update_keys = keys %$update_params; |
|
| 502 |
+ |
|
| 503 |
+ # Not exists update kyes |
|
| 504 |
+ croak("Key-value pairs for update must be specified to 'update' second argument")
|
|
| 505 |
+ unless @update_keys; |
|
| 506 |
+ |
|
| 507 |
+ # Where keys |
|
| 508 |
+ my @where_keys = keys %$where_params; |
|
| 509 |
+ |
|
| 510 |
+ # Not exists where keys |
|
| 511 |
+ croak("Key-value pairs for where clause must be specified to 'update' third argument")
|
|
| 512 |
+ if !@where_keys && !$options->{allow_update_all};
|
|
| 513 |
+ |
|
| 514 |
+ # Update clause |
|
| 515 |
+ my $update_clause = '{update ' . join(' ', @update_keys) . '}';
|
|
| 516 |
+ |
|
| 517 |
+ # Where clause |
|
| 518 |
+ my $where_clause = ''; |
|
| 519 |
+ if (@where_keys) {
|
|
| 520 |
+ $where_clause = 'where '; |
|
| 521 |
+ foreach my $where_key (@where_keys) {
|
|
| 522 |
+ $where_clause .= "{= $where_key} and ";
|
|
| 523 |
+ } |
|
| 524 |
+ $where_clause =~ s/ and $//; |
|
| 525 |
+ } |
|
| 526 |
+ |
|
| 527 |
+ # Template for update |
|
| 528 |
+ my $template = "update $table $update_clause $where_clause"; |
|
| 529 |
+ |
|
| 530 |
+ # Create query |
|
| 531 |
+ my $query = $self->create_query($template); |
|
| 532 |
+ |
|
| 533 |
+ # Query edit callback must be code reference |
|
| 534 |
+ croak("Query edit callback must be code reference")
|
|
| 535 |
+ if $query_edit_cb && ref $query_edit_cb ne 'CODE'; |
|
| 536 |
+ |
|
| 537 |
+ # Query edit if need |
|
| 538 |
+ $query_edit_cb->($query) if $query_edit_cb; |
|
| 539 |
+ |
|
| 540 |
+ # Rearrange parammeters |
|
| 541 |
+ my $params = {'#update' => $update_params, %$where_params};
|
|
| 542 |
+ |
|
| 543 |
+ # Execute query |
|
| 544 |
+ my $ret_val = $self->execute($query, $params); |
|
| 545 |
+ |
|
| 546 |
+ return $ret_val; |
|
| 547 |
+} |
|
| 548 |
+ |
|
| 549 |
+# Update all rows |
|
| 550 |
+sub update_all {
|
|
| 551 |
+ my ($self, $table, $update_params, $query_edit_cb) = @_; |
|
| 552 |
+ |
|
| 553 |
+ return $self->update($table, $update_params, {}, $query_edit_cb,
|
|
| 554 |
+ {allow_update_all => 1});
|
|
| 555 |
+} |
|
| 556 |
+ |
|
| 557 |
+# Delete |
|
| 558 |
+sub delete {
|
|
| 559 |
+ my ($self, $table, $where_params, $query_edit_cb, $options) = @_; |
|
| 560 |
+ $table ||= ''; |
|
| 561 |
+ $where_params ||= {};
|
|
| 562 |
+ |
|
| 563 |
+ # Where keys |
|
| 564 |
+ my @where_keys = keys %$where_params; |
|
| 565 |
+ |
|
| 566 |
+ # Not exists where keys |
|
| 567 |
+ croak("Key-value pairs for where clause must be specified to 'delete' second argument")
|
|
| 568 |
+ if !@where_keys && !$options->{allow_delete_all};
|
|
| 569 |
+ |
|
| 570 |
+ # Where clause |
|
| 571 |
+ my $where_clause = ''; |
|
| 572 |
+ if (@where_keys) {
|
|
| 573 |
+ $where_clause = 'where '; |
|
| 574 |
+ foreach my $where_key (@where_keys) {
|
|
| 575 |
+ $where_clause .= "{= $where_key} and ";
|
|
| 576 |
+ } |
|
| 577 |
+ $where_clause =~ s/ and $//; |
|
| 578 |
+ } |
|
| 579 |
+ |
|
| 580 |
+ # Template for delete |
|
| 581 |
+ my $template = "delete from $table $where_clause"; |
|
| 582 |
+ |
|
| 583 |
+ # Create query |
|
| 584 |
+ my $query = $self->create_query($template); |
|
| 585 |
+ |
|
| 586 |
+ # Query edit callback must be code reference |
|
| 587 |
+ croak("Query edit callback must be code reference")
|
|
| 588 |
+ if $query_edit_cb && ref $query_edit_cb ne 'CODE'; |
|
| 589 |
+ |
|
| 590 |
+ # Query edit if need |
|
| 591 |
+ $query_edit_cb->($query) if $query_edit_cb; |
|
| 592 |
+ |
|
| 593 |
+ # Execute query |
|
| 594 |
+ my $ret_val = $self->execute($query, $where_params); |
|
| 595 |
+ |
|
| 596 |
+ return $ret_val; |
|
| 597 |
+} |
|
| 598 |
+ |
|
| 599 |
+# Delete all rows |
|
| 600 |
+sub delete_all {
|
|
| 601 |
+ my ($self, $table) = @_; |
|
| 602 |
+ return $self->delete($table, {}, undef, {allow_delete_all => 1});
|
|
| 603 |
+} |
|
| 604 |
+ |
|
| 605 |
+sub _select_usage { return << 'EOS' }
|
|
| 606 |
+Your select arguments is wrong. |
|
| 607 |
+select usage: |
|
| 608 |
+$dbi->select( |
|
| 609 |
+ $table, # must be string or array ref |
|
| 610 |
+ [@$columns], # must be array reference. this is optional |
|
| 611 |
+ {%$where_params}, # must be hash reference. this is optional
|
|
| 612 |
+ $append_statement, # must be string. this is optional |
|
| 613 |
+ $query_edit_callback # must be code reference. this is optional |
|
| 614 |
+); |
|
| 615 |
+EOS |
|
| 616 |
+ |
|
| 617 |
+sub select {
|
|
| 618 |
+ my $self = shift; |
|
| 619 |
+ |
|
| 620 |
+ # Check argument |
|
| 621 |
+ croak($self->_select_usage) unless @_; |
|
| 622 |
+ |
|
| 623 |
+ # Arguments |
|
| 624 |
+ my $tables = shift || ''; |
|
| 625 |
+ $tables = [$tables] unless ref $tables; |
|
| 626 |
+ |
|
| 627 |
+ my $columns = ref $_[0] eq 'ARRAY' ? shift : []; |
|
| 628 |
+ my $where_params = ref $_[0] eq 'HASH' ? shift : {};
|
|
| 629 |
+ my $append_statement = $_[0] && !ref $_[0] ? shift : ''; |
|
| 630 |
+ my $query_edit_cb = shift if ref $_[0] eq 'CODE'; |
|
| 631 |
+ |
|
| 632 |
+ # Check rest argument |
|
| 633 |
+ croak($self->_select_usage) if @_; |
|
| 634 |
+ |
|
| 635 |
+ # SQL template for select statement |
|
| 636 |
+ my $template = 'select '; |
|
| 637 |
+ |
|
| 638 |
+ # Join column clause |
|
| 639 |
+ if (@$columns) {
|
|
| 640 |
+ foreach my $column (@$columns) {
|
|
| 641 |
+ $template .= "$column, "; |
|
| 642 |
+ } |
|
| 643 |
+ $template =~ s/, $/ /; |
|
| 644 |
+ } |
|
| 645 |
+ else {
|
|
| 646 |
+ $template .= '* '; |
|
| 647 |
+ } |
|
| 648 |
+ |
|
| 649 |
+ # Join table |
|
| 650 |
+ $template .= 'from '; |
|
| 651 |
+ foreach my $table (@$tables) {
|
|
| 652 |
+ $template .= "$table, "; |
|
| 653 |
+ } |
|
| 654 |
+ $template =~ s/, $/ /; |
|
| 655 |
+ |
|
| 656 |
+ # Where clause keys |
|
| 657 |
+ my @where_keys = keys %$where_params; |
|
| 658 |
+ |
|
| 659 |
+ # Join where clause |
|
| 660 |
+ if (@where_keys) {
|
|
| 661 |
+ $template .= 'where '; |
|
| 662 |
+ foreach my $where_key (@where_keys) {
|
|
| 663 |
+ $template .= "{= $where_key} and ";
|
|
| 664 |
+ } |
|
| 665 |
+ } |
|
| 666 |
+ $template =~ s/ and $//; |
|
| 667 |
+ |
|
| 668 |
+ # Append something to last of statement |
|
| 669 |
+ if ($append_statement =~ s/^where //) {
|
|
| 670 |
+ if (@where_keys) {
|
|
| 671 |
+ $template .= " and $append_statement"; |
|
| 672 |
+ } |
|
| 673 |
+ else {
|
|
| 674 |
+ $template .= " where $append_statement"; |
|
| 675 |
+ } |
|
| 676 |
+ } |
|
| 677 |
+ else {
|
|
| 678 |
+ $template .= " $append_statement"; |
|
| 679 |
+ } |
|
| 680 |
+ |
|
| 681 |
+ # Create query |
|
| 682 |
+ my $query = $self->create_query($template); |
|
| 683 |
+ |
|
| 684 |
+ # Query edit |
|
| 685 |
+ $query_edit_cb->($query) if $query_edit_cb; |
|
| 686 |
+ |
|
| 687 |
+ # Execute query |
|
| 688 |
+ my $result = $self->execute($query, $where_params); |
|
| 689 |
+ |
|
| 690 |
+ return $result; |
|
| 691 |
+} |
|
| 692 |
+ |
|
| 693 |
+sub _query_caches : ClassAttr { type => 'hash',
|
|
| 694 |
+ auto_build => sub {shift->_query_caches({}) } }
|
|
| 695 |
+ |
|
| 696 |
+sub _query_cache_keys : ClassAttr { type => 'array',
|
|
| 697 |
+ auto_build => sub {shift->_query_cache_keys([])} }
|
|
| 698 |
+ |
|
| 699 |
+sub query_cache_max : ClassAttr { auto_build => sub {shift->query_cache_max(50)} }
|
|
| 700 |
+ |
|
| 701 |
+# Add query cahce |
|
| 702 |
+sub _add_query_cache {
|
|
| 703 |
+ my ($class, $template, $query) = @_; |
|
| 704 |
+ my $query_cache_keys = $class->_query_cache_keys; |
|
| 705 |
+ my $query_caches = $class->_query_caches; |
|
| 706 |
+ |
|
| 707 |
+ return $class if $query_caches->{$template};
|
|
| 708 |
+ |
|
| 709 |
+ $query_caches->{$template} = $query;
|
|
| 710 |
+ push @$query_cache_keys, $template; |
|
| 711 |
+ |
|
| 712 |
+ my $overflow = @$query_cache_keys - $class->query_cache_max; |
|
| 713 |
+ |
|
| 714 |
+ for (my $i = 0; $i < $overflow; $i++) {
|
|
| 715 |
+ my $template = shift @$query_cache_keys; |
|
| 716 |
+ delete $query_caches->{$template};
|
|
| 717 |
+ } |
|
| 718 |
+ |
|
| 719 |
+ return $class; |
|
| 720 |
+} |
|
| 721 |
+ |
|
| 722 |
+# Both bind_filter and fetch_filter off |
|
| 723 |
+sub filter_off {
|
|
| 724 |
+ my $self = shift; |
|
| 725 |
+ |
|
| 726 |
+ # filter off |
|
| 727 |
+ $self->bind_filter(undef); |
|
| 728 |
+ $self->fetch_filter(undef); |
|
| 729 |
+ |
|
| 730 |
+ return $self; |
|
| 731 |
+} |
|
| 732 |
+ |
|
| 733 |
+Object::Simple->build_class; |
|
| 734 |
+ |
|
| 735 |
+=head1 NAME |
|
| 736 |
+ |
|
| 737 |
+DBIx::Custom - Customizable simple DBI |
|
| 738 |
+ |
|
| 739 |
+=head1 VERSION |
|
| 740 |
+ |
|
| 741 |
+Version 0.0501 |
|
| 742 |
+ |
|
| 743 |
+=head1 CAUTION |
|
| 744 |
+ |
|
| 745 |
+This module is now experimental stage. |
|
| 746 |
+ |
|
| 747 |
+I want you to try this module |
|
| 748 |
+because I want this module stable, and not to damage your DB data by this module bug. |
|
| 749 |
+ |
|
| 750 |
+Please tell me bug if you find |
|
| 751 |
+ |
|
| 752 |
+=head1 SYNOPSIS |
|
| 753 |
+ |
|
| 754 |
+ my $dbi = DBIx::Custom->new; |
|
| 755 |
+ |
|
| 756 |
+ my $query = $dbi->create_query($template); |
|
| 757 |
+ $dbi->execute($query); |
|
| 758 |
+ |
|
| 759 |
+=head1 CLASS-OBJECT ACCESSORS |
|
| 760 |
+ |
|
| 761 |
+=head2 user |
|
| 762 |
+ |
|
| 763 |
+ # Set and get database user name |
|
| 764 |
+ $self = $dbi->user($user); |
|
| 765 |
+ $user = $dbi->user; |
|
| 766 |
+ |
|
| 767 |
+ # Sample |
|
| 768 |
+ $dbi->user('taro');
|
|
| 769 |
+ |
|
| 770 |
+=head2 password |
|
| 771 |
+ |
|
| 772 |
+ # Set and get database password |
|
| 773 |
+ $self = $dbi->password($password); |
|
| 774 |
+ $password = $dbi->password; |
|
| 775 |
+ |
|
| 776 |
+ # Sample |
|
| 777 |
+ $dbi->password('lkj&le`@s');
|
|
| 778 |
+ |
|
| 779 |
+=head2 data_source |
|
| 780 |
+ |
|
| 781 |
+ # Set and get database data source |
|
| 782 |
+ $self = $dbi->data_source($data_soruce); |
|
| 783 |
+ $data_source = $dbi->data_source; |
|
| 784 |
+ |
|
| 785 |
+ # Sample(SQLite) |
|
| 786 |
+ $dbi->data_source(dbi:SQLite:dbname=$database); |
|
| 787 |
+ |
|
| 788 |
+ # Sample(MySQL); |
|
| 789 |
+ $dbi->data_source("dbi:mysql:dbname=$database");
|
|
| 790 |
+ |
|
| 791 |
+ # Sample(PostgreSQL) |
|
| 792 |
+ $dbi->data_source("dbi:Pg:dbname=$database");
|
|
| 793 |
+ |
|
| 794 |
+=head2 database |
|
| 795 |
+ |
|
| 796 |
+ # Set and get database name |
|
| 797 |
+ $self = $dbi->database($database); |
|
| 798 |
+ $database = $dbi->database; |
|
| 799 |
+ |
|
| 800 |
+This method will be used in subclass connect method. |
|
| 801 |
+ |
|
| 802 |
+=head2 dbi_options |
|
| 803 |
+ |
|
| 804 |
+ # Set and get DBI option |
|
| 805 |
+ $self = $dbi->dbi_options({$options => $value, ...});
|
|
| 806 |
+ $dbi_options = $dbi->dbi_options; |
|
| 807 |
+ |
|
| 808 |
+ # Sample |
|
| 809 |
+ $dbi->dbi_options({PrintError => 0, RaiseError => 1});
|
|
| 810 |
+ |
|
| 811 |
+dbi_options is used when you connect database by using connect. |
|
| 812 |
+ |
|
| 813 |
+=head2 prepare |
|
| 814 |
+ |
|
| 815 |
+ $sth = $dbi->prepare($sql); |
|
| 816 |
+ |
|
| 817 |
+This method is same as DBI::prepare |
|
| 818 |
+ |
|
| 819 |
+=head2 do |
|
| 820 |
+ |
|
| 821 |
+ $dbi->do($sql, @bind_values); |
|
| 822 |
+ |
|
| 823 |
+This method is same as DBI::do |
|
| 824 |
+ |
|
| 825 |
+=head2 sql_template |
|
| 826 |
+ |
|
| 827 |
+ # Set and get SQL::Template object |
|
| 828 |
+ $self = $dbi->sql_template($sql_template); |
|
| 829 |
+ $sql_template = $dbi->sql_template; |
|
| 830 |
+ |
|
| 831 |
+ # Sample |
|
| 832 |
+ $dbi->sql_template(DBI::Cutom::SQL::Template->new); |
|
| 833 |
+ |
|
| 834 |
+=head2 filters |
|
| 835 |
+ |
|
| 836 |
+ # Set and get filters |
|
| 837 |
+ $self = $dbi->filters($filters); |
|
| 838 |
+ $filters = $dbi->filters; |
|
| 839 |
+ |
|
| 840 |
+=head2 formats |
|
| 841 |
+ |
|
| 842 |
+ # Set and get formats |
|
| 843 |
+ $self = $dbi->formats($formats); |
|
| 844 |
+ $formats = $dbi->formats; |
|
| 845 |
+ |
|
| 846 |
+=head2 bind_filter |
|
| 847 |
+ |
|
| 848 |
+ # Set and get binding filter |
|
| 849 |
+ $self = $dbi->bind_filter($bind_filter); |
|
| 850 |
+ $bind_filter = $dbi->bind_filter |
|
| 851 |
+ |
|
| 852 |
+ # Sample |
|
| 853 |
+ $dbi->bind_filter($self->filters->{default_bind_filter});
|
|
| 854 |
+ |
|
| 855 |
+ |
|
| 856 |
+you can get DBI database handle if you need. |
|
| 857 |
+ |
|
| 858 |
+=head2 fetch_filter |
|
| 859 |
+ |
|
| 860 |
+ # Set and get Fetch filter |
|
| 861 |
+ $self = $dbi->fetch_filter($fetch_filter); |
|
| 862 |
+ $fetch_filter = $dbi->fetch_filter; |
|
| 863 |
+ |
|
| 864 |
+ # Sample |
|
| 865 |
+ $dbi->fetch_filter($self->filters->{default_fetch_filter});
|
|
| 866 |
+ |
|
| 867 |
+=head2 no_bind_filters |
|
| 868 |
+ |
|
| 869 |
+ # Set and get no filter keys when binding |
|
| 870 |
+ $self = $dbi->no_bind_filters($no_bind_filters); |
|
| 871 |
+ $no_bind_filters = $dbi->no_bind_filters; |
|
| 872 |
+ |
|
| 873 |
+=head2 no_fetch_filters |
|
| 874 |
+ |
|
| 875 |
+ # Set and get no filter keys when fetching |
|
| 876 |
+ $self = $dbi->no_fetch_filters($no_fetch_filters); |
|
| 877 |
+ $no_fetch_filters = $dbi->no_fetch_filters; |
|
| 878 |
+ |
|
| 879 |
+=head2 result_class |
|
| 880 |
+ |
|
| 881 |
+ # Set and get resultset class |
|
| 882 |
+ $self = $dbi->result_class($result_class); |
|
| 883 |
+ $result_class = $dbi->result_class; |
|
| 884 |
+ |
|
| 885 |
+ # Sample |
|
| 886 |
+ $dbi->result_class('DBIx::Custom::Result');
|
|
| 887 |
+ |
|
| 888 |
+=head2 dbh |
|
| 889 |
+ |
|
| 890 |
+ # Get database handle |
|
| 891 |
+ $dbh = $self->dbh; |
|
| 892 |
+ |
|
| 893 |
+=head1 METHODS |
|
| 894 |
+ |
|
| 895 |
+=head2 connect |
|
| 896 |
+ |
|
| 897 |
+ # Connect to database |
|
| 898 |
+ $self = $dbi->connect; |
|
| 899 |
+ |
|
| 900 |
+ # Sample |
|
| 901 |
+ $dbi = DBIx::Custom->new(user => 'taro', password => 'lji8(',
|
|
| 902 |
+ data_soruce => "dbi:mysql:dbname=$database"); |
|
| 903 |
+ $dbi->connect; |
|
| 904 |
+ |
|
| 905 |
+=head2 disconnect |
|
| 906 |
+ |
|
| 907 |
+ # Disconnect database |
|
| 908 |
+ $dbi->disconnect; |
|
| 909 |
+ |
|
| 910 |
+If database is already disconnected, this method do noting. |
|
| 911 |
+ |
|
| 912 |
+=head2 reconnect |
|
| 913 |
+ |
|
| 914 |
+ # Reconnect |
|
| 915 |
+ $dbi->reconnect; |
|
| 916 |
+ |
|
| 917 |
+=head2 connected |
|
| 918 |
+ |
|
| 919 |
+ # Check connected |
|
| 920 |
+ $dbi->connected |
|
| 921 |
+ |
|
| 922 |
+=head2 filter_off |
|
| 923 |
+ |
|
| 924 |
+ # bind_filter and fitch_filter off |
|
| 925 |
+ $self->filter_off; |
|
| 926 |
+ |
|
| 927 |
+This is equeal to |
|
| 928 |
+ |
|
| 929 |
+ $self->bind_filter(undef); |
|
| 930 |
+ $self->fetch_filter(undef); |
|
| 931 |
+ |
|
| 932 |
+=head2 add_filter |
|
| 933 |
+ |
|
| 934 |
+ # Add filter (hash ref or hash can be recieve) |
|
| 935 |
+ $self = $dbi->add_filter({$filter_name => $filter, ...});
|
|
| 936 |
+ $self = $dbi->add_filter($filetr_name => $filter, ...); |
|
| 937 |
+ |
|
| 938 |
+ # Sample |
|
| 939 |
+ $dbi->add_filter( |
|
| 940 |
+ decode_utf8 => sub {
|
|
| 941 |
+ my ($key, $value, $table, $column) = @_; |
|
| 942 |
+ return Encode::decode('UTF-8', $value);
|
|
| 943 |
+ }, |
|
| 944 |
+ datetime_to_string => sub {
|
|
| 945 |
+ my ($key, $value, $table, $column) = @_; |
|
| 946 |
+ return $value->strftime('%Y-%m-%d %H:%M:%S')
|
|
| 947 |
+ }, |
|
| 948 |
+ default_bind_filter => sub {
|
|
| 949 |
+ my ($key, $value, $table, $column) = @_; |
|
| 950 |
+ if (ref $value eq 'Time::Piece') {
|
|
| 951 |
+ return $dbi->filters->{datetime_to_string}->($value);
|
|
| 952 |
+ } |
|
| 953 |
+ else {
|
|
| 954 |
+ return $dbi->filters->{decode_utf8}->($value);
|
|
| 955 |
+ } |
|
| 956 |
+ }, |
|
| 957 |
+ |
|
| 958 |
+ encode_utf8 => sub {
|
|
| 959 |
+ my ($key, $value) = @_; |
|
| 960 |
+ return Encode::encode('UTF-8', $value);
|
|
| 961 |
+ }, |
|
| 962 |
+ string_to_datetime => sub {
|
|
| 963 |
+ my ($key, $value) = @_; |
|
| 964 |
+ return DateTime::Format::MySQL->parse_datetime($value); |
|
| 965 |
+ }, |
|
| 966 |
+ default_fetch_filter => sub {
|
|
| 967 |
+ my ($key, $value, $type, $sth, $i) = @_; |
|
| 968 |
+ if ($type eq 'DATETIME') {
|
|
| 969 |
+ return $dbi->filters->{string_to_datetime}->($value);
|
|
| 970 |
+ } |
|
| 971 |
+ else {
|
|
| 972 |
+ return $dbi->filters->{encode_utf8}->($value);
|
|
| 973 |
+ } |
|
| 974 |
+ } |
|
| 975 |
+ ); |
|
| 976 |
+ |
|
| 977 |
+add_filter add filter to filters |
|
| 978 |
+ |
|
| 979 |
+=head2 add_format |
|
| 980 |
+ |
|
| 981 |
+ $dbi->add_format(date => '%Y:%m:%d'); |
|
| 982 |
+ |
|
| 983 |
+=head2 create_query |
|
| 984 |
+ |
|
| 985 |
+ # Create Query object from SQL template |
|
| 986 |
+ my $query = $dbi->create_query($template); |
|
| 987 |
+ |
|
| 988 |
+=head2 execute |
|
| 989 |
+ |
|
| 990 |
+ # Parse SQL template and execute SQL |
|
| 991 |
+ $result = $dbi->query($query, $params); |
|
| 992 |
+ $result = $dbi->query($template, $params); # Shorcut |
|
| 993 |
+ |
|
| 994 |
+ # Sample |
|
| 995 |
+ $result = $dbi->query("select * from authors where {= name} and {= age}",
|
|
| 996 |
+ {author => 'taro', age => 19});
|
|
| 997 |
+ |
|
| 998 |
+ while (my @row = $result->fetch) {
|
|
| 999 |
+ # do something |
|
| 1000 |
+ } |
|
| 1001 |
+ |
|
| 1002 |
+See also L<DBIx::Custom::SQL::Template> |
|
| 1003 |
+ |
|
| 1004 |
+=head2 run_transaction |
|
| 1005 |
+ |
|
| 1006 |
+ # Run transaction |
|
| 1007 |
+ $dbi->run_transaction(sub {
|
|
| 1008 |
+ # do something |
|
| 1009 |
+ }); |
|
| 1010 |
+ |
|
| 1011 |
+If transaction is success, commit is execute. |
|
| 1012 |
+If tranzation is died, rollback is execute. |
|
| 1013 |
+ |
|
| 1014 |
+=head2 insert |
|
| 1015 |
+ |
|
| 1016 |
+ # Insert |
|
| 1017 |
+ $dbi->insert($table, $insert_values); |
|
| 1018 |
+ |
|
| 1019 |
+ # Sample |
|
| 1020 |
+ $dbi->insert('books', {title => 'Perl', author => 'Taro'});
|
|
| 1021 |
+ |
|
| 1022 |
+=head2 update |
|
| 1023 |
+ |
|
| 1024 |
+ # Update |
|
| 1025 |
+ $dbi->update($table, $update_values, $where); |
|
| 1026 |
+ |
|
| 1027 |
+ # Sample |
|
| 1028 |
+ $dbi->update('books', {title => 'Perl', author => 'Taro'}, {id => 5});
|
|
| 1029 |
+ |
|
| 1030 |
+=head2 update_all |
|
| 1031 |
+ |
|
| 1032 |
+ # Update all rows |
|
| 1033 |
+ $dbi->update($table, $updat_values); |
|
| 1034 |
+ |
|
| 1035 |
+=head2 delete |
|
| 1036 |
+ |
|
| 1037 |
+ # Delete |
|
| 1038 |
+ $dbi->delete($table, $where); |
|
| 1039 |
+ |
|
| 1040 |
+ # Sample |
|
| 1041 |
+ $dbi->delete('Books', {id => 5});
|
|
| 1042 |
+ |
|
| 1043 |
+=head2 delete_all |
|
| 1044 |
+ |
|
| 1045 |
+ # Delete all rows |
|
| 1046 |
+ $dbi->delete_all($table); |
|
| 1047 |
+ |
|
| 1048 |
+=head2 last_insert_id |
|
| 1049 |
+ |
|
| 1050 |
+ # Get last insert id |
|
| 1051 |
+ $last_insert_id = $dbi->last_insert_id; |
|
| 1052 |
+ |
|
| 1053 |
+This method is same as DBI last_insert_id; |
|
| 1054 |
+ |
|
| 1055 |
+=head2 select |
|
| 1056 |
+ |
|
| 1057 |
+ # Select |
|
| 1058 |
+ $dbi->select( |
|
| 1059 |
+ $table, # must be string or array; |
|
| 1060 |
+ [@$columns], # must be array reference. this is optional |
|
| 1061 |
+ {%$where_params}, # must be hash reference. this is optional
|
|
| 1062 |
+ $append_statement, # must be string. this is optional |
|
| 1063 |
+ $query_edit_callback # must be code reference. this is optional |
|
| 1064 |
+ ); |
|
| 1065 |
+ |
|
| 1066 |
+ # Sample |
|
| 1067 |
+ $dbi->select( |
|
| 1068 |
+ 'Books', |
|
| 1069 |
+ ['title', 'author'], |
|
| 1070 |
+ {id => 1},
|
|
| 1071 |
+ "for update", |
|
| 1072 |
+ sub {
|
|
| 1073 |
+ my $query = shift; |
|
| 1074 |
+ $query->bind_filter(sub {
|
|
| 1075 |
+ # ... |
|
| 1076 |
+ }); |
|
| 1077 |
+ } |
|
| 1078 |
+ ); |
|
| 1079 |
+ |
|
| 1080 |
+ # The way to join multi tables |
|
| 1081 |
+ $dbi->select( |
|
| 1082 |
+ ['table1', 'table2'], |
|
| 1083 |
+ ['table1.id as table1_id', 'title'], |
|
| 1084 |
+ {table1.id => 1},
|
|
| 1085 |
+ "where table1.id = table2.id", |
|
| 1086 |
+ ); |
|
| 1087 |
+ |
|
| 1088 |
+=head1 Class Accessors |
|
| 1089 |
+ |
|
| 1090 |
+=head2 query_cache_max |
|
| 1091 |
+ |
|
| 1092 |
+ # Max query cache count |
|
| 1093 |
+ $class = $class->query_cache_max($query_cache_max); |
|
| 1094 |
+ $query_cache_max = $class->query_cache_max; |
|
| 1095 |
+ |
|
| 1096 |
+ # Sample |
|
| 1097 |
+ DBIx::Custom->query_cache_max(50); |
|
| 1098 |
+ |
|
| 1099 |
+=head1 CAUTION |
|
| 1100 |
+ |
|
| 1101 |
+DBIx::Custom have DIB object internal. |
|
| 1102 |
+This module is work well in the following DBI condition. |
|
| 1103 |
+ |
|
| 1104 |
+ 1. AutoCommit is true |
|
| 1105 |
+ 2. RaiseError is true |
|
| 1106 |
+ |
|
| 1107 |
+By default, Both AutoCommit and RaiseError is true. |
|
| 1108 |
+You must not change these mode not to damage your data. |
|
| 1109 |
+ |
|
| 1110 |
+If you change these mode, |
|
| 1111 |
+you cannot get correct error message, |
|
| 1112 |
+or run_transaction may fail. |
|
| 1113 |
+ |
|
| 1114 |
+=head1 AUTHOR |
|
| 1115 |
+ |
|
| 1116 |
+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >> |
|
| 1117 |
+ |
|
| 1118 |
+Github L<http://github.com/yuki-kimoto> |
|
| 1119 |
+ |
|
| 1120 |
+=head1 COPYRIGHT & LICENSE |
|
| 1121 |
+ |
|
| 1122 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 1123 |
+ |
|
| 1124 |
+This program is free software; you can redistribute it and/or modify it |
|
| 1125 |
+under the same terms as Perl itself. |
|
| 1126 |
+ |
|
| 1127 |
+=cut |
| ... | ... |
@@ -0,0 +1,117 @@ |
| 1 |
+package DBIx::Custom::Basic; |
|
| 2 |
+use 5.008001; |
|
| 3 |
+use base 'DBIx::Custom'; |
|
| 4 |
+use Encode qw/decode encode/; |
|
| 5 |
+ |
|
| 6 |
+use warnings; |
|
| 7 |
+use strict; |
|
| 8 |
+ |
|
| 9 |
+my $class = __PACKAGE__; |
|
| 10 |
+ |
|
| 11 |
+$class->add_filter( |
|
| 12 |
+ encode_utf8 => sub {
|
|
| 13 |
+ my $value = shift; |
|
| 14 |
+ utf8::upgrade($value) unless Encode::is_utf8($value); |
|
| 15 |
+ return encode('UTF-8', $value);
|
|
| 16 |
+ }, |
|
| 17 |
+ decode_utf8 => sub { decode('UTF-8', shift) }
|
|
| 18 |
+); |
|
| 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 |
+# Methods |
|
| 30 |
+sub utf8_filter_on {
|
|
| 31 |
+ my $self = shift; |
|
| 32 |
+ $self->bind_filter($self->filters->{encode_utf8});
|
|
| 33 |
+ $self->fetch_filter($self->filters->{decode_utf8});
|
|
| 34 |
+} |
|
| 35 |
+ |
|
| 36 |
+1; |
|
| 37 |
+ |
|
| 38 |
+=head1 NAME |
|
| 39 |
+ |
|
| 40 |
+DBIx::Custom::Basic - DBIx::Custom basic implementation |
|
| 41 |
+ |
|
| 42 |
+=head1 Version |
|
| 43 |
+ |
|
| 44 |
+Version 0.0201 |
|
| 45 |
+ |
|
| 46 |
+=head1 See DBIx::Custom documentation |
|
| 47 |
+ |
|
| 48 |
+This class is L<DBIx::Custom> subclass. |
|
| 49 |
+ |
|
| 50 |
+You can use all methods of L<DBIx::Custom> |
|
| 51 |
+ |
|
| 52 |
+Please see L<DBIx::Custom> documentation |
|
| 53 |
+ |
|
| 54 |
+=head1 Filters |
|
| 55 |
+ |
|
| 56 |
+=head2 encode_utf8 |
|
| 57 |
+ |
|
| 58 |
+ # Encode to UTF-8 byte stream (utf8::upgrade is done if need) |
|
| 59 |
+ $dbi->filters->{encode_utf8}->($value);
|
|
| 60 |
+ |
|
| 61 |
+This filter is generally used as bind filter |
|
| 62 |
+ |
|
| 63 |
+ $dbi->bind_filter($dbi->filters->{encode_utf8});
|
|
| 64 |
+ |
|
| 65 |
+=head2 decode_utf8 |
|
| 66 |
+ |
|
| 67 |
+ # Decode to perl internal string |
|
| 68 |
+ $dbi->filters->{decode_utf8}->($value);
|
|
| 69 |
+ |
|
| 70 |
+This filter is generally used as fetch filter |
|
| 71 |
+ |
|
| 72 |
+ $dbi->fetch_filter($dbi->filters->{decode_utf8});
|
|
| 73 |
+ |
|
| 74 |
+=head2 Formats |
|
| 75 |
+ |
|
| 76 |
+strptime formats is available |
|
| 77 |
+ |
|
| 78 |
+ # format name format |
|
| 79 |
+ 'SQL99_date' '%Y-%m-%d', |
|
| 80 |
+ 'SQL99_datetime' '%Y-%m-%d %H:%M:%S', |
|
| 81 |
+ 'SQL99_time' '%H:%M:%S', |
|
| 82 |
+ 'ISO-8601_date' '%Y-%m-%d', |
|
| 83 |
+ 'ISO-8601_datetime' '%Y-%m-%dT%H:%M:%S', |
|
| 84 |
+ 'ISO-8601_time' '%H:%M:%S', |
|
| 85 |
+ |
|
| 86 |
+You get format as the following |
|
| 87 |
+ |
|
| 88 |
+ my $format = $dbi->formats->{$format_name};
|
|
| 89 |
+ |
|
| 90 |
+=head1 Methods |
|
| 91 |
+ |
|
| 92 |
+=head2 utf8_filter_on |
|
| 93 |
+ |
|
| 94 |
+ # Encode and decode utf8 filter on |
|
| 95 |
+ $dbi->utf8_filter_on; |
|
| 96 |
+ |
|
| 97 |
+This equel to |
|
| 98 |
+ |
|
| 99 |
+ $dbi->bind_filter($dbi->filters->{encode_utf8});
|
|
| 100 |
+ $dbi->fetch_filter($dbi->filters->{decode_utf8});
|
|
| 101 |
+ |
|
| 102 |
+=head1 AUTHOR |
|
| 103 |
+ |
|
| 104 |
+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >> |
|
| 105 |
+ |
|
| 106 |
+Github L<http://github.com/yuki-kimoto> |
|
| 107 |
+ |
|
| 108 |
+I develope this module L<http://github.com/yuki-kimoto/DBIx-Custom> |
|
| 109 |
+ |
|
| 110 |
+=head1 COPYRIGHT & LICENSE |
|
| 111 |
+ |
|
| 112 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 113 |
+ |
|
| 114 |
+This program is free software; you can redistribute it and/or modify it |
|
| 115 |
+under the same terms as Perl itself. |
|
| 116 |
+ |
|
| 117 |
+=cut |
| ... | ... |
@@ -0,0 +1,86 @@ |
| 1 |
+package DBIx::Custom::MySQL; |
|
| 2 |
+use base 'DBIx::Custom::Basic'; |
|
| 3 |
+ |
|
| 4 |
+use warnings; |
|
| 5 |
+use strict; |
|
| 6 |
+ |
|
| 7 |
+my $class = __PACKAGE__; |
|
| 8 |
+ |
|
| 9 |
+$class->add_format( |
|
| 10 |
+ datetime => $class->formats->{SQL99_datetime},
|
|
| 11 |
+ date => $class->formats->{SQL99_date},
|
|
| 12 |
+ time => $class->formats->{SQL99_time},
|
|
| 13 |
+); |
|
| 14 |
+ |
|
| 15 |
+ |
|
| 16 |
+sub connect {
|
|
| 17 |
+ my $self = shift; |
|
| 18 |
+ |
|
| 19 |
+ if (!$self->data_source && (my $database = $self->database)) {
|
|
| 20 |
+ $self->data_source("dbi:mysql:dbname=$database");
|
|
| 21 |
+ } |
|
| 22 |
+ |
|
| 23 |
+ return $self->SUPER::connect; |
|
| 24 |
+} |
|
| 25 |
+ |
|
| 26 |
+=head1 NAME |
|
| 27 |
+ |
|
| 28 |
+DBIx::Custom::MySQL - DBIx::Custom MySQL implementation |
|
| 29 |
+ |
|
| 30 |
+=head1 Version |
|
| 31 |
+ |
|
| 32 |
+Version 0.0102 |
|
| 33 |
+ |
|
| 34 |
+=head1 Synopsys |
|
| 35 |
+ |
|
| 36 |
+ # New |
|
| 37 |
+ my $dbi = DBIx::Custom::MySQL->new(user => 'taro', $password => 'kliej&@K', |
|
| 38 |
+ database => 'sample_db'); |
|
| 39 |
+ # Insert |
|
| 40 |
+ $dbi->insert('books', {title => 'perl', author => 'taro'});
|
|
| 41 |
+ |
|
| 42 |
+ # Update |
|
| 43 |
+ # same as 'update books set (title = 'aaa', author = 'ken') where id = 5; |
|
| 44 |
+ $dbi->update('books', {title => 'aaa', author => 'ken'}, {id => 5});
|
|
| 45 |
+ |
|
| 46 |
+ # Delete |
|
| 47 |
+ $dbi->delete('books', {author => 'taro'});
|
|
| 48 |
+ |
|
| 49 |
+ # select * from books; |
|
| 50 |
+ $dbi->select('books');
|
|
| 51 |
+ |
|
| 52 |
+ # select * from books where ahthor = 'taro'; |
|
| 53 |
+ $dbi->select('books', {author => 'taro'});
|
|
| 54 |
+ |
|
| 55 |
+=head1 See DBIx::Custom and DBI::Custom::Basic documentation |
|
| 56 |
+ |
|
| 57 |
+This class is L<DBIx::Custom::Basic> subclass, |
|
| 58 |
+and L<DBIx::Custom::Basic> is L<DBIx::Custom> subclass. |
|
| 59 |
+ |
|
| 60 |
+You can use all methods of L<DBIx::Custom::Basic> and <DBIx::Custom> |
|
| 61 |
+Please see L<DBIx::Custom::Basic> and <DBIx::Custom> documentation. |
|
| 62 |
+ |
|
| 63 |
+=head1 Object methods |
|
| 64 |
+ |
|
| 65 |
+=head2 connect |
|
| 66 |
+ |
|
| 67 |
+ This method override DBIx::Custom::connect |
|
| 68 |
+ |
|
| 69 |
+ If database attribute is set, automatically data source is created and connect |
|
| 70 |
+ |
|
| 71 |
+=head1 Author |
|
| 72 |
+ |
|
| 73 |
+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >> |
|
| 74 |
+ |
|
| 75 |
+Github L<http://github.com/yuki-kimoto> |
|
| 76 |
+ |
|
| 77 |
+I develope this module L<http://github.com/yuki-kimoto/DBIx-Custom> |
|
| 78 |
+ |
|
| 79 |
+=head1 Copyright & license |
|
| 80 |
+ |
|
| 81 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 82 |
+ |
|
| 83 |
+This program is free software; you can redistribute it and/or modify it |
|
| 84 |
+under the same terms as Perl itself. |
|
| 85 |
+ |
|
| 86 |
+ |
| ... | ... |
@@ -0,0 +1,101 @@ |
| 1 |
+package DBIx::Custom::Query; |
|
| 2 |
+use Object::Simple; |
|
| 3 |
+ |
|
| 4 |
+sub sql : Attr {}
|
|
| 5 |
+sub key_infos : Attr {}
|
|
| 6 |
+sub bind_filter : Attr {}
|
|
| 7 |
+sub fetch_filter : Attr {}
|
|
| 8 |
+sub sth : Attr {}
|
|
| 9 |
+ |
|
| 10 |
+sub no_bind_filters : Attr { type => 'array', trigger => sub {
|
|
| 11 |
+ my $self = shift; |
|
| 12 |
+ my $no_bind_filters = $self->no_bind_filters || []; |
|
| 13 |
+ my %no_bind_filters_map = map {$_ => 1} @{$no_bind_filters};
|
|
| 14 |
+ $self->_no_bind_filters_map(\%no_bind_filters_map); |
|
| 15 |
+}} |
|
| 16 |
+sub _no_bind_filters_map : Attr {default => sub { {} }}
|
|
| 17 |
+ |
|
| 18 |
+sub no_fetch_filters : Attr { type => 'array', default => sub { [] } }
|
|
| 19 |
+ |
|
| 20 |
+Object::Simple->build_class; |
|
| 21 |
+ |
|
| 22 |
+=head1 NAME |
|
| 23 |
+ |
|
| 24 |
+DBIx::Custom::Query - Query object for DBIx::Custom |
|
| 25 |
+ |
|
| 26 |
+=head1 VERSION |
|
| 27 |
+ |
|
| 28 |
+Version 0.0101 |
|
| 29 |
+ |
|
| 30 |
+=head1 SYNOPSIS |
|
| 31 |
+ |
|
| 32 |
+ # Create query |
|
| 33 |
+ my $dbi = DBIx::Custom->new; |
|
| 34 |
+ my $query = $dbi->create_query($template); |
|
| 35 |
+ |
|
| 36 |
+ # Set query attributes |
|
| 37 |
+ $query->bind_filter($dbi->filters->{default_bind_filter});
|
|
| 38 |
+ $query->no_bind_filters('title', 'author');
|
|
| 39 |
+ |
|
| 40 |
+ $query->fetch_filter($dbi->filters->{default_fetch_filter});
|
|
| 41 |
+ $query->no_fetch_filters('title', 'author');
|
|
| 42 |
+ |
|
| 43 |
+ # Execute query |
|
| 44 |
+ $dbi->execute($query, $params); |
|
| 45 |
+ |
|
| 46 |
+=head1 OBJECT ACCESSORS |
|
| 47 |
+ |
|
| 48 |
+=head2 sth |
|
| 49 |
+ |
|
| 50 |
+ # Set and get statement handle |
|
| 51 |
+ $self = $query->sth($sql); |
|
| 52 |
+ $sth = $query->sth; |
|
| 53 |
+ |
|
| 54 |
+=head2 sql |
|
| 55 |
+ |
|
| 56 |
+ # Set and get SQL |
|
| 57 |
+ $self = $query->sql($sql); |
|
| 58 |
+ $sql = $query->sql; |
|
| 59 |
+ |
|
| 60 |
+=head2 bind_filter |
|
| 61 |
+ |
|
| 62 |
+ # Set and get bind filter |
|
| 63 |
+ $self = $query->bind_filter($bind_filter); |
|
| 64 |
+ $bind_filter = $query->bind_filter; |
|
| 65 |
+ |
|
| 66 |
+=head2 no_bind_filters |
|
| 67 |
+ |
|
| 68 |
+ # Set and get keys of no filtering |
|
| 69 |
+ $self = $query->no_bind_filters($no_filters); |
|
| 70 |
+ $no_bind_filters = $query->no_bind_filters; |
|
| 71 |
+ |
|
| 72 |
+=head2 fetch_filter |
|
| 73 |
+ |
|
| 74 |
+ # Set and get fetch filter |
|
| 75 |
+ $self = $query->fetch_filter($fetch_filter); |
|
| 76 |
+ $fetch_filter = $query->fetch_filter; |
|
| 77 |
+ |
|
| 78 |
+=head2 no_fetch_filters |
|
| 79 |
+ |
|
| 80 |
+ # Set and get keys of no filtering |
|
| 81 |
+ $self = $query->no_fetch_filters($no_filters); |
|
| 82 |
+ $no_fetch_filters = $query->no_fetch_filters; |
|
| 83 |
+ |
|
| 84 |
+=head2 key_infos |
|
| 85 |
+ |
|
| 86 |
+ # Set and get key informations |
|
| 87 |
+ $self = $query->key_infos($key_infos); |
|
| 88 |
+ $key_infos = $query->key_infos; |
|
| 89 |
+ |
|
| 90 |
+=head1 AUTHOR |
|
| 91 |
+ |
|
| 92 |
+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >> |
|
| 93 |
+ |
|
| 94 |
+Github L<http://github.com/yuki-kimoto> |
|
| 95 |
+ |
|
| 96 |
+=head1 COPYRIGHT & LICENSE |
|
| 97 |
+ |
|
| 98 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 99 |
+ |
|
| 100 |
+This program is free software; you can redistribute it and/or modify it |
|
| 101 |
+under the same terms as Perl itself. |
| ... | ... |
@@ -0,0 +1,384 @@ |
| 1 |
+package DBIx::Custom::Result; |
|
| 2 |
+use Object::Simple; |
|
| 3 |
+use strict; |
|
| 4 |
+use warnings; |
|
| 5 |
+use Carp 'croak'; |
|
| 6 |
+ |
|
| 7 |
+# Attributes |
|
| 8 |
+sub sth : Attr {}
|
|
| 9 |
+sub fetch_filter : Attr {}
|
|
| 10 |
+sub no_fetch_filters : Attr { type => 'array', trigger => sub {
|
|
| 11 |
+ my $self = shift; |
|
| 12 |
+ my $no_fetch_filters = $self->no_fetch_filters || []; |
|
| 13 |
+ my %no_fetch_filters_map = map {$_ => 1} @{$no_fetch_filters};
|
|
| 14 |
+ $self->_no_fetch_filters_map(\%no_fetch_filters_map); |
|
| 15 |
+}} |
|
| 16 |
+sub _no_fetch_filters_map : Attr {default => sub { {} }}
|
|
| 17 |
+ |
|
| 18 |
+# Fetch (array) |
|
| 19 |
+sub fetch {
|
|
| 20 |
+ my ($self, $type) = @_; |
|
| 21 |
+ my $sth = $self->sth; |
|
| 22 |
+ my $fetch_filter = $self->fetch_filter; |
|
| 23 |
+ |
|
| 24 |
+ # Fetch |
|
| 25 |
+ my $row = $sth->fetchrow_arrayref; |
|
| 26 |
+ |
|
| 27 |
+ # Cannot fetch |
|
| 28 |
+ return unless $row; |
|
| 29 |
+ |
|
| 30 |
+ # Filter |
|
| 31 |
+ if ($fetch_filter) {
|
|
| 32 |
+ my $keys = $sth->{NAME_lc};
|
|
| 33 |
+ my $types = $sth->{TYPE};
|
|
| 34 |
+ for (my $i = 0; $i < @$keys; $i++) {
|
|
| 35 |
+ next if $self->_no_fetch_filters_map->{$keys->[$i]};
|
|
| 36 |
+ $row->[$i]= $fetch_filter->($row->[$i], $keys->[$i], $types->[$i], |
|
| 37 |
+ $sth, $i); |
|
| 38 |
+ } |
|
| 39 |
+ } |
|
| 40 |
+ return wantarray ? @$row : $row; |
|
| 41 |
+} |
|
| 42 |
+ |
|
| 43 |
+# Fetch (hash) |
|
| 44 |
+sub fetch_hash {
|
|
| 45 |
+ my $self = shift; |
|
| 46 |
+ my $sth = $self->sth; |
|
| 47 |
+ my $fetch_filter = $self->fetch_filter; |
|
| 48 |
+ |
|
| 49 |
+ # Fetch |
|
| 50 |
+ my $row = $sth->fetchrow_arrayref; |
|
| 51 |
+ |
|
| 52 |
+ # Cannot fetch |
|
| 53 |
+ return unless $row; |
|
| 54 |
+ |
|
| 55 |
+ # Keys |
|
| 56 |
+ my $keys = $sth->{NAME_lc};
|
|
| 57 |
+ |
|
| 58 |
+ # Filter |
|
| 59 |
+ my $row_hash = {};
|
|
| 60 |
+ if ($fetch_filter) {
|
|
| 61 |
+ my $types = $sth->{TYPE};
|
|
| 62 |
+ for (my $i = 0; $i < @$keys; $i++) {
|
|
| 63 |
+ if ($self->_no_fetch_filters_map->{$keys->[$i]}) {
|
|
| 64 |
+ $row_hash->{$keys->[$i]} = $row->[$i];
|
|
| 65 |
+ } |
|
| 66 |
+ else {
|
|
| 67 |
+ $row_hash->{$keys->[$i]}
|
|
| 68 |
+ = $fetch_filter->($row->[$i], $keys->[$i], |
|
| 69 |
+ $types->[$i], $sth, $i); |
|
| 70 |
+ } |
|
| 71 |
+ } |
|
| 72 |
+ } |
|
| 73 |
+ |
|
| 74 |
+ # No filter |
|
| 75 |
+ else {
|
|
| 76 |
+ for (my $i = 0; $i < @$keys; $i++) {
|
|
| 77 |
+ $row_hash->{$keys->[$i]} = $row->[$i];
|
|
| 78 |
+ } |
|
| 79 |
+ } |
|
| 80 |
+ return wantarray ? %$row_hash : $row_hash; |
|
| 81 |
+} |
|
| 82 |
+ |
|
| 83 |
+# Fetch only first (array) |
|
| 84 |
+sub fetch_first {
|
|
| 85 |
+ my $self = shift; |
|
| 86 |
+ |
|
| 87 |
+ # Fetch |
|
| 88 |
+ my $row = $self->fetch; |
|
| 89 |
+ |
|
| 90 |
+ # Not exist |
|
| 91 |
+ return unless $row; |
|
| 92 |
+ |
|
| 93 |
+ # Finish statement handle |
|
| 94 |
+ $self->finish; |
|
| 95 |
+ |
|
| 96 |
+ return wantarray ? @$row : $row; |
|
| 97 |
+} |
|
| 98 |
+ |
|
| 99 |
+# Fetch only first (hash) |
|
| 100 |
+sub fetch_hash_first {
|
|
| 101 |
+ my $self = shift; |
|
| 102 |
+ |
|
| 103 |
+ # Fetch hash |
|
| 104 |
+ my $row = $self->fetch_hash; |
|
| 105 |
+ |
|
| 106 |
+ # Not exist |
|
| 107 |
+ return unless $row; |
|
| 108 |
+ |
|
| 109 |
+ # Finish statement handle |
|
| 110 |
+ $self->finish; |
|
| 111 |
+ |
|
| 112 |
+ return wantarray ? %$row : $row; |
|
| 113 |
+} |
|
| 114 |
+ |
|
| 115 |
+# Fetch multi rows (array) |
|
| 116 |
+sub fetch_rows {
|
|
| 117 |
+ my ($self, $count) = @_; |
|
| 118 |
+ |
|
| 119 |
+ # Not specified Row count |
|
| 120 |
+ croak("Row count must be specified")
|
|
| 121 |
+ unless $count; |
|
| 122 |
+ |
|
| 123 |
+ # Fetch multi rows |
|
| 124 |
+ my $rows = []; |
|
| 125 |
+ for (my $i = 0; $i < $count; $i++) {
|
|
| 126 |
+ my @row = $self->fetch; |
|
| 127 |
+ |
|
| 128 |
+ last unless @row; |
|
| 129 |
+ |
|
| 130 |
+ push @$rows, \@row; |
|
| 131 |
+ } |
|
| 132 |
+ |
|
| 133 |
+ return unless @$rows; |
|
| 134 |
+ return wantarray ? @$rows : $rows; |
|
| 135 |
+} |
|
| 136 |
+ |
|
| 137 |
+# Fetch multi rows (hash) |
|
| 138 |
+sub fetch_hash_rows {
|
|
| 139 |
+ my ($self, $count) = @_; |
|
| 140 |
+ |
|
| 141 |
+ # Not specified Row count |
|
| 142 |
+ croak("Row count must be specified")
|
|
| 143 |
+ unless $count; |
|
| 144 |
+ |
|
| 145 |
+ # Fetch multi rows |
|
| 146 |
+ my $rows = []; |
|
| 147 |
+ for (my $i = 0; $i < $count; $i++) {
|
|
| 148 |
+ my %row = $self->fetch_hash; |
|
| 149 |
+ |
|
| 150 |
+ last unless %row; |
|
| 151 |
+ |
|
| 152 |
+ push @$rows, \%row; |
|
| 153 |
+ } |
|
| 154 |
+ |
|
| 155 |
+ return unless @$rows; |
|
| 156 |
+ return wantarray ? @$rows : $rows; |
|
| 157 |
+} |
|
| 158 |
+ |
|
| 159 |
+ |
|
| 160 |
+# Fetch all (array) |
|
| 161 |
+sub fetch_all {
|
|
| 162 |
+ my $self = shift; |
|
| 163 |
+ |
|
| 164 |
+ my $rows = []; |
|
| 165 |
+ while(my @row = $self->fetch) {
|
|
| 166 |
+ push @$rows, [@row]; |
|
| 167 |
+ } |
|
| 168 |
+ return wantarray ? @$rows : $rows; |
|
| 169 |
+} |
|
| 170 |
+ |
|
| 171 |
+# Fetch all (hash) |
|
| 172 |
+sub fetch_hash_all {
|
|
| 173 |
+ my $self = shift; |
|
| 174 |
+ |
|
| 175 |
+ my $rows = []; |
|
| 176 |
+ while(my %row = $self->fetch_hash) {
|
|
| 177 |
+ push @$rows, {%row};
|
|
| 178 |
+ } |
|
| 179 |
+ return wantarray ? @$rows : $rows; |
|
| 180 |
+} |
|
| 181 |
+ |
|
| 182 |
+# Finish |
|
| 183 |
+sub finish { shift->sth->finish }
|
|
| 184 |
+ |
|
| 185 |
+# Error |
|
| 186 |
+sub error {
|
|
| 187 |
+ my $self = shift; |
|
| 188 |
+ my $sth = $self->sth; |
|
| 189 |
+ return wantarray ? ($sth->errstr, $sth->err, $sth->state) : $sth->errstr; |
|
| 190 |
+} |
|
| 191 |
+ |
|
| 192 |
+Object::Simple->build_class; |
|
| 193 |
+ |
|
| 194 |
+=head1 NAME |
|
| 195 |
+ |
|
| 196 |
+DBIx::Custom::Result - Resultset for DBIx::Custom |
|
| 197 |
+ |
|
| 198 |
+=head1 VERSION |
|
| 199 |
+ |
|
| 200 |
+Version 0.0301 |
|
| 201 |
+ |
|
| 202 |
+=head1 SYNOPSIS |
|
| 203 |
+ |
|
| 204 |
+ # $result is DBIx::Custom::Result object |
|
| 205 |
+ my $dbi = DBIx::Custom->new; |
|
| 206 |
+ my $result = $dbi->query($sql_template, $param); |
|
| 207 |
+ |
|
| 208 |
+ while (my ($val1, $val2) = $result->fetch) {
|
|
| 209 |
+ # do something |
|
| 210 |
+ } |
|
| 211 |
+ |
|
| 212 |
+=head1 OBJECT ACCESSORS |
|
| 213 |
+ |
|
| 214 |
+=head2 sth |
|
| 215 |
+ |
|
| 216 |
+ # Set and Get statement handle |
|
| 217 |
+ $self = $result->sth($sth); |
|
| 218 |
+ $sth = $reuslt->sth |
|
| 219 |
+ |
|
| 220 |
+Statement handle is automatically set by DBIx::Custom. |
|
| 221 |
+so you do not set statement handle. |
|
| 222 |
+ |
|
| 223 |
+If you need statement handle, you can get statement handle by using this method. |
|
| 224 |
+ |
|
| 225 |
+=head2 fetch_filter |
|
| 226 |
+ |
|
| 227 |
+ # Set and Get fetch filter |
|
| 228 |
+ $self = $result->fetch_filter($sth); |
|
| 229 |
+ $fetch_filter = $result->fech_filter; |
|
| 230 |
+ |
|
| 231 |
+Statement handle is automatically set by DBIx::Custom. |
|
| 232 |
+If you want to set your fetch filter, you set it. |
|
| 233 |
+ |
|
| 234 |
+=head2 no_fetch_filters |
|
| 235 |
+ |
|
| 236 |
+ # Set and Get no filter keys when fetching |
|
| 237 |
+ $self = $result->no_fetch_filters($no_fetch_filters); |
|
| 238 |
+ $no_fetch_filters = $result->no_fetch_filters; |
|
| 239 |
+ |
|
| 240 |
+=head1 METHODS |
|
| 241 |
+ |
|
| 242 |
+=head2 fetch |
|
| 243 |
+ |
|
| 244 |
+ # Fetch row as array reference (Scalar context) |
|
| 245 |
+ $row = $result->fetch; |
|
| 246 |
+ |
|
| 247 |
+ # Fetch row as array (List context) |
|
| 248 |
+ @row = $result->fecth |
|
| 249 |
+ |
|
| 250 |
+ # Sample |
|
| 251 |
+ while (my $row = $result->fetch) {
|
|
| 252 |
+ # do something |
|
| 253 |
+ my $val1 = $row->[0]; |
|
| 254 |
+ my $val2 = $row->[1]; |
|
| 255 |
+ } |
|
| 256 |
+ |
|
| 257 |
+fetch method is fetch resultset and get row as array or array reference. |
|
| 258 |
+ |
|
| 259 |
+=head2 fetch_hash |
|
| 260 |
+ |
|
| 261 |
+ # Fetch row as hash reference (Scalar context) |
|
| 262 |
+ $row = $result->fetch_hash; |
|
| 263 |
+ |
|
| 264 |
+ # Fetch row as hash (List context) |
|
| 265 |
+ %row = $result->fecth_hash |
|
| 266 |
+ |
|
| 267 |
+ # Sample |
|
| 268 |
+ while (my $row = $result->fetch_hash) {
|
|
| 269 |
+ # do something |
|
| 270 |
+ my $val1 = $row->{key1};
|
|
| 271 |
+ my $val2 = $row->{key2};
|
|
| 272 |
+ } |
|
| 273 |
+ |
|
| 274 |
+fetch_hash method is fetch resultset and get row as hash or hash reference. |
|
| 275 |
+ |
|
| 276 |
+=head2 fetch_first |
|
| 277 |
+ |
|
| 278 |
+ # Fetch only first (Scalar context) |
|
| 279 |
+ $row = $result->fetch_first; |
|
| 280 |
+ |
|
| 281 |
+ # Fetch only first (List context) |
|
| 282 |
+ @row = $result->fetch_first; |
|
| 283 |
+ |
|
| 284 |
+This method fetch only first and finish statement handle |
|
| 285 |
+ |
|
| 286 |
+=head2 fetch_hash_first |
|
| 287 |
+ |
|
| 288 |
+ # Fetch only first as hash (Scalar context) |
|
| 289 |
+ $row = $result->fetch_hash_first; |
|
| 290 |
+ |
|
| 291 |
+ # Fetch only first as hash (Scalar context) |
|
| 292 |
+ @row = $result->fetch_hash_first; |
|
| 293 |
+ |
|
| 294 |
+This method fetch only first and finish statement handle |
|
| 295 |
+ |
|
| 296 |
+=head2 fetch_rows |
|
| 297 |
+ |
|
| 298 |
+ # Fetch multi rows (Scalar context) |
|
| 299 |
+ $rows = $result->fetch_rows($row_count); |
|
| 300 |
+ |
|
| 301 |
+ # Fetch multi rows (List context) |
|
| 302 |
+ @rows = $result->fetch_rows($row_count); |
|
| 303 |
+ |
|
| 304 |
+ # Sapmle |
|
| 305 |
+ $rows = $result->fetch_rows(10); |
|
| 306 |
+ |
|
| 307 |
+=head2 fetch_hash_rows |
|
| 308 |
+ |
|
| 309 |
+ # Fetch multi rows as hash (Scalar context) |
|
| 310 |
+ $rows = $result->fetch_hash_rows($row_count); |
|
| 311 |
+ |
|
| 312 |
+ # Fetch multi rows as hash (List context) |
|
| 313 |
+ @rows = $result->fetch_hash_rows($row_count); |
|
| 314 |
+ |
|
| 315 |
+ # Sapmle |
|
| 316 |
+ $rows = $result->fetch_hash_rows(10); |
|
| 317 |
+ |
|
| 318 |
+=head2 fetch_all |
|
| 319 |
+ |
|
| 320 |
+ # Fetch all row as array ref of array ref (Scalar context) |
|
| 321 |
+ $rows = $result->fetch_all; |
|
| 322 |
+ |
|
| 323 |
+ # Fetch all row as array of array ref (List context) |
|
| 324 |
+ @rows = $result->fecth_all; |
|
| 325 |
+ |
|
| 326 |
+ # Sample |
|
| 327 |
+ my $rows = $result->fetch_all; |
|
| 328 |
+ my $val0_0 = $rows->[0][0]; |
|
| 329 |
+ my $val1_1 = $rows->[1][1]; |
|
| 330 |
+ |
|
| 331 |
+fetch_all method is fetch resultset and get all rows as array or array reference. |
|
| 332 |
+ |
|
| 333 |
+=head2 fetch_hash_all |
|
| 334 |
+ |
|
| 335 |
+ # Fetch all row as array ref of hash ref (Scalar context) |
|
| 336 |
+ $rows = $result->fetch_hash_all; |
|
| 337 |
+ |
|
| 338 |
+ # Fetch all row as array of hash ref (List context) |
|
| 339 |
+ @rows = $result->fecth_all_hash; |
|
| 340 |
+ |
|
| 341 |
+ # Sample |
|
| 342 |
+ my $rows = $result->fetch_hash_all; |
|
| 343 |
+ my $val0_key1 = $rows->[0]{key1};
|
|
| 344 |
+ my $val1_key2 = $rows->[1]{key2};
|
|
| 345 |
+ |
|
| 346 |
+=head2 error |
|
| 347 |
+ |
|
| 348 |
+ # Get error infomation |
|
| 349 |
+ $error_messege = $result->error; |
|
| 350 |
+ ($error_message, $error_number, $error_state) = $result->error; |
|
| 351 |
+ |
|
| 352 |
+You can get get information. This is crenspond to the following. |
|
| 353 |
+ |
|
| 354 |
+ $error_message : $result->sth->errstr |
|
| 355 |
+ $error_number : $result->sth->err |
|
| 356 |
+ $error_state : $result->sth->state |
|
| 357 |
+ |
|
| 358 |
+=head2 finish |
|
| 359 |
+ |
|
| 360 |
+ # Finish statement handle |
|
| 361 |
+ $result->finish |
|
| 362 |
+ |
|
| 363 |
+ # Sample |
|
| 364 |
+ my $row = $reuslt->fetch; # fetch only one row |
|
| 365 |
+ $result->finish |
|
| 366 |
+ |
|
| 367 |
+You can finish statement handle.This is equel to |
|
| 368 |
+ |
|
| 369 |
+ $result->sth->finish; |
|
| 370 |
+ |
|
| 371 |
+=head1 AUTHOR |
|
| 372 |
+ |
|
| 373 |
+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >> |
|
| 374 |
+ |
|
| 375 |
+Github L<http://github.com/yuki-kimoto> |
|
| 376 |
+ |
|
| 377 |
+=head1 COPYRIGHT & LICENSE |
|
| 378 |
+ |
|
| 379 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 380 |
+ |
|
| 381 |
+This program is free software; you can redistribute it and/or modify it |
|
| 382 |
+under the same terms as Perl itself. |
|
| 383 |
+ |
|
| 384 |
+=cut |
| ... | ... |
@@ -0,0 +1,694 @@ |
| 1 |
+package DBIx::Custom::SQL::Template; |
|
| 2 |
+use Object::Simple; |
|
| 3 |
+ |
|
| 4 |
+use Carp 'croak'; |
|
| 5 |
+ |
|
| 6 |
+# Accessor is created by Object::Simple. Please read Object::Simple document |
|
| 7 |
+ |
|
| 8 |
+### Class-Object accessors |
|
| 9 |
+ |
|
| 10 |
+# Tag start |
|
| 11 |
+sub tag_start : ClassObjectAttr {
|
|
| 12 |
+ initialize => {default => '{', clone => 'scalar'}
|
|
| 13 |
+} |
|
| 14 |
+ |
|
| 15 |
+# Tag end |
|
| 16 |
+sub tag_end : ClassObjectAttr {
|
|
| 17 |
+ initialize => {default => '}', clone => 'scalar'}
|
|
| 18 |
+} |
|
| 19 |
+ |
|
| 20 |
+# Tag syntax |
|
| 21 |
+sub tag_syntax : ClassObjectAttr {
|
|
| 22 |
+ initialize => {default => <<'EOS', clone => 'scalar'}}
|
|
| 23 |
+[tag] [expand] |
|
| 24 |
+{? name} ?
|
|
| 25 |
+{= name} name = ?
|
|
| 26 |
+{<> name} name <> ?
|
|
| 27 |
+ |
|
| 28 |
+{< name} name < ?
|
|
| 29 |
+{> name} name > ?
|
|
| 30 |
+{>= name} name >= ?
|
|
| 31 |
+{<= name} name <= ?
|
|
| 32 |
+ |
|
| 33 |
+{like name} name like ?
|
|
| 34 |
+{in name number} name in [?, ?, ..]
|
|
| 35 |
+ |
|
| 36 |
+{insert key1 key2} (key1, key2) values (?, ?)
|
|
| 37 |
+{update key1 key2} set key1 = ?, key2 = ?
|
|
| 38 |
+EOS |
|
| 39 |
+ |
|
| 40 |
+# Tag processors |
|
| 41 |
+sub tag_processors : ClassObjectAttr {
|
|
| 42 |
+ type => 'hash', |
|
| 43 |
+ deref => 1, |
|
| 44 |
+ initialize => {
|
|
| 45 |
+ clone => 'hash', |
|
| 46 |
+ default => sub {{
|
|
| 47 |
+ '?' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_basic_tag, |
|
| 48 |
+ '=' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_basic_tag, |
|
| 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 |
+ 'like' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_basic_tag, |
|
| 55 |
+ 'in' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_in_tag, |
|
| 56 |
+ 'insert' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_insert_tag, |
|
| 57 |
+ 'update' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_update_tag |
|
| 58 |
+ }} |
|
| 59 |
+ } |
|
| 60 |
+} |
|
| 61 |
+ |
|
| 62 |
+# Add Tag processor |
|
| 63 |
+sub add_tag_processor {
|
|
| 64 |
+ my $invocant = shift; |
|
| 65 |
+ my $tag_processors = ref $_[0] eq 'HASH' ? $_[0] : {@_};
|
|
| 66 |
+ $invocant->tag_processors(%{$invocant->tag_processors}, %{$tag_processors});
|
|
| 67 |
+ return $invocant; |
|
| 68 |
+} |
|
| 69 |
+ |
|
| 70 |
+# Clone |
|
| 71 |
+sub clone {
|
|
| 72 |
+ my $self = shift; |
|
| 73 |
+ my $new = $self->new; |
|
| 74 |
+ |
|
| 75 |
+ $new->tag_start($self->tag_start); |
|
| 76 |
+ $new->tag_end($self->tag_end); |
|
| 77 |
+ $new->tag_syntax($self->tag_syntax); |
|
| 78 |
+ $new->tag_processors({%{$self->tag_processors || {}}});
|
|
| 79 |
+ |
|
| 80 |
+ return $new; |
|
| 81 |
+} |
|
| 82 |
+ |
|
| 83 |
+ |
|
| 84 |
+### Object Methods |
|
| 85 |
+ |
|
| 86 |
+# Create Query |
|
| 87 |
+sub create_query {
|
|
| 88 |
+ my ($self, $template) = @_; |
|
| 89 |
+ |
|
| 90 |
+ # Parse template |
|
| 91 |
+ my $tree = $self->_parse_template($template); |
|
| 92 |
+ |
|
| 93 |
+ # Build query |
|
| 94 |
+ my $query = $self->_build_query($tree); |
|
| 95 |
+ |
|
| 96 |
+ return $query; |
|
| 97 |
+} |
|
| 98 |
+ |
|
| 99 |
+# Parse template |
|
| 100 |
+sub _parse_template {
|
|
| 101 |
+ my ($self, $template) = @_; |
|
| 102 |
+ $template ||= ''; |
|
| 103 |
+ |
|
| 104 |
+ my $tree = []; |
|
| 105 |
+ |
|
| 106 |
+ # Tags |
|
| 107 |
+ my $tag_start = quotemeta $self->tag_start; |
|
| 108 |
+ my $tag_end = quotemeta $self->tag_end; |
|
| 109 |
+ |
|
| 110 |
+ # Tokenize |
|
| 111 |
+ my $state = 'text'; |
|
| 112 |
+ |
|
| 113 |
+ # Save original template |
|
| 114 |
+ my $original_template = $template; |
|
| 115 |
+ |
|
| 116 |
+ # Parse template |
|
| 117 |
+ while ($template =~ s/([^$tag_start]*?)$tag_start([^$tag_end].*?)$tag_end//sm) {
|
|
| 118 |
+ my $text = $1; |
|
| 119 |
+ my $tag = $2; |
|
| 120 |
+ |
|
| 121 |
+ # Parse tree |
|
| 122 |
+ push @$tree, {type => 'text', tag_args => [$text]} if $text;
|
|
| 123 |
+ |
|
| 124 |
+ if ($tag) {
|
|
| 125 |
+ # Get tag name and arguments |
|
| 126 |
+ my ($tag_name, @tag_args) = split /\s+/, $tag; |
|
| 127 |
+ |
|
| 128 |
+ # Tag processor is exist? |
|
| 129 |
+ unless ($self->tag_processors->{$tag_name}) {
|
|
| 130 |
+ my $tag_syntax = $self->tag_syntax; |
|
| 131 |
+ croak("Tag '{$tag}' in SQL template is not exist.\n\n" .
|
|
| 132 |
+ "<SQL template tag syntax>\n" . |
|
| 133 |
+ "$tag_syntax\n" . |
|
| 134 |
+ "<Your SQL template>\n" . |
|
| 135 |
+ "$original_template\n\n"); |
|
| 136 |
+ } |
|
| 137 |
+ |
|
| 138 |
+ # Check tag arguments |
|
| 139 |
+ foreach my $tag_arg (@tag_args) {
|
|
| 140 |
+ # Cannot cantain placehosder '?' |
|
| 141 |
+ croak("Tag '{t }' arguments cannot contain '?'")
|
|
| 142 |
+ if $tag_arg =~ /\?/; |
|
| 143 |
+ } |
|
| 144 |
+ |
|
| 145 |
+ # Add tag to parsing tree |
|
| 146 |
+ push @$tree, {type => 'tag', tag_name => $tag_name, tag_args => [@tag_args]};
|
|
| 147 |
+ } |
|
| 148 |
+ } |
|
| 149 |
+ |
|
| 150 |
+ # Add text to parsing tree |
|
| 151 |
+ push @$tree, {type => 'text', tag_args => [$template]} if $template;
|
|
| 152 |
+ |
|
| 153 |
+ return $tree; |
|
| 154 |
+} |
|
| 155 |
+ |
|
| 156 |
+# Build SQL from parsing tree |
|
| 157 |
+sub _build_query {
|
|
| 158 |
+ my ($self, $tree) = @_; |
|
| 159 |
+ |
|
| 160 |
+ # SQL |
|
| 161 |
+ my $sql = ''; |
|
| 162 |
+ |
|
| 163 |
+ # All parameter key infomation |
|
| 164 |
+ my $all_key_infos = []; |
|
| 165 |
+ |
|
| 166 |
+ # Build SQL |
|
| 167 |
+ foreach my $node (@$tree) {
|
|
| 168 |
+ |
|
| 169 |
+ # Get type, tag name, and arguments |
|
| 170 |
+ my $type = $node->{type};
|
|
| 171 |
+ my $tag_name = $node->{tag_name};
|
|
| 172 |
+ my $tag_args = $node->{tag_args};
|
|
| 173 |
+ |
|
| 174 |
+ # Text |
|
| 175 |
+ if ($type eq 'text') {
|
|
| 176 |
+ # Join text |
|
| 177 |
+ $sql .= $tag_args->[0]; |
|
| 178 |
+ } |
|
| 179 |
+ |
|
| 180 |
+ # Tag |
|
| 181 |
+ elsif ($type eq 'tag') {
|
|
| 182 |
+ |
|
| 183 |
+ # Get tag processor |
|
| 184 |
+ my $tag_processor = $self->tag_processors->{$tag_name};
|
|
| 185 |
+ |
|
| 186 |
+ # Tag processor is code ref? |
|
| 187 |
+ croak("Tag processor '$tag_name' must be code reference")
|
|
| 188 |
+ unless ref $tag_processor eq 'CODE'; |
|
| 189 |
+ |
|
| 190 |
+ # Expand tag using tag processor |
|
| 191 |
+ my ($expand, $key_infos) |
|
| 192 |
+ = $tag_processor->($tag_name, $tag_args); |
|
| 193 |
+ |
|
| 194 |
+ # Check tag processor return value |
|
| 195 |
+ croak("Tag processor '$tag_name' must return (\$expand, \$key_infos)")
|
|
| 196 |
+ if !defined $expand || ref $key_infos ne 'ARRAY'; |
|
| 197 |
+ |
|
| 198 |
+ # Check placeholder count |
|
| 199 |
+ croak("Placeholder count in SQL created by tag processor '$tag_name' " .
|
|
| 200 |
+ "must be same as key informations count") |
|
| 201 |
+ unless $self->_placeholder_count($expand) eq @$key_infos; |
|
| 202 |
+ |
|
| 203 |
+ # Add key information |
|
| 204 |
+ push @$all_key_infos, @$key_infos; |
|
| 205 |
+ |
|
| 206 |
+ # Join expand tag to SQL |
|
| 207 |
+ $sql .= $expand; |
|
| 208 |
+ } |
|
| 209 |
+ } |
|
| 210 |
+ |
|
| 211 |
+ # Add semicolon |
|
| 212 |
+ $sql .= ';' unless $sql =~ /;$/; |
|
| 213 |
+ |
|
| 214 |
+ # Query |
|
| 215 |
+ my $query = {sql => $sql, key_infos => $all_key_infos};
|
|
| 216 |
+ |
|
| 217 |
+ return $query; |
|
| 218 |
+} |
|
| 219 |
+ |
|
| 220 |
+# Get placeholder count |
|
| 221 |
+sub _placeholder_count {
|
|
| 222 |
+ my ($self, $expand) = @_; |
|
| 223 |
+ $expand ||= ''; |
|
| 224 |
+ |
|
| 225 |
+ my $count = 0; |
|
| 226 |
+ my $pos = -1; |
|
| 227 |
+ while (($pos = index($expand, '?', $pos + 1)) != -1) {
|
|
| 228 |
+ $count++; |
|
| 229 |
+ } |
|
| 230 |
+ return $count; |
|
| 231 |
+} |
|
| 232 |
+ |
|
| 233 |
+Object::Simple->build_class; |
|
| 234 |
+ |
|
| 235 |
+ |
|
| 236 |
+package DBIx::Custom::SQL::Template::TagProcessor; |
|
| 237 |
+use strict; |
|
| 238 |
+use warnings; |
|
| 239 |
+use Carp 'croak'; |
|
| 240 |
+ |
|
| 241 |
+# Expand tag '?', '=', '<>', '>', '<', '>=', '<=', 'like' |
|
| 242 |
+sub expand_basic_tag {
|
|
| 243 |
+ my ($tag_name, $tag_args) = @_; |
|
| 244 |
+ my $original_key = $tag_args->[0]; |
|
| 245 |
+ |
|
| 246 |
+ # Key is not exist |
|
| 247 |
+ croak("You must be pass key as argument to tag '{$tag_name }'")
|
|
| 248 |
+ if !$original_key; |
|
| 249 |
+ |
|
| 250 |
+ # Expanded tag |
|
| 251 |
+ my $expand = $tag_name eq '?' |
|
| 252 |
+ ? '?' |
|
| 253 |
+ : "$original_key $tag_name ?"; |
|
| 254 |
+ |
|
| 255 |
+ # Get table and clumn name |
|
| 256 |
+ my ($table, $column) = get_table_and_column($original_key); |
|
| 257 |
+ |
|
| 258 |
+ # Parameter key infomation |
|
| 259 |
+ my $key_info = {};
|
|
| 260 |
+ |
|
| 261 |
+ # Original key |
|
| 262 |
+ $key_info->{original_key} = $original_key;
|
|
| 263 |
+ |
|
| 264 |
+ # Table |
|
| 265 |
+ $key_info->{table} = $table;
|
|
| 266 |
+ |
|
| 267 |
+ # Column name |
|
| 268 |
+ $key_info->{column} = $column;
|
|
| 269 |
+ |
|
| 270 |
+ # Access keys |
|
| 271 |
+ my $access_keys = []; |
|
| 272 |
+ push @$access_keys, [$original_key]; |
|
| 273 |
+ push @$access_keys, [$table, $column] if $table && $column; |
|
| 274 |
+ $key_info->{access_keys} = $access_keys;
|
|
| 275 |
+ |
|
| 276 |
+ # Add parameter key information |
|
| 277 |
+ my $key_infos = []; |
|
| 278 |
+ push @$key_infos, $key_info; |
|
| 279 |
+ |
|
| 280 |
+ return ($expand, $key_infos); |
|
| 281 |
+} |
|
| 282 |
+ |
|
| 283 |
+# Expand tag 'in' |
|
| 284 |
+sub expand_in_tag {
|
|
| 285 |
+ my ($tag_name, $tag_args) = @_; |
|
| 286 |
+ my ($original_key, $placeholder_count) = @$tag_args; |
|
| 287 |
+ |
|
| 288 |
+ # Key must be specified |
|
| 289 |
+ croak("You must be pass key as first argument of tag '{$tag_name }'\n" .
|
|
| 290 |
+ "Usage: {$tag_name \$key \$placeholder_count}")
|
|
| 291 |
+ unless $original_key; |
|
| 292 |
+ |
|
| 293 |
+ |
|
| 294 |
+ # Place holder count must be specified |
|
| 295 |
+ croak("You must be pass placeholder count as second argument of tag '{$tag_name }'\n" .
|
|
| 296 |
+ "Usage: {$tag_name \$key \$placeholder_count}")
|
|
| 297 |
+ if !$placeholder_count || $placeholder_count =~ /\D/; |
|
| 298 |
+ |
|
| 299 |
+ # Expand tag |
|
| 300 |
+ my $expand = "$original_key $tag_name (";
|
|
| 301 |
+ for (my $i = 0; $i < $placeholder_count; $i++) {
|
|
| 302 |
+ $expand .= '?, '; |
|
| 303 |
+ } |
|
| 304 |
+ |
|
| 305 |
+ $expand =~ s/, $//; |
|
| 306 |
+ $expand .= ')'; |
|
| 307 |
+ |
|
| 308 |
+ # Get table and clumn name |
|
| 309 |
+ my ($table, $column) = get_table_and_column($original_key); |
|
| 310 |
+ |
|
| 311 |
+ # Create parameter key infomations |
|
| 312 |
+ my $key_infos = []; |
|
| 313 |
+ for (my $i = 0; $i < $placeholder_count; $i++) {
|
|
| 314 |
+ # Parameter key infomation |
|
| 315 |
+ my $key_info = {};
|
|
| 316 |
+ |
|
| 317 |
+ # Original key |
|
| 318 |
+ $key_info->{original_key} = $original_key;
|
|
| 319 |
+ |
|
| 320 |
+ # Table |
|
| 321 |
+ $key_info->{table} = $table;
|
|
| 322 |
+ |
|
| 323 |
+ # Column name |
|
| 324 |
+ $key_info->{column} = $column;
|
|
| 325 |
+ |
|
| 326 |
+ # Access keys |
|
| 327 |
+ my $access_keys = []; |
|
| 328 |
+ push @$access_keys, [$original_key, [$i]]; |
|
| 329 |
+ push @$access_keys, [$table, $column, [$i]] if $table && $column; |
|
| 330 |
+ $key_info->{access_keys} = $access_keys;
|
|
| 331 |
+ |
|
| 332 |
+ # Add parameter key infos |
|
| 333 |
+ push @$key_infos, $key_info; |
|
| 334 |
+ } |
|
| 335 |
+ |
|
| 336 |
+ return ($expand, $key_infos); |
|
| 337 |
+} |
|
| 338 |
+ |
|
| 339 |
+# Get table and column |
|
| 340 |
+sub get_table_and_column {
|
|
| 341 |
+ my $key = shift; |
|
| 342 |
+ $key ||= ''; |
|
| 343 |
+ |
|
| 344 |
+ return ('', $key) unless $key =~ /\./;
|
|
| 345 |
+ |
|
| 346 |
+ my ($table, $column) = split /\./, $key; |
|
| 347 |
+ |
|
| 348 |
+ return ($table, $column); |
|
| 349 |
+} |
|
| 350 |
+ |
|
| 351 |
+# Expand tag 'insert' |
|
| 352 |
+sub expand_insert_tag {
|
|
| 353 |
+ my ($tag_name, $tag_args) = @_; |
|
| 354 |
+ my $original_keys = $tag_args; |
|
| 355 |
+ |
|
| 356 |
+ # Insert key (k1, k2, k3, ..) |
|
| 357 |
+ my $insert_keys = '(';
|
|
| 358 |
+ |
|
| 359 |
+ # placeholder (?, ?, ?, ..) |
|
| 360 |
+ my $place_holders = '(';
|
|
| 361 |
+ |
|
| 362 |
+ foreach my $original_key (@$original_keys) {
|
|
| 363 |
+ # Get table and column |
|
| 364 |
+ my ($table, $column) = get_table_and_column($original_key); |
|
| 365 |
+ |
|
| 366 |
+ # Join insert column |
|
| 367 |
+ $insert_keys .= "$column, "; |
|
| 368 |
+ |
|
| 369 |
+ # Join place holder |
|
| 370 |
+ $place_holders .= "?, "; |
|
| 371 |
+ } |
|
| 372 |
+ |
|
| 373 |
+ # Delete last ', ' |
|
| 374 |
+ $insert_keys =~ s/, $//; |
|
| 375 |
+ |
|
| 376 |
+ # Close |
|
| 377 |
+ $insert_keys .= ')'; |
|
| 378 |
+ $place_holders =~ s/, $//; |
|
| 379 |
+ $place_holders .= ')'; |
|
| 380 |
+ |
|
| 381 |
+ # Expand tag |
|
| 382 |
+ my $expand = "$insert_keys values $place_holders"; |
|
| 383 |
+ |
|
| 384 |
+ # Create parameter key infomations |
|
| 385 |
+ my $key_infos = []; |
|
| 386 |
+ foreach my $original_key (@$original_keys) {
|
|
| 387 |
+ # Get table and clumn name |
|
| 388 |
+ my ($table, $column) = get_table_and_column($original_key); |
|
| 389 |
+ |
|
| 390 |
+ # Parameter key infomation |
|
| 391 |
+ my $key_info = {};
|
|
| 392 |
+ |
|
| 393 |
+ # Original key |
|
| 394 |
+ $key_info->{original_key} = $original_key;
|
|
| 395 |
+ |
|
| 396 |
+ # Table |
|
| 397 |
+ $key_info->{table} = $table;
|
|
| 398 |
+ |
|
| 399 |
+ # Column name |
|
| 400 |
+ $key_info->{column} = $column;
|
|
| 401 |
+ |
|
| 402 |
+ # Access keys |
|
| 403 |
+ my $access_keys = []; |
|
| 404 |
+ push @$access_keys, ['#insert', $original_key]; |
|
| 405 |
+ push @$access_keys, ['#insert', $table, $column] if $table && $column; |
|
| 406 |
+ push @$access_keys, [$original_key]; |
|
| 407 |
+ push @$access_keys, [$table, $column] if $table && $column; |
|
| 408 |
+ $key_info->{access_keys} = $access_keys;
|
|
| 409 |
+ |
|
| 410 |
+ # Add parameter key infos |
|
| 411 |
+ push @$key_infos, $key_info; |
|
| 412 |
+ } |
|
| 413 |
+ |
|
| 414 |
+ return ($expand, $key_infos); |
|
| 415 |
+} |
|
| 416 |
+ |
|
| 417 |
+# Expand tag 'update' |
|
| 418 |
+sub expand_update_tag {
|
|
| 419 |
+ my ($tag_name, $tag_args) = @_; |
|
| 420 |
+ my $original_keys = $tag_args; |
|
| 421 |
+ |
|
| 422 |
+ # Expanded tag |
|
| 423 |
+ my $expand = 'set '; |
|
| 424 |
+ |
|
| 425 |
+ # |
|
| 426 |
+ foreach my $original_key (@$original_keys) {
|
|
| 427 |
+ # Get table and clumn name |
|
| 428 |
+ my ($table, $column) = get_table_and_column($original_key); |
|
| 429 |
+ |
|
| 430 |
+ # Join key and placeholder |
|
| 431 |
+ $expand .= "$column = ?, "; |
|
| 432 |
+ } |
|
| 433 |
+ |
|
| 434 |
+ # Delete last ', ' |
|
| 435 |
+ $expand =~ s/, $//; |
|
| 436 |
+ |
|
| 437 |
+ # Create parameter key infomations |
|
| 438 |
+ my $key_infos = []; |
|
| 439 |
+ foreach my $original_key (@$original_keys) {
|
|
| 440 |
+ # Get table and clumn name |
|
| 441 |
+ my ($table, $column) = get_table_and_column($original_key); |
|
| 442 |
+ |
|
| 443 |
+ # Parameter key infomation |
|
| 444 |
+ my $key_info = {};
|
|
| 445 |
+ |
|
| 446 |
+ # Original key |
|
| 447 |
+ $key_info->{original_key} = $original_key;
|
|
| 448 |
+ |
|
| 449 |
+ # Table |
|
| 450 |
+ $key_info->{table} = $table;
|
|
| 451 |
+ |
|
| 452 |
+ # Column name |
|
| 453 |
+ $key_info->{column} = $column;
|
|
| 454 |
+ |
|
| 455 |
+ # Access keys |
|
| 456 |
+ my $access_keys = []; |
|
| 457 |
+ push @$access_keys, ['#update', $original_key]; |
|
| 458 |
+ push @$access_keys, ['#update', $table, $column] if $table && $column; |
|
| 459 |
+ push @$access_keys, [$original_key]; |
|
| 460 |
+ push @$access_keys, [$table, $column] if $table && $column; |
|
| 461 |
+ $key_info->{access_keys} = $access_keys;
|
|
| 462 |
+ |
|
| 463 |
+ # Add parameter key infos |
|
| 464 |
+ push @$key_infos, $key_info; |
|
| 465 |
+ } |
|
| 466 |
+ |
|
| 467 |
+ return ($expand, $key_infos); |
|
| 468 |
+} |
|
| 469 |
+ |
|
| 470 |
+1; |
|
| 471 |
+ |
|
| 472 |
+=head1 NAME |
|
| 473 |
+ |
|
| 474 |
+DBIx::Custom::SQL::Template - Custamizable SQL Template for DBIx::Custom |
|
| 475 |
+ |
|
| 476 |
+=head1 VERSION |
|
| 477 |
+ |
|
| 478 |
+Version 0.0101 |
|
| 479 |
+ |
|
| 480 |
+=cut |
|
| 481 |
+ |
|
| 482 |
+=head1 SYNOPSIS |
|
| 483 |
+ |
|
| 484 |
+ my $sql_tmpl = DBIx::Custom::SQL::Template->new; |
|
| 485 |
+ |
|
| 486 |
+ my $tmpl = "select from table {= k1} && {<> k2} || {like k3}";
|
|
| 487 |
+ my $param = {k1 => 1, k2 => 2, k3 => 3};
|
|
| 488 |
+ |
|
| 489 |
+ my $query = $sql_template->create_query($tmpl); |
|
| 490 |
+ |
|
| 491 |
+ |
|
| 492 |
+ # Using query from DBIx::Custom |
|
| 493 |
+ use DBIx::Custom; |
|
| 494 |
+ my $dbi = DBI->new( |
|
| 495 |
+ data_source => $data_source, |
|
| 496 |
+ user => $user, |
|
| 497 |
+ password => $password, |
|
| 498 |
+ dbi_options => {PrintError => 0, RaiseError => 1}
|
|
| 499 |
+ ); |
|
| 500 |
+ |
|
| 501 |
+ $query = $dbi->create_query($tmpl); # This is SQL::Template create_query |
|
| 502 |
+ $dbi->query($query, $param); |
|
| 503 |
+ |
|
| 504 |
+=head1 CLASS-OBJECT ACCESSORS |
|
| 505 |
+ |
|
| 506 |
+Class-Object accessor is used from both object and class |
|
| 507 |
+ |
|
| 508 |
+ $class->$accessor # call from class |
|
| 509 |
+ $self->$accessor # call form object |
|
| 510 |
+ |
|
| 511 |
+=head2 tag_processors |
|
| 512 |
+ |
|
| 513 |
+ # Set and get |
|
| 514 |
+ $self = $sql_tmpl->tag_processors($tag_processors); |
|
| 515 |
+ $tag_processors = $sql_tmpl->tag_processors; |
|
| 516 |
+ |
|
| 517 |
+ # Sample |
|
| 518 |
+ $sql_tmpl->tag_processors( |
|
| 519 |
+ '?' => \&expand_question, |
|
| 520 |
+ '=' => \&expand_equel |
|
| 521 |
+ ); |
|
| 522 |
+ |
|
| 523 |
+You can use add_tag_processor to add tag processor |
|
| 524 |
+ |
|
| 525 |
+=head2 tag_start |
|
| 526 |
+ |
|
| 527 |
+ # Set and get |
|
| 528 |
+ $self = $sql_tmpl->tag_start($tag_start); |
|
| 529 |
+ $tag_start = $sql_tmpl->tag_start; |
|
| 530 |
+ |
|
| 531 |
+ # Sample |
|
| 532 |
+ $sql_tmpl->tag_start('{');
|
|
| 533 |
+ |
|
| 534 |
+Default is '{'
|
|
| 535 |
+ |
|
| 536 |
+=head2 tag_end |
|
| 537 |
+ |
|
| 538 |
+ # Set and get |
|
| 539 |
+ $self = $sql_tmpl->tag_start($tag_end); |
|
| 540 |
+ $tag_end = $sql_tmpl->tag_start; |
|
| 541 |
+ |
|
| 542 |
+ # Sample |
|
| 543 |
+ $sql_tmpl->tag_start('}');
|
|
| 544 |
+ |
|
| 545 |
+Default is '}' |
|
| 546 |
+ |
|
| 547 |
+=head2 tag_syntax |
|
| 548 |
+ |
|
| 549 |
+ # Set and get |
|
| 550 |
+ $self = $sql_tmpl->tag_syntax($tag_syntax); |
|
| 551 |
+ $tag_syntax = $sql_tmpl->tag_syntax; |
|
| 552 |
+ |
|
| 553 |
+ # Sample |
|
| 554 |
+ $sql_tmpl->tag_syntax( |
|
| 555 |
+ "[Tag] [Expand]\n" . |
|
| 556 |
+ "{? name} ?\n" .
|
|
| 557 |
+ "{= name} name = ?\n" .
|
|
| 558 |
+ "{<> name} name <> ?\n"
|
|
| 559 |
+ ); |
|
| 560 |
+ |
|
| 561 |
+=head1 METHODS |
|
| 562 |
+ |
|
| 563 |
+=head2 create_query |
|
| 564 |
+ |
|
| 565 |
+ # Create SQL form SQL template |
|
| 566 |
+ $query = $sql_tmpl->create_query($tmpl); |
|
| 567 |
+ |
|
| 568 |
+ # Sample |
|
| 569 |
+ $query = $sql_tmpl->create_sql( |
|
| 570 |
+ "select * from table where {= title} && {like author} || {<= price}")
|
|
| 571 |
+ |
|
| 572 |
+ # Result |
|
| 573 |
+ $qeury->{sql} : "select * from table where title = ? && author like ? price <= ?;"
|
|
| 574 |
+ $query->{key_infos} : [['title'], ['author'], ['price']]
|
|
| 575 |
+ |
|
| 576 |
+ # Sample2 (with table name) |
|
| 577 |
+ ($sql, @bind_values) = $sql_tmpl->create_sql( |
|
| 578 |
+ "select * from table where {= table.title} && {like table.author}",
|
|
| 579 |
+ {table => {title => 'Perl', author => '%Taro%'}}
|
|
| 580 |
+ ) |
|
| 581 |
+ |
|
| 582 |
+ # Result2 |
|
| 583 |
+ $query->{sql} : "select * from table where table.title = ? && table.title like ?;"
|
|
| 584 |
+ $query->{key_infos} :[ [['table.title'],['table', 'title']],
|
|
| 585 |
+ [['table.author'],['table', 'author']] ] |
|
| 586 |
+ |
|
| 587 |
+This method create query using by DBIx::Custom. |
|
| 588 |
+query is two infomation |
|
| 589 |
+ |
|
| 590 |
+ 1.sql : SQL |
|
| 591 |
+ 2.key_infos : Parameter access key information |
|
| 592 |
+ |
|
| 593 |
+=head2 add_tag_processor |
|
| 594 |
+ |
|
| 595 |
+Add tag processor |
|
| 596 |
+ |
|
| 597 |
+ # Add |
|
| 598 |
+ $self = $sql_tmpl->add_tag_processor($tag_processor); |
|
| 599 |
+ |
|
| 600 |
+ # Sample |
|
| 601 |
+ $sql_tmpl->add_tag_processor( |
|
| 602 |
+ '?' => sub {
|
|
| 603 |
+ my ($tag_name, $tag_args) = @_; |
|
| 604 |
+ |
|
| 605 |
+ my $key1 = $tag_args->[0]; |
|
| 606 |
+ my $key2 = $tag_args->[1]; |
|
| 607 |
+ |
|
| 608 |
+ my $key_infos = []; |
|
| 609 |
+ |
|
| 610 |
+ # Expand tag and create key informations |
|
| 611 |
+ |
|
| 612 |
+ # Return expand tags and key informations |
|
| 613 |
+ return ($expand, $key_infos); |
|
| 614 |
+ } |
|
| 615 |
+ ); |
|
| 616 |
+ |
|
| 617 |
+Tag processor recieve 2 argument |
|
| 618 |
+ |
|
| 619 |
+ 1. Tag name (?, =, <>, or etc) |
|
| 620 |
+ 2. Tag arguments (arg1 and arg2 in {tag_name arg1 arg2})
|
|
| 621 |
+ |
|
| 622 |
+Tag processor return 2 value |
|
| 623 |
+ |
|
| 624 |
+ 1. Expanded Tag (For exsample, '{= title}' is expanded to 'title = ?')
|
|
| 625 |
+ 2. Key infomations |
|
| 626 |
+ |
|
| 627 |
+You must be return expanded tag and key infomations. |
|
| 628 |
+ |
|
| 629 |
+Key information is a little complex. so I will explan this in future. |
|
| 630 |
+ |
|
| 631 |
+If you want to know more, Please see DBIx::Custom::SQL::Template source code. |
|
| 632 |
+ |
|
| 633 |
+=head2 clone |
|
| 634 |
+ |
|
| 635 |
+ # Clone DBIx::Custom::SQL::Template object |
|
| 636 |
+ $clone = $self->clone; |
|
| 637 |
+ |
|
| 638 |
+=head1 Available Tags |
|
| 639 |
+ |
|
| 640 |
+ # Available Tags |
|
| 641 |
+ [tag] [expand] |
|
| 642 |
+ {? name} ?
|
|
| 643 |
+ {= name} name = ?
|
|
| 644 |
+ {<> name} name <> ?
|
|
| 645 |
+ |
|
| 646 |
+ {< name} name < ?
|
|
| 647 |
+ {> name} name > ?
|
|
| 648 |
+ {>= name} name >= ?
|
|
| 649 |
+ {<= name} name <= ?
|
|
| 650 |
+ |
|
| 651 |
+ {like name} name like ?
|
|
| 652 |
+ {in name} name in [?, ?, ..]
|
|
| 653 |
+ |
|
| 654 |
+ {insert} (key1, key2, key3) values (?, ?, ?)
|
|
| 655 |
+ {update} set key1 = ?, key2 = ?, key3 = ?
|
|
| 656 |
+ |
|
| 657 |
+ # Sample1 |
|
| 658 |
+ $query = $sql_tmpl->create_sql( |
|
| 659 |
+ "insert into table {insert key1 key2}"
|
|
| 660 |
+ ); |
|
| 661 |
+ # Result1 |
|
| 662 |
+ $sql : "insert into table (key1, key2) values (?, ?)" |
|
| 663 |
+ |
|
| 664 |
+ |
|
| 665 |
+ # Sample2 |
|
| 666 |
+ $query = $sql_tmpl->create_sql( |
|
| 667 |
+ "update table {update key1 key2} where {= key3}"
|
|
| 668 |
+ ); |
|
| 669 |
+ |
|
| 670 |
+ # Result2 |
|
| 671 |
+ $query->{sql} : "update table set key1 = ?, key2 = ? where key3 = ?;"
|
|
| 672 |
+ |
|
| 673 |
+=head1 AUTHOR |
|
| 674 |
+ |
|
| 675 |
+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >> |
|
| 676 |
+ |
|
| 677 |
+Github |
|
| 678 |
+L<http://github.com/yuki-kimoto> |
|
| 679 |
+L<http://github.com/yuki-kimoto/DBIx-Custom-SQL-Template> |
|
| 680 |
+ |
|
| 681 |
+Please let know me bag if you find |
|
| 682 |
+Please request me if you want to do something |
|
| 683 |
+ |
|
| 684 |
+=head1 COPYRIGHT & LICENSE |
|
| 685 |
+ |
|
| 686 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 687 |
+ |
|
| 688 |
+This program is free software; you can redistribute it and/or modify it |
|
| 689 |
+under the same terms as Perl itself. |
|
| 690 |
+ |
|
| 691 |
+ |
|
| 692 |
+=cut |
|
| 693 |
+ |
|
| 694 |
+1; # End of DBIx::Custom::SQL::Template |
| ... | ... |
@@ -0,0 +1,136 @@ |
| 1 |
+package DBIx::Custom::SQLite; |
|
| 2 |
+use base 'DBIx::Custom::Basic'; |
|
| 3 |
+ |
|
| 4 |
+use warnings; |
|
| 5 |
+use strict; |
|
| 6 |
+use Carp 'croak'; |
|
| 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 |
+sub connect {
|
|
| 17 |
+ my $self = shift; |
|
| 18 |
+ |
|
| 19 |
+ if (!$self->data_source && (my $database = $self->database)) {
|
|
| 20 |
+ $self->data_source("dbi:SQLite:dbname=$database");
|
|
| 21 |
+ } |
|
| 22 |
+ |
|
| 23 |
+ return $self->SUPER::connect; |
|
| 24 |
+} |
|
| 25 |
+ |
|
| 26 |
+sub connect_memory {
|
|
| 27 |
+ my $self = shift; |
|
| 28 |
+ |
|
| 29 |
+ # Data source for memory database |
|
| 30 |
+ $self->data_source('dbi:SQLite:dbname=:memory:');
|
|
| 31 |
+ |
|
| 32 |
+ # Already connected |
|
| 33 |
+ croak("Already connected") if $self->connected;
|
|
| 34 |
+ |
|
| 35 |
+ # Connect |
|
| 36 |
+ $self->connect; |
|
| 37 |
+ |
|
| 38 |
+ return $self; |
|
| 39 |
+} |
|
| 40 |
+ |
|
| 41 |
+sub reconnect_memory {
|
|
| 42 |
+ my $self = shift; |
|
| 43 |
+ |
|
| 44 |
+ # Data source for memory database |
|
| 45 |
+ $self->data_source('dbi:SQLite:dbname=:memory:');
|
|
| 46 |
+ |
|
| 47 |
+ # Reconnect |
|
| 48 |
+ $self->reconnect; |
|
| 49 |
+ |
|
| 50 |
+ return $self; |
|
| 51 |
+} |
|
| 52 |
+ |
|
| 53 |
+ |
|
| 54 |
+=head1 NAME |
|
| 55 |
+ |
|
| 56 |
+DBIx::Custom::SQLite - DBIx::Custom SQLite implementation |
|
| 57 |
+ |
|
| 58 |
+=head1 Version |
|
| 59 |
+ |
|
| 60 |
+Version 0.0201 |
|
| 61 |
+ |
|
| 62 |
+=head1 Synopsys |
|
| 63 |
+ |
|
| 64 |
+ use DBIx::Custom::SQLite; |
|
| 65 |
+ |
|
| 66 |
+ # New |
|
| 67 |
+ my $dbi = DBIx::Custom::SQLite->new(user => 'taro', $password => 'kliej&@K', |
|
| 68 |
+ database => 'sample.db'); |
|
| 69 |
+ |
|
| 70 |
+ # Insert |
|
| 71 |
+ $dbi->insert('books', {title => 'perl', author => 'taro'});
|
|
| 72 |
+ |
|
| 73 |
+ # Update |
|
| 74 |
+ # same as 'update books set (title = 'aaa', author = 'ken') where id = 5; |
|
| 75 |
+ $dbi->update('books', {title => 'aaa', author => 'ken'}, {id => 5});
|
|
| 76 |
+ |
|
| 77 |
+ # Delete |
|
| 78 |
+ $dbi->delete('books', {author => 'taro'});
|
|
| 79 |
+ |
|
| 80 |
+ # select * from books; |
|
| 81 |
+ $dbi->select('books');
|
|
| 82 |
+ |
|
| 83 |
+ # select * from books where ahthor = 'taro'; |
|
| 84 |
+ $dbi->select('books', {author => 'taro'});
|
|
| 85 |
+ |
|
| 86 |
+ # select author, title from books where author = 'taro' |
|
| 87 |
+ $dbi->select('books', [qw/author title/], {author => 'taro'});
|
|
| 88 |
+ |
|
| 89 |
+ # select author, title from books where author = 'taro' order by id limit 1; |
|
| 90 |
+ $dbi->select('books', [qw/author title/], {author => 'taro'},
|
|
| 91 |
+ 'order by id limit 1'); |
|
| 92 |
+ |
|
| 93 |
+=head1 See DBIx::Custom and DBI::Custom::Basic documentation |
|
| 94 |
+ |
|
| 95 |
+This class is L<DBIx::Custom::Basic> subclass. |
|
| 96 |
+and L<DBIx::Custom::Basic> is L<DBIx::Custom> subclass |
|
| 97 |
+ |
|
| 98 |
+You can use all methods of L<DBIx::Custom::Basic> and <DBIx::Custom> |
|
| 99 |
+Please see L<DBIx::Custom::Basic> and <DBIx::Custom> documentation |
|
| 100 |
+ |
|
| 101 |
+=head1 Object methods |
|
| 102 |
+ |
|
| 103 |
+=head2 connect |
|
| 104 |
+ |
|
| 105 |
+This override L<DBIx::Custom> connect. |
|
| 106 |
+ |
|
| 107 |
+ # Connect to database |
|
| 108 |
+ $dbi->connect; |
|
| 109 |
+ |
|
| 110 |
+If database attribute is set, automatically data source is created and connect |
|
| 111 |
+ |
|
| 112 |
+=head2 connect_memory |
|
| 113 |
+ |
|
| 114 |
+ # Connect memory database |
|
| 115 |
+ $self = $dbi->connect_memory; |
|
| 116 |
+ |
|
| 117 |
+=head2 reconnect_memory |
|
| 118 |
+ |
|
| 119 |
+ # Reconnect memory database |
|
| 120 |
+ $self = $dbi->reconnect_memory; |
|
| 121 |
+ |
|
| 122 |
+=head1 Author |
|
| 123 |
+ |
|
| 124 |
+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >> |
|
| 125 |
+ |
|
| 126 |
+Github L<http://github.com/yuki-kimoto> |
|
| 127 |
+ |
|
| 128 |
+I develope this module L<http://github.com/yuki-kimoto/DBIx-Custom> |
|
| 129 |
+ |
|
| 130 |
+=head1 Copyright & lisence |
|
| 131 |
+ |
|
| 132 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 133 |
+ |
|
| 134 |
+This program is free software; you can redistribute it and/or modify it |
|
| 135 |
+under the same terms as Perl itself. |
|
| 136 |
+ |
| ... | ... |
@@ -0,0 +1,15 @@ |
| 1 |
+#!perl -T |
|
| 2 |
+ |
|
| 3 |
+use Test::More tests => 7; |
|
| 4 |
+ |
|
| 5 |
+BEGIN {
|
|
| 6 |
+ use_ok( 'DBIx::Custom' ); |
|
| 7 |
+ use_ok( 'DBIx::Custom::Basic' ); |
|
| 8 |
+ use_ok( 'DBIx::Custom::MySQL' ); |
|
| 9 |
+ use_ok( 'DBIx::Custom::Query' ); |
|
| 10 |
+ use_ok( 'DBIx::Custom::Result' ); |
|
| 11 |
+ use_ok( 'DBIx::Custom::SQL::Template' ); |
|
| 12 |
+ use_ok( 'DBIx::Custom::SQLite' ); |
|
| 13 |
+} |
|
| 14 |
+ |
|
| 15 |
+diag( "Testing DBIx::Custom $DBIx::Custom::VERSION, Perl $], $^X" ); |
| ... | ... |
@@ -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.pm');
|
|
| 50 |
+ |
|
| 51 |
+ |
| ... | ... |
@@ -0,0 +1,67 @@ |
| 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->{encode_utf8}, "$test : exists default_bind_filter");
|
|
| 53 |
+ok($dbi->filters->{decode_utf8}, "$test : exists default_fetch_filter");
|
|
| 54 |
+ |
|
| 55 |
+$dbi->utf8_filter_on; |
|
| 56 |
+is($dbi->bind_filter, $dbi->filters->{encode_utf8}, 'default bind filter');
|
|
| 57 |
+is($dbi->fetch_filter, $dbi->filters->{decode_utf8}, 'default fetch filter');
|
|
| 58 |
+ |
|
| 59 |
+$decoded_str = 'あ'; |
|
| 60 |
+$encoded_str = $dbi->bind_filter->($decoded_str); |
|
| 61 |
+is($encoded_str, encode('UTF-8', $decoded_str), "$test : encode utf8");
|
|
| 62 |
+is($decoded_str, $dbi->fetch_filter->($encoded_str), "$test : fetch_filter"); |
|
| 63 |
+ |
|
| 64 |
+$decoded_str = 'a'; |
|
| 65 |
+$encoded_str = $dbi->bind_filter->($decoded_str); |
|
| 66 |
+is($encoded_str, encode('UTF-8', $decoded_str), "$test : upgrade and encode utf8");
|
|
| 67 |
+is($decoded_str, $dbi->fetch_filter->($encoded_str), "$test : fetch_filter"); |
| ... | ... |
@@ -0,0 +1,36 @@ |
| 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 |
+use DBIx::Custom; |
|
| 13 |
+use Scalar::Util 'blessed'; |
|
| 14 |
+{
|
|
| 15 |
+ my $dbi = DBIx::Custom->new( |
|
| 16 |
+ user => $USER, |
|
| 17 |
+ password => $PASSWORD, |
|
| 18 |
+ data_source => "dbi:mysql:dbname=$DATABASE" |
|
| 19 |
+ ); |
|
| 20 |
+ $dbi->connect; |
|
| 21 |
+ |
|
| 22 |
+ ok(blessed $dbi->dbh); |
|
| 23 |
+ can_ok($dbi->dbh, qw/prepare/); |
|
| 24 |
+} |
|
| 25 |
+ |
|
| 26 |
+sub connect_info {
|
|
| 27 |
+ my $file = 'password.tmp'; |
|
| 28 |
+ open my $fh, '<', $file |
|
| 29 |
+ or return; |
|
| 30 |
+ |
|
| 31 |
+ my ($user, $password, $database) = split(/\s/, (<$fh>)[0]); |
|
| 32 |
+ |
|
| 33 |
+ close $fh; |
|
| 34 |
+ |
|
| 35 |
+ return ($user, $password, $database); |
|
| 36 |
+} |
| ... | ... |
@@ -0,0 +1,716 @@ |
| 1 |
+use Test::More; |
|
| 2 |
+use strict; |
|
| 3 |
+use warnings; |
|
| 4 |
+ |
|
| 5 |
+BEGIN {
|
|
| 6 |
+ eval { require DBD::SQLite; 1 }
|
|
| 7 |
+ or plan skip_all => 'DBD::SQLite required'; |
|
| 8 |
+ eval { DBD::SQLite->VERSION >= 1.25 }
|
|
| 9 |
+ or plan skip_all => 'DBD::SQLite >= 1.25 required'; |
|
| 10 |
+ |
|
| 11 |
+ plan 'no_plan'; |
|
| 12 |
+ use_ok('DBIx::Custom');
|
|
| 13 |
+} |
|
| 14 |
+ |
|
| 15 |
+# Function for test name |
|
| 16 |
+my $test; |
|
| 17 |
+sub test {
|
|
| 18 |
+ $test = shift; |
|
| 19 |
+} |
|
| 20 |
+ |
|
| 21 |
+# Constant varialbes for test |
|
| 22 |
+my $CREATE_TABLE = {
|
|
| 23 |
+ 0 => 'create table table1 (key1 char(255), key2 char(255));', |
|
| 24 |
+ 1 => 'create table table1 (key1 char(255), key2 char(255), key3 char(255), key4 char(255), key5 char(255));', |
|
| 25 |
+ 2 => 'create table table2 (key1 char(255), key3 char(255));' |
|
| 26 |
+}; |
|
| 27 |
+ |
|
| 28 |
+my $SELECT_TMPL = {
|
|
| 29 |
+ 0 => 'select * from table1;' |
|
| 30 |
+}; |
|
| 31 |
+ |
|
| 32 |
+my $DROP_TABLE = {
|
|
| 33 |
+ 0 => 'drop table table1' |
|
| 34 |
+}; |
|
| 35 |
+ |
|
| 36 |
+my $NEW_ARGS = {
|
|
| 37 |
+ 0 => {data_source => 'dbi:SQLite:dbname=:memory:'}
|
|
| 38 |
+}; |
|
| 39 |
+ |
|
| 40 |
+# Variables for test |
|
| 41 |
+my $dbi; |
|
| 42 |
+my $sth; |
|
| 43 |
+my $tmpl; |
|
| 44 |
+my @tmpls; |
|
| 45 |
+my $select_tmpl; |
|
| 46 |
+my $insert_tmpl; |
|
| 47 |
+my $update_tmpl; |
|
| 48 |
+my $params; |
|
| 49 |
+my $sql; |
|
| 50 |
+my $result; |
|
| 51 |
+my @rows; |
|
| 52 |
+my $rows; |
|
| 53 |
+my $query; |
|
| 54 |
+my @queries; |
|
| 55 |
+my $select_query; |
|
| 56 |
+my $insert_query; |
|
| 57 |
+my $update_query; |
|
| 58 |
+my $ret_val; |
|
| 59 |
+ |
|
| 60 |
+ |
|
| 61 |
+test 'disconnect'; |
|
| 62 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 63 |
+$dbi->connect; |
|
| 64 |
+$dbi->disconnect; |
|
| 65 |
+ok(!$dbi->dbh, $test); |
|
| 66 |
+ |
|
| 67 |
+ |
|
| 68 |
+test 'connected'; |
|
| 69 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 70 |
+ok(!$dbi->connected, "$test : not connected"); |
|
| 71 |
+$dbi->connect; |
|
| 72 |
+ok($dbi->connected, "$test : connected"); |
|
| 73 |
+ |
|
| 74 |
+ |
|
| 75 |
+test 'preapare'; |
|
| 76 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 77 |
+$sth = $dbi->prepare($CREATE_TABLE->{0});
|
|
| 78 |
+ok($sth, "$test : auto connect"); |
|
| 79 |
+$sth->execute; |
|
| 80 |
+$sth = $dbi->prepare($DROP_TABLE->{0});
|
|
| 81 |
+ok($sth, "$test : basic"); |
|
| 82 |
+ |
|
| 83 |
+ |
|
| 84 |
+test 'do'; |
|
| 85 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 86 |
+$ret_val = $dbi->do($CREATE_TABLE->{0});
|
|
| 87 |
+ok(defined $ret_val, "$test : auto connect"); |
|
| 88 |
+$ret_val = $dbi->do($DROP_TABLE->{0});
|
|
| 89 |
+ok(defined $ret_val, "$test : basic"); |
|
| 90 |
+ |
|
| 91 |
+ |
|
| 92 |
+# Prepare table |
|
| 93 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 94 |
+$dbi->connect; |
|
| 95 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 96 |
+$sth = $dbi->prepare("insert into table1 (key1, key2) values (?, ?);");
|
|
| 97 |
+$sth->execute(1, 2); |
|
| 98 |
+$sth->execute(3, 4); |
|
| 99 |
+ |
|
| 100 |
+ |
|
| 101 |
+test 'DBIx::Custom::Result test'; |
|
| 102 |
+$tmpl = "select key1, key2 from table1"; |
|
| 103 |
+$query = $dbi->create_query($tmpl); |
|
| 104 |
+$result = $dbi->execute($query); |
|
| 105 |
+ |
|
| 106 |
+@rows = (); |
|
| 107 |
+while (my $row = $result->fetch) {
|
|
| 108 |
+ push @rows, [@$row]; |
|
| 109 |
+} |
|
| 110 |
+is_deeply(\@rows, [[1, 2], [3, 4]], "$test : fetch scalar context"); |
|
| 111 |
+ |
|
| 112 |
+$result = $dbi->execute($query); |
|
| 113 |
+@rows = (); |
|
| 114 |
+while (my @row = $result->fetch) {
|
|
| 115 |
+ push @rows, [@row]; |
|
| 116 |
+} |
|
| 117 |
+is_deeply(\@rows, [[1, 2], [3, 4]], "$test : fetch list context"); |
|
| 118 |
+ |
|
| 119 |
+$result = $dbi->execute($query); |
|
| 120 |
+@rows = (); |
|
| 121 |
+while (my $row = $result->fetch_hash) {
|
|
| 122 |
+ push @rows, {%$row};
|
|
| 123 |
+} |
|
| 124 |
+is_deeply(\@rows, [{key1 => 1, key2 => 2}, {key1 => 3, key2 => 4}], "$test : fetch_hash scalar context");
|
|
| 125 |
+ |
|
| 126 |
+$result = $dbi->execute($query); |
|
| 127 |
+@rows = (); |
|
| 128 |
+while (my %row = $result->fetch_hash) {
|
|
| 129 |
+ push @rows, {%row};
|
|
| 130 |
+} |
|
| 131 |
+is_deeply(\@rows, [{key1 => 1, key2 => 2}, {key1 => 3, key2 => 4}], "$test : fetch hash list context");
|
|
| 132 |
+ |
|
| 133 |
+$result = $dbi->execute($query); |
|
| 134 |
+$rows = $result->fetch_all; |
|
| 135 |
+is_deeply($rows, [[1, 2], [3, 4]], "$test : fetch_all scalar context"); |
|
| 136 |
+ |
|
| 137 |
+$result = $dbi->execute($query); |
|
| 138 |
+@rows = $result->fetch_all; |
|
| 139 |
+is_deeply(\@rows, [[1, 2], [3, 4]], "$test : fetch_all list context"); |
|
| 140 |
+ |
|
| 141 |
+$result = $dbi->execute($query); |
|
| 142 |
+@rows = $result->fetch_hash_all; |
|
| 143 |
+is_deeply($rows, [[1, 2], [3, 4]], "$test : fetch_hash_all scalar context"); |
|
| 144 |
+ |
|
| 145 |
+$result = $dbi->execute($query); |
|
| 146 |
+@rows = $result->fetch_all; |
|
| 147 |
+is_deeply(\@rows, [[1, 2], [3, 4]], "$test : fetch_hash_all list context"); |
|
| 148 |
+ |
|
| 149 |
+ |
|
| 150 |
+test 'Insert query return value'; |
|
| 151 |
+$dbi->do($DROP_TABLE->{0});
|
|
| 152 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 153 |
+$tmpl = "insert into table1 {insert key1 key2}";
|
|
| 154 |
+$query = $dbi->create_query($tmpl); |
|
| 155 |
+$ret_val = $dbi->execute($query, {key1 => 1, key2 => 2});
|
|
| 156 |
+ok($ret_val, $test); |
|
| 157 |
+ |
|
| 158 |
+ |
|
| 159 |
+test 'Direct execute'; |
|
| 160 |
+$dbi->do($DROP_TABLE->{0});
|
|
| 161 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 162 |
+$insert_tmpl = "insert into table1 {insert key1 key2}";
|
|
| 163 |
+$dbi->execute($insert_tmpl, {key1 => 1, key2 => 2}, sub {
|
|
| 164 |
+ my $query = shift; |
|
| 165 |
+ $query->bind_filter(sub {
|
|
| 166 |
+ my ($value, $key) = @_; |
|
| 167 |
+ if ($key eq 'key2') {
|
|
| 168 |
+ return $value + 1; |
|
| 169 |
+ } |
|
| 170 |
+ return $value; |
|
| 171 |
+ }); |
|
| 172 |
+}); |
|
| 173 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 174 |
+$rows = $result->fetch_hash_all; |
|
| 175 |
+is_deeply($rows, [{key1 => 1, key2 => 3}], $test);
|
|
| 176 |
+ |
|
| 177 |
+ |
|
| 178 |
+test 'Filter basic'; |
|
| 179 |
+$dbi->do($DROP_TABLE->{0});
|
|
| 180 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 181 |
+ |
|
| 182 |
+$insert_tmpl = "insert into table1 {insert key1 key2};";
|
|
| 183 |
+$insert_query = $dbi->create_query($insert_tmpl); |
|
| 184 |
+$insert_query->bind_filter(sub {
|
|
| 185 |
+ my ($value, $key, $table, $column) = @_; |
|
| 186 |
+ if ($key eq 'key1' && $table eq '' && $column eq 'key1') {
|
|
| 187 |
+ return $value * 2; |
|
| 188 |
+ } |
|
| 189 |
+ return $value; |
|
| 190 |
+}); |
|
| 191 |
+$dbi->execute($insert_query, {key1 => 1, key2 => 2});
|
|
| 192 |
+$select_query = $dbi->create_query($SELECT_TMPL->{0});
|
|
| 193 |
+$select_query->fetch_filter(sub {
|
|
| 194 |
+ my ($value, $key, $type, $sth, $i) = @_; |
|
| 195 |
+ if ($key eq 'key2' && $type =~ /char/ && $sth->can('execute') && $i == 1) {
|
|
| 196 |
+ return $value * 3; |
|
| 197 |
+ } |
|
| 198 |
+ return $value; |
|
| 199 |
+}); |
|
| 200 |
+$result = $dbi->execute($select_query); |
|
| 201 |
+$rows = $result->fetch_hash_all; |
|
| 202 |
+is_deeply($rows, [{key1 => 2, key2 => 6}], "$test : bind_filter fetch_filter");
|
|
| 203 |
+ |
|
| 204 |
+$dbi->do("delete from table1;");
|
|
| 205 |
+$insert_query->no_bind_filters('key1');
|
|
| 206 |
+$select_query->no_fetch_filters('key2');
|
|
| 207 |
+$dbi->execute($insert_query, {key1 => 1, key2 => 2});
|
|
| 208 |
+$result = $dbi->execute($select_query); |
|
| 209 |
+$rows = $result->fetch_hash_all; |
|
| 210 |
+is_deeply($rows, [{key1 => 1, key2 => 2}], "$test : no_fetch_filters no_bind_filters");
|
|
| 211 |
+ |
|
| 212 |
+$dbi->do($DROP_TABLE->{0});
|
|
| 213 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 214 |
+$insert_tmpl = "insert into table1 {insert table1.key1 table1.key2}";
|
|
| 215 |
+$insert_query = $dbi->create_query($insert_tmpl); |
|
| 216 |
+$insert_query->bind_filter(sub {
|
|
| 217 |
+ my ($value, $key, $table, $column) = @_; |
|
| 218 |
+ if ($key eq 'table1.key1' && $table eq 'table1' && $column eq 'key1') {
|
|
| 219 |
+ return $value * 3; |
|
| 220 |
+ } |
|
| 221 |
+ return $value; |
|
| 222 |
+}); |
|
| 223 |
+$dbi->execute($insert_query, {table1 => {key1 => 1, key2 => 2}});
|
|
| 224 |
+$select_query = $dbi->create_query($SELECT_TMPL->{0});
|
|
| 225 |
+$result = $dbi->execute($select_query); |
|
| 226 |
+$rows = $result->fetch_hash_all; |
|
| 227 |
+is_deeply($rows, [{key1 => 3, key2 => 2}], "$test : insert with table name");
|
|
| 228 |
+ |
|
| 229 |
+test 'Filter in'; |
|
| 230 |
+$insert_tmpl = "insert into table1 {insert key1 key2};";
|
|
| 231 |
+$insert_query = $dbi->create_query($insert_tmpl); |
|
| 232 |
+$dbi->execute($insert_query, {key1 => 2, key2 => 4});
|
|
| 233 |
+$select_tmpl = "select * from table1 where {in table1.key1 2} and {in table1.key2 2}";
|
|
| 234 |
+$select_query = $dbi->create_query($select_tmpl); |
|
| 235 |
+$select_query->bind_filter(sub {
|
|
| 236 |
+ my ($value, $key, $table, $column) = @_; |
|
| 237 |
+ if ($key eq 'table1.key1' && $table eq 'table1' && $column eq 'key1' || $key eq 'table1.key2') {
|
|
| 238 |
+ return $value * 2; |
|
| 239 |
+ } |
|
| 240 |
+ return $value; |
|
| 241 |
+}); |
|
| 242 |
+$result = $dbi->execute($select_query, {table1 => {key1 => [1,5], key2 => [2,5]}});
|
|
| 243 |
+$rows = $result->fetch_hash_all; |
|
| 244 |
+is_deeply($rows, [{key1 => 2, key2 => 4}], "$test : bind_filter");
|
|
| 245 |
+ |
|
| 246 |
+ |
|
| 247 |
+test 'DBIx::Custom::SQL::Template basic tag'; |
|
| 248 |
+$dbi->do($DROP_TABLE->{0});
|
|
| 249 |
+$dbi->do($CREATE_TABLE->{1});
|
|
| 250 |
+$sth = $dbi->prepare("insert into table1 (key1, key2, key3, key4, key5) values (?, ?, ?, ?, ?);");
|
|
| 251 |
+$sth->execute(1, 2, 3, 4, 5); |
|
| 252 |
+$sth->execute(6, 7, 8, 9, 10); |
|
| 253 |
+ |
|
| 254 |
+$tmpl = "select * from table1 where {= key1} and {<> key2} and {< key3} and {> key4} and {>= key5};";
|
|
| 255 |
+$query = $dbi->create_query($tmpl); |
|
| 256 |
+$result = $dbi->execute($query, {key1 => 1, key2 => 3, key3 => 4, key4 => 3, key5 => 5});
|
|
| 257 |
+$rows = $result->fetch_hash_all; |
|
| 258 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : basic tag1");
|
|
| 259 |
+ |
|
| 260 |
+$tmpl = "select * from table1 where {= table1.key1} and {<> table1.key2} and {< table1.key3} and {> table1.key4} and {>= table1.key5};";
|
|
| 261 |
+$query = $dbi->create_query($tmpl); |
|
| 262 |
+$result = $dbi->execute($query, {table1 => {key1 => 1, key2 => 3, key3 => 4, key4 => 3, key5 => 5}});
|
|
| 263 |
+$rows = $result->fetch_hash_all; |
|
| 264 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : basic tag1 with table");
|
|
| 265 |
+ |
|
| 266 |
+$tmpl = "select * from table1 where {= table1.key1} and {<> table1.key2} and {< table1.key3} and {> table1.key4} and {>= table1.key5};";
|
|
| 267 |
+$query = $dbi->create_query($tmpl); |
|
| 268 |
+$result = $dbi->execute($query, {'table1.key1' => 1, 'table1.key2' => 3, 'table1.key3' => 4, 'table1.key4' => 3, 'table1.key5' => 5});
|
|
| 269 |
+$rows = $result->fetch_hash_all; |
|
| 270 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : basic tag1 with table dot");
|
|
| 271 |
+ |
|
| 272 |
+$tmpl = "select * from table1 where {<= key1} and {like key2};";
|
|
| 273 |
+$query = $dbi->create_query($tmpl); |
|
| 274 |
+$result = $dbi->execute($query, {key1 => 1, key2 => '%2%'});
|
|
| 275 |
+$rows = $result->fetch_hash_all; |
|
| 276 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : basic tag2");
|
|
| 277 |
+ |
|
| 278 |
+$tmpl = "select * from table1 where {<= table1.key1} and {like table1.key2};";
|
|
| 279 |
+$query = $dbi->create_query($tmpl); |
|
| 280 |
+$result = $dbi->execute($query, {table1 => {key1 => 1, key2 => '%2%'}});
|
|
| 281 |
+$rows = $result->fetch_hash_all; |
|
| 282 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : basic tag2 with table");
|
|
| 283 |
+ |
|
| 284 |
+$tmpl = "select * from table1 where {<= table1.key1} and {like table1.key2};";
|
|
| 285 |
+$query = $dbi->create_query($tmpl); |
|
| 286 |
+$result = $dbi->execute($query, {'table1.key1' => 1, 'table1.key2' => '%2%'});
|
|
| 287 |
+$rows = $result->fetch_hash_all; |
|
| 288 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : basic tag2 with table dot");
|
|
| 289 |
+ |
|
| 290 |
+ |
|
| 291 |
+test 'DIB::Custom::SQL::Template in tag'; |
|
| 292 |
+$dbi->do($DROP_TABLE->{0});
|
|
| 293 |
+$dbi->do($CREATE_TABLE->{1});
|
|
| 294 |
+$sth = $dbi->prepare("insert into table1 (key1, key2, key3, key4, key5) values (?, ?, ?, ?, ?);");
|
|
| 295 |
+$sth->execute(1, 2, 3, 4, 5); |
|
| 296 |
+$sth->execute(6, 7, 8, 9, 10); |
|
| 297 |
+ |
|
| 298 |
+$tmpl = "select * from table1 where {in key1 2};";
|
|
| 299 |
+$query = $dbi->create_query($tmpl); |
|
| 300 |
+$result = $dbi->execute($query, {key1 => [9, 1]});
|
|
| 301 |
+$rows = $result->fetch_hash_all; |
|
| 302 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : basic");
|
|
| 303 |
+ |
|
| 304 |
+$tmpl = "select * from table1 where {in table1.key1 2};";
|
|
| 305 |
+$query = $dbi->create_query($tmpl); |
|
| 306 |
+$result = $dbi->execute($query, {table1 => {key1 => [9, 1]}});
|
|
| 307 |
+$rows = $result->fetch_hash_all; |
|
| 308 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : with table");
|
|
| 309 |
+ |
|
| 310 |
+$tmpl = "select * from table1 where {in table1.key1 2};";
|
|
| 311 |
+$query = $dbi->create_query($tmpl); |
|
| 312 |
+$result = $dbi->execute($query, {'table1.key1' => [9, 1]});
|
|
| 313 |
+$rows = $result->fetch_hash_all; |
|
| 314 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : with table dot");
|
|
| 315 |
+ |
|
| 316 |
+ |
|
| 317 |
+test 'DBIx::Custom::SQL::Template insert tag'; |
|
| 318 |
+$dbi->do("delete from table1");
|
|
| 319 |
+$insert_tmpl = 'insert into table1 {insert key1 key2 key3 key4 key5}';
|
|
| 320 |
+$dbi->execute($insert_tmpl, {key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5});
|
|
| 321 |
+ |
|
| 322 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 323 |
+$rows = $result->fetch_hash_all; |
|
| 324 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : basic");
|
|
| 325 |
+ |
|
| 326 |
+$dbi->do("delete from table1");
|
|
| 327 |
+$dbi->execute($insert_tmpl, {'#insert' => {key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}});
|
|
| 328 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 329 |
+$rows = $result->fetch_hash_all; |
|
| 330 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : #insert");
|
|
| 331 |
+ |
|
| 332 |
+$dbi->do("delete from table1");
|
|
| 333 |
+$insert_tmpl = 'insert into table1 {insert table1.key1 table1.key2 table1.key3 table1.key4 table1.key5}';
|
|
| 334 |
+$dbi->execute($insert_tmpl, {table1 => {key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}});
|
|
| 335 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 336 |
+$rows = $result->fetch_hash_all; |
|
| 337 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : with table name");
|
|
| 338 |
+ |
|
| 339 |
+$dbi->do("delete from table1");
|
|
| 340 |
+$insert_tmpl = 'insert into table1 {insert table1.key1 table1.key2 table1.key3 table1.key4 table1.key5}';
|
|
| 341 |
+$dbi->execute($insert_tmpl, {'table1.key1' => 1, 'table1.key2' => 2, 'table1.key3' => 3, 'table1.key4' => 4, 'table1.key5' => 5});
|
|
| 342 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 343 |
+$rows = $result->fetch_hash_all; |
|
| 344 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : with table name dot");
|
|
| 345 |
+ |
|
| 346 |
+$dbi->do("delete from table1");
|
|
| 347 |
+$dbi->execute($insert_tmpl, {'#insert' => {table1 => {key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}}});
|
|
| 348 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 349 |
+$rows = $result->fetch_hash_all; |
|
| 350 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : #insert with table name");
|
|
| 351 |
+ |
|
| 352 |
+$dbi->do("delete from table1");
|
|
| 353 |
+$dbi->execute($insert_tmpl, {'#insert' => {'table1.key1' => 1, 'table1.key2' => 2, 'table1.key3' => 3, 'table1.key4' => 4, 'table1.key5' => 5}});
|
|
| 354 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 355 |
+$rows = $result->fetch_hash_all; |
|
| 356 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : #insert with table name dot");
|
|
| 357 |
+ |
|
| 358 |
+ |
|
| 359 |
+test 'DBIx::Custom::SQL::Template update tag'; |
|
| 360 |
+$dbi->do("delete from table1");
|
|
| 361 |
+$insert_tmpl = "insert into table1 {insert key1 key2 key3 key4 key5}";
|
|
| 362 |
+$dbi->execute($insert_tmpl, {key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5});
|
|
| 363 |
+$dbi->execute($insert_tmpl, {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10});
|
|
| 364 |
+ |
|
| 365 |
+$update_tmpl = 'update table1 {update key1 key2 key3 key4} where {= key5}';
|
|
| 366 |
+$dbi->execute($update_tmpl, {key1 => 1, key2 => 1, key3 => 1, key4 => 1, key5 => 5});
|
|
| 367 |
+ |
|
| 368 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 369 |
+$rows = $result->fetch_hash_all; |
|
| 370 |
+is_deeply($rows, [{key1 => 1, key2 => 1, key3 => 1, key4 => 1, key5 => 5},
|
|
| 371 |
+ {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10}], "$test : basic");
|
|
| 372 |
+ |
|
| 373 |
+$dbi->execute($update_tmpl, {'#update' => {key1 => 2, key2 => 2, key3 => 2, key4 => 2}, key5 => 5});
|
|
| 374 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 375 |
+$rows = $result->fetch_hash_all; |
|
| 376 |
+is_deeply($rows, [{key1 => 2, key2 => 2, key3 => 2, key4 => 2, key5 => 5},
|
|
| 377 |
+ {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10}], "$test : #update");
|
|
| 378 |
+ |
|
| 379 |
+$update_tmpl = 'update table1 {update table1.key1 table1.key2 table1.key3 table1.key4} where {= table1.key5}';
|
|
| 380 |
+$dbi->execute($update_tmpl, {table1 => {key1 => 3, key2 => 3, key3 => 3, key4 => 3, key5 => 5}});
|
|
| 381 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 382 |
+$rows = $result->fetch_hash_all; |
|
| 383 |
+is_deeply($rows, [{key1 => 3, key2 => 3, key3 => 3, key4 => 3, key5 => 5},
|
|
| 384 |
+ {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10}], "$test : with table name");
|
|
| 385 |
+ |
|
| 386 |
+$update_tmpl = 'update table1 {update table1.key1 table1.key2 table1.key3 table1.key4} where {= table1.key5}';
|
|
| 387 |
+$dbi->execute($update_tmpl, {'table1.key1' => 4, 'table1.key2' => 4, 'table1.key3' => 4, 'table1.key4' => 4, 'table1.key5' => 5});
|
|
| 388 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 389 |
+$rows = $result->fetch_hash_all; |
|
| 390 |
+is_deeply($rows, [{key1 => 4, key2 => 4, key3 => 4, key4 => 4, key5 => 5},
|
|
| 391 |
+ {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10}], "$test : with table name dot");
|
|
| 392 |
+ |
|
| 393 |
+$dbi->execute($update_tmpl, {'#update' => {table1 => {key1 => 5, key2 => 5, key3 => 5, key4 => 5}}, table1 => {key5 => 5}});
|
|
| 394 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 395 |
+$rows = $result->fetch_hash_all; |
|
| 396 |
+is_deeply($rows, [{key1 => 5, key2 => 5, key3 => 5, key4 => 5, key5 => 5},
|
|
| 397 |
+ {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10}], "$test : update tag #update with table name");
|
|
| 398 |
+ |
|
| 399 |
+$dbi->execute($update_tmpl, {'#update' => {'table1.key1' => 6, 'table1.key2' => 6, 'table1.key3' => 6, 'table1.key4' => 6}, 'table1.key5' => 5});
|
|
| 400 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 401 |
+$rows = $result->fetch_hash_all; |
|
| 402 |
+is_deeply($rows, [{key1 => 6, key2 => 6, key3 => 6, key4 => 6, key5 => 5},
|
|
| 403 |
+ {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10}], "$test : update tag #update with table name dot");
|
|
| 404 |
+ |
|
| 405 |
+ |
|
| 406 |
+test 'run_tansaction'; |
|
| 407 |
+$dbi->do($DROP_TABLE->{0});
|
|
| 408 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 409 |
+$dbi->run_transaction(sub {
|
|
| 410 |
+ $insert_tmpl = 'insert into table1 {insert key1 key2}';
|
|
| 411 |
+ $dbi->execute($insert_tmpl, {key1 => 1, key2 => 2});
|
|
| 412 |
+ $dbi->execute($insert_tmpl, {key1 => 3, key2 => 4});
|
|
| 413 |
+}); |
|
| 414 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 415 |
+$rows = $result->fetch_hash_all; |
|
| 416 |
+is_deeply($rows, [{key1 => 1, key2 => 2}, {key1 => 3, key2 => 4}], "$test : commit");
|
|
| 417 |
+ |
|
| 418 |
+$dbi->do($DROP_TABLE->{0});
|
|
| 419 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 420 |
+$dbi->dbh->{RaiseError} = 0;
|
|
| 421 |
+eval{
|
|
| 422 |
+ $dbi->run_transaction(sub {
|
|
| 423 |
+ $insert_tmpl = 'insert into table1 {insert key1 key2}';
|
|
| 424 |
+ $dbi->execute($insert_tmpl, {key1 => 1, key2 => 2});
|
|
| 425 |
+ die "Fatal Error"; |
|
| 426 |
+ $dbi->execute($insert_tmpl, {key1 => 3, key2 => 4});
|
|
| 427 |
+ }) |
|
| 428 |
+}; |
|
| 429 |
+like($@, qr/Fatal Error.*Rollback is success/ms, "$test : Rollback success message"); |
|
| 430 |
+ok(!$dbi->dbh->{RaiseError}, "$test : restore RaiseError value");
|
|
| 431 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 432 |
+$rows = $result->fetch_hash_all; |
|
| 433 |
+is_deeply($rows, [], "$test : rollback"); |
|
| 434 |
+ |
|
| 435 |
+ |
|
| 436 |
+test 'Error case'; |
|
| 437 |
+$dbi = DBIx::Custom->new; |
|
| 438 |
+eval{$dbi->run_transaction};
|
|
| 439 |
+like($@, qr/Not yet connect to database/, "$test : Yet Connected"); |
|
| 440 |
+ |
|
| 441 |
+$dbi = DBIx::Custom->new(data_source => 'dbi:SQLit'); |
|
| 442 |
+eval{$dbi->connect;};
|
|
| 443 |
+ok($@, "$test : connect error"); |
|
| 444 |
+ |
|
| 445 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 446 |
+$dbi->connect; |
|
| 447 |
+$dbi->dbh->{AutoCommit} = 0;
|
|
| 448 |
+eval{$dbi->run_transaction()};
|
|
| 449 |
+like($@, qr/AutoCommit must be true before transaction start/, |
|
| 450 |
+ "$test : run_transaction auto commit is false"); |
|
| 451 |
+ |
|
| 452 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 453 |
+$sql = 'laksjdf'; |
|
| 454 |
+eval{$dbi->prepare($sql)};
|
|
| 455 |
+like($@, qr/$sql/, "$test : prepare fail"); |
|
| 456 |
+ |
|
| 457 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 458 |
+$sql = 'laksjdf'; |
|
| 459 |
+eval{$dbi->do($sql, qw/1 2 3/)};
|
|
| 460 |
+like($@, qr/$sql/, "$test : do fail"); |
|
| 461 |
+ |
|
| 462 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 463 |
+eval{$dbi->create_query("{p }")};
|
|
| 464 |
+ok($@, "$test : create_query invalid SQL template"); |
|
| 465 |
+ |
|
| 466 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 467 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 468 |
+$query = $dbi->create_query("select * from table1 where {= key1}");
|
|
| 469 |
+eval{$dbi->execute($query, {key2 => 1})};
|
|
| 470 |
+like($@, qr/Corresponding key is not found in your parameters/, |
|
| 471 |
+ "$test : execute corresponding key not found"); |
|
| 472 |
+ |
|
| 473 |
+ |
|
| 474 |
+test 'insert'; |
|
| 475 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 476 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 477 |
+$dbi->insert('table1', {key1 => 1, key2 => 2});
|
|
| 478 |
+$dbi->insert('table1', {key1 => 3, key2 => 4});
|
|
| 479 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 480 |
+$rows = $result->fetch_hash_all; |
|
| 481 |
+is_deeply($rows, [{key1 => 1, key2 => 2}, {key1 => 3, key2 => 4}], "$test : basic");
|
|
| 482 |
+ |
|
| 483 |
+$dbi->do('delete from table1');
|
|
| 484 |
+$dbi->insert('table1', {key1 => 1, key2 => 2}, sub {
|
|
| 485 |
+ my $query = shift; |
|
| 486 |
+ $query->bind_filter(sub {
|
|
| 487 |
+ my ($value, $key) = @_; |
|
| 488 |
+ if ($key eq 'key1') {
|
|
| 489 |
+ return $value * 3; |
|
| 490 |
+ } |
|
| 491 |
+ return $value; |
|
| 492 |
+ }); |
|
| 493 |
+}); |
|
| 494 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 495 |
+$rows = $result->fetch_hash_all; |
|
| 496 |
+is_deeply($rows, [{key1 => 3, key2 => 2}], "$test : edit_query_callback");
|
|
| 497 |
+ |
|
| 498 |
+ |
|
| 499 |
+test 'insert error'; |
|
| 500 |
+eval{$dbi->insert('table1')};
|
|
| 501 |
+like($@, qr/Key-value pairs for insert must be specified to 'insert' second argument/, "$test : insert key-value not specifed"); |
|
| 502 |
+ |
|
| 503 |
+eval{$dbi->insert('table1', {key1 => 1, key2 => 2}, 'aaa')};
|
|
| 504 |
+like($@, qr/Query edit callback must be code reference/, "$test : query edit callback not code ref"); |
|
| 505 |
+ |
|
| 506 |
+ |
|
| 507 |
+test 'update'; |
|
| 508 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 509 |
+$dbi->do($CREATE_TABLE->{1});
|
|
| 510 |
+$dbi->insert('table1', {key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5});
|
|
| 511 |
+$dbi->insert('table1', {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10});
|
|
| 512 |
+$dbi->update('table1', {key2 => 11}, {key1 => 1});
|
|
| 513 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 514 |
+$rows = $result->fetch_hash_all; |
|
| 515 |
+is_deeply($rows, [{key1 => 1, key2 => 11, key3 => 3, key4 => 4, key5 => 5},
|
|
| 516 |
+ {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10}],
|
|
| 517 |
+ "$test : basic"); |
|
| 518 |
+ |
|
| 519 |
+$dbi->do("delete from table1");
|
|
| 520 |
+$dbi->insert('table1', {key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5});
|
|
| 521 |
+$dbi->insert('table1', {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10});
|
|
| 522 |
+$dbi->update('table1', {key2 => 12}, {key2 => 2, key3 => 3});
|
|
| 523 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 524 |
+$rows = $result->fetch_hash_all; |
|
| 525 |
+is_deeply($rows, [{key1 => 1, key2 => 12, key3 => 3, key4 => 4, key5 => 5},
|
|
| 526 |
+ {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10}],
|
|
| 527 |
+ "$test : update key same as search key"); |
|
| 528 |
+ |
|
| 529 |
+$dbi->do("delete from table1");
|
|
| 530 |
+$dbi->insert('table1', {key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5});
|
|
| 531 |
+$dbi->insert('table1', {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10});
|
|
| 532 |
+$dbi->update('table1', {key2 => 11}, {key1 => 1}, sub {
|
|
| 533 |
+ my $query = shift; |
|
| 534 |
+ $query->bind_filter(sub {
|
|
| 535 |
+ my ($value, $key) = @_; |
|
| 536 |
+ if ($key eq 'key2') {
|
|
| 537 |
+ return $value * 2; |
|
| 538 |
+ } |
|
| 539 |
+ return $value; |
|
| 540 |
+ }); |
|
| 541 |
+}); |
|
| 542 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 543 |
+$rows = $result->fetch_hash_all; |
|
| 544 |
+is_deeply($rows, [{key1 => 1, key2 => 22, key3 => 3, key4 => 4, key5 => 5},
|
|
| 545 |
+ {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10}],
|
|
| 546 |
+ "$test : query edit callback"); |
|
| 547 |
+ |
|
| 548 |
+ |
|
| 549 |
+test 'update error'; |
|
| 550 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 551 |
+$dbi->do($CREATE_TABLE->{1});
|
|
| 552 |
+eval{$dbi->update('table1')};
|
|
| 553 |
+like($@, qr/Key-value pairs for update must be specified to 'update' second argument/, |
|
| 554 |
+ "$test : update key-value pairs not specified"); |
|
| 555 |
+ |
|
| 556 |
+eval{$dbi->update('table1', {key2 => 1})};
|
|
| 557 |
+like($@, qr/Key-value pairs for where clause must be specified to 'update' third argument/, |
|
| 558 |
+ "$test : where key-value pairs not specified"); |
|
| 559 |
+ |
|
| 560 |
+eval{$dbi->update('table1', {key2 => 1}, {key2 => 3}, 'aaa')};
|
|
| 561 |
+like($@, qr/Query edit callback must be code reference/, |
|
| 562 |
+ "$test : query edit callback not code reference"); |
|
| 563 |
+ |
|
| 564 |
+ |
|
| 565 |
+test 'update_all'; |
|
| 566 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 567 |
+$dbi->do($CREATE_TABLE->{1});
|
|
| 568 |
+$dbi->insert('table1', {key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5});
|
|
| 569 |
+$dbi->insert('table1', {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10});
|
|
| 570 |
+$dbi->update_all('table1', {key2 => 10}, sub {
|
|
| 571 |
+ my $query = shift; |
|
| 572 |
+ $query->bind_filter(sub {
|
|
| 573 |
+ my ($value, $key) = @_; |
|
| 574 |
+ return $value * 2; |
|
| 575 |
+ }) |
|
| 576 |
+}); |
|
| 577 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 578 |
+$rows = $result->fetch_hash_all; |
|
| 579 |
+is_deeply($rows, [{key1 => 1, key2 => 20, key3 => 3, key4 => 4, key5 => 5},
|
|
| 580 |
+ {key1 => 6, key2 => 20, key3 => 8, key4 => 9, key5 => 10}],
|
|
| 581 |
+ "$test : query edit callback"); |
|
| 582 |
+ |
|
| 583 |
+ |
|
| 584 |
+test 'delete'; |
|
| 585 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 586 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 587 |
+$dbi->insert('table1', {key1 => 1, key2 => 2});
|
|
| 588 |
+$dbi->insert('table1', {key1 => 3, key2 => 4});
|
|
| 589 |
+$dbi->delete('table1', {key1 => 1});
|
|
| 590 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 591 |
+$rows = $result->fetch_hash_all; |
|
| 592 |
+is_deeply($rows, [{key1 => 3, key2 => 4}], "$test : basic");
|
|
| 593 |
+ |
|
| 594 |
+$dbi->do("delete from table1;");
|
|
| 595 |
+$dbi->insert('table1', {key1 => 1, key2 => 2});
|
|
| 596 |
+$dbi->insert('table1', {key1 => 3, key2 => 4});
|
|
| 597 |
+$dbi->delete('table1', {key2 => 1}, sub {
|
|
| 598 |
+ my $query = shift; |
|
| 599 |
+ $query->bind_filter(sub {
|
|
| 600 |
+ my ($value, $key) = @_; |
|
| 601 |
+ return $value * 2; |
|
| 602 |
+ }); |
|
| 603 |
+}); |
|
| 604 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 605 |
+$rows = $result->fetch_hash_all; |
|
| 606 |
+is_deeply($rows, [{key1 => 3, key2 => 4}], "$test : query edit callback");
|
|
| 607 |
+ |
|
| 608 |
+$dbi->delete_all('table1');
|
|
| 609 |
+$dbi->insert('table1', {key1 => 1, key2 => 2});
|
|
| 610 |
+$dbi->insert('table1', {key1 => 3, key2 => 4});
|
|
| 611 |
+$dbi->delete('table1', {key1 => 1, key2 => 2});
|
|
| 612 |
+$rows = $dbi->select('table1')->fetch_hash_all;
|
|
| 613 |
+is_deeply($rows, [{key1 => 3, key2 => 4}], "$test : delete multi key");
|
|
| 614 |
+ |
|
| 615 |
+ |
|
| 616 |
+test 'delete error'; |
|
| 617 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 618 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 619 |
+eval{$dbi->delete('table1')};
|
|
| 620 |
+like($@, qr/Key-value pairs for where clause must be specified to 'delete' second argument/, |
|
| 621 |
+ "$test : where key-value pairs not specified"); |
|
| 622 |
+ |
|
| 623 |
+eval{$dbi->delete('table1', {key1 => 1}, 'aaa')};
|
|
| 624 |
+like($@, qr/Query edit callback must be code reference/, |
|
| 625 |
+ "$test : query edit callback not code ref"); |
|
| 626 |
+ |
|
| 627 |
+ |
|
| 628 |
+test 'delete_all'; |
|
| 629 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 630 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 631 |
+$dbi->insert('table1', {key1 => 1, key2 => 2});
|
|
| 632 |
+$dbi->insert('table1', {key1 => 3, key2 => 4});
|
|
| 633 |
+$dbi->delete_all('table1');
|
|
| 634 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 635 |
+$rows = $result->fetch_hash_all; |
|
| 636 |
+is_deeply($rows, [], "$test : basic"); |
|
| 637 |
+ |
|
| 638 |
+ |
|
| 639 |
+test 'select'; |
|
| 640 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 641 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 642 |
+$dbi->insert('table1', {key1 => 1, key2 => 2});
|
|
| 643 |
+$dbi->insert('table1', {key1 => 3, key2 => 4});
|
|
| 644 |
+$rows = $dbi->select('table1')->fetch_hash_all;
|
|
| 645 |
+is_deeply($rows, [{key1 => 1, key2 => 2},
|
|
| 646 |
+ {key1 => 3, key2 => 4}], "$test : table");
|
|
| 647 |
+ |
|
| 648 |
+$rows = $dbi->select('table1', ['key1'])->fetch_hash_all;
|
|
| 649 |
+is_deeply($rows, [{key1 => 1}, {key1 => 3}], "$test : table and columns and where key");
|
|
| 650 |
+ |
|
| 651 |
+$rows = $dbi->select('table1', {key1 => 1})->fetch_hash_all;
|
|
| 652 |
+is_deeply($rows, [{key1 => 1, key2 => 2}], "$test : table and columns and where key");
|
|
| 653 |
+ |
|
| 654 |
+$rows = $dbi->select('table1', ['key1'], {key1 => 3})->fetch_hash_all;
|
|
| 655 |
+is_deeply($rows, [{key1 => 3}], "$test : table and columns and where key");
|
|
| 656 |
+ |
|
| 657 |
+$rows = $dbi->select('table1', "order by key1 desc limit 1")->fetch_hash_all;
|
|
| 658 |
+is_deeply($rows, [{key1 => 3, key2 => 4}], "$test : append statement");
|
|
| 659 |
+ |
|
| 660 |
+$rows = $dbi->select('table1', {key1 => 2}, sub {
|
|
| 661 |
+ my $query = shift; |
|
| 662 |
+ $query->bind_filter(sub {
|
|
| 663 |
+ my ($value, $key) = @_; |
|
| 664 |
+ if ($key eq 'key1') {
|
|
| 665 |
+ return $value - 1; |
|
| 666 |
+ } |
|
| 667 |
+ return $value; |
|
| 668 |
+ }); |
|
| 669 |
+})->fetch_hash_all; |
|
| 670 |
+is_deeply($rows, [{key1 => 1, key2 => 2}], "$test : query edit call back");
|
|
| 671 |
+ |
|
| 672 |
+$dbi->do($CREATE_TABLE->{2});
|
|
| 673 |
+$dbi->insert('table2', {key1 => 1, key3 => 5});
|
|
| 674 |
+$rows = $dbi->select([qw/table1 table2/], |
|
| 675 |
+ ['table1.key1 as table1_key1', 'table2.key1 as table2_key1', 'key2', 'key3'], |
|
| 676 |
+ {'table1.key2' => 2},
|
|
| 677 |
+ "where table1.key1 = table2.key1")->fetch_hash_all; |
|
| 678 |
+is_deeply($rows, [{table1_key1 => 1, table2_key1 => 1, key2 => 2, key3 => 5}], "$test : join");
|
|
| 679 |
+ |
|
| 680 |
+test 'Cache'; |
|
| 681 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 682 |
+DBIx::Custom->query_cache_max(2); |
|
| 683 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 684 |
+DBIx::Custom->delete_class_attr('_query_caches');
|
|
| 685 |
+DBIx::Custom->delete_class_attr('_query_cache_keys');
|
|
| 686 |
+$tmpls[0] = "insert into table1 {insert key1 key2}";
|
|
| 687 |
+$queries[0] = $dbi->create_query($tmpls[0]); |
|
| 688 |
+is(DBIx::Custom->_query_caches->{$tmpls[0]}{sql}, $queries[0]->sql, "$test : sql first");
|
|
| 689 |
+is(DBIx::Custom->_query_caches->{$tmpls[0]}{key_infos}, $queries[0]->key_infos, "$test : key_infos first");
|
|
| 690 |
+is_deeply(DBIx::Custom->_query_cache_keys, [@tmpls], "$test : cache key first"); |
|
| 691 |
+ |
|
| 692 |
+$tmpls[1] = "select * from table1"; |
|
| 693 |
+$queries[1] = $dbi->create_query($tmpls[1]); |
|
| 694 |
+is(DBIx::Custom->_query_caches->{$tmpls[0]}{sql}, $queries[0]->sql, "$test : sql first");
|
|
| 695 |
+is(DBIx::Custom->_query_caches->{$tmpls[0]}{key_infos}, $queries[0]->key_infos, "$test : key_infos first");
|
|
| 696 |
+is(DBIx::Custom->_query_caches->{$tmpls[1]}{sql}, $queries[1]->sql, "$test : sql second");
|
|
| 697 |
+is(DBIx::Custom->_query_caches->{$tmpls[1]}{key_infos}, $queries[1]->key_infos, "$test : key_infos second");
|
|
| 698 |
+is_deeply(DBIx::Custom->_query_cache_keys, [@tmpls], "$test : cache key second"); |
|
| 699 |
+ |
|
| 700 |
+$tmpls[2] = "select key1, key2 from table1"; |
|
| 701 |
+$queries[2] = $dbi->create_query($tmpls[2]); |
|
| 702 |
+ok(!exists DBIx::Custom->_query_caches->{$tmpls[0]}, "$test : cache overflow deleted key");
|
|
| 703 |
+is(DBIx::Custom->_query_caches->{$tmpls[1]}{sql}, $queries[1]->sql, "$test : sql cache overflow deleted key");
|
|
| 704 |
+is(DBIx::Custom->_query_caches->{$tmpls[1]}{key_infos}, $queries[1]->key_infos, "$test : key_infos cache overflow deleted key");
|
|
| 705 |
+is(DBIx::Custom->_query_caches->{$tmpls[2]}{sql}, $queries[2]->sql, "$test : sql cache overflow deleted key");
|
|
| 706 |
+is(DBIx::Custom->_query_caches->{$tmpls[2]}{key_infos}, $queries[2]->key_infos, "$test : key_infos cache overflow deleted key");
|
|
| 707 |
+is_deeply(DBIx::Custom->_query_cache_keys, [@tmpls[1, 2]], "$test : cache key third"); |
|
| 708 |
+ |
|
| 709 |
+$queries[1] = $dbi->create_query($tmpls[1]); |
|
| 710 |
+ok(!exists DBIx::Custom->_query_caches->{$tmpls[0]}, "$test : cache overflow deleted key");
|
|
| 711 |
+is(DBIx::Custom->_query_caches->{$tmpls[1]}{sql}, $queries[1]->sql, "$test : sql cache overflow deleted key");
|
|
| 712 |
+is(DBIx::Custom->_query_caches->{$tmpls[1]}{key_infos}, $queries[1]->key_infos, "$test : key_infos cache overflow deleted key");
|
|
| 713 |
+is(DBIx::Custom->_query_caches->{$tmpls[2]}{sql}, $queries[2]->sql, "$test : sql cache overflow deleted key");
|
|
| 714 |
+is(DBIx::Custom->_query_caches->{$tmpls[2]}{key_infos}, $queries[2]->key_infos, "$test : key_infos cache overflow deleted key");
|
|
| 715 |
+is_deeply(DBIx::Custom->_query_cache_keys, [@tmpls[1, 2]], "$test : cache key third"); |
|
| 716 |
+ |
| ... | ... |
@@ -0,0 +1,220 @@ |
| 1 |
+use Test::More 'no_plan'; |
|
| 2 |
+use strict; |
|
| 3 |
+use warnings; |
|
| 4 |
+ |
|
| 5 |
+use DBIx::Custom; |
|
| 6 |
+use DBIx::Custom::SQL::Template; |
|
| 7 |
+ |
|
| 8 |
+# Function for test name |
|
| 9 |
+my $test; |
|
| 10 |
+sub test {
|
|
| 11 |
+ $test = shift; |
|
| 12 |
+} |
|
| 13 |
+ |
|
| 14 |
+# Variables for test |
|
| 15 |
+our $SQL_TMPL = {
|
|
| 16 |
+ 0 => DBIx::Custom::SQL::Template->new->tag_start(0), |
|
| 17 |
+ 1 => DBIx::Custom::SQL::Template->new->tag_start(1), |
|
| 18 |
+ 2 => DBIx::Custom::SQL::Template->new->tag_start(2) |
|
| 19 |
+}; |
|
| 20 |
+my $dbi; |
|
| 21 |
+ |
|
| 22 |
+ |
|
| 23 |
+test 'Constructor'; |
|
| 24 |
+$dbi = DBIx::Custom->new( |
|
| 25 |
+ user => 'a', |
|
| 26 |
+ database => 'a', |
|
| 27 |
+ password => 'b', |
|
| 28 |
+ data_source => 'c', |
|
| 29 |
+ dbi_options => {d => 1, e => 2},
|
|
| 30 |
+ filters => {
|
|
| 31 |
+ f => 3, |
|
| 32 |
+ }, |
|
| 33 |
+ bind_filter => 'f', |
|
| 34 |
+ fetch_filter => 'g', |
|
| 35 |
+ result_class => 'g', |
|
| 36 |
+ sql_template => $SQL_TMPL->{0},
|
|
| 37 |
+); |
|
| 38 |
+is_deeply($dbi,{user => 'a', database => 'a', password => 'b', data_source => 'c',
|
|
| 39 |
+ dbi_options => {d => 1, e => 2}, filters => {f => 3}, bind_filter => 'f',
|
|
| 40 |
+ fetch_filter => 'g', result_class => 'g', |
|
| 41 |
+ sql_template => $SQL_TMPL->{0}}, $test);
|
|
| 42 |
+isa_ok($dbi, 'DBIx::Custom'); |
|
| 43 |
+ |
|
| 44 |
+ |
|
| 45 |
+test 'Sub class constructor'; |
|
| 46 |
+{
|
|
| 47 |
+ package DBIx::Custom::T1; |
|
| 48 |
+ use base 'DBIx::Custom'; |
|
| 49 |
+ |
|
| 50 |
+ __PACKAGE__ |
|
| 51 |
+ ->user('a')
|
|
| 52 |
+ ->database('a')
|
|
| 53 |
+ ->password('b')
|
|
| 54 |
+ ->data_source('c')
|
|
| 55 |
+ ->dbi_options({d => 1, e => 2})
|
|
| 56 |
+ ->filters( |
|
| 57 |
+ f => 3 |
|
| 58 |
+ ) |
|
| 59 |
+ ->formats( |
|
| 60 |
+ f => 3 |
|
| 61 |
+ ) |
|
| 62 |
+ ->bind_filter('f')
|
|
| 63 |
+ ->fetch_filter('g')
|
|
| 64 |
+ ->result_class('DBIx::Custom::Result')
|
|
| 65 |
+ ->sql_template($SQL_TMPL->{0})
|
|
| 66 |
+ ; |
|
| 67 |
+} |
|
| 68 |
+$dbi = DBIx::Custom::T1->new( |
|
| 69 |
+ user => 'ao', |
|
| 70 |
+ database => 'ao', |
|
| 71 |
+ password => 'bo', |
|
| 72 |
+ data_source => 'co', |
|
| 73 |
+ dbi_options => {do => 10, eo => 20},
|
|
| 74 |
+ filters => {
|
|
| 75 |
+ fo => 30, |
|
| 76 |
+ }, |
|
| 77 |
+ formats => {
|
|
| 78 |
+ fo => 30, |
|
| 79 |
+ }, |
|
| 80 |
+ bind_filter => 'fo', |
|
| 81 |
+ fetch_filter => 'go', |
|
| 82 |
+ result_class => 'ho', |
|
| 83 |
+ sql_template => $SQL_TMPL->{0},
|
|
| 84 |
+); |
|
| 85 |
+is($dbi->user, 'ao', "$test : user"); |
|
| 86 |
+is($dbi->database, 'ao', "$test : database"); |
|
| 87 |
+is($dbi->password, 'bo', "$test : passowr"); |
|
| 88 |
+is($dbi->data_source, 'co', "$test : data_source"); |
|
| 89 |
+is_deeply($dbi->dbi_options, {do => 10, eo => 20}, "$test : dbi_options");
|
|
| 90 |
+is_deeply(scalar $dbi->filters, {fo => 30}, "$test : filters");
|
|
| 91 |
+is_deeply(scalar $dbi->formats, {fo => 30}, "$test : formats");
|
|
| 92 |
+is($dbi->bind_filter, 'fo', "$test : bind_filter"); |
|
| 93 |
+is($dbi->fetch_filter, 'go', "$test : fetch_filter"); |
|
| 94 |
+is($dbi->result_class, 'ho', "$test : result_class"); |
|
| 95 |
+is($dbi->sql_template->tag_start, 0, "$test : sql_template"); |
|
| 96 |
+isa_ok($dbi, 'DBIx::Custom::T1'); |
|
| 97 |
+ |
|
| 98 |
+test 'Sub class constructor default'; |
|
| 99 |
+$dbi = DBIx::Custom::T1->new; |
|
| 100 |
+is($dbi->user, 'a', "$test : user"); |
|
| 101 |
+is($dbi->database, 'a', "$test : database"); |
|
| 102 |
+is($dbi->password, 'b', "$test : password"); |
|
| 103 |
+is($dbi->data_source, 'c', "$test : data_source"); |
|
| 104 |
+is_deeply($dbi->dbi_options, {d => 1, e => 2}, "$test : dbi_options");
|
|
| 105 |
+is_deeply({$dbi->filters}, {f => 3}, "$test : filters");
|
|
| 106 |
+is_deeply({$dbi->formats}, {f => 3}, "$test : formats");
|
|
| 107 |
+is($dbi->bind_filter, 'f', "$test : bind_filter"); |
|
| 108 |
+is($dbi->fetch_filter, 'g', "$test : fetch_filter"); |
|
| 109 |
+is($dbi->result_class, 'DBIx::Custom::Result', "$test : result_class"); |
|
| 110 |
+is($dbi->sql_template->tag_start, 0, "$test : sql_template"); |
|
| 111 |
+isa_ok($dbi, 'DBIx::Custom::T1'); |
|
| 112 |
+ |
|
| 113 |
+ |
|
| 114 |
+test 'Sub sub class constructor default'; |
|
| 115 |
+{
|
|
| 116 |
+ package DBIx::Custom::T1_2; |
|
| 117 |
+ use base 'DBIx::Custom::T1'; |
|
| 118 |
+} |
|
| 119 |
+$dbi = DBIx::Custom::T1_2->new; |
|
| 120 |
+is($dbi->user, 'a', "$test : user"); |
|
| 121 |
+is($dbi->database, 'a', "$test : database"); |
|
| 122 |
+is($dbi->password, 'b', "$test : passowrd"); |
|
| 123 |
+is($dbi->data_source, 'c', "$test : data_source"); |
|
| 124 |
+is_deeply($dbi->dbi_options, {d => 1, e => 2}, "$test : dbi_options");
|
|
| 125 |
+is_deeply(scalar $dbi->filters, {f => 3}, "$test : filters");
|
|
| 126 |
+is_deeply(scalar $dbi->formats, {f => 3}, "$test : formats");
|
|
| 127 |
+is($dbi->bind_filter, 'f', "$test : bind_filter"); |
|
| 128 |
+is($dbi->fetch_filter, 'g', "$test : fetch_filter"); |
|
| 129 |
+is($dbi->result_class, 'DBIx::Custom::Result', "$test : result_class"); |
|
| 130 |
+is($dbi->sql_template->tag_start, 0, "$test sql_template"); |
|
| 131 |
+isa_ok($dbi, 'DBIx::Custom::T1_2'); |
|
| 132 |
+ |
|
| 133 |
+ |
|
| 134 |
+test 'Customized sub class constructor default'; |
|
| 135 |
+{
|
|
| 136 |
+ package DBIx::Custom::T1_3; |
|
| 137 |
+ use base 'DBIx::Custom::T1'; |
|
| 138 |
+ |
|
| 139 |
+ __PACKAGE__ |
|
| 140 |
+ ->user('ao')
|
|
| 141 |
+ ->database('ao')
|
|
| 142 |
+ ->password('bo')
|
|
| 143 |
+ ->data_source('co')
|
|
| 144 |
+ ->dbi_options({do => 10, eo => 20})
|
|
| 145 |
+ ->filters( |
|
| 146 |
+ fo => 30 |
|
| 147 |
+ ) |
|
| 148 |
+ ->formats( |
|
| 149 |
+ fo => 30 |
|
| 150 |
+ ) |
|
| 151 |
+ ->bind_filter('fo')
|
|
| 152 |
+ ->fetch_filter('go')
|
|
| 153 |
+ ->result_class('ho')
|
|
| 154 |
+ ->sql_template($SQL_TMPL->{1})
|
|
| 155 |
+ ; |
|
| 156 |
+} |
|
| 157 |
+$dbi = DBIx::Custom::T1_3->new; |
|
| 158 |
+is($dbi->user, 'ao', "$test : user"); |
|
| 159 |
+is($dbi->database, 'ao', "$test : database"); |
|
| 160 |
+is($dbi->password, 'bo', "$test : password"); |
|
| 161 |
+is($dbi->data_source, 'co', "$test : data_source"); |
|
| 162 |
+is_deeply($dbi->dbi_options, {do => 10, eo => 20}, "$test : dbi_options");
|
|
| 163 |
+is_deeply(scalar $dbi->filters, {fo => 30}, "$test : filters");
|
|
| 164 |
+is_deeply(scalar $dbi->formats, {fo => 30}, "$test : formats");
|
|
| 165 |
+is($dbi->bind_filter, 'fo', "$test : bind_filter"); |
|
| 166 |
+is($dbi->fetch_filter, 'go', "$test : fetch_filter"); |
|
| 167 |
+is($dbi->result_class, 'ho', "$test : result_class"); |
|
| 168 |
+is($dbi->sql_template->tag_start, 1, "$test : sql_template"); |
|
| 169 |
+isa_ok($dbi, 'DBIx::Custom::T1_3'); |
|
| 170 |
+ |
|
| 171 |
+ |
|
| 172 |
+test 'Customized sub class constructor'; |
|
| 173 |
+$dbi = DBIx::Custom::T1_3->new( |
|
| 174 |
+ user => 'a', |
|
| 175 |
+ database => 'a', |
|
| 176 |
+ password => 'b', |
|
| 177 |
+ data_source => 'c', |
|
| 178 |
+ dbi_options => {d => 1, e => 2},
|
|
| 179 |
+ filters => {
|
|
| 180 |
+ f => 3, |
|
| 181 |
+ }, |
|
| 182 |
+ formats => {
|
|
| 183 |
+ f => 3, |
|
| 184 |
+ }, |
|
| 185 |
+ bind_filter => 'f', |
|
| 186 |
+ fetch_filter => 'g', |
|
| 187 |
+ result_class => 'h', |
|
| 188 |
+ sql_template => $SQL_TMPL->{2},
|
|
| 189 |
+); |
|
| 190 |
+is($dbi->user, 'a', "$test : user"); |
|
| 191 |
+is($dbi->database, 'a', "$test : database"); |
|
| 192 |
+is($dbi->password, 'b', "$test : password"); |
|
| 193 |
+is($dbi->data_source, 'c', "$test : data_source"); |
|
| 194 |
+is_deeply($dbi->dbi_options, {d => 1, e => 2}, "$test : dbi_options");
|
|
| 195 |
+is_deeply({$dbi->filters}, {f => 3}, "$test : filters");
|
|
| 196 |
+is_deeply({$dbi->formats}, {f => 3}, "$test : formats");
|
|
| 197 |
+is($dbi->bind_filter, 'f', "$test : bind_filter"); |
|
| 198 |
+is($dbi->fetch_filter, 'g', "$test : fetch_filter"); |
|
| 199 |
+is($dbi->result_class, 'h', "$test : result_class"); |
|
| 200 |
+is($dbi->sql_template->tag_start, 2, "$test : sql_template"); |
|
| 201 |
+isa_ok($dbi, 'DBIx::Custom'); |
|
| 202 |
+ |
|
| 203 |
+ |
|
| 204 |
+test 'add_filters'; |
|
| 205 |
+$dbi = DBIx::Custom->new; |
|
| 206 |
+$dbi->add_filter(a => sub {1});
|
|
| 207 |
+is($dbi->filters->{a}->(), 1, $test);
|
|
| 208 |
+ |
|
| 209 |
+test 'add_formats'; |
|
| 210 |
+$dbi = DBIx::Custom->new; |
|
| 211 |
+$dbi->add_format(a => sub {1});
|
|
| 212 |
+is($dbi->formats->{a}->(), 1, $test);
|
|
| 213 |
+ |
|
| 214 |
+test 'filter_off'; |
|
| 215 |
+$dbi = DBIx::Custom->new; |
|
| 216 |
+$dbi->bind_filter('a');
|
|
| 217 |
+$dbi->fetch_filter('b');
|
|
| 218 |
+$dbi->filter_off; |
|
| 219 |
+ok(!$dbi->bind_filter, "$test : bind_filter off"); |
|
| 220 |
+ok(!$dbi->fetch_filter, "$test : fetch_filter off"); |
| ... | ... |
@@ -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 |
+ |
| ... | ... |
@@ -0,0 +1,85 @@ |
| 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 |
+ eval { Time::Piece->VERSION >= 1.15 }
|
|
| 10 |
+ or plan skip_all => 'Time::Piece >= 1.15 requred'; |
|
| 11 |
+ |
|
| 12 |
+ plan 'no_plan'; |
|
| 13 |
+ use_ok('DBIx::Custom');
|
|
| 14 |
+} |
|
| 15 |
+ |
|
| 16 |
+# Function for test name |
|
| 17 |
+my $test; |
|
| 18 |
+sub test {
|
|
| 19 |
+ $test = shift; |
|
| 20 |
+} |
|
| 21 |
+ |
|
| 22 |
+# Varialbe for tests |
|
| 23 |
+ |
|
| 24 |
+my $format; |
|
| 25 |
+my $data; |
|
| 26 |
+my $timepiece; |
|
| 27 |
+my $dbi; |
|
| 28 |
+ |
|
| 29 |
+use DBIx::Custom::MySQL; |
|
| 30 |
+ |
|
| 31 |
+ |
|
| 32 |
+test 'SQL99 format'; |
|
| 33 |
+$dbi = DBIx::Custom::MySQL->new; |
|
| 34 |
+$data = '2009-01-02 03:04:05'; |
|
| 35 |
+$format = $dbi->formats->{'SQL99_datetime'};
|
|
| 36 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 37 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : datetime date");
|
|
| 38 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : datetime time");
|
|
| 39 |
+ |
|
| 40 |
+$data = '2009-01-02'; |
|
| 41 |
+$format = $dbi->formats->{'SQL99_date'};
|
|
| 42 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 43 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : date");
|
|
| 44 |
+ |
|
| 45 |
+$data = '03:04:05'; |
|
| 46 |
+$format = $dbi->formats->{'SQL99_time'};
|
|
| 47 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 48 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : time");
|
|
| 49 |
+ |
|
| 50 |
+ |
|
| 51 |
+test 'ISO-8601 format'; |
|
| 52 |
+$data = '2009-01-02T03:04:05'; |
|
| 53 |
+$format = $dbi->formats->{'ISO-8601_datetime'};
|
|
| 54 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 55 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : datetime date");
|
|
| 56 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : datetime time");
|
|
| 57 |
+ |
|
| 58 |
+$data = '2009-01-02'; |
|
| 59 |
+$format = $dbi->formats->{'ISO-8601_date'};
|
|
| 60 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 61 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : date");
|
|
| 62 |
+ |
|
| 63 |
+$data = '03:04:05'; |
|
| 64 |
+$format = $dbi->formats->{'ISO-8601_time'};
|
|
| 65 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 66 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : time");
|
|
| 67 |
+ |
|
| 68 |
+ |
|
| 69 |
+test 'default format'; |
|
| 70 |
+$data = '2009-01-02 03:04:05'; |
|
| 71 |
+$format = $dbi->formats->{'datetime'};
|
|
| 72 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 73 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : datetime date");
|
|
| 74 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : datetime time");
|
|
| 75 |
+ |
|
| 76 |
+$data = '2009-01-02'; |
|
| 77 |
+$format = $dbi->formats->{'date'};
|
|
| 78 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 79 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : date");
|
|
| 80 |
+ |
|
| 81 |
+$data = '03:04:05'; |
|
| 82 |
+$format = $dbi->formats->{'time'};
|
|
| 83 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 84 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : time");
|
|
| 85 |
+ |
| ... | ... |
@@ -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 |
+ |
| ... | ... |
@@ -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_hash_first'; |
|
| 99 |
+$result = query($dbh, $sql); |
|
| 100 |
+$row = $result->fetch_hash_first; |
|
| 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_hash_first list context'; |
|
| 107 |
+$result = query($dbh, $sql); |
|
| 108 |
+@row = $result->fetch_hash_first; |
|
| 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_hash_rows'; |
|
| 152 |
+$result = query($dbh, $sql); |
|
| 153 |
+$rows = $result->fetch_hash_rows(2); |
|
| 154 |
+is_deeply($rows, [{key1 => 1, key2 => 2},
|
|
| 155 |
+ {key1 => 3, key2 => 4}], "$test : fetch_rows first");
|
|
| 156 |
+$rows = $result->fetch_hash_rows(2); |
|
| 157 |
+is_deeply($rows, [{key1 => 5, key2 => 6},
|
|
| 158 |
+ {key1 => 7, key2 => 8}], "$test : fetch_rows secound");
|
|
| 159 |
+$rows = $result->fetch_hash_rows(2); |
|
| 160 |
+is_deeply($rows, [{key1 => 9, key2 => 10}], "$test : fetch_rows third");
|
|
| 161 |
+$rows = $result->fetch_hash_rows(2); |
|
| 162 |
+ok(!$rows); |
|
| 163 |
+ |
|
| 164 |
+ |
|
| 165 |
+test 'fetch_rows list context'; |
|
| 166 |
+$result = query($dbh, $sql); |
|
| 167 |
+@rows = $result->fetch_hash_rows(2); |
|
| 168 |
+is_deeply([@rows], [{key1 => 1, key2 => 2},
|
|
| 169 |
+ {key1 => 3, key2 => 4}], "$test : fetch_rows first");
|
|
| 170 |
+@rows = $result->fetch_hash_rows(2); |
|
| 171 |
+is_deeply([@rows], [{key1 => 5, key2 => 6},
|
|
| 172 |
+ {key1 => 7, key2 => 8}], "$test : fetch_rows secound");
|
|
| 173 |
+@rows = $result->fetch_hash_rows(2); |
|
| 174 |
+is_deeply([@rows], [{key1 => 9, key2 => 10}], "$test : fetch_rows third");
|
|
| 175 |
+@rows = $result->fetch_hash_rows(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_hash_rows};
|
|
| 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_hash_all'; |
|
| 198 |
+$result = query($dbh, $sql); |
|
| 199 |
+@rows = $result->fetch_hash_all; |
|
| 200 |
+is_deeply($rows, [[1, 2], [3, 4]], $test); |
|
| 201 |
+ |
|
| 202 |
+ |
|
| 203 |
+test 'fetch_hash_all 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 ($value, $key, $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_hash_all; |
|
| 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_hash_all; |
|
| 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 |
+ |
| ... | ... |
@@ -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 |
+ |
| ... | ... |
@@ -0,0 +1,85 @@ |
| 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 |
+ eval { Time::Piece->VERSION >= 1.15 }
|
|
| 10 |
+ or plan skip_all => 'Time::Piece >= 1.15 requred'; |
|
| 11 |
+ |
|
| 12 |
+ plan 'no_plan'; |
|
| 13 |
+ use_ok('DBIx::Custom');
|
|
| 14 |
+} |
|
| 15 |
+ |
|
| 16 |
+# Function for test name |
|
| 17 |
+my $test; |
|
| 18 |
+sub test {
|
|
| 19 |
+ $test = shift; |
|
| 20 |
+} |
|
| 21 |
+ |
|
| 22 |
+# Varialbe for tests |
|
| 23 |
+ |
|
| 24 |
+my $format; |
|
| 25 |
+my $data; |
|
| 26 |
+my $timepiece; |
|
| 27 |
+my $dbi; |
|
| 28 |
+ |
|
| 29 |
+use DBIx::Custom::SQLite; |
|
| 30 |
+ |
|
| 31 |
+ |
|
| 32 |
+test 'SQL99 format'; |
|
| 33 |
+$dbi = DBIx::Custom::SQLite->new; |
|
| 34 |
+$data = '2009-01-02 03:04:05'; |
|
| 35 |
+$format = $dbi->formats->{'SQL99_datetime'};
|
|
| 36 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 37 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : datetime date");
|
|
| 38 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : datetime time");
|
|
| 39 |
+ |
|
| 40 |
+$data = '2009-01-02'; |
|
| 41 |
+$format = $dbi->formats->{'SQL99_date'};
|
|
| 42 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 43 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : date");
|
|
| 44 |
+ |
|
| 45 |
+$data = '03:04:05'; |
|
| 46 |
+$format = $dbi->formats->{'SQL99_time'};
|
|
| 47 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 48 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : time");
|
|
| 49 |
+ |
|
| 50 |
+ |
|
| 51 |
+test 'ISO-8601 format'; |
|
| 52 |
+$data = '2009-01-02T03:04:05'; |
|
| 53 |
+$format = $dbi->formats->{'ISO-8601_datetime'};
|
|
| 54 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 55 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : datetime date");
|
|
| 56 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : datetime time");
|
|
| 57 |
+ |
|
| 58 |
+$data = '2009-01-02'; |
|
| 59 |
+$format = $dbi->formats->{'ISO-8601_date'};
|
|
| 60 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 61 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : date");
|
|
| 62 |
+ |
|
| 63 |
+$data = '03:04:05'; |
|
| 64 |
+$format = $dbi->formats->{'ISO-8601_time'};
|
|
| 65 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 66 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : time");
|
|
| 67 |
+ |
|
| 68 |
+ |
|
| 69 |
+test 'default format'; |
|
| 70 |
+$data = '2009-01-02 03:04:05'; |
|
| 71 |
+$format = $dbi->formats->{'datetime'};
|
|
| 72 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 73 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : datetime date");
|
|
| 74 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : datetime time");
|
|
| 75 |
+ |
|
| 76 |
+$data = '2009-01-02'; |
|
| 77 |
+$format = $dbi->formats->{'date'};
|
|
| 78 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 79 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : date");
|
|
| 80 |
+ |
|
| 81 |
+$data = '03:04:05'; |
|
| 82 |
+$format = $dbi->formats->{'time'};
|
|
| 83 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 84 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : time");
|
|
| 85 |
+ |
| ... | ... |
@@ -0,0 +1,69 @@ |
| 1 |
+use Test::More; |
|
| 2 |
+use strict; |
|
| 3 |
+use warnings; |
|
| 4 |
+use utf8; |
|
| 5 |
+ |
|
| 6 |
+BEGIN {
|
|
| 7 |
+ eval { require DBD::SQLite; 1 }
|
|
| 8 |
+ or plan skip_all => 'DBD::SQLite required'; |
|
| 9 |
+ eval { DBD::SQLite->VERSION >= 1.25 }
|
|
| 10 |
+ or plan skip_all => 'DBD::SQLite >= 1.25 required'; |
|
| 11 |
+ |
|
| 12 |
+ plan 'no_plan'; |
|
| 13 |
+ use_ok('DBIx::Custom::SQLite');
|
|
| 14 |
+} |
|
| 15 |
+ |
|
| 16 |
+# Function for test name |
|
| 17 |
+my $test; |
|
| 18 |
+sub test {
|
|
| 19 |
+ $test = shift; |
|
| 20 |
+} |
|
| 21 |
+ |
|
| 22 |
+# Constant varialbes for test |
|
| 23 |
+my $CREATE_TABLE = {
|
|
| 24 |
+ 0 => 'create table table1 (key1 char(255), key2 char(255));', |
|
| 25 |
+ 1 => 'create table table1 (key1 char(255), key2 char(255), key3 char(255), key4 char(255), key5 char(255));', |
|
| 26 |
+ 2 => 'create table table2 (key1 char(255), key3 char(255));' |
|
| 27 |
+}; |
|
| 28 |
+ |
|
| 29 |
+ |
|
| 30 |
+# Variables for tests |
|
| 31 |
+my $dbi; |
|
| 32 |
+my $ret_val; |
|
| 33 |
+my $rows; |
|
| 34 |
+my $db_file; |
|
| 35 |
+ |
|
| 36 |
+test 'connect_memory'; |
|
| 37 |
+$dbi = DBIx::Custom::SQLite->new; |
|
| 38 |
+$dbi->connect_memory; |
|
| 39 |
+$ret_val = $dbi->do($CREATE_TABLE->{0});
|
|
| 40 |
+ok(defined $ret_val, $test); |
|
| 41 |
+$dbi->utf8_filter_on; |
|
| 42 |
+$dbi->insert('table1', {key1 => 'あ', key2 => 2});
|
|
| 43 |
+$rows = $dbi->select('table1', {key1 => 'あ'})->fetch_hash_all;
|
|
| 44 |
+is_deeply($rows, [{key1 => 'あ', key2 => 2}], "$test : select rows");
|
|
| 45 |
+ |
|
| 46 |
+test 'connect_memory error'; |
|
| 47 |
+eval{$dbi->connect_memory};
|
|
| 48 |
+like($@, qr/Already connected/, "$test : already connected"); |
|
| 49 |
+ |
|
| 50 |
+test 'reconnect_memory'; |
|
| 51 |
+$dbi = DBIx::Custom::SQLite->new; |
|
| 52 |
+$dbi->reconnect_memory; |
|
| 53 |
+$ret_val = $dbi->do($CREATE_TABLE->{0});
|
|
| 54 |
+ok(defined $ret_val, "$test : connect first"); |
|
| 55 |
+$dbi->reconnect_memory; |
|
| 56 |
+$ret_val = $dbi->do($CREATE_TABLE->{2});
|
|
| 57 |
+ok(defined $ret_val, "$test : connect first"); |
|
| 58 |
+ |
|
| 59 |
+test 'connect'; |
|
| 60 |
+$db_file = 't/test.db'; |
|
| 61 |
+unlink $db_file if -f $db_file; |
|
| 62 |
+$dbi = DBIx::Custom::SQLite->new(database => $db_file); |
|
| 63 |
+$dbi->connect; |
|
| 64 |
+ok(-f $db_file, "$test : database file"); |
|
| 65 |
+$ret_val = $dbi->do($CREATE_TABLE->{0});
|
|
| 66 |
+ok(defined $ret_val, "$test : database"); |
|
| 67 |
+$dbi->disconnect; |
|
| 68 |
+unlink $db_file if -f $db_file; |
|
| 69 |
+ |
| ... | ... |
@@ -0,0 +1,67 @@ |
| 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 |
+ eval { Time::Piece->VERSION >= 1.15 }
|
|
| 10 |
+ or plan skip_all => 'Time::Piece >= 1.15 requred'; |
|
| 11 |
+ |
|
| 12 |
+ plan 'no_plan'; |
|
| 13 |
+ use_ok('DBIx::Custom');
|
|
| 14 |
+} |
|
| 15 |
+ |
|
| 16 |
+# Function for test name |
|
| 17 |
+my $test; |
|
| 18 |
+sub test {
|
|
| 19 |
+ $test = shift; |
|
| 20 |
+} |
|
| 21 |
+ |
|
| 22 |
+# Varialbe for tests |
|
| 23 |
+ |
|
| 24 |
+my $format; |
|
| 25 |
+my $data; |
|
| 26 |
+my $timepiece; |
|
| 27 |
+my $dbi; |
|
| 28 |
+ |
|
| 29 |
+use DBIx::Custom::Basic; |
|
| 30 |
+ |
|
| 31 |
+ |
|
| 32 |
+test 'SQL99 format'; |
|
| 33 |
+$dbi = DBIx::Custom::Basic->new; |
|
| 34 |
+$data = '2009-01-02 03:04:05'; |
|
| 35 |
+$format = $dbi->formats->{'SQL99_datetime'};
|
|
| 36 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 37 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : datetime date");
|
|
| 38 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : datetime time");
|
|
| 39 |
+ |
|
| 40 |
+$data = '2009-01-02'; |
|
| 41 |
+$format = $dbi->formats->{'SQL99_date'};
|
|
| 42 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 43 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : date");
|
|
| 44 |
+ |
|
| 45 |
+$data = '03:04:05'; |
|
| 46 |
+$format = $dbi->formats->{'SQL99_time'};
|
|
| 47 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 48 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : time");
|
|
| 49 |
+ |
|
| 50 |
+ |
|
| 51 |
+test 'ISO-8601 format'; |
|
| 52 |
+$data = '2009-01-02T03:04:05'; |
|
| 53 |
+$format = $dbi->formats->{'ISO-8601_datetime'};
|
|
| 54 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 55 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : datetime date");
|
|
| 56 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : datetime time");
|
|
| 57 |
+ |
|
| 58 |
+$data = '2009-01-02'; |
|
| 59 |
+$format = $dbi->formats->{'ISO-8601_date'};
|
|
| 60 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 61 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : date");
|
|
| 62 |
+ |
|
| 63 |
+$data = '03:04:05'; |
|
| 64 |
+$format = $dbi->formats->{'ISO-8601_time'};
|
|
| 65 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 66 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : time");
|
|
| 67 |
+ |
| ... | ... |
@@ -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(); |
| ... | ... |
@@ -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(); |
| ... | ... |
@@ -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/ |
| ... | ... |
@@ -0,0 +1,15 @@ |
| 1 |
+DBIx-Custom |
|
| 2 |
+ |
|
| 3 |
+Custamizable DBI |
|
| 4 |
+ |
|
| 5 |
+INSTALLATION |
|
| 6 |
+ |
|
| 7 |
+cpan DBIx::Custom |
|
| 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 |
+ |
| ... | ... |
@@ -0,0 +1,1127 @@ |
| 1 |
+use 5.008001; |
|
| 2 |
+ |
|
| 3 |
+package DBIx::Custom; |
|
| 4 |
+use Object::Simple; |
|
| 5 |
+ |
|
| 6 |
+our $VERSION = '0.0501'; |
|
| 7 |
+ |
|
| 8 |
+use Carp 'croak'; |
|
| 9 |
+use DBI; |
|
| 10 |
+use DBIx::Custom::Query; |
|
| 11 |
+use DBIx::Custom::Result; |
|
| 12 |
+use DBIx::Custom::SQL::Template; |
|
| 13 |
+ |
|
| 14 |
+ |
|
| 15 |
+### Class-Object Accessors |
|
| 16 |
+sub user : ClassObjectAttr { initialize => {clone => 'scalar'} }
|
|
| 17 |
+sub password : ClassObjectAttr { initialize => {clone => 'scalar'} }
|
|
| 18 |
+sub data_source : ClassObjectAttr { initialize => {clone => 'scalar'} }
|
|
| 19 |
+sub dbi_options : ClassObjectAttr { initialize => {clone => 'hash',
|
|
| 20 |
+ default => sub { {} } } }
|
|
| 21 |
+sub database : ClassObjectAttr { initialize => {clone => 'scalar'} }
|
|
| 22 |
+ |
|
| 23 |
+sub bind_filter : ClassObjectAttr { initialize => {clone => 'scalar'} }
|
|
| 24 |
+sub fetch_filter : ClassObjectAttr { initialize => {clone => 'scalar'} }
|
|
| 25 |
+ |
|
| 26 |
+sub no_bind_filters : ClassObjectAttr { initialize => {clone => 'array'} }
|
|
| 27 |
+sub no_fetch_filters : ClassObjectAttr { initialize => {clone => 'array'} }
|
|
| 28 |
+ |
|
| 29 |
+sub filters : ClassObjectAttr {
|
|
| 30 |
+ type => 'hash', |
|
| 31 |
+ deref => 1, |
|
| 32 |
+ initialize => {
|
|
| 33 |
+ clone => 'hash', |
|
| 34 |
+ default => sub { {} }
|
|
| 35 |
+ } |
|
| 36 |
+} |
|
| 37 |
+ |
|
| 38 |
+sub formats : ClassObjectAttr {
|
|
| 39 |
+ type => 'hash', |
|
| 40 |
+ deref => 1, |
|
| 41 |
+ initialize => {
|
|
| 42 |
+ clone => 'hash', |
|
| 43 |
+ default => sub { {} }
|
|
| 44 |
+ } |
|
| 45 |
+} |
|
| 46 |
+ |
|
| 47 |
+sub result_class : ClassObjectAttr {
|
|
| 48 |
+ initialize => {
|
|
| 49 |
+ clone => 'scalar', |
|
| 50 |
+ default => 'DBIx::Custom::Result' |
|
| 51 |
+ } |
|
| 52 |
+} |
|
| 53 |
+ |
|
| 54 |
+sub sql_template : ClassObjectAttr {
|
|
| 55 |
+ initialize => {
|
|
| 56 |
+ clone => sub {$_[0] ? $_[0]->clone : undef},
|
|
| 57 |
+ default => sub {DBIx::Custom::SQL::Template->new}
|
|
| 58 |
+ } |
|
| 59 |
+} |
|
| 60 |
+ |
|
| 61 |
+### Object Accessor |
|
| 62 |
+sub dbh : Attr {}
|
|
| 63 |
+ |
|
| 64 |
+ |
|
| 65 |
+### Methods |
|
| 66 |
+ |
|
| 67 |
+# Add filter |
|
| 68 |
+sub add_filter {
|
|
| 69 |
+ my $invocant = shift; |
|
| 70 |
+ |
|
| 71 |
+ my %old_filters = $invocant->filters; |
|
| 72 |
+ my %new_filters = ref $_[0] eq 'HASH' ? %{$_[0]} : @_;
|
|
| 73 |
+ $invocant->filters(%old_filters, %new_filters); |
|
| 74 |
+ return $invocant; |
|
| 75 |
+} |
|
| 76 |
+ |
|
| 77 |
+# Add format |
|
| 78 |
+sub add_format{
|
|
| 79 |
+ my $invocant = shift; |
|
| 80 |
+ |
|
| 81 |
+ my %old_formats = $invocant->formats; |
|
| 82 |
+ my %new_formats = ref $_[0] eq 'HASH' ? %{$_[0]} : @_;
|
|
| 83 |
+ $invocant->formats(%old_formats, %new_formats); |
|
| 84 |
+ return $invocant; |
|
| 85 |
+} |
|
| 86 |
+ |
|
| 87 |
+# Auto commit |
|
| 88 |
+sub _auto_commit {
|
|
| 89 |
+ my $self = shift; |
|
| 90 |
+ |
|
| 91 |
+ croak("Not yet connect to database") unless $self->dbh;
|
|
| 92 |
+ |
|
| 93 |
+ if (@_) {
|
|
| 94 |
+ $self->dbh->{AutoCommit} = $_[0];
|
|
| 95 |
+ return $self; |
|
| 96 |
+ } |
|
| 97 |
+ return $self->dbh->{AutoCommit};
|
|
| 98 |
+} |
|
| 99 |
+ |
|
| 100 |
+# Connect |
|
| 101 |
+sub connect {
|
|
| 102 |
+ my $self = shift; |
|
| 103 |
+ my $data_source = $self->data_source; |
|
| 104 |
+ my $user = $self->user; |
|
| 105 |
+ my $password = $self->password; |
|
| 106 |
+ my $dbi_options = $self->dbi_options; |
|
| 107 |
+ |
|
| 108 |
+ my $dbh = eval{DBI->connect(
|
|
| 109 |
+ $data_source, |
|
| 110 |
+ $user, |
|
| 111 |
+ $password, |
|
| 112 |
+ {
|
|
| 113 |
+ RaiseError => 1, |
|
| 114 |
+ PrintError => 0, |
|
| 115 |
+ AutoCommit => 1, |
|
| 116 |
+ %{$dbi_options || {} }
|
|
| 117 |
+ } |
|
| 118 |
+ )}; |
|
| 119 |
+ |
|
| 120 |
+ croak $@ if $@; |
|
| 121 |
+ |
|
| 122 |
+ $self->dbh($dbh); |
|
| 123 |
+ return $self; |
|
| 124 |
+} |
|
| 125 |
+ |
|
| 126 |
+# DESTROY |
|
| 127 |
+sub DESTROY {
|
|
| 128 |
+ my $self = shift; |
|
| 129 |
+ $self->disconnect if $self->connected; |
|
| 130 |
+} |
|
| 131 |
+ |
|
| 132 |
+# Is connected? |
|
| 133 |
+sub connected {
|
|
| 134 |
+ my $self = shift; |
|
| 135 |
+ return ref $self->{dbh} eq 'DBI::db';
|
|
| 136 |
+} |
|
| 137 |
+ |
|
| 138 |
+# Disconnect |
|
| 139 |
+sub disconnect {
|
|
| 140 |
+ my $self = shift; |
|
| 141 |
+ if ($self->connected) {
|
|
| 142 |
+ $self->dbh->disconnect; |
|
| 143 |
+ delete $self->{dbh};
|
|
| 144 |
+ } |
|
| 145 |
+} |
|
| 146 |
+ |
|
| 147 |
+# Reconnect |
|
| 148 |
+sub reconnect {
|
|
| 149 |
+ my $self = shift; |
|
| 150 |
+ $self->disconnect if $self->connected; |
|
| 151 |
+ $self->connect; |
|
| 152 |
+} |
|
| 153 |
+ |
|
| 154 |
+# Prepare statement handle |
|
| 155 |
+sub prepare {
|
|
| 156 |
+ my ($self, $sql) = @_; |
|
| 157 |
+ |
|
| 158 |
+ # Connect if not |
|
| 159 |
+ $self->connect unless $self->connected; |
|
| 160 |
+ |
|
| 161 |
+ # Prepare |
|
| 162 |
+ my $sth = eval{$self->dbh->prepare($sql)};
|
|
| 163 |
+ |
|
| 164 |
+ # Error |
|
| 165 |
+ croak("$@<Your SQL>\n$sql") if $@;
|
|
| 166 |
+ |
|
| 167 |
+ return $sth; |
|
| 168 |
+} |
|
| 169 |
+ |
|
| 170 |
+# Execute SQL directly |
|
| 171 |
+sub do{
|
|
| 172 |
+ my ($self, $sql, @bind_values) = @_; |
|
| 173 |
+ |
|
| 174 |
+ # Connect if not |
|
| 175 |
+ $self->connect unless $self->connected; |
|
| 176 |
+ |
|
| 177 |
+ # Do |
|
| 178 |
+ my $ret_val = eval{$self->dbh->do($sql, @bind_values)};
|
|
| 179 |
+ |
|
| 180 |
+ # Error |
|
| 181 |
+ if ($@) {
|
|
| 182 |
+ my $error = $@; |
|
| 183 |
+ require Data::Dumper; |
|
| 184 |
+ |
|
| 185 |
+ my $bind_value_dump |
|
| 186 |
+ = Data::Dumper->Dump([\@bind_values], ['*bind_valuds']); |
|
| 187 |
+ |
|
| 188 |
+ croak("$error<Your SQL>\n$sql\n<Your bind values>\n$bind_value_dump\n");
|
|
| 189 |
+ } |
|
| 190 |
+} |
|
| 191 |
+ |
|
| 192 |
+# Create query |
|
| 193 |
+sub create_query {
|
|
| 194 |
+ my ($self, $template) = @_; |
|
| 195 |
+ my $class = ref $self; |
|
| 196 |
+ |
|
| 197 |
+ # Create query from SQL template |
|
| 198 |
+ my $sql_template = $self->sql_template; |
|
| 199 |
+ |
|
| 200 |
+ # Try to get cached query |
|
| 201 |
+ my $query = $class->_query_caches->{$template};
|
|
| 202 |
+ |
|
| 203 |
+ # Create query |
|
| 204 |
+ unless ($query) {
|
|
| 205 |
+ $query = eval{$sql_template->create_query($template)};
|
|
| 206 |
+ croak($@) if $@; |
|
| 207 |
+ |
|
| 208 |
+ $query = DBIx::Custom::Query->new($query); |
|
| 209 |
+ |
|
| 210 |
+ $class->_add_query_cache($template, $query); |
|
| 211 |
+ } |
|
| 212 |
+ |
|
| 213 |
+ # Connect if not |
|
| 214 |
+ $self->connect unless $self->connected; |
|
| 215 |
+ |
|
| 216 |
+ # Prepare statement handle |
|
| 217 |
+ my $sth = $self->prepare($query->{sql});
|
|
| 218 |
+ |
|
| 219 |
+ # Set statement handle |
|
| 220 |
+ $query->sth($sth); |
|
| 221 |
+ |
|
| 222 |
+ # Set bind filter |
|
| 223 |
+ $query->bind_filter($self->bind_filter); |
|
| 224 |
+ |
|
| 225 |
+ # Set no filter keys when binding |
|
| 226 |
+ $query->no_bind_filters($self->no_bind_filters); |
|
| 227 |
+ |
|
| 228 |
+ # Set fetch filter |
|
| 229 |
+ $query->fetch_filter($self->fetch_filter); |
|
| 230 |
+ |
|
| 231 |
+ # Set no filter keys when fetching |
|
| 232 |
+ $query->no_fetch_filters($self->no_fetch_filters); |
|
| 233 |
+ |
|
| 234 |
+ return $query; |
|
| 235 |
+} |
|
| 236 |
+ |
|
| 237 |
+# Execute query |
|
| 238 |
+sub execute {
|
|
| 239 |
+ my ($self, $query, $params) = @_; |
|
| 240 |
+ $params ||= {};
|
|
| 241 |
+ |
|
| 242 |
+ # First argument is SQL template |
|
| 243 |
+ if (!ref $query) {
|
|
| 244 |
+ my $template = $query; |
|
| 245 |
+ $query = $self->create_query($template); |
|
| 246 |
+ my $query_edit_cb = $_[3]; |
|
| 247 |
+ $query_edit_cb->($query) if ref $query_edit_cb eq 'CODE'; |
|
| 248 |
+ } |
|
| 249 |
+ |
|
| 250 |
+ # Create bind value |
|
| 251 |
+ my $bind_values = $self->_build_bind_values($query, $params); |
|
| 252 |
+ |
|
| 253 |
+ # Execute |
|
| 254 |
+ my $sth = $query->sth; |
|
| 255 |
+ my $ret_val = eval{$sth->execute(@$bind_values)};
|
|
| 256 |
+ |
|
| 257 |
+ # Execute error |
|
| 258 |
+ if (my $execute_error = $@) {
|
|
| 259 |
+ require Data::Dumper; |
|
| 260 |
+ my $sql = $query->{sql} || '';
|
|
| 261 |
+ my $key_infos_dump = Data::Dumper->Dump([$query->key_infos], ['*key_infos']); |
|
| 262 |
+ my $params_dump = Data::Dumper->Dump([$params], ['*params']); |
|
| 263 |
+ |
|
| 264 |
+ croak("$execute_error" .
|
|
| 265 |
+ "<Your SQL>\n$sql\n" . |
|
| 266 |
+ "<Your parameters>\n$params_dump"); |
|
| 267 |
+ } |
|
| 268 |
+ |
|
| 269 |
+ # Return resultset if select statement is executed |
|
| 270 |
+ if ($sth->{NUM_OF_FIELDS}) {
|
|
| 271 |
+ |
|
| 272 |
+ # Get result class |
|
| 273 |
+ my $result_class = $self->result_class; |
|
| 274 |
+ |
|
| 275 |
+ # Create result |
|
| 276 |
+ my $result = $result_class->new({
|
|
| 277 |
+ sth => $sth, |
|
| 278 |
+ fetch_filter => $query->fetch_filter, |
|
| 279 |
+ no_fetch_filters => $query->no_fetch_filters |
|
| 280 |
+ }); |
|
| 281 |
+ return $result; |
|
| 282 |
+ } |
|
| 283 |
+ return $ret_val; |
|
| 284 |
+} |
|
| 285 |
+ |
|
| 286 |
+# Build binding values |
|
| 287 |
+sub _build_bind_values {
|
|
| 288 |
+ my ($self, $query, $params) = @_; |
|
| 289 |
+ my $key_infos = $query->key_infos; |
|
| 290 |
+ my $bind_filter = $query->bind_filter; |
|
| 291 |
+ my $no_bind_filters_map = $query->_no_bind_filters_map || {};
|
|
| 292 |
+ |
|
| 293 |
+ # binding values |
|
| 294 |
+ my @bind_values; |
|
| 295 |
+ |
|
| 296 |
+ # Create bind values |
|
| 297 |
+ KEY_INFOS : |
|
| 298 |
+ foreach my $key_info (@$key_infos) {
|
|
| 299 |
+ # Set variable |
|
| 300 |
+ my $access_keys = $key_info->{access_keys};
|
|
| 301 |
+ my $original_key = $key_info->{original_key} || '';
|
|
| 302 |
+ my $table = $key_info->{table} || '';
|
|
| 303 |
+ my $column = $key_info->{column} || '';
|
|
| 304 |
+ |
|
| 305 |
+ # Key is found? |
|
| 306 |
+ my $found; |
|
| 307 |
+ |
|
| 308 |
+ # Build bind values |
|
| 309 |
+ ACCESS_KEYS : |
|
| 310 |
+ foreach my $access_key (@$access_keys) {
|
|
| 311 |
+ # Root parameter |
|
| 312 |
+ my $root_params = $params; |
|
| 313 |
+ |
|
| 314 |
+ # Search corresponding value |
|
| 315 |
+ for (my $i = 0; $i < @$access_key; $i++) {
|
|
| 316 |
+ # Current key |
|
| 317 |
+ my $current_key = $access_key->[$i]; |
|
| 318 |
+ |
|
| 319 |
+ # Last key |
|
| 320 |
+ if ($i == @$access_key - 1) {
|
|
| 321 |
+ # Key is array reference |
|
| 322 |
+ if (ref $current_key eq 'ARRAY') {
|
|
| 323 |
+ # Filtering |
|
| 324 |
+ if ($bind_filter && |
|
| 325 |
+ !$no_bind_filters_map->{$original_key})
|
|
| 326 |
+ {
|
|
| 327 |
+ push @bind_values, |
|
| 328 |
+ $bind_filter->($root_params->[$current_key->[0]], |
|
| 329 |
+ $original_key, |
|
| 330 |
+ $table, $column); |
|
| 331 |
+ } |
|
| 332 |
+ # Not filtering |
|
| 333 |
+ else {
|
|
| 334 |
+ push @bind_values, |
|
| 335 |
+ scalar $root_params->[$current_key->[0]]; |
|
| 336 |
+ } |
|
| 337 |
+ } |
|
| 338 |
+ # Key is string |
|
| 339 |
+ else {
|
|
| 340 |
+ # Key is not found |
|
| 341 |
+ next ACCESS_KEYS |
|
| 342 |
+ unless exists $root_params->{$current_key};
|
|
| 343 |
+ |
|
| 344 |
+ # Filtering |
|
| 345 |
+ if ($bind_filter && |
|
| 346 |
+ !$no_bind_filters_map->{$original_key})
|
|
| 347 |
+ {
|
|
| 348 |
+ push @bind_values, |
|
| 349 |
+ $bind_filter->($root_params->{$current_key},
|
|
| 350 |
+ $original_key, |
|
| 351 |
+ $table, $column); |
|
| 352 |
+ } |
|
| 353 |
+ # Not filtering |
|
| 354 |
+ else {
|
|
| 355 |
+ push @bind_values, |
|
| 356 |
+ scalar $root_params->{$current_key};
|
|
| 357 |
+ } |
|
| 358 |
+ } |
|
| 359 |
+ |
|
| 360 |
+ # Key is found |
|
| 361 |
+ $found = 1; |
|
| 362 |
+ next KEY_INFOS; |
|
| 363 |
+ } |
|
| 364 |
+ # First or middle key |
|
| 365 |
+ else {
|
|
| 366 |
+ # Key is array reference |
|
| 367 |
+ if (ref $current_key eq 'ARRAY') {
|
|
| 368 |
+ # Go next key |
|
| 369 |
+ $root_params = $root_params->[$current_key->[0]]; |
|
| 370 |
+ } |
|
| 371 |
+ # Key is string |
|
| 372 |
+ else {
|
|
| 373 |
+ # Not found |
|
| 374 |
+ next ACCESS_KEYS |
|
| 375 |
+ unless exists $root_params->{$current_key};
|
|
| 376 |
+ |
|
| 377 |
+ # Go next key |
|
| 378 |
+ $root_params = $root_params->{$current_key};
|
|
| 379 |
+ } |
|
| 380 |
+ } |
|
| 381 |
+ } |
|
| 382 |
+ } |
|
| 383 |
+ |
|
| 384 |
+ # Key is not found |
|
| 385 |
+ unless ($found) {
|
|
| 386 |
+ require Data::Dumper; |
|
| 387 |
+ my $key_info_dump = Data::Dumper->Dump([$key_info], ['*key_info']); |
|
| 388 |
+ my $params_dump = Data::Dumper->Dump([$params], ['*params']); |
|
| 389 |
+ croak("Corresponding key is not found in your parameters\n" .
|
|
| 390 |
+ "<Key information>\n$key_info_dump\n\n" . |
|
| 391 |
+ "<Your parameters>\n$params_dump\n"); |
|
| 392 |
+ } |
|
| 393 |
+ } |
|
| 394 |
+ return \@bind_values; |
|
| 395 |
+} |
|
| 396 |
+ |
|
| 397 |
+# Run transaction |
|
| 398 |
+sub run_transaction {
|
|
| 399 |
+ my ($self, $transaction) = @_; |
|
| 400 |
+ |
|
| 401 |
+ # Check auto commit |
|
| 402 |
+ croak("AutoCommit must be true before transaction start")
|
|
| 403 |
+ unless $self->_auto_commit; |
|
| 404 |
+ |
|
| 405 |
+ # Auto commit off |
|
| 406 |
+ $self->_auto_commit(0); |
|
| 407 |
+ |
|
| 408 |
+ # Run transaction |
|
| 409 |
+ eval {$transaction->()};
|
|
| 410 |
+ |
|
| 411 |
+ # Tranzaction error |
|
| 412 |
+ my $transaction_error = $@; |
|
| 413 |
+ |
|
| 414 |
+ # Tranzaction is failed. |
|
| 415 |
+ if ($transaction_error) {
|
|
| 416 |
+ # Rollback |
|
| 417 |
+ eval{$self->dbh->rollback};
|
|
| 418 |
+ |
|
| 419 |
+ # Rollback error |
|
| 420 |
+ my $rollback_error = $@; |
|
| 421 |
+ |
|
| 422 |
+ # Auto commit on |
|
| 423 |
+ $self->_auto_commit(1); |
|
| 424 |
+ |
|
| 425 |
+ if ($rollback_error) {
|
|
| 426 |
+ # Rollback is failed |
|
| 427 |
+ croak("${transaction_error}Rollback is failed : $rollback_error");
|
|
| 428 |
+ } |
|
| 429 |
+ else {
|
|
| 430 |
+ # Rollback is success |
|
| 431 |
+ croak("${transaction_error}Rollback is success");
|
|
| 432 |
+ } |
|
| 433 |
+ } |
|
| 434 |
+ # Tranzaction is success |
|
| 435 |
+ else {
|
|
| 436 |
+ # Commit |
|
| 437 |
+ eval{$self->dbh->commit};
|
|
| 438 |
+ my $commit_error = $@; |
|
| 439 |
+ |
|
| 440 |
+ # Auto commit on |
|
| 441 |
+ $self->_auto_commit(1); |
|
| 442 |
+ |
|
| 443 |
+ # Commit is failed |
|
| 444 |
+ croak($commit_error) if $commit_error; |
|
| 445 |
+ } |
|
| 446 |
+} |
|
| 447 |
+ |
|
| 448 |
+# Get last insert id |
|
| 449 |
+sub last_insert_id {
|
|
| 450 |
+ my $self = shift; |
|
| 451 |
+ |
|
| 452 |
+ # Not connected |
|
| 453 |
+ croak("Not yet connect to database")
|
|
| 454 |
+ unless $self->connected; |
|
| 455 |
+ |
|
| 456 |
+ return $self->dbh->last_insert_id(@_); |
|
| 457 |
+} |
|
| 458 |
+ |
|
| 459 |
+# Insert |
|
| 460 |
+sub insert {
|
|
| 461 |
+ my ($self, $table, $insert_params, $query_edit_cb) = @_; |
|
| 462 |
+ $table ||= ''; |
|
| 463 |
+ $insert_params ||= {};
|
|
| 464 |
+ |
|
| 465 |
+ # Insert keys |
|
| 466 |
+ my @insert_keys = keys %$insert_params; |
|
| 467 |
+ |
|
| 468 |
+ # Not exists insert keys |
|
| 469 |
+ croak("Key-value pairs for insert must be specified to 'insert' second argument")
|
|
| 470 |
+ unless @insert_keys; |
|
| 471 |
+ |
|
| 472 |
+ # Templte for insert |
|
| 473 |
+ my $template = "insert into $table {insert " . join(' ', @insert_keys) . '}';
|
|
| 474 |
+ |
|
| 475 |
+ # Create query |
|
| 476 |
+ my $query = $self->create_query($template); |
|
| 477 |
+ |
|
| 478 |
+ # Query edit callback must be code reference |
|
| 479 |
+ croak("Query edit callback must be code reference")
|
|
| 480 |
+ if $query_edit_cb && ref $query_edit_cb ne 'CODE'; |
|
| 481 |
+ |
|
| 482 |
+ # Query edit if need |
|
| 483 |
+ $query_edit_cb->($query) if $query_edit_cb; |
|
| 484 |
+ |
|
| 485 |
+ # Execute query |
|
| 486 |
+ my $ret_val = $self->execute($query, $insert_params); |
|
| 487 |
+ |
|
| 488 |
+ return $ret_val; |
|
| 489 |
+} |
|
| 490 |
+ |
|
| 491 |
+# Update |
|
| 492 |
+sub update {
|
|
| 493 |
+ my ($self, $table, $update_params, |
|
| 494 |
+ $where_params, $query_edit_cb, $options) = @_; |
|
| 495 |
+ |
|
| 496 |
+ $table ||= ''; |
|
| 497 |
+ $update_params ||= {};
|
|
| 498 |
+ $where_params ||= {};
|
|
| 499 |
+ |
|
| 500 |
+ # Update keys |
|
| 501 |
+ my @update_keys = keys %$update_params; |
|
| 502 |
+ |
|
| 503 |
+ # Not exists update kyes |
|
| 504 |
+ croak("Key-value pairs for update must be specified to 'update' second argument")
|
|
| 505 |
+ unless @update_keys; |
|
| 506 |
+ |
|
| 507 |
+ # Where keys |
|
| 508 |
+ my @where_keys = keys %$where_params; |
|
| 509 |
+ |
|
| 510 |
+ # Not exists where keys |
|
| 511 |
+ croak("Key-value pairs for where clause must be specified to 'update' third argument")
|
|
| 512 |
+ if !@where_keys && !$options->{allow_update_all};
|
|
| 513 |
+ |
|
| 514 |
+ # Update clause |
|
| 515 |
+ my $update_clause = '{update ' . join(' ', @update_keys) . '}';
|
|
| 516 |
+ |
|
| 517 |
+ # Where clause |
|
| 518 |
+ my $where_clause = ''; |
|
| 519 |
+ if (@where_keys) {
|
|
| 520 |
+ $where_clause = 'where '; |
|
| 521 |
+ foreach my $where_key (@where_keys) {
|
|
| 522 |
+ $where_clause .= "{= $where_key} and ";
|
|
| 523 |
+ } |
|
| 524 |
+ $where_clause =~ s/ and $//; |
|
| 525 |
+ } |
|
| 526 |
+ |
|
| 527 |
+ # Template for update |
|
| 528 |
+ my $template = "update $table $update_clause $where_clause"; |
|
| 529 |
+ |
|
| 530 |
+ # Create query |
|
| 531 |
+ my $query = $self->create_query($template); |
|
| 532 |
+ |
|
| 533 |
+ # Query edit callback must be code reference |
|
| 534 |
+ croak("Query edit callback must be code reference")
|
|
| 535 |
+ if $query_edit_cb && ref $query_edit_cb ne 'CODE'; |
|
| 536 |
+ |
|
| 537 |
+ # Query edit if need |
|
| 538 |
+ $query_edit_cb->($query) if $query_edit_cb; |
|
| 539 |
+ |
|
| 540 |
+ # Rearrange parammeters |
|
| 541 |
+ my $params = {'#update' => $update_params, %$where_params};
|
|
| 542 |
+ |
|
| 543 |
+ # Execute query |
|
| 544 |
+ my $ret_val = $self->execute($query, $params); |
|
| 545 |
+ |
|
| 546 |
+ return $ret_val; |
|
| 547 |
+} |
|
| 548 |
+ |
|
| 549 |
+# Update all rows |
|
| 550 |
+sub update_all {
|
|
| 551 |
+ my ($self, $table, $update_params, $query_edit_cb) = @_; |
|
| 552 |
+ |
|
| 553 |
+ return $self->update($table, $update_params, {}, $query_edit_cb,
|
|
| 554 |
+ {allow_update_all => 1});
|
|
| 555 |
+} |
|
| 556 |
+ |
|
| 557 |
+# Delete |
|
| 558 |
+sub delete {
|
|
| 559 |
+ my ($self, $table, $where_params, $query_edit_cb, $options) = @_; |
|
| 560 |
+ $table ||= ''; |
|
| 561 |
+ $where_params ||= {};
|
|
| 562 |
+ |
|
| 563 |
+ # Where keys |
|
| 564 |
+ my @where_keys = keys %$where_params; |
|
| 565 |
+ |
|
| 566 |
+ # Not exists where keys |
|
| 567 |
+ croak("Key-value pairs for where clause must be specified to 'delete' second argument")
|
|
| 568 |
+ if !@where_keys && !$options->{allow_delete_all};
|
|
| 569 |
+ |
|
| 570 |
+ # Where clause |
|
| 571 |
+ my $where_clause = ''; |
|
| 572 |
+ if (@where_keys) {
|
|
| 573 |
+ $where_clause = 'where '; |
|
| 574 |
+ foreach my $where_key (@where_keys) {
|
|
| 575 |
+ $where_clause .= "{= $where_key} and ";
|
|
| 576 |
+ } |
|
| 577 |
+ $where_clause =~ s/ and $//; |
|
| 578 |
+ } |
|
| 579 |
+ |
|
| 580 |
+ # Template for delete |
|
| 581 |
+ my $template = "delete from $table $where_clause"; |
|
| 582 |
+ |
|
| 583 |
+ # Create query |
|
| 584 |
+ my $query = $self->create_query($template); |
|
| 585 |
+ |
|
| 586 |
+ # Query edit callback must be code reference |
|
| 587 |
+ croak("Query edit callback must be code reference")
|
|
| 588 |
+ if $query_edit_cb && ref $query_edit_cb ne 'CODE'; |
|
| 589 |
+ |
|
| 590 |
+ # Query edit if need |
|
| 591 |
+ $query_edit_cb->($query) if $query_edit_cb; |
|
| 592 |
+ |
|
| 593 |
+ # Execute query |
|
| 594 |
+ my $ret_val = $self->execute($query, $where_params); |
|
| 595 |
+ |
|
| 596 |
+ return $ret_val; |
|
| 597 |
+} |
|
| 598 |
+ |
|
| 599 |
+# Delete all rows |
|
| 600 |
+sub delete_all {
|
|
| 601 |
+ my ($self, $table) = @_; |
|
| 602 |
+ return $self->delete($table, {}, undef, {allow_delete_all => 1});
|
|
| 603 |
+} |
|
| 604 |
+ |
|
| 605 |
+sub _select_usage { return << 'EOS' }
|
|
| 606 |
+Your select arguments is wrong. |
|
| 607 |
+select usage: |
|
| 608 |
+$dbi->select( |
|
| 609 |
+ $table, # must be string or array ref |
|
| 610 |
+ [@$columns], # must be array reference. this is optional |
|
| 611 |
+ {%$where_params}, # must be hash reference. this is optional
|
|
| 612 |
+ $append_statement, # must be string. this is optional |
|
| 613 |
+ $query_edit_callback # must be code reference. this is optional |
|
| 614 |
+); |
|
| 615 |
+EOS |
|
| 616 |
+ |
|
| 617 |
+sub select {
|
|
| 618 |
+ my $self = shift; |
|
| 619 |
+ |
|
| 620 |
+ # Check argument |
|
| 621 |
+ croak($self->_select_usage) unless @_; |
|
| 622 |
+ |
|
| 623 |
+ # Arguments |
|
| 624 |
+ my $tables = shift || ''; |
|
| 625 |
+ $tables = [$tables] unless ref $tables; |
|
| 626 |
+ |
|
| 627 |
+ my $columns = ref $_[0] eq 'ARRAY' ? shift : []; |
|
| 628 |
+ my $where_params = ref $_[0] eq 'HASH' ? shift : {};
|
|
| 629 |
+ my $append_statement = $_[0] && !ref $_[0] ? shift : ''; |
|
| 630 |
+ my $query_edit_cb = shift if ref $_[0] eq 'CODE'; |
|
| 631 |
+ |
|
| 632 |
+ # Check rest argument |
|
| 633 |
+ croak($self->_select_usage) if @_; |
|
| 634 |
+ |
|
| 635 |
+ # SQL template for select statement |
|
| 636 |
+ my $template = 'select '; |
|
| 637 |
+ |
|
| 638 |
+ # Join column clause |
|
| 639 |
+ if (@$columns) {
|
|
| 640 |
+ foreach my $column (@$columns) {
|
|
| 641 |
+ $template .= "$column, "; |
|
| 642 |
+ } |
|
| 643 |
+ $template =~ s/, $/ /; |
|
| 644 |
+ } |
|
| 645 |
+ else {
|
|
| 646 |
+ $template .= '* '; |
|
| 647 |
+ } |
|
| 648 |
+ |
|
| 649 |
+ # Join table |
|
| 650 |
+ $template .= 'from '; |
|
| 651 |
+ foreach my $table (@$tables) {
|
|
| 652 |
+ $template .= "$table, "; |
|
| 653 |
+ } |
|
| 654 |
+ $template =~ s/, $/ /; |
|
| 655 |
+ |
|
| 656 |
+ # Where clause keys |
|
| 657 |
+ my @where_keys = keys %$where_params; |
|
| 658 |
+ |
|
| 659 |
+ # Join where clause |
|
| 660 |
+ if (@where_keys) {
|
|
| 661 |
+ $template .= 'where '; |
|
| 662 |
+ foreach my $where_key (@where_keys) {
|
|
| 663 |
+ $template .= "{= $where_key} and ";
|
|
| 664 |
+ } |
|
| 665 |
+ } |
|
| 666 |
+ $template =~ s/ and $//; |
|
| 667 |
+ |
|
| 668 |
+ # Append something to last of statement |
|
| 669 |
+ if ($append_statement =~ s/^where //) {
|
|
| 670 |
+ if (@where_keys) {
|
|
| 671 |
+ $template .= " and $append_statement"; |
|
| 672 |
+ } |
|
| 673 |
+ else {
|
|
| 674 |
+ $template .= " where $append_statement"; |
|
| 675 |
+ } |
|
| 676 |
+ } |
|
| 677 |
+ else {
|
|
| 678 |
+ $template .= " $append_statement"; |
|
| 679 |
+ } |
|
| 680 |
+ |
|
| 681 |
+ # Create query |
|
| 682 |
+ my $query = $self->create_query($template); |
|
| 683 |
+ |
|
| 684 |
+ # Query edit |
|
| 685 |
+ $query_edit_cb->($query) if $query_edit_cb; |
|
| 686 |
+ |
|
| 687 |
+ # Execute query |
|
| 688 |
+ my $result = $self->execute($query, $where_params); |
|
| 689 |
+ |
|
| 690 |
+ return $result; |
|
| 691 |
+} |
|
| 692 |
+ |
|
| 693 |
+sub _query_caches : ClassAttr { type => 'hash',
|
|
| 694 |
+ auto_build => sub {shift->_query_caches({}) } }
|
|
| 695 |
+ |
|
| 696 |
+sub _query_cache_keys : ClassAttr { type => 'array',
|
|
| 697 |
+ auto_build => sub {shift->_query_cache_keys([])} }
|
|
| 698 |
+ |
|
| 699 |
+sub query_cache_max : ClassAttr { auto_build => sub {shift->query_cache_max(50)} }
|
|
| 700 |
+ |
|
| 701 |
+# Add query cahce |
|
| 702 |
+sub _add_query_cache {
|
|
| 703 |
+ my ($class, $template, $query) = @_; |
|
| 704 |
+ my $query_cache_keys = $class->_query_cache_keys; |
|
| 705 |
+ my $query_caches = $class->_query_caches; |
|
| 706 |
+ |
|
| 707 |
+ return $class if $query_caches->{$template};
|
|
| 708 |
+ |
|
| 709 |
+ $query_caches->{$template} = $query;
|
|
| 710 |
+ push @$query_cache_keys, $template; |
|
| 711 |
+ |
|
| 712 |
+ my $overflow = @$query_cache_keys - $class->query_cache_max; |
|
| 713 |
+ |
|
| 714 |
+ for (my $i = 0; $i < $overflow; $i++) {
|
|
| 715 |
+ my $template = shift @$query_cache_keys; |
|
| 716 |
+ delete $query_caches->{$template};
|
|
| 717 |
+ } |
|
| 718 |
+ |
|
| 719 |
+ return $class; |
|
| 720 |
+} |
|
| 721 |
+ |
|
| 722 |
+# Both bind_filter and fetch_filter off |
|
| 723 |
+sub filter_off {
|
|
| 724 |
+ my $self = shift; |
|
| 725 |
+ |
|
| 726 |
+ # filter off |
|
| 727 |
+ $self->bind_filter(undef); |
|
| 728 |
+ $self->fetch_filter(undef); |
|
| 729 |
+ |
|
| 730 |
+ return $self; |
|
| 731 |
+} |
|
| 732 |
+ |
|
| 733 |
+Object::Simple->build_class; |
|
| 734 |
+ |
|
| 735 |
+=head1 NAME |
|
| 736 |
+ |
|
| 737 |
+DBIx::Custom - Customizable simple DBI |
|
| 738 |
+ |
|
| 739 |
+=head1 VERSION |
|
| 740 |
+ |
|
| 741 |
+Version 0.0501 |
|
| 742 |
+ |
|
| 743 |
+=head1 CAUTION |
|
| 744 |
+ |
|
| 745 |
+This module is now experimental stage. |
|
| 746 |
+ |
|
| 747 |
+I want you to try this module |
|
| 748 |
+because I want this module stable, and not to damage your DB data by this module bug. |
|
| 749 |
+ |
|
| 750 |
+Please tell me bug if you find |
|
| 751 |
+ |
|
| 752 |
+=head1 SYNOPSIS |
|
| 753 |
+ |
|
| 754 |
+ my $dbi = DBIx::Custom->new; |
|
| 755 |
+ |
|
| 756 |
+ my $query = $dbi->create_query($template); |
|
| 757 |
+ $dbi->execute($query); |
|
| 758 |
+ |
|
| 759 |
+=head1 CLASS-OBJECT ACCESSORS |
|
| 760 |
+ |
|
| 761 |
+=head2 user |
|
| 762 |
+ |
|
| 763 |
+ # Set and get database user name |
|
| 764 |
+ $self = $dbi->user($user); |
|
| 765 |
+ $user = $dbi->user; |
|
| 766 |
+ |
|
| 767 |
+ # Sample |
|
| 768 |
+ $dbi->user('taro');
|
|
| 769 |
+ |
|
| 770 |
+=head2 password |
|
| 771 |
+ |
|
| 772 |
+ # Set and get database password |
|
| 773 |
+ $self = $dbi->password($password); |
|
| 774 |
+ $password = $dbi->password; |
|
| 775 |
+ |
|
| 776 |
+ # Sample |
|
| 777 |
+ $dbi->password('lkj&le`@s');
|
|
| 778 |
+ |
|
| 779 |
+=head2 data_source |
|
| 780 |
+ |
|
| 781 |
+ # Set and get database data source |
|
| 782 |
+ $self = $dbi->data_source($data_soruce); |
|
| 783 |
+ $data_source = $dbi->data_source; |
|
| 784 |
+ |
|
| 785 |
+ # Sample(SQLite) |
|
| 786 |
+ $dbi->data_source(dbi:SQLite:dbname=$database); |
|
| 787 |
+ |
|
| 788 |
+ # Sample(MySQL); |
|
| 789 |
+ $dbi->data_source("dbi:mysql:dbname=$database");
|
|
| 790 |
+ |
|
| 791 |
+ # Sample(PostgreSQL) |
|
| 792 |
+ $dbi->data_source("dbi:Pg:dbname=$database");
|
|
| 793 |
+ |
|
| 794 |
+=head2 database |
|
| 795 |
+ |
|
| 796 |
+ # Set and get database name |
|
| 797 |
+ $self = $dbi->database($database); |
|
| 798 |
+ $database = $dbi->database; |
|
| 799 |
+ |
|
| 800 |
+This method will be used in subclass connect method. |
|
| 801 |
+ |
|
| 802 |
+=head2 dbi_options |
|
| 803 |
+ |
|
| 804 |
+ # Set and get DBI option |
|
| 805 |
+ $self = $dbi->dbi_options({$options => $value, ...});
|
|
| 806 |
+ $dbi_options = $dbi->dbi_options; |
|
| 807 |
+ |
|
| 808 |
+ # Sample |
|
| 809 |
+ $dbi->dbi_options({PrintError => 0, RaiseError => 1});
|
|
| 810 |
+ |
|
| 811 |
+dbi_options is used when you connect database by using connect. |
|
| 812 |
+ |
|
| 813 |
+=head2 prepare |
|
| 814 |
+ |
|
| 815 |
+ $sth = $dbi->prepare($sql); |
|
| 816 |
+ |
|
| 817 |
+This method is same as DBI::prepare |
|
| 818 |
+ |
|
| 819 |
+=head2 do |
|
| 820 |
+ |
|
| 821 |
+ $dbi->do($sql, @bind_values); |
|
| 822 |
+ |
|
| 823 |
+This method is same as DBI::do |
|
| 824 |
+ |
|
| 825 |
+=head2 sql_template |
|
| 826 |
+ |
|
| 827 |
+ # Set and get SQL::Template object |
|
| 828 |
+ $self = $dbi->sql_template($sql_template); |
|
| 829 |
+ $sql_template = $dbi->sql_template; |
|
| 830 |
+ |
|
| 831 |
+ # Sample |
|
| 832 |
+ $dbi->sql_template(DBI::Cutom::SQL::Template->new); |
|
| 833 |
+ |
|
| 834 |
+=head2 filters |
|
| 835 |
+ |
|
| 836 |
+ # Set and get filters |
|
| 837 |
+ $self = $dbi->filters($filters); |
|
| 838 |
+ $filters = $dbi->filters; |
|
| 839 |
+ |
|
| 840 |
+=head2 formats |
|
| 841 |
+ |
|
| 842 |
+ # Set and get formats |
|
| 843 |
+ $self = $dbi->formats($formats); |
|
| 844 |
+ $formats = $dbi->formats; |
|
| 845 |
+ |
|
| 846 |
+=head2 bind_filter |
|
| 847 |
+ |
|
| 848 |
+ # Set and get binding filter |
|
| 849 |
+ $self = $dbi->bind_filter($bind_filter); |
|
| 850 |
+ $bind_filter = $dbi->bind_filter |
|
| 851 |
+ |
|
| 852 |
+ # Sample |
|
| 853 |
+ $dbi->bind_filter($self->filters->{default_bind_filter});
|
|
| 854 |
+ |
|
| 855 |
+ |
|
| 856 |
+you can get DBI database handle if you need. |
|
| 857 |
+ |
|
| 858 |
+=head2 fetch_filter |
|
| 859 |
+ |
|
| 860 |
+ # Set and get Fetch filter |
|
| 861 |
+ $self = $dbi->fetch_filter($fetch_filter); |
|
| 862 |
+ $fetch_filter = $dbi->fetch_filter; |
|
| 863 |
+ |
|
| 864 |
+ # Sample |
|
| 865 |
+ $dbi->fetch_filter($self->filters->{default_fetch_filter});
|
|
| 866 |
+ |
|
| 867 |
+=head2 no_bind_filters |
|
| 868 |
+ |
|
| 869 |
+ # Set and get no filter keys when binding |
|
| 870 |
+ $self = $dbi->no_bind_filters($no_bind_filters); |
|
| 871 |
+ $no_bind_filters = $dbi->no_bind_filters; |
|
| 872 |
+ |
|
| 873 |
+=head2 no_fetch_filters |
|
| 874 |
+ |
|
| 875 |
+ # Set and get no filter keys when fetching |
|
| 876 |
+ $self = $dbi->no_fetch_filters($no_fetch_filters); |
|
| 877 |
+ $no_fetch_filters = $dbi->no_fetch_filters; |
|
| 878 |
+ |
|
| 879 |
+=head2 result_class |
|
| 880 |
+ |
|
| 881 |
+ # Set and get resultset class |
|
| 882 |
+ $self = $dbi->result_class($result_class); |
|
| 883 |
+ $result_class = $dbi->result_class; |
|
| 884 |
+ |
|
| 885 |
+ # Sample |
|
| 886 |
+ $dbi->result_class('DBIx::Custom::Result');
|
|
| 887 |
+ |
|
| 888 |
+=head2 dbh |
|
| 889 |
+ |
|
| 890 |
+ # Get database handle |
|
| 891 |
+ $dbh = $self->dbh; |
|
| 892 |
+ |
|
| 893 |
+=head1 METHODS |
|
| 894 |
+ |
|
| 895 |
+=head2 connect |
|
| 896 |
+ |
|
| 897 |
+ # Connect to database |
|
| 898 |
+ $self = $dbi->connect; |
|
| 899 |
+ |
|
| 900 |
+ # Sample |
|
| 901 |
+ $dbi = DBIx::Custom->new(user => 'taro', password => 'lji8(',
|
|
| 902 |
+ data_soruce => "dbi:mysql:dbname=$database"); |
|
| 903 |
+ $dbi->connect; |
|
| 904 |
+ |
|
| 905 |
+=head2 disconnect |
|
| 906 |
+ |
|
| 907 |
+ # Disconnect database |
|
| 908 |
+ $dbi->disconnect; |
|
| 909 |
+ |
|
| 910 |
+If database is already disconnected, this method do noting. |
|
| 911 |
+ |
|
| 912 |
+=head2 reconnect |
|
| 913 |
+ |
|
| 914 |
+ # Reconnect |
|
| 915 |
+ $dbi->reconnect; |
|
| 916 |
+ |
|
| 917 |
+=head2 connected |
|
| 918 |
+ |
|
| 919 |
+ # Check connected |
|
| 920 |
+ $dbi->connected |
|
| 921 |
+ |
|
| 922 |
+=head2 filter_off |
|
| 923 |
+ |
|
| 924 |
+ # bind_filter and fitch_filter off |
|
| 925 |
+ $self->filter_off; |
|
| 926 |
+ |
|
| 927 |
+This is equeal to |
|
| 928 |
+ |
|
| 929 |
+ $self->bind_filter(undef); |
|
| 930 |
+ $self->fetch_filter(undef); |
|
| 931 |
+ |
|
| 932 |
+=head2 add_filter |
|
| 933 |
+ |
|
| 934 |
+ # Add filter (hash ref or hash can be recieve) |
|
| 935 |
+ $self = $dbi->add_filter({$filter_name => $filter, ...});
|
|
| 936 |
+ $self = $dbi->add_filter($filetr_name => $filter, ...); |
|
| 937 |
+ |
|
| 938 |
+ # Sample |
|
| 939 |
+ $dbi->add_filter( |
|
| 940 |
+ decode_utf8 => sub {
|
|
| 941 |
+ my ($key, $value, $table, $column) = @_; |
|
| 942 |
+ return Encode::decode('UTF-8', $value);
|
|
| 943 |
+ }, |
|
| 944 |
+ datetime_to_string => sub {
|
|
| 945 |
+ my ($key, $value, $table, $column) = @_; |
|
| 946 |
+ return $value->strftime('%Y-%m-%d %H:%M:%S')
|
|
| 947 |
+ }, |
|
| 948 |
+ default_bind_filter => sub {
|
|
| 949 |
+ my ($key, $value, $table, $column) = @_; |
|
| 950 |
+ if (ref $value eq 'Time::Piece') {
|
|
| 951 |
+ return $dbi->filters->{datetime_to_string}->($value);
|
|
| 952 |
+ } |
|
| 953 |
+ else {
|
|
| 954 |
+ return $dbi->filters->{decode_utf8}->($value);
|
|
| 955 |
+ } |
|
| 956 |
+ }, |
|
| 957 |
+ |
|
| 958 |
+ encode_utf8 => sub {
|
|
| 959 |
+ my ($key, $value) = @_; |
|
| 960 |
+ return Encode::encode('UTF-8', $value);
|
|
| 961 |
+ }, |
|
| 962 |
+ string_to_datetime => sub {
|
|
| 963 |
+ my ($key, $value) = @_; |
|
| 964 |
+ return DateTime::Format::MySQL->parse_datetime($value); |
|
| 965 |
+ }, |
|
| 966 |
+ default_fetch_filter => sub {
|
|
| 967 |
+ my ($key, $value, $type, $sth, $i) = @_; |
|
| 968 |
+ if ($type eq 'DATETIME') {
|
|
| 969 |
+ return $dbi->filters->{string_to_datetime}->($value);
|
|
| 970 |
+ } |
|
| 971 |
+ else {
|
|
| 972 |
+ return $dbi->filters->{encode_utf8}->($value);
|
|
| 973 |
+ } |
|
| 974 |
+ } |
|
| 975 |
+ ); |
|
| 976 |
+ |
|
| 977 |
+add_filter add filter to filters |
|
| 978 |
+ |
|
| 979 |
+=head2 add_format |
|
| 980 |
+ |
|
| 981 |
+ $dbi->add_format(date => '%Y:%m:%d'); |
|
| 982 |
+ |
|
| 983 |
+=head2 create_query |
|
| 984 |
+ |
|
| 985 |
+ # Create Query object from SQL template |
|
| 986 |
+ my $query = $dbi->create_query($template); |
|
| 987 |
+ |
|
| 988 |
+=head2 execute |
|
| 989 |
+ |
|
| 990 |
+ # Parse SQL template and execute SQL |
|
| 991 |
+ $result = $dbi->query($query, $params); |
|
| 992 |
+ $result = $dbi->query($template, $params); # Shorcut |
|
| 993 |
+ |
|
| 994 |
+ # Sample |
|
| 995 |
+ $result = $dbi->query("select * from authors where {= name} and {= age}",
|
|
| 996 |
+ {author => 'taro', age => 19});
|
|
| 997 |
+ |
|
| 998 |
+ while (my @row = $result->fetch) {
|
|
| 999 |
+ # do something |
|
| 1000 |
+ } |
|
| 1001 |
+ |
|
| 1002 |
+See also L<DBIx::Custom::SQL::Template> |
|
| 1003 |
+ |
|
| 1004 |
+=head2 run_transaction |
|
| 1005 |
+ |
|
| 1006 |
+ # Run transaction |
|
| 1007 |
+ $dbi->run_transaction(sub {
|
|
| 1008 |
+ # do something |
|
| 1009 |
+ }); |
|
| 1010 |
+ |
|
| 1011 |
+If transaction is success, commit is execute. |
|
| 1012 |
+If tranzation is died, rollback is execute. |
|
| 1013 |
+ |
|
| 1014 |
+=head2 insert |
|
| 1015 |
+ |
|
| 1016 |
+ # Insert |
|
| 1017 |
+ $dbi->insert($table, $insert_values); |
|
| 1018 |
+ |
|
| 1019 |
+ # Sample |
|
| 1020 |
+ $dbi->insert('books', {title => 'Perl', author => 'Taro'});
|
|
| 1021 |
+ |
|
| 1022 |
+=head2 update |
|
| 1023 |
+ |
|
| 1024 |
+ # Update |
|
| 1025 |
+ $dbi->update($table, $update_values, $where); |
|
| 1026 |
+ |
|
| 1027 |
+ # Sample |
|
| 1028 |
+ $dbi->update('books', {title => 'Perl', author => 'Taro'}, {id => 5});
|
|
| 1029 |
+ |
|
| 1030 |
+=head2 update_all |
|
| 1031 |
+ |
|
| 1032 |
+ # Update all rows |
|
| 1033 |
+ $dbi->update($table, $updat_values); |
|
| 1034 |
+ |
|
| 1035 |
+=head2 delete |
|
| 1036 |
+ |
|
| 1037 |
+ # Delete |
|
| 1038 |
+ $dbi->delete($table, $where); |
|
| 1039 |
+ |
|
| 1040 |
+ # Sample |
|
| 1041 |
+ $dbi->delete('Books', {id => 5});
|
|
| 1042 |
+ |
|
| 1043 |
+=head2 delete_all |
|
| 1044 |
+ |
|
| 1045 |
+ # Delete all rows |
|
| 1046 |
+ $dbi->delete_all($table); |
|
| 1047 |
+ |
|
| 1048 |
+=head2 last_insert_id |
|
| 1049 |
+ |
|
| 1050 |
+ # Get last insert id |
|
| 1051 |
+ $last_insert_id = $dbi->last_insert_id; |
|
| 1052 |
+ |
|
| 1053 |
+This method is same as DBI last_insert_id; |
|
| 1054 |
+ |
|
| 1055 |
+=head2 select |
|
| 1056 |
+ |
|
| 1057 |
+ # Select |
|
| 1058 |
+ $dbi->select( |
|
| 1059 |
+ $table, # must be string or array; |
|
| 1060 |
+ [@$columns], # must be array reference. this is optional |
|
| 1061 |
+ {%$where_params}, # must be hash reference. this is optional
|
|
| 1062 |
+ $append_statement, # must be string. this is optional |
|
| 1063 |
+ $query_edit_callback # must be code reference. this is optional |
|
| 1064 |
+ ); |
|
| 1065 |
+ |
|
| 1066 |
+ # Sample |
|
| 1067 |
+ $dbi->select( |
|
| 1068 |
+ 'Books', |
|
| 1069 |
+ ['title', 'author'], |
|
| 1070 |
+ {id => 1},
|
|
| 1071 |
+ "for update", |
|
| 1072 |
+ sub {
|
|
| 1073 |
+ my $query = shift; |
|
| 1074 |
+ $query->bind_filter(sub {
|
|
| 1075 |
+ # ... |
|
| 1076 |
+ }); |
|
| 1077 |
+ } |
|
| 1078 |
+ ); |
|
| 1079 |
+ |
|
| 1080 |
+ # The way to join multi tables |
|
| 1081 |
+ $dbi->select( |
|
| 1082 |
+ ['table1', 'table2'], |
|
| 1083 |
+ ['table1.id as table1_id', 'title'], |
|
| 1084 |
+ {table1.id => 1},
|
|
| 1085 |
+ "where table1.id = table2.id", |
|
| 1086 |
+ ); |
|
| 1087 |
+ |
|
| 1088 |
+=head1 Class Accessors |
|
| 1089 |
+ |
|
| 1090 |
+=head2 query_cache_max |
|
| 1091 |
+ |
|
| 1092 |
+ # Max query cache count |
|
| 1093 |
+ $class = $class->query_cache_max($query_cache_max); |
|
| 1094 |
+ $query_cache_max = $class->query_cache_max; |
|
| 1095 |
+ |
|
| 1096 |
+ # Sample |
|
| 1097 |
+ DBIx::Custom->query_cache_max(50); |
|
| 1098 |
+ |
|
| 1099 |
+=head1 CAUTION |
|
| 1100 |
+ |
|
| 1101 |
+DBIx::Custom have DIB object internal. |
|
| 1102 |
+This module is work well in the following DBI condition. |
|
| 1103 |
+ |
|
| 1104 |
+ 1. AutoCommit is true |
|
| 1105 |
+ 2. RaiseError is true |
|
| 1106 |
+ |
|
| 1107 |
+By default, Both AutoCommit and RaiseError is true. |
|
| 1108 |
+You must not change these mode not to damage your data. |
|
| 1109 |
+ |
|
| 1110 |
+If you change these mode, |
|
| 1111 |
+you cannot get correct error message, |
|
| 1112 |
+or run_transaction may fail. |
|
| 1113 |
+ |
|
| 1114 |
+=head1 AUTHOR |
|
| 1115 |
+ |
|
| 1116 |
+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >> |
|
| 1117 |
+ |
|
| 1118 |
+Github L<http://github.com/yuki-kimoto> |
|
| 1119 |
+ |
|
| 1120 |
+=head1 COPYRIGHT & LICENSE |
|
| 1121 |
+ |
|
| 1122 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 1123 |
+ |
|
| 1124 |
+This program is free software; you can redistribute it and/or modify it |
|
| 1125 |
+under the same terms as Perl itself. |
|
| 1126 |
+ |
|
| 1127 |
+=cut |
| ... | ... |
@@ -0,0 +1,117 @@ |
| 1 |
+package DBIx::Custom::Basic; |
|
| 2 |
+use 5.008001; |
|
| 3 |
+use base 'DBIx::Custom'; |
|
| 4 |
+use Encode qw/decode encode/; |
|
| 5 |
+ |
|
| 6 |
+use warnings; |
|
| 7 |
+use strict; |
|
| 8 |
+ |
|
| 9 |
+my $class = __PACKAGE__; |
|
| 10 |
+ |
|
| 11 |
+$class->add_filter( |
|
| 12 |
+ encode_utf8 => sub {
|
|
| 13 |
+ my $value = shift; |
|
| 14 |
+ utf8::upgrade($value) unless Encode::is_utf8($value); |
|
| 15 |
+ return encode('UTF-8', $value);
|
|
| 16 |
+ }, |
|
| 17 |
+ decode_utf8 => sub { decode('UTF-8', shift) }
|
|
| 18 |
+); |
|
| 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 |
+# Methods |
|
| 30 |
+sub utf8_filter_on {
|
|
| 31 |
+ my $self = shift; |
|
| 32 |
+ $self->bind_filter($self->filters->{encode_utf8});
|
|
| 33 |
+ $self->fetch_filter($self->filters->{decode_utf8});
|
|
| 34 |
+} |
|
| 35 |
+ |
|
| 36 |
+1; |
|
| 37 |
+ |
|
| 38 |
+=head1 NAME |
|
| 39 |
+ |
|
| 40 |
+DBIx::Custom::Basic - DBIx::Custom basic implementation |
|
| 41 |
+ |
|
| 42 |
+=head1 Version |
|
| 43 |
+ |
|
| 44 |
+Version 0.0201 |
|
| 45 |
+ |
|
| 46 |
+=head1 See DBIx::Custom documentation |
|
| 47 |
+ |
|
| 48 |
+This class is L<DBIx::Custom> subclass. |
|
| 49 |
+ |
|
| 50 |
+You can use all methods of L<DBIx::Custom> |
|
| 51 |
+ |
|
| 52 |
+Please see L<DBIx::Custom> documentation |
|
| 53 |
+ |
|
| 54 |
+=head1 Filters |
|
| 55 |
+ |
|
| 56 |
+=head2 encode_utf8 |
|
| 57 |
+ |
|
| 58 |
+ # Encode to UTF-8 byte stream (utf8::upgrade is done if need) |
|
| 59 |
+ $dbi->filters->{encode_utf8}->($value);
|
|
| 60 |
+ |
|
| 61 |
+This filter is generally used as bind filter |
|
| 62 |
+ |
|
| 63 |
+ $dbi->bind_filter($dbi->filters->{encode_utf8});
|
|
| 64 |
+ |
|
| 65 |
+=head2 decode_utf8 |
|
| 66 |
+ |
|
| 67 |
+ # Decode to perl internal string |
|
| 68 |
+ $dbi->filters->{decode_utf8}->($value);
|
|
| 69 |
+ |
|
| 70 |
+This filter is generally used as fetch filter |
|
| 71 |
+ |
|
| 72 |
+ $dbi->fetch_filter($dbi->filters->{decode_utf8});
|
|
| 73 |
+ |
|
| 74 |
+=head2 Formats |
|
| 75 |
+ |
|
| 76 |
+strptime formats is available |
|
| 77 |
+ |
|
| 78 |
+ # format name format |
|
| 79 |
+ 'SQL99_date' '%Y-%m-%d', |
|
| 80 |
+ 'SQL99_datetime' '%Y-%m-%d %H:%M:%S', |
|
| 81 |
+ 'SQL99_time' '%H:%M:%S', |
|
| 82 |
+ 'ISO-8601_date' '%Y-%m-%d', |
|
| 83 |
+ 'ISO-8601_datetime' '%Y-%m-%dT%H:%M:%S', |
|
| 84 |
+ 'ISO-8601_time' '%H:%M:%S', |
|
| 85 |
+ |
|
| 86 |
+You get format as the following |
|
| 87 |
+ |
|
| 88 |
+ my $format = $dbi->formats->{$format_name};
|
|
| 89 |
+ |
|
| 90 |
+=head1 Methods |
|
| 91 |
+ |
|
| 92 |
+=head2 utf8_filter_on |
|
| 93 |
+ |
|
| 94 |
+ # Encode and decode utf8 filter on |
|
| 95 |
+ $dbi->utf8_filter_on; |
|
| 96 |
+ |
|
| 97 |
+This equel to |
|
| 98 |
+ |
|
| 99 |
+ $dbi->bind_filter($dbi->filters->{encode_utf8});
|
|
| 100 |
+ $dbi->fetch_filter($dbi->filters->{decode_utf8});
|
|
| 101 |
+ |
|
| 102 |
+=head1 AUTHOR |
|
| 103 |
+ |
|
| 104 |
+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >> |
|
| 105 |
+ |
|
| 106 |
+Github L<http://github.com/yuki-kimoto> |
|
| 107 |
+ |
|
| 108 |
+I develope this module L<http://github.com/yuki-kimoto/DBIx-Custom> |
|
| 109 |
+ |
|
| 110 |
+=head1 COPYRIGHT & LICENSE |
|
| 111 |
+ |
|
| 112 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 113 |
+ |
|
| 114 |
+This program is free software; you can redistribute it and/or modify it |
|
| 115 |
+under the same terms as Perl itself. |
|
| 116 |
+ |
|
| 117 |
+=cut |
| ... | ... |
@@ -0,0 +1,86 @@ |
| 1 |
+package DBIx::Custom::MySQL; |
|
| 2 |
+use base 'DBIx::Custom::Basic'; |
|
| 3 |
+ |
|
| 4 |
+use warnings; |
|
| 5 |
+use strict; |
|
| 6 |
+ |
|
| 7 |
+my $class = __PACKAGE__; |
|
| 8 |
+ |
|
| 9 |
+$class->add_format( |
|
| 10 |
+ datetime => $class->formats->{SQL99_datetime},
|
|
| 11 |
+ date => $class->formats->{SQL99_date},
|
|
| 12 |
+ time => $class->formats->{SQL99_time},
|
|
| 13 |
+); |
|
| 14 |
+ |
|
| 15 |
+ |
|
| 16 |
+sub connect {
|
|
| 17 |
+ my $self = shift; |
|
| 18 |
+ |
|
| 19 |
+ if (!$self->data_source && (my $database = $self->database)) {
|
|
| 20 |
+ $self->data_source("dbi:mysql:dbname=$database");
|
|
| 21 |
+ } |
|
| 22 |
+ |
|
| 23 |
+ return $self->SUPER::connect; |
|
| 24 |
+} |
|
| 25 |
+ |
|
| 26 |
+=head1 NAME |
|
| 27 |
+ |
|
| 28 |
+DBIx::Custom::MySQL - DBIx::Custom MySQL implementation |
|
| 29 |
+ |
|
| 30 |
+=head1 Version |
|
| 31 |
+ |
|
| 32 |
+Version 0.0102 |
|
| 33 |
+ |
|
| 34 |
+=head1 Synopsys |
|
| 35 |
+ |
|
| 36 |
+ # New |
|
| 37 |
+ my $dbi = DBIx::Custom::MySQL->new(user => 'taro', $password => 'kliej&@K', |
|
| 38 |
+ database => 'sample_db'); |
|
| 39 |
+ # Insert |
|
| 40 |
+ $dbi->insert('books', {title => 'perl', author => 'taro'});
|
|
| 41 |
+ |
|
| 42 |
+ # Update |
|
| 43 |
+ # same as 'update books set (title = 'aaa', author = 'ken') where id = 5; |
|
| 44 |
+ $dbi->update('books', {title => 'aaa', author => 'ken'}, {id => 5});
|
|
| 45 |
+ |
|
| 46 |
+ # Delete |
|
| 47 |
+ $dbi->delete('books', {author => 'taro'});
|
|
| 48 |
+ |
|
| 49 |
+ # select * from books; |
|
| 50 |
+ $dbi->select('books');
|
|
| 51 |
+ |
|
| 52 |
+ # select * from books where ahthor = 'taro'; |
|
| 53 |
+ $dbi->select('books', {author => 'taro'});
|
|
| 54 |
+ |
|
| 55 |
+=head1 See DBIx::Custom and DBI::Custom::Basic documentation |
|
| 56 |
+ |
|
| 57 |
+This class is L<DBIx::Custom::Basic> subclass, |
|
| 58 |
+and L<DBIx::Custom::Basic> is L<DBIx::Custom> subclass. |
|
| 59 |
+ |
|
| 60 |
+You can use all methods of L<DBIx::Custom::Basic> and <DBIx::Custom> |
|
| 61 |
+Please see L<DBIx::Custom::Basic> and <DBIx::Custom> documentation. |
|
| 62 |
+ |
|
| 63 |
+=head1 Object methods |
|
| 64 |
+ |
|
| 65 |
+=head2 connect |
|
| 66 |
+ |
|
| 67 |
+ This method override DBIx::Custom::connect |
|
| 68 |
+ |
|
| 69 |
+ If database attribute is set, automatically data source is created and connect |
|
| 70 |
+ |
|
| 71 |
+=head1 Author |
|
| 72 |
+ |
|
| 73 |
+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >> |
|
| 74 |
+ |
|
| 75 |
+Github L<http://github.com/yuki-kimoto> |
|
| 76 |
+ |
|
| 77 |
+I develope this module L<http://github.com/yuki-kimoto/DBIx-Custom> |
|
| 78 |
+ |
|
| 79 |
+=head1 Copyright & license |
|
| 80 |
+ |
|
| 81 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 82 |
+ |
|
| 83 |
+This program is free software; you can redistribute it and/or modify it |
|
| 84 |
+under the same terms as Perl itself. |
|
| 85 |
+ |
|
| 86 |
+ |
| ... | ... |
@@ -0,0 +1,101 @@ |
| 1 |
+package DBIx::Custom::Query; |
|
| 2 |
+use Object::Simple; |
|
| 3 |
+ |
|
| 4 |
+sub sql : Attr {}
|
|
| 5 |
+sub key_infos : Attr {}
|
|
| 6 |
+sub bind_filter : Attr {}
|
|
| 7 |
+sub fetch_filter : Attr {}
|
|
| 8 |
+sub sth : Attr {}
|
|
| 9 |
+ |
|
| 10 |
+sub no_bind_filters : Attr { type => 'array', trigger => sub {
|
|
| 11 |
+ my $self = shift; |
|
| 12 |
+ my $no_bind_filters = $self->no_bind_filters || []; |
|
| 13 |
+ my %no_bind_filters_map = map {$_ => 1} @{$no_bind_filters};
|
|
| 14 |
+ $self->_no_bind_filters_map(\%no_bind_filters_map); |
|
| 15 |
+}} |
|
| 16 |
+sub _no_bind_filters_map : Attr {default => sub { {} }}
|
|
| 17 |
+ |
|
| 18 |
+sub no_fetch_filters : Attr { type => 'array', default => sub { [] } }
|
|
| 19 |
+ |
|
| 20 |
+Object::Simple->build_class; |
|
| 21 |
+ |
|
| 22 |
+=head1 NAME |
|
| 23 |
+ |
|
| 24 |
+DBIx::Custom::Query - Query object for DBIx::Custom |
|
| 25 |
+ |
|
| 26 |
+=head1 VERSION |
|
| 27 |
+ |
|
| 28 |
+Version 0.0101 |
|
| 29 |
+ |
|
| 30 |
+=head1 SYNOPSIS |
|
| 31 |
+ |
|
| 32 |
+ # Create query |
|
| 33 |
+ my $dbi = DBIx::Custom->new; |
|
| 34 |
+ my $query = $dbi->create_query($template); |
|
| 35 |
+ |
|
| 36 |
+ # Set query attributes |
|
| 37 |
+ $query->bind_filter($dbi->filters->{default_bind_filter});
|
|
| 38 |
+ $query->no_bind_filters('title', 'author');
|
|
| 39 |
+ |
|
| 40 |
+ $query->fetch_filter($dbi->filters->{default_fetch_filter});
|
|
| 41 |
+ $query->no_fetch_filters('title', 'author');
|
|
| 42 |
+ |
|
| 43 |
+ # Execute query |
|
| 44 |
+ $dbi->execute($query, $params); |
|
| 45 |
+ |
|
| 46 |
+=head1 OBJECT ACCESSORS |
|
| 47 |
+ |
|
| 48 |
+=head2 sth |
|
| 49 |
+ |
|
| 50 |
+ # Set and get statement handle |
|
| 51 |
+ $self = $query->sth($sql); |
|
| 52 |
+ $sth = $query->sth; |
|
| 53 |
+ |
|
| 54 |
+=head2 sql |
|
| 55 |
+ |
|
| 56 |
+ # Set and get SQL |
|
| 57 |
+ $self = $query->sql($sql); |
|
| 58 |
+ $sql = $query->sql; |
|
| 59 |
+ |
|
| 60 |
+=head2 bind_filter |
|
| 61 |
+ |
|
| 62 |
+ # Set and get bind filter |
|
| 63 |
+ $self = $query->bind_filter($bind_filter); |
|
| 64 |
+ $bind_filter = $query->bind_filter; |
|
| 65 |
+ |
|
| 66 |
+=head2 no_bind_filters |
|
| 67 |
+ |
|
| 68 |
+ # Set and get keys of no filtering |
|
| 69 |
+ $self = $query->no_bind_filters($no_filters); |
|
| 70 |
+ $no_bind_filters = $query->no_bind_filters; |
|
| 71 |
+ |
|
| 72 |
+=head2 fetch_filter |
|
| 73 |
+ |
|
| 74 |
+ # Set and get fetch filter |
|
| 75 |
+ $self = $query->fetch_filter($fetch_filter); |
|
| 76 |
+ $fetch_filter = $query->fetch_filter; |
|
| 77 |
+ |
|
| 78 |
+=head2 no_fetch_filters |
|
| 79 |
+ |
|
| 80 |
+ # Set and get keys of no filtering |
|
| 81 |
+ $self = $query->no_fetch_filters($no_filters); |
|
| 82 |
+ $no_fetch_filters = $query->no_fetch_filters; |
|
| 83 |
+ |
|
| 84 |
+=head2 key_infos |
|
| 85 |
+ |
|
| 86 |
+ # Set and get key informations |
|
| 87 |
+ $self = $query->key_infos($key_infos); |
|
| 88 |
+ $key_infos = $query->key_infos; |
|
| 89 |
+ |
|
| 90 |
+=head1 AUTHOR |
|
| 91 |
+ |
|
| 92 |
+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >> |
|
| 93 |
+ |
|
| 94 |
+Github L<http://github.com/yuki-kimoto> |
|
| 95 |
+ |
|
| 96 |
+=head1 COPYRIGHT & LICENSE |
|
| 97 |
+ |
|
| 98 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 99 |
+ |
|
| 100 |
+This program is free software; you can redistribute it and/or modify it |
|
| 101 |
+under the same terms as Perl itself. |
| ... | ... |
@@ -0,0 +1,384 @@ |
| 1 |
+package DBIx::Custom::Result; |
|
| 2 |
+use Object::Simple; |
|
| 3 |
+use strict; |
|
| 4 |
+use warnings; |
|
| 5 |
+use Carp 'croak'; |
|
| 6 |
+ |
|
| 7 |
+# Attributes |
|
| 8 |
+sub sth : Attr {}
|
|
| 9 |
+sub fetch_filter : Attr {}
|
|
| 10 |
+sub no_fetch_filters : Attr { type => 'array', trigger => sub {
|
|
| 11 |
+ my $self = shift; |
|
| 12 |
+ my $no_fetch_filters = $self->no_fetch_filters || []; |
|
| 13 |
+ my %no_fetch_filters_map = map {$_ => 1} @{$no_fetch_filters};
|
|
| 14 |
+ $self->_no_fetch_filters_map(\%no_fetch_filters_map); |
|
| 15 |
+}} |
|
| 16 |
+sub _no_fetch_filters_map : Attr {default => sub { {} }}
|
|
| 17 |
+ |
|
| 18 |
+# Fetch (array) |
|
| 19 |
+sub fetch {
|
|
| 20 |
+ my ($self, $type) = @_; |
|
| 21 |
+ my $sth = $self->sth; |
|
| 22 |
+ my $fetch_filter = $self->fetch_filter; |
|
| 23 |
+ |
|
| 24 |
+ # Fetch |
|
| 25 |
+ my $row = $sth->fetchrow_arrayref; |
|
| 26 |
+ |
|
| 27 |
+ # Cannot fetch |
|
| 28 |
+ return unless $row; |
|
| 29 |
+ |
|
| 30 |
+ # Filter |
|
| 31 |
+ if ($fetch_filter) {
|
|
| 32 |
+ my $keys = $sth->{NAME_lc};
|
|
| 33 |
+ my $types = $sth->{TYPE};
|
|
| 34 |
+ for (my $i = 0; $i < @$keys; $i++) {
|
|
| 35 |
+ next if $self->_no_fetch_filters_map->{$keys->[$i]};
|
|
| 36 |
+ $row->[$i]= $fetch_filter->($row->[$i], $keys->[$i], $types->[$i], |
|
| 37 |
+ $sth, $i); |
|
| 38 |
+ } |
|
| 39 |
+ } |
|
| 40 |
+ return wantarray ? @$row : $row; |
|
| 41 |
+} |
|
| 42 |
+ |
|
| 43 |
+# Fetch (hash) |
|
| 44 |
+sub fetch_hash {
|
|
| 45 |
+ my $self = shift; |
|
| 46 |
+ my $sth = $self->sth; |
|
| 47 |
+ my $fetch_filter = $self->fetch_filter; |
|
| 48 |
+ |
|
| 49 |
+ # Fetch |
|
| 50 |
+ my $row = $sth->fetchrow_arrayref; |
|
| 51 |
+ |
|
| 52 |
+ # Cannot fetch |
|
| 53 |
+ return unless $row; |
|
| 54 |
+ |
|
| 55 |
+ # Keys |
|
| 56 |
+ my $keys = $sth->{NAME_lc};
|
|
| 57 |
+ |
|
| 58 |
+ # Filter |
|
| 59 |
+ my $row_hash = {};
|
|
| 60 |
+ if ($fetch_filter) {
|
|
| 61 |
+ my $types = $sth->{TYPE};
|
|
| 62 |
+ for (my $i = 0; $i < @$keys; $i++) {
|
|
| 63 |
+ if ($self->_no_fetch_filters_map->{$keys->[$i]}) {
|
|
| 64 |
+ $row_hash->{$keys->[$i]} = $row->[$i];
|
|
| 65 |
+ } |
|
| 66 |
+ else {
|
|
| 67 |
+ $row_hash->{$keys->[$i]}
|
|
| 68 |
+ = $fetch_filter->($row->[$i], $keys->[$i], |
|
| 69 |
+ $types->[$i], $sth, $i); |
|
| 70 |
+ } |
|
| 71 |
+ } |
|
| 72 |
+ } |
|
| 73 |
+ |
|
| 74 |
+ # No filter |
|
| 75 |
+ else {
|
|
| 76 |
+ for (my $i = 0; $i < @$keys; $i++) {
|
|
| 77 |
+ $row_hash->{$keys->[$i]} = $row->[$i];
|
|
| 78 |
+ } |
|
| 79 |
+ } |
|
| 80 |
+ return wantarray ? %$row_hash : $row_hash; |
|
| 81 |
+} |
|
| 82 |
+ |
|
| 83 |
+# Fetch only first (array) |
|
| 84 |
+sub fetch_first {
|
|
| 85 |
+ my $self = shift; |
|
| 86 |
+ |
|
| 87 |
+ # Fetch |
|
| 88 |
+ my $row = $self->fetch; |
|
| 89 |
+ |
|
| 90 |
+ # Not exist |
|
| 91 |
+ return unless $row; |
|
| 92 |
+ |
|
| 93 |
+ # Finish statement handle |
|
| 94 |
+ $self->finish; |
|
| 95 |
+ |
|
| 96 |
+ return wantarray ? @$row : $row; |
|
| 97 |
+} |
|
| 98 |
+ |
|
| 99 |
+# Fetch only first (hash) |
|
| 100 |
+sub fetch_hash_first {
|
|
| 101 |
+ my $self = shift; |
|
| 102 |
+ |
|
| 103 |
+ # Fetch hash |
|
| 104 |
+ my $row = $self->fetch_hash; |
|
| 105 |
+ |
|
| 106 |
+ # Not exist |
|
| 107 |
+ return unless $row; |
|
| 108 |
+ |
|
| 109 |
+ # Finish statement handle |
|
| 110 |
+ $self->finish; |
|
| 111 |
+ |
|
| 112 |
+ return wantarray ? %$row : $row; |
|
| 113 |
+} |
|
| 114 |
+ |
|
| 115 |
+# Fetch multi rows (array) |
|
| 116 |
+sub fetch_rows {
|
|
| 117 |
+ my ($self, $count) = @_; |
|
| 118 |
+ |
|
| 119 |
+ # Not specified Row count |
|
| 120 |
+ croak("Row count must be specified")
|
|
| 121 |
+ unless $count; |
|
| 122 |
+ |
|
| 123 |
+ # Fetch multi rows |
|
| 124 |
+ my $rows = []; |
|
| 125 |
+ for (my $i = 0; $i < $count; $i++) {
|
|
| 126 |
+ my @row = $self->fetch; |
|
| 127 |
+ |
|
| 128 |
+ last unless @row; |
|
| 129 |
+ |
|
| 130 |
+ push @$rows, \@row; |
|
| 131 |
+ } |
|
| 132 |
+ |
|
| 133 |
+ return unless @$rows; |
|
| 134 |
+ return wantarray ? @$rows : $rows; |
|
| 135 |
+} |
|
| 136 |
+ |
|
| 137 |
+# Fetch multi rows (hash) |
|
| 138 |
+sub fetch_hash_rows {
|
|
| 139 |
+ my ($self, $count) = @_; |
|
| 140 |
+ |
|
| 141 |
+ # Not specified Row count |
|
| 142 |
+ croak("Row count must be specified")
|
|
| 143 |
+ unless $count; |
|
| 144 |
+ |
|
| 145 |
+ # Fetch multi rows |
|
| 146 |
+ my $rows = []; |
|
| 147 |
+ for (my $i = 0; $i < $count; $i++) {
|
|
| 148 |
+ my %row = $self->fetch_hash; |
|
| 149 |
+ |
|
| 150 |
+ last unless %row; |
|
| 151 |
+ |
|
| 152 |
+ push @$rows, \%row; |
|
| 153 |
+ } |
|
| 154 |
+ |
|
| 155 |
+ return unless @$rows; |
|
| 156 |
+ return wantarray ? @$rows : $rows; |
|
| 157 |
+} |
|
| 158 |
+ |
|
| 159 |
+ |
|
| 160 |
+# Fetch all (array) |
|
| 161 |
+sub fetch_all {
|
|
| 162 |
+ my $self = shift; |
|
| 163 |
+ |
|
| 164 |
+ my $rows = []; |
|
| 165 |
+ while(my @row = $self->fetch) {
|
|
| 166 |
+ push @$rows, [@row]; |
|
| 167 |
+ } |
|
| 168 |
+ return wantarray ? @$rows : $rows; |
|
| 169 |
+} |
|
| 170 |
+ |
|
| 171 |
+# Fetch all (hash) |
|
| 172 |
+sub fetch_hash_all {
|
|
| 173 |
+ my $self = shift; |
|
| 174 |
+ |
|
| 175 |
+ my $rows = []; |
|
| 176 |
+ while(my %row = $self->fetch_hash) {
|
|
| 177 |
+ push @$rows, {%row};
|
|
| 178 |
+ } |
|
| 179 |
+ return wantarray ? @$rows : $rows; |
|
| 180 |
+} |
|
| 181 |
+ |
|
| 182 |
+# Finish |
|
| 183 |
+sub finish { shift->sth->finish }
|
|
| 184 |
+ |
|
| 185 |
+# Error |
|
| 186 |
+sub error {
|
|
| 187 |
+ my $self = shift; |
|
| 188 |
+ my $sth = $self->sth; |
|
| 189 |
+ return wantarray ? ($sth->errstr, $sth->err, $sth->state) : $sth->errstr; |
|
| 190 |
+} |
|
| 191 |
+ |
|
| 192 |
+Object::Simple->build_class; |
|
| 193 |
+ |
|
| 194 |
+=head1 NAME |
|
| 195 |
+ |
|
| 196 |
+DBIx::Custom::Result - Resultset for DBIx::Custom |
|
| 197 |
+ |
|
| 198 |
+=head1 VERSION |
|
| 199 |
+ |
|
| 200 |
+Version 0.0301 |
|
| 201 |
+ |
|
| 202 |
+=head1 SYNOPSIS |
|
| 203 |
+ |
|
| 204 |
+ # $result is DBIx::Custom::Result object |
|
| 205 |
+ my $dbi = DBIx::Custom->new; |
|
| 206 |
+ my $result = $dbi->query($sql_template, $param); |
|
| 207 |
+ |
|
| 208 |
+ while (my ($val1, $val2) = $result->fetch) {
|
|
| 209 |
+ # do something |
|
| 210 |
+ } |
|
| 211 |
+ |
|
| 212 |
+=head1 OBJECT ACCESSORS |
|
| 213 |
+ |
|
| 214 |
+=head2 sth |
|
| 215 |
+ |
|
| 216 |
+ # Set and Get statement handle |
|
| 217 |
+ $self = $result->sth($sth); |
|
| 218 |
+ $sth = $reuslt->sth |
|
| 219 |
+ |
|
| 220 |
+Statement handle is automatically set by DBIx::Custom. |
|
| 221 |
+so you do not set statement handle. |
|
| 222 |
+ |
|
| 223 |
+If you need statement handle, you can get statement handle by using this method. |
|
| 224 |
+ |
|
| 225 |
+=head2 fetch_filter |
|
| 226 |
+ |
|
| 227 |
+ # Set and Get fetch filter |
|
| 228 |
+ $self = $result->fetch_filter($sth); |
|
| 229 |
+ $fetch_filter = $result->fech_filter; |
|
| 230 |
+ |
|
| 231 |
+Statement handle is automatically set by DBIx::Custom. |
|
| 232 |
+If you want to set your fetch filter, you set it. |
|
| 233 |
+ |
|
| 234 |
+=head2 no_fetch_filters |
|
| 235 |
+ |
|
| 236 |
+ # Set and Get no filter keys when fetching |
|
| 237 |
+ $self = $result->no_fetch_filters($no_fetch_filters); |
|
| 238 |
+ $no_fetch_filters = $result->no_fetch_filters; |
|
| 239 |
+ |
|
| 240 |
+=head1 METHODS |
|
| 241 |
+ |
|
| 242 |
+=head2 fetch |
|
| 243 |
+ |
|
| 244 |
+ # Fetch row as array reference (Scalar context) |
|
| 245 |
+ $row = $result->fetch; |
|
| 246 |
+ |
|
| 247 |
+ # Fetch row as array (List context) |
|
| 248 |
+ @row = $result->fecth |
|
| 249 |
+ |
|
| 250 |
+ # Sample |
|
| 251 |
+ while (my $row = $result->fetch) {
|
|
| 252 |
+ # do something |
|
| 253 |
+ my $val1 = $row->[0]; |
|
| 254 |
+ my $val2 = $row->[1]; |
|
| 255 |
+ } |
|
| 256 |
+ |
|
| 257 |
+fetch method is fetch resultset and get row as array or array reference. |
|
| 258 |
+ |
|
| 259 |
+=head2 fetch_hash |
|
| 260 |
+ |
|
| 261 |
+ # Fetch row as hash reference (Scalar context) |
|
| 262 |
+ $row = $result->fetch_hash; |
|
| 263 |
+ |
|
| 264 |
+ # Fetch row as hash (List context) |
|
| 265 |
+ %row = $result->fecth_hash |
|
| 266 |
+ |
|
| 267 |
+ # Sample |
|
| 268 |
+ while (my $row = $result->fetch_hash) {
|
|
| 269 |
+ # do something |
|
| 270 |
+ my $val1 = $row->{key1};
|
|
| 271 |
+ my $val2 = $row->{key2};
|
|
| 272 |
+ } |
|
| 273 |
+ |
|
| 274 |
+fetch_hash method is fetch resultset and get row as hash or hash reference. |
|
| 275 |
+ |
|
| 276 |
+=head2 fetch_first |
|
| 277 |
+ |
|
| 278 |
+ # Fetch only first (Scalar context) |
|
| 279 |
+ $row = $result->fetch_first; |
|
| 280 |
+ |
|
| 281 |
+ # Fetch only first (List context) |
|
| 282 |
+ @row = $result->fetch_first; |
|
| 283 |
+ |
|
| 284 |
+This method fetch only first and finish statement handle |
|
| 285 |
+ |
|
| 286 |
+=head2 fetch_hash_first |
|
| 287 |
+ |
|
| 288 |
+ # Fetch only first as hash (Scalar context) |
|
| 289 |
+ $row = $result->fetch_hash_first; |
|
| 290 |
+ |
|
| 291 |
+ # Fetch only first as hash (Scalar context) |
|
| 292 |
+ @row = $result->fetch_hash_first; |
|
| 293 |
+ |
|
| 294 |
+This method fetch only first and finish statement handle |
|
| 295 |
+ |
|
| 296 |
+=head2 fetch_rows |
|
| 297 |
+ |
|
| 298 |
+ # Fetch multi rows (Scalar context) |
|
| 299 |
+ $rows = $result->fetch_rows($row_count); |
|
| 300 |
+ |
|
| 301 |
+ # Fetch multi rows (List context) |
|
| 302 |
+ @rows = $result->fetch_rows($row_count); |
|
| 303 |
+ |
|
| 304 |
+ # Sapmle |
|
| 305 |
+ $rows = $result->fetch_rows(10); |
|
| 306 |
+ |
|
| 307 |
+=head2 fetch_hash_rows |
|
| 308 |
+ |
|
| 309 |
+ # Fetch multi rows as hash (Scalar context) |
|
| 310 |
+ $rows = $result->fetch_hash_rows($row_count); |
|
| 311 |
+ |
|
| 312 |
+ # Fetch multi rows as hash (List context) |
|
| 313 |
+ @rows = $result->fetch_hash_rows($row_count); |
|
| 314 |
+ |
|
| 315 |
+ # Sapmle |
|
| 316 |
+ $rows = $result->fetch_hash_rows(10); |
|
| 317 |
+ |
|
| 318 |
+=head2 fetch_all |
|
| 319 |
+ |
|
| 320 |
+ # Fetch all row as array ref of array ref (Scalar context) |
|
| 321 |
+ $rows = $result->fetch_all; |
|
| 322 |
+ |
|
| 323 |
+ # Fetch all row as array of array ref (List context) |
|
| 324 |
+ @rows = $result->fecth_all; |
|
| 325 |
+ |
|
| 326 |
+ # Sample |
|
| 327 |
+ my $rows = $result->fetch_all; |
|
| 328 |
+ my $val0_0 = $rows->[0][0]; |
|
| 329 |
+ my $val1_1 = $rows->[1][1]; |
|
| 330 |
+ |
|
| 331 |
+fetch_all method is fetch resultset and get all rows as array or array reference. |
|
| 332 |
+ |
|
| 333 |
+=head2 fetch_hash_all |
|
| 334 |
+ |
|
| 335 |
+ # Fetch all row as array ref of hash ref (Scalar context) |
|
| 336 |
+ $rows = $result->fetch_hash_all; |
|
| 337 |
+ |
|
| 338 |
+ # Fetch all row as array of hash ref (List context) |
|
| 339 |
+ @rows = $result->fecth_all_hash; |
|
| 340 |
+ |
|
| 341 |
+ # Sample |
|
| 342 |
+ my $rows = $result->fetch_hash_all; |
|
| 343 |
+ my $val0_key1 = $rows->[0]{key1};
|
|
| 344 |
+ my $val1_key2 = $rows->[1]{key2};
|
|
| 345 |
+ |
|
| 346 |
+=head2 error |
|
| 347 |
+ |
|
| 348 |
+ # Get error infomation |
|
| 349 |
+ $error_messege = $result->error; |
|
| 350 |
+ ($error_message, $error_number, $error_state) = $result->error; |
|
| 351 |
+ |
|
| 352 |
+You can get get information. This is crenspond to the following. |
|
| 353 |
+ |
|
| 354 |
+ $error_message : $result->sth->errstr |
|
| 355 |
+ $error_number : $result->sth->err |
|
| 356 |
+ $error_state : $result->sth->state |
|
| 357 |
+ |
|
| 358 |
+=head2 finish |
|
| 359 |
+ |
|
| 360 |
+ # Finish statement handle |
|
| 361 |
+ $result->finish |
|
| 362 |
+ |
|
| 363 |
+ # Sample |
|
| 364 |
+ my $row = $reuslt->fetch; # fetch only one row |
|
| 365 |
+ $result->finish |
|
| 366 |
+ |
|
| 367 |
+You can finish statement handle.This is equel to |
|
| 368 |
+ |
|
| 369 |
+ $result->sth->finish; |
|
| 370 |
+ |
|
| 371 |
+=head1 AUTHOR |
|
| 372 |
+ |
|
| 373 |
+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >> |
|
| 374 |
+ |
|
| 375 |
+Github L<http://github.com/yuki-kimoto> |
|
| 376 |
+ |
|
| 377 |
+=head1 COPYRIGHT & LICENSE |
|
| 378 |
+ |
|
| 379 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 380 |
+ |
|
| 381 |
+This program is free software; you can redistribute it and/or modify it |
|
| 382 |
+under the same terms as Perl itself. |
|
| 383 |
+ |
|
| 384 |
+=cut |
| ... | ... |
@@ -0,0 +1,694 @@ |
| 1 |
+package DBIx::Custom::SQL::Template; |
|
| 2 |
+use Object::Simple; |
|
| 3 |
+ |
|
| 4 |
+use Carp 'croak'; |
|
| 5 |
+ |
|
| 6 |
+# Accessor is created by Object::Simple. Please read Object::Simple document |
|
| 7 |
+ |
|
| 8 |
+### Class-Object accessors |
|
| 9 |
+ |
|
| 10 |
+# Tag start |
|
| 11 |
+sub tag_start : ClassObjectAttr {
|
|
| 12 |
+ initialize => {default => '{', clone => 'scalar'}
|
|
| 13 |
+} |
|
| 14 |
+ |
|
| 15 |
+# Tag end |
|
| 16 |
+sub tag_end : ClassObjectAttr {
|
|
| 17 |
+ initialize => {default => '}', clone => 'scalar'}
|
|
| 18 |
+} |
|
| 19 |
+ |
|
| 20 |
+# Tag syntax |
|
| 21 |
+sub tag_syntax : ClassObjectAttr {
|
|
| 22 |
+ initialize => {default => <<'EOS', clone => 'scalar'}}
|
|
| 23 |
+[tag] [expand] |
|
| 24 |
+{? name} ?
|
|
| 25 |
+{= name} name = ?
|
|
| 26 |
+{<> name} name <> ?
|
|
| 27 |
+ |
|
| 28 |
+{< name} name < ?
|
|
| 29 |
+{> name} name > ?
|
|
| 30 |
+{>= name} name >= ?
|
|
| 31 |
+{<= name} name <= ?
|
|
| 32 |
+ |
|
| 33 |
+{like name} name like ?
|
|
| 34 |
+{in name number} name in [?, ?, ..]
|
|
| 35 |
+ |
|
| 36 |
+{insert key1 key2} (key1, key2) values (?, ?)
|
|
| 37 |
+{update key1 key2} set key1 = ?, key2 = ?
|
|
| 38 |
+EOS |
|
| 39 |
+ |
|
| 40 |
+# Tag processors |
|
| 41 |
+sub tag_processors : ClassObjectAttr {
|
|
| 42 |
+ type => 'hash', |
|
| 43 |
+ deref => 1, |
|
| 44 |
+ initialize => {
|
|
| 45 |
+ clone => 'hash', |
|
| 46 |
+ default => sub {{
|
|
| 47 |
+ '?' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_basic_tag, |
|
| 48 |
+ '=' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_basic_tag, |
|
| 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 |
+ 'like' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_basic_tag, |
|
| 55 |
+ 'in' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_in_tag, |
|
| 56 |
+ 'insert' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_insert_tag, |
|
| 57 |
+ 'update' => \&DBIx::Custom::SQL::Template::TagProcessor::expand_update_tag |
|
| 58 |
+ }} |
|
| 59 |
+ } |
|
| 60 |
+} |
|
| 61 |
+ |
|
| 62 |
+# Add Tag processor |
|
| 63 |
+sub add_tag_processor {
|
|
| 64 |
+ my $invocant = shift; |
|
| 65 |
+ my $tag_processors = ref $_[0] eq 'HASH' ? $_[0] : {@_};
|
|
| 66 |
+ $invocant->tag_processors(%{$invocant->tag_processors}, %{$tag_processors});
|
|
| 67 |
+ return $invocant; |
|
| 68 |
+} |
|
| 69 |
+ |
|
| 70 |
+# Clone |
|
| 71 |
+sub clone {
|
|
| 72 |
+ my $self = shift; |
|
| 73 |
+ my $new = $self->new; |
|
| 74 |
+ |
|
| 75 |
+ $new->tag_start($self->tag_start); |
|
| 76 |
+ $new->tag_end($self->tag_end); |
|
| 77 |
+ $new->tag_syntax($self->tag_syntax); |
|
| 78 |
+ $new->tag_processors({%{$self->tag_processors || {}}});
|
|
| 79 |
+ |
|
| 80 |
+ return $new; |
|
| 81 |
+} |
|
| 82 |
+ |
|
| 83 |
+ |
|
| 84 |
+### Object Methods |
|
| 85 |
+ |
|
| 86 |
+# Create Query |
|
| 87 |
+sub create_query {
|
|
| 88 |
+ my ($self, $template) = @_; |
|
| 89 |
+ |
|
| 90 |
+ # Parse template |
|
| 91 |
+ my $tree = $self->_parse_template($template); |
|
| 92 |
+ |
|
| 93 |
+ # Build query |
|
| 94 |
+ my $query = $self->_build_query($tree); |
|
| 95 |
+ |
|
| 96 |
+ return $query; |
|
| 97 |
+} |
|
| 98 |
+ |
|
| 99 |
+# Parse template |
|
| 100 |
+sub _parse_template {
|
|
| 101 |
+ my ($self, $template) = @_; |
|
| 102 |
+ $template ||= ''; |
|
| 103 |
+ |
|
| 104 |
+ my $tree = []; |
|
| 105 |
+ |
|
| 106 |
+ # Tags |
|
| 107 |
+ my $tag_start = quotemeta $self->tag_start; |
|
| 108 |
+ my $tag_end = quotemeta $self->tag_end; |
|
| 109 |
+ |
|
| 110 |
+ # Tokenize |
|
| 111 |
+ my $state = 'text'; |
|
| 112 |
+ |
|
| 113 |
+ # Save original template |
|
| 114 |
+ my $original_template = $template; |
|
| 115 |
+ |
|
| 116 |
+ # Parse template |
|
| 117 |
+ while ($template =~ s/([^$tag_start]*?)$tag_start([^$tag_end].*?)$tag_end//sm) {
|
|
| 118 |
+ my $text = $1; |
|
| 119 |
+ my $tag = $2; |
|
| 120 |
+ |
|
| 121 |
+ # Parse tree |
|
| 122 |
+ push @$tree, {type => 'text', tag_args => [$text]} if $text;
|
|
| 123 |
+ |
|
| 124 |
+ if ($tag) {
|
|
| 125 |
+ # Get tag name and arguments |
|
| 126 |
+ my ($tag_name, @tag_args) = split /\s+/, $tag; |
|
| 127 |
+ |
|
| 128 |
+ # Tag processor is exist? |
|
| 129 |
+ unless ($self->tag_processors->{$tag_name}) {
|
|
| 130 |
+ my $tag_syntax = $self->tag_syntax; |
|
| 131 |
+ croak("Tag '{$tag}' in SQL template is not exist.\n\n" .
|
|
| 132 |
+ "<SQL template tag syntax>\n" . |
|
| 133 |
+ "$tag_syntax\n" . |
|
| 134 |
+ "<Your SQL template>\n" . |
|
| 135 |
+ "$original_template\n\n"); |
|
| 136 |
+ } |
|
| 137 |
+ |
|
| 138 |
+ # Check tag arguments |
|
| 139 |
+ foreach my $tag_arg (@tag_args) {
|
|
| 140 |
+ # Cannot cantain placehosder '?' |
|
| 141 |
+ croak("Tag '{t }' arguments cannot contain '?'")
|
|
| 142 |
+ if $tag_arg =~ /\?/; |
|
| 143 |
+ } |
|
| 144 |
+ |
|
| 145 |
+ # Add tag to parsing tree |
|
| 146 |
+ push @$tree, {type => 'tag', tag_name => $tag_name, tag_args => [@tag_args]};
|
|
| 147 |
+ } |
|
| 148 |
+ } |
|
| 149 |
+ |
|
| 150 |
+ # Add text to parsing tree |
|
| 151 |
+ push @$tree, {type => 'text', tag_args => [$template]} if $template;
|
|
| 152 |
+ |
|
| 153 |
+ return $tree; |
|
| 154 |
+} |
|
| 155 |
+ |
|
| 156 |
+# Build SQL from parsing tree |
|
| 157 |
+sub _build_query {
|
|
| 158 |
+ my ($self, $tree) = @_; |
|
| 159 |
+ |
|
| 160 |
+ # SQL |
|
| 161 |
+ my $sql = ''; |
|
| 162 |
+ |
|
| 163 |
+ # All parameter key infomation |
|
| 164 |
+ my $all_key_infos = []; |
|
| 165 |
+ |
|
| 166 |
+ # Build SQL |
|
| 167 |
+ foreach my $node (@$tree) {
|
|
| 168 |
+ |
|
| 169 |
+ # Get type, tag name, and arguments |
|
| 170 |
+ my $type = $node->{type};
|
|
| 171 |
+ my $tag_name = $node->{tag_name};
|
|
| 172 |
+ my $tag_args = $node->{tag_args};
|
|
| 173 |
+ |
|
| 174 |
+ # Text |
|
| 175 |
+ if ($type eq 'text') {
|
|
| 176 |
+ # Join text |
|
| 177 |
+ $sql .= $tag_args->[0]; |
|
| 178 |
+ } |
|
| 179 |
+ |
|
| 180 |
+ # Tag |
|
| 181 |
+ elsif ($type eq 'tag') {
|
|
| 182 |
+ |
|
| 183 |
+ # Get tag processor |
|
| 184 |
+ my $tag_processor = $self->tag_processors->{$tag_name};
|
|
| 185 |
+ |
|
| 186 |
+ # Tag processor is code ref? |
|
| 187 |
+ croak("Tag processor '$tag_name' must be code reference")
|
|
| 188 |
+ unless ref $tag_processor eq 'CODE'; |
|
| 189 |
+ |
|
| 190 |
+ # Expand tag using tag processor |
|
| 191 |
+ my ($expand, $key_infos) |
|
| 192 |
+ = $tag_processor->($tag_name, $tag_args); |
|
| 193 |
+ |
|
| 194 |
+ # Check tag processor return value |
|
| 195 |
+ croak("Tag processor '$tag_name' must return (\$expand, \$key_infos)")
|
|
| 196 |
+ if !defined $expand || ref $key_infos ne 'ARRAY'; |
|
| 197 |
+ |
|
| 198 |
+ # Check placeholder count |
|
| 199 |
+ croak("Placeholder count in SQL created by tag processor '$tag_name' " .
|
|
| 200 |
+ "must be same as key informations count") |
|
| 201 |
+ unless $self->_placeholder_count($expand) eq @$key_infos; |
|
| 202 |
+ |
|
| 203 |
+ # Add key information |
|
| 204 |
+ push @$all_key_infos, @$key_infos; |
|
| 205 |
+ |
|
| 206 |
+ # Join expand tag to SQL |
|
| 207 |
+ $sql .= $expand; |
|
| 208 |
+ } |
|
| 209 |
+ } |
|
| 210 |
+ |
|
| 211 |
+ # Add semicolon |
|
| 212 |
+ $sql .= ';' unless $sql =~ /;$/; |
|
| 213 |
+ |
|
| 214 |
+ # Query |
|
| 215 |
+ my $query = {sql => $sql, key_infos => $all_key_infos};
|
|
| 216 |
+ |
|
| 217 |
+ return $query; |
|
| 218 |
+} |
|
| 219 |
+ |
|
| 220 |
+# Get placeholder count |
|
| 221 |
+sub _placeholder_count {
|
|
| 222 |
+ my ($self, $expand) = @_; |
|
| 223 |
+ $expand ||= ''; |
|
| 224 |
+ |
|
| 225 |
+ my $count = 0; |
|
| 226 |
+ my $pos = -1; |
|
| 227 |
+ while (($pos = index($expand, '?', $pos + 1)) != -1) {
|
|
| 228 |
+ $count++; |
|
| 229 |
+ } |
|
| 230 |
+ return $count; |
|
| 231 |
+} |
|
| 232 |
+ |
|
| 233 |
+Object::Simple->build_class; |
|
| 234 |
+ |
|
| 235 |
+ |
|
| 236 |
+package DBIx::Custom::SQL::Template::TagProcessor; |
|
| 237 |
+use strict; |
|
| 238 |
+use warnings; |
|
| 239 |
+use Carp 'croak'; |
|
| 240 |
+ |
|
| 241 |
+# Expand tag '?', '=', '<>', '>', '<', '>=', '<=', 'like' |
|
| 242 |
+sub expand_basic_tag {
|
|
| 243 |
+ my ($tag_name, $tag_args) = @_; |
|
| 244 |
+ my $original_key = $tag_args->[0]; |
|
| 245 |
+ |
|
| 246 |
+ # Key is not exist |
|
| 247 |
+ croak("You must be pass key as argument to tag '{$tag_name }'")
|
|
| 248 |
+ if !$original_key; |
|
| 249 |
+ |
|
| 250 |
+ # Expanded tag |
|
| 251 |
+ my $expand = $tag_name eq '?' |
|
| 252 |
+ ? '?' |
|
| 253 |
+ : "$original_key $tag_name ?"; |
|
| 254 |
+ |
|
| 255 |
+ # Get table and clumn name |
|
| 256 |
+ my ($table, $column) = get_table_and_column($original_key); |
|
| 257 |
+ |
|
| 258 |
+ # Parameter key infomation |
|
| 259 |
+ my $key_info = {};
|
|
| 260 |
+ |
|
| 261 |
+ # Original key |
|
| 262 |
+ $key_info->{original_key} = $original_key;
|
|
| 263 |
+ |
|
| 264 |
+ # Table |
|
| 265 |
+ $key_info->{table} = $table;
|
|
| 266 |
+ |
|
| 267 |
+ # Column name |
|
| 268 |
+ $key_info->{column} = $column;
|
|
| 269 |
+ |
|
| 270 |
+ # Access keys |
|
| 271 |
+ my $access_keys = []; |
|
| 272 |
+ push @$access_keys, [$original_key]; |
|
| 273 |
+ push @$access_keys, [$table, $column] if $table && $column; |
|
| 274 |
+ $key_info->{access_keys} = $access_keys;
|
|
| 275 |
+ |
|
| 276 |
+ # Add parameter key information |
|
| 277 |
+ my $key_infos = []; |
|
| 278 |
+ push @$key_infos, $key_info; |
|
| 279 |
+ |
|
| 280 |
+ return ($expand, $key_infos); |
|
| 281 |
+} |
|
| 282 |
+ |
|
| 283 |
+# Expand tag 'in' |
|
| 284 |
+sub expand_in_tag {
|
|
| 285 |
+ my ($tag_name, $tag_args) = @_; |
|
| 286 |
+ my ($original_key, $placeholder_count) = @$tag_args; |
|
| 287 |
+ |
|
| 288 |
+ # Key must be specified |
|
| 289 |
+ croak("You must be pass key as first argument of tag '{$tag_name }'\n" .
|
|
| 290 |
+ "Usage: {$tag_name \$key \$placeholder_count}")
|
|
| 291 |
+ unless $original_key; |
|
| 292 |
+ |
|
| 293 |
+ |
|
| 294 |
+ # Place holder count must be specified |
|
| 295 |
+ croak("You must be pass placeholder count as second argument of tag '{$tag_name }'\n" .
|
|
| 296 |
+ "Usage: {$tag_name \$key \$placeholder_count}")
|
|
| 297 |
+ if !$placeholder_count || $placeholder_count =~ /\D/; |
|
| 298 |
+ |
|
| 299 |
+ # Expand tag |
|
| 300 |
+ my $expand = "$original_key $tag_name (";
|
|
| 301 |
+ for (my $i = 0; $i < $placeholder_count; $i++) {
|
|
| 302 |
+ $expand .= '?, '; |
|
| 303 |
+ } |
|
| 304 |
+ |
|
| 305 |
+ $expand =~ s/, $//; |
|
| 306 |
+ $expand .= ')'; |
|
| 307 |
+ |
|
| 308 |
+ # Get table and clumn name |
|
| 309 |
+ my ($table, $column) = get_table_and_column($original_key); |
|
| 310 |
+ |
|
| 311 |
+ # Create parameter key infomations |
|
| 312 |
+ my $key_infos = []; |
|
| 313 |
+ for (my $i = 0; $i < $placeholder_count; $i++) {
|
|
| 314 |
+ # Parameter key infomation |
|
| 315 |
+ my $key_info = {};
|
|
| 316 |
+ |
|
| 317 |
+ # Original key |
|
| 318 |
+ $key_info->{original_key} = $original_key;
|
|
| 319 |
+ |
|
| 320 |
+ # Table |
|
| 321 |
+ $key_info->{table} = $table;
|
|
| 322 |
+ |
|
| 323 |
+ # Column name |
|
| 324 |
+ $key_info->{column} = $column;
|
|
| 325 |
+ |
|
| 326 |
+ # Access keys |
|
| 327 |
+ my $access_keys = []; |
|
| 328 |
+ push @$access_keys, [$original_key, [$i]]; |
|
| 329 |
+ push @$access_keys, [$table, $column, [$i]] if $table && $column; |
|
| 330 |
+ $key_info->{access_keys} = $access_keys;
|
|
| 331 |
+ |
|
| 332 |
+ # Add parameter key infos |
|
| 333 |
+ push @$key_infos, $key_info; |
|
| 334 |
+ } |
|
| 335 |
+ |
|
| 336 |
+ return ($expand, $key_infos); |
|
| 337 |
+} |
|
| 338 |
+ |
|
| 339 |
+# Get table and column |
|
| 340 |
+sub get_table_and_column {
|
|
| 341 |
+ my $key = shift; |
|
| 342 |
+ $key ||= ''; |
|
| 343 |
+ |
|
| 344 |
+ return ('', $key) unless $key =~ /\./;
|
|
| 345 |
+ |
|
| 346 |
+ my ($table, $column) = split /\./, $key; |
|
| 347 |
+ |
|
| 348 |
+ return ($table, $column); |
|
| 349 |
+} |
|
| 350 |
+ |
|
| 351 |
+# Expand tag 'insert' |
|
| 352 |
+sub expand_insert_tag {
|
|
| 353 |
+ my ($tag_name, $tag_args) = @_; |
|
| 354 |
+ my $original_keys = $tag_args; |
|
| 355 |
+ |
|
| 356 |
+ # Insert key (k1, k2, k3, ..) |
|
| 357 |
+ my $insert_keys = '(';
|
|
| 358 |
+ |
|
| 359 |
+ # placeholder (?, ?, ?, ..) |
|
| 360 |
+ my $place_holders = '(';
|
|
| 361 |
+ |
|
| 362 |
+ foreach my $original_key (@$original_keys) {
|
|
| 363 |
+ # Get table and column |
|
| 364 |
+ my ($table, $column) = get_table_and_column($original_key); |
|
| 365 |
+ |
|
| 366 |
+ # Join insert column |
|
| 367 |
+ $insert_keys .= "$column, "; |
|
| 368 |
+ |
|
| 369 |
+ # Join place holder |
|
| 370 |
+ $place_holders .= "?, "; |
|
| 371 |
+ } |
|
| 372 |
+ |
|
| 373 |
+ # Delete last ', ' |
|
| 374 |
+ $insert_keys =~ s/, $//; |
|
| 375 |
+ |
|
| 376 |
+ # Close |
|
| 377 |
+ $insert_keys .= ')'; |
|
| 378 |
+ $place_holders =~ s/, $//; |
|
| 379 |
+ $place_holders .= ')'; |
|
| 380 |
+ |
|
| 381 |
+ # Expand tag |
|
| 382 |
+ my $expand = "$insert_keys values $place_holders"; |
|
| 383 |
+ |
|
| 384 |
+ # Create parameter key infomations |
|
| 385 |
+ my $key_infos = []; |
|
| 386 |
+ foreach my $original_key (@$original_keys) {
|
|
| 387 |
+ # Get table and clumn name |
|
| 388 |
+ my ($table, $column) = get_table_and_column($original_key); |
|
| 389 |
+ |
|
| 390 |
+ # Parameter key infomation |
|
| 391 |
+ my $key_info = {};
|
|
| 392 |
+ |
|
| 393 |
+ # Original key |
|
| 394 |
+ $key_info->{original_key} = $original_key;
|
|
| 395 |
+ |
|
| 396 |
+ # Table |
|
| 397 |
+ $key_info->{table} = $table;
|
|
| 398 |
+ |
|
| 399 |
+ # Column name |
|
| 400 |
+ $key_info->{column} = $column;
|
|
| 401 |
+ |
|
| 402 |
+ # Access keys |
|
| 403 |
+ my $access_keys = []; |
|
| 404 |
+ push @$access_keys, ['#insert', $original_key]; |
|
| 405 |
+ push @$access_keys, ['#insert', $table, $column] if $table && $column; |
|
| 406 |
+ push @$access_keys, [$original_key]; |
|
| 407 |
+ push @$access_keys, [$table, $column] if $table && $column; |
|
| 408 |
+ $key_info->{access_keys} = $access_keys;
|
|
| 409 |
+ |
|
| 410 |
+ # Add parameter key infos |
|
| 411 |
+ push @$key_infos, $key_info; |
|
| 412 |
+ } |
|
| 413 |
+ |
|
| 414 |
+ return ($expand, $key_infos); |
|
| 415 |
+} |
|
| 416 |
+ |
|
| 417 |
+# Expand tag 'update' |
|
| 418 |
+sub expand_update_tag {
|
|
| 419 |
+ my ($tag_name, $tag_args) = @_; |
|
| 420 |
+ my $original_keys = $tag_args; |
|
| 421 |
+ |
|
| 422 |
+ # Expanded tag |
|
| 423 |
+ my $expand = 'set '; |
|
| 424 |
+ |
|
| 425 |
+ # |
|
| 426 |
+ foreach my $original_key (@$original_keys) {
|
|
| 427 |
+ # Get table and clumn name |
|
| 428 |
+ my ($table, $column) = get_table_and_column($original_key); |
|
| 429 |
+ |
|
| 430 |
+ # Join key and placeholder |
|
| 431 |
+ $expand .= "$column = ?, "; |
|
| 432 |
+ } |
|
| 433 |
+ |
|
| 434 |
+ # Delete last ', ' |
|
| 435 |
+ $expand =~ s/, $//; |
|
| 436 |
+ |
|
| 437 |
+ # Create parameter key infomations |
|
| 438 |
+ my $key_infos = []; |
|
| 439 |
+ foreach my $original_key (@$original_keys) {
|
|
| 440 |
+ # Get table and clumn name |
|
| 441 |
+ my ($table, $column) = get_table_and_column($original_key); |
|
| 442 |
+ |
|
| 443 |
+ # Parameter key infomation |
|
| 444 |
+ my $key_info = {};
|
|
| 445 |
+ |
|
| 446 |
+ # Original key |
|
| 447 |
+ $key_info->{original_key} = $original_key;
|
|
| 448 |
+ |
|
| 449 |
+ # Table |
|
| 450 |
+ $key_info->{table} = $table;
|
|
| 451 |
+ |
|
| 452 |
+ # Column name |
|
| 453 |
+ $key_info->{column} = $column;
|
|
| 454 |
+ |
|
| 455 |
+ # Access keys |
|
| 456 |
+ my $access_keys = []; |
|
| 457 |
+ push @$access_keys, ['#update', $original_key]; |
|
| 458 |
+ push @$access_keys, ['#update', $table, $column] if $table && $column; |
|
| 459 |
+ push @$access_keys, [$original_key]; |
|
| 460 |
+ push @$access_keys, [$table, $column] if $table && $column; |
|
| 461 |
+ $key_info->{access_keys} = $access_keys;
|
|
| 462 |
+ |
|
| 463 |
+ # Add parameter key infos |
|
| 464 |
+ push @$key_infos, $key_info; |
|
| 465 |
+ } |
|
| 466 |
+ |
|
| 467 |
+ return ($expand, $key_infos); |
|
| 468 |
+} |
|
| 469 |
+ |
|
| 470 |
+1; |
|
| 471 |
+ |
|
| 472 |
+=head1 NAME |
|
| 473 |
+ |
|
| 474 |
+DBIx::Custom::SQL::Template - Custamizable SQL Template for DBIx::Custom |
|
| 475 |
+ |
|
| 476 |
+=head1 VERSION |
|
| 477 |
+ |
|
| 478 |
+Version 0.0101 |
|
| 479 |
+ |
|
| 480 |
+=cut |
|
| 481 |
+ |
|
| 482 |
+=head1 SYNOPSIS |
|
| 483 |
+ |
|
| 484 |
+ my $sql_tmpl = DBIx::Custom::SQL::Template->new; |
|
| 485 |
+ |
|
| 486 |
+ my $tmpl = "select from table {= k1} && {<> k2} || {like k3}";
|
|
| 487 |
+ my $param = {k1 => 1, k2 => 2, k3 => 3};
|
|
| 488 |
+ |
|
| 489 |
+ my $query = $sql_template->create_query($tmpl); |
|
| 490 |
+ |
|
| 491 |
+ |
|
| 492 |
+ # Using query from DBIx::Custom |
|
| 493 |
+ use DBIx::Custom; |
|
| 494 |
+ my $dbi = DBI->new( |
|
| 495 |
+ data_source => $data_source, |
|
| 496 |
+ user => $user, |
|
| 497 |
+ password => $password, |
|
| 498 |
+ dbi_options => {PrintError => 0, RaiseError => 1}
|
|
| 499 |
+ ); |
|
| 500 |
+ |
|
| 501 |
+ $query = $dbi->create_query($tmpl); # This is SQL::Template create_query |
|
| 502 |
+ $dbi->query($query, $param); |
|
| 503 |
+ |
|
| 504 |
+=head1 CLASS-OBJECT ACCESSORS |
|
| 505 |
+ |
|
| 506 |
+Class-Object accessor is used from both object and class |
|
| 507 |
+ |
|
| 508 |
+ $class->$accessor # call from class |
|
| 509 |
+ $self->$accessor # call form object |
|
| 510 |
+ |
|
| 511 |
+=head2 tag_processors |
|
| 512 |
+ |
|
| 513 |
+ # Set and get |
|
| 514 |
+ $self = $sql_tmpl->tag_processors($tag_processors); |
|
| 515 |
+ $tag_processors = $sql_tmpl->tag_processors; |
|
| 516 |
+ |
|
| 517 |
+ # Sample |
|
| 518 |
+ $sql_tmpl->tag_processors( |
|
| 519 |
+ '?' => \&expand_question, |
|
| 520 |
+ '=' => \&expand_equel |
|
| 521 |
+ ); |
|
| 522 |
+ |
|
| 523 |
+You can use add_tag_processor to add tag processor |
|
| 524 |
+ |
|
| 525 |
+=head2 tag_start |
|
| 526 |
+ |
|
| 527 |
+ # Set and get |
|
| 528 |
+ $self = $sql_tmpl->tag_start($tag_start); |
|
| 529 |
+ $tag_start = $sql_tmpl->tag_start; |
|
| 530 |
+ |
|
| 531 |
+ # Sample |
|
| 532 |
+ $sql_tmpl->tag_start('{');
|
|
| 533 |
+ |
|
| 534 |
+Default is '{'
|
|
| 535 |
+ |
|
| 536 |
+=head2 tag_end |
|
| 537 |
+ |
|
| 538 |
+ # Set and get |
|
| 539 |
+ $self = $sql_tmpl->tag_start($tag_end); |
|
| 540 |
+ $tag_end = $sql_tmpl->tag_start; |
|
| 541 |
+ |
|
| 542 |
+ # Sample |
|
| 543 |
+ $sql_tmpl->tag_start('}');
|
|
| 544 |
+ |
|
| 545 |
+Default is '}' |
|
| 546 |
+ |
|
| 547 |
+=head2 tag_syntax |
|
| 548 |
+ |
|
| 549 |
+ # Set and get |
|
| 550 |
+ $self = $sql_tmpl->tag_syntax($tag_syntax); |
|
| 551 |
+ $tag_syntax = $sql_tmpl->tag_syntax; |
|
| 552 |
+ |
|
| 553 |
+ # Sample |
|
| 554 |
+ $sql_tmpl->tag_syntax( |
|
| 555 |
+ "[Tag] [Expand]\n" . |
|
| 556 |
+ "{? name} ?\n" .
|
|
| 557 |
+ "{= name} name = ?\n" .
|
|
| 558 |
+ "{<> name} name <> ?\n"
|
|
| 559 |
+ ); |
|
| 560 |
+ |
|
| 561 |
+=head1 METHODS |
|
| 562 |
+ |
|
| 563 |
+=head2 create_query |
|
| 564 |
+ |
|
| 565 |
+ # Create SQL form SQL template |
|
| 566 |
+ $query = $sql_tmpl->create_query($tmpl); |
|
| 567 |
+ |
|
| 568 |
+ # Sample |
|
| 569 |
+ $query = $sql_tmpl->create_sql( |
|
| 570 |
+ "select * from table where {= title} && {like author} || {<= price}")
|
|
| 571 |
+ |
|
| 572 |
+ # Result |
|
| 573 |
+ $qeury->{sql} : "select * from table where title = ? && author like ? price <= ?;"
|
|
| 574 |
+ $query->{key_infos} : [['title'], ['author'], ['price']]
|
|
| 575 |
+ |
|
| 576 |
+ # Sample2 (with table name) |
|
| 577 |
+ ($sql, @bind_values) = $sql_tmpl->create_sql( |
|
| 578 |
+ "select * from table where {= table.title} && {like table.author}",
|
|
| 579 |
+ {table => {title => 'Perl', author => '%Taro%'}}
|
|
| 580 |
+ ) |
|
| 581 |
+ |
|
| 582 |
+ # Result2 |
|
| 583 |
+ $query->{sql} : "select * from table where table.title = ? && table.title like ?;"
|
|
| 584 |
+ $query->{key_infos} :[ [['table.title'],['table', 'title']],
|
|
| 585 |
+ [['table.author'],['table', 'author']] ] |
|
| 586 |
+ |
|
| 587 |
+This method create query using by DBIx::Custom. |
|
| 588 |
+query is two infomation |
|
| 589 |
+ |
|
| 590 |
+ 1.sql : SQL |
|
| 591 |
+ 2.key_infos : Parameter access key information |
|
| 592 |
+ |
|
| 593 |
+=head2 add_tag_processor |
|
| 594 |
+ |
|
| 595 |
+Add tag processor |
|
| 596 |
+ |
|
| 597 |
+ # Add |
|
| 598 |
+ $self = $sql_tmpl->add_tag_processor($tag_processor); |
|
| 599 |
+ |
|
| 600 |
+ # Sample |
|
| 601 |
+ $sql_tmpl->add_tag_processor( |
|
| 602 |
+ '?' => sub {
|
|
| 603 |
+ my ($tag_name, $tag_args) = @_; |
|
| 604 |
+ |
|
| 605 |
+ my $key1 = $tag_args->[0]; |
|
| 606 |
+ my $key2 = $tag_args->[1]; |
|
| 607 |
+ |
|
| 608 |
+ my $key_infos = []; |
|
| 609 |
+ |
|
| 610 |
+ # Expand tag and create key informations |
|
| 611 |
+ |
|
| 612 |
+ # Return expand tags and key informations |
|
| 613 |
+ return ($expand, $key_infos); |
|
| 614 |
+ } |
|
| 615 |
+ ); |
|
| 616 |
+ |
|
| 617 |
+Tag processor recieve 2 argument |
|
| 618 |
+ |
|
| 619 |
+ 1. Tag name (?, =, <>, or etc) |
|
| 620 |
+ 2. Tag arguments (arg1 and arg2 in {tag_name arg1 arg2})
|
|
| 621 |
+ |
|
| 622 |
+Tag processor return 2 value |
|
| 623 |
+ |
|
| 624 |
+ 1. Expanded Tag (For exsample, '{= title}' is expanded to 'title = ?')
|
|
| 625 |
+ 2. Key infomations |
|
| 626 |
+ |
|
| 627 |
+You must be return expanded tag and key infomations. |
|
| 628 |
+ |
|
| 629 |
+Key information is a little complex. so I will explan this in future. |
|
| 630 |
+ |
|
| 631 |
+If you want to know more, Please see DBIx::Custom::SQL::Template source code. |
|
| 632 |
+ |
|
| 633 |
+=head2 clone |
|
| 634 |
+ |
|
| 635 |
+ # Clone DBIx::Custom::SQL::Template object |
|
| 636 |
+ $clone = $self->clone; |
|
| 637 |
+ |
|
| 638 |
+=head1 Available Tags |
|
| 639 |
+ |
|
| 640 |
+ # Available Tags |
|
| 641 |
+ [tag] [expand] |
|
| 642 |
+ {? name} ?
|
|
| 643 |
+ {= name} name = ?
|
|
| 644 |
+ {<> name} name <> ?
|
|
| 645 |
+ |
|
| 646 |
+ {< name} name < ?
|
|
| 647 |
+ {> name} name > ?
|
|
| 648 |
+ {>= name} name >= ?
|
|
| 649 |
+ {<= name} name <= ?
|
|
| 650 |
+ |
|
| 651 |
+ {like name} name like ?
|
|
| 652 |
+ {in name} name in [?, ?, ..]
|
|
| 653 |
+ |
|
| 654 |
+ {insert} (key1, key2, key3) values (?, ?, ?)
|
|
| 655 |
+ {update} set key1 = ?, key2 = ?, key3 = ?
|
|
| 656 |
+ |
|
| 657 |
+ # Sample1 |
|
| 658 |
+ $query = $sql_tmpl->create_sql( |
|
| 659 |
+ "insert into table {insert key1 key2}"
|
|
| 660 |
+ ); |
|
| 661 |
+ # Result1 |
|
| 662 |
+ $sql : "insert into table (key1, key2) values (?, ?)" |
|
| 663 |
+ |
|
| 664 |
+ |
|
| 665 |
+ # Sample2 |
|
| 666 |
+ $query = $sql_tmpl->create_sql( |
|
| 667 |
+ "update table {update key1 key2} where {= key3}"
|
|
| 668 |
+ ); |
|
| 669 |
+ |
|
| 670 |
+ # Result2 |
|
| 671 |
+ $query->{sql} : "update table set key1 = ?, key2 = ? where key3 = ?;"
|
|
| 672 |
+ |
|
| 673 |
+=head1 AUTHOR |
|
| 674 |
+ |
|
| 675 |
+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >> |
|
| 676 |
+ |
|
| 677 |
+Github |
|
| 678 |
+L<http://github.com/yuki-kimoto> |
|
| 679 |
+L<http://github.com/yuki-kimoto/DBIx-Custom-SQL-Template> |
|
| 680 |
+ |
|
| 681 |
+Please let know me bag if you find |
|
| 682 |
+Please request me if you want to do something |
|
| 683 |
+ |
|
| 684 |
+=head1 COPYRIGHT & LICENSE |
|
| 685 |
+ |
|
| 686 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 687 |
+ |
|
| 688 |
+This program is free software; you can redistribute it and/or modify it |
|
| 689 |
+under the same terms as Perl itself. |
|
| 690 |
+ |
|
| 691 |
+ |
|
| 692 |
+=cut |
|
| 693 |
+ |
|
| 694 |
+1; # End of DBIx::Custom::SQL::Template |
| ... | ... |
@@ -0,0 +1,136 @@ |
| 1 |
+package DBIx::Custom::SQLite; |
|
| 2 |
+use base 'DBIx::Custom::Basic'; |
|
| 3 |
+ |
|
| 4 |
+use warnings; |
|
| 5 |
+use strict; |
|
| 6 |
+use Carp 'croak'; |
|
| 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 |
+sub connect {
|
|
| 17 |
+ my $self = shift; |
|
| 18 |
+ |
|
| 19 |
+ if (!$self->data_source && (my $database = $self->database)) {
|
|
| 20 |
+ $self->data_source("dbi:SQLite:dbname=$database");
|
|
| 21 |
+ } |
|
| 22 |
+ |
|
| 23 |
+ return $self->SUPER::connect; |
|
| 24 |
+} |
|
| 25 |
+ |
|
| 26 |
+sub connect_memory {
|
|
| 27 |
+ my $self = shift; |
|
| 28 |
+ |
|
| 29 |
+ # Data source for memory database |
|
| 30 |
+ $self->data_source('dbi:SQLite:dbname=:memory:');
|
|
| 31 |
+ |
|
| 32 |
+ # Already connected |
|
| 33 |
+ croak("Already connected") if $self->connected;
|
|
| 34 |
+ |
|
| 35 |
+ # Connect |
|
| 36 |
+ $self->connect; |
|
| 37 |
+ |
|
| 38 |
+ return $self; |
|
| 39 |
+} |
|
| 40 |
+ |
|
| 41 |
+sub reconnect_memory {
|
|
| 42 |
+ my $self = shift; |
|
| 43 |
+ |
|
| 44 |
+ # Data source for memory database |
|
| 45 |
+ $self->data_source('dbi:SQLite:dbname=:memory:');
|
|
| 46 |
+ |
|
| 47 |
+ # Reconnect |
|
| 48 |
+ $self->reconnect; |
|
| 49 |
+ |
|
| 50 |
+ return $self; |
|
| 51 |
+} |
|
| 52 |
+ |
|
| 53 |
+ |
|
| 54 |
+=head1 NAME |
|
| 55 |
+ |
|
| 56 |
+DBIx::Custom::SQLite - DBIx::Custom SQLite implementation |
|
| 57 |
+ |
|
| 58 |
+=head1 Version |
|
| 59 |
+ |
|
| 60 |
+Version 0.0201 |
|
| 61 |
+ |
|
| 62 |
+=head1 Synopsys |
|
| 63 |
+ |
|
| 64 |
+ use DBIx::Custom::SQLite; |
|
| 65 |
+ |
|
| 66 |
+ # New |
|
| 67 |
+ my $dbi = DBIx::Custom::SQLite->new(user => 'taro', $password => 'kliej&@K', |
|
| 68 |
+ database => 'sample.db'); |
|
| 69 |
+ |
|
| 70 |
+ # Insert |
|
| 71 |
+ $dbi->insert('books', {title => 'perl', author => 'taro'});
|
|
| 72 |
+ |
|
| 73 |
+ # Update |
|
| 74 |
+ # same as 'update books set (title = 'aaa', author = 'ken') where id = 5; |
|
| 75 |
+ $dbi->update('books', {title => 'aaa', author => 'ken'}, {id => 5});
|
|
| 76 |
+ |
|
| 77 |
+ # Delete |
|
| 78 |
+ $dbi->delete('books', {author => 'taro'});
|
|
| 79 |
+ |
|
| 80 |
+ # select * from books; |
|
| 81 |
+ $dbi->select('books');
|
|
| 82 |
+ |
|
| 83 |
+ # select * from books where ahthor = 'taro'; |
|
| 84 |
+ $dbi->select('books', {author => 'taro'});
|
|
| 85 |
+ |
|
| 86 |
+ # select author, title from books where author = 'taro' |
|
| 87 |
+ $dbi->select('books', [qw/author title/], {author => 'taro'});
|
|
| 88 |
+ |
|
| 89 |
+ # select author, title from books where author = 'taro' order by id limit 1; |
|
| 90 |
+ $dbi->select('books', [qw/author title/], {author => 'taro'},
|
|
| 91 |
+ 'order by id limit 1'); |
|
| 92 |
+ |
|
| 93 |
+=head1 See DBIx::Custom and DBI::Custom::Basic documentation |
|
| 94 |
+ |
|
| 95 |
+This class is L<DBIx::Custom::Basic> subclass. |
|
| 96 |
+and L<DBIx::Custom::Basic> is L<DBIx::Custom> subclass |
|
| 97 |
+ |
|
| 98 |
+You can use all methods of L<DBIx::Custom::Basic> and <DBIx::Custom> |
|
| 99 |
+Please see L<DBIx::Custom::Basic> and <DBIx::Custom> documentation |
|
| 100 |
+ |
|
| 101 |
+=head1 Object methods |
|
| 102 |
+ |
|
| 103 |
+=head2 connect |
|
| 104 |
+ |
|
| 105 |
+This override L<DBIx::Custom> connect. |
|
| 106 |
+ |
|
| 107 |
+ # Connect to database |
|
| 108 |
+ $dbi->connect; |
|
| 109 |
+ |
|
| 110 |
+If database attribute is set, automatically data source is created and connect |
|
| 111 |
+ |
|
| 112 |
+=head2 connect_memory |
|
| 113 |
+ |
|
| 114 |
+ # Connect memory database |
|
| 115 |
+ $self = $dbi->connect_memory; |
|
| 116 |
+ |
|
| 117 |
+=head2 reconnect_memory |
|
| 118 |
+ |
|
| 119 |
+ # Reconnect memory database |
|
| 120 |
+ $self = $dbi->reconnect_memory; |
|
| 121 |
+ |
|
| 122 |
+=head1 Author |
|
| 123 |
+ |
|
| 124 |
+Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >> |
|
| 125 |
+ |
|
| 126 |
+Github L<http://github.com/yuki-kimoto> |
|
| 127 |
+ |
|
| 128 |
+I develope this module L<http://github.com/yuki-kimoto/DBIx-Custom> |
|
| 129 |
+ |
|
| 130 |
+=head1 Copyright & lisence |
|
| 131 |
+ |
|
| 132 |
+Copyright 2009 Yuki Kimoto, all rights reserved. |
|
| 133 |
+ |
|
| 134 |
+This program is free software; you can redistribute it and/or modify it |
|
| 135 |
+under the same terms as Perl itself. |
|
| 136 |
+ |
| ... | ... |
@@ -0,0 +1,15 @@ |
| 1 |
+#!perl -T |
|
| 2 |
+ |
|
| 3 |
+use Test::More tests => 7; |
|
| 4 |
+ |
|
| 5 |
+BEGIN {
|
|
| 6 |
+ use_ok( 'DBIx::Custom' ); |
|
| 7 |
+ use_ok( 'DBIx::Custom::Basic' ); |
|
| 8 |
+ use_ok( 'DBIx::Custom::MySQL' ); |
|
| 9 |
+ use_ok( 'DBIx::Custom::Query' ); |
|
| 10 |
+ use_ok( 'DBIx::Custom::Result' ); |
|
| 11 |
+ use_ok( 'DBIx::Custom::SQL::Template' ); |
|
| 12 |
+ use_ok( 'DBIx::Custom::SQLite' ); |
|
| 13 |
+} |
|
| 14 |
+ |
|
| 15 |
+diag( "Testing DBIx::Custom $DBIx::Custom::VERSION, Perl $], $^X" ); |
| ... | ... |
@@ -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.pm');
|
|
| 50 |
+ |
|
| 51 |
+ |
| ... | ... |
@@ -0,0 +1,67 @@ |
| 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->{encode_utf8}, "$test : exists default_bind_filter");
|
|
| 53 |
+ok($dbi->filters->{decode_utf8}, "$test : exists default_fetch_filter");
|
|
| 54 |
+ |
|
| 55 |
+$dbi->utf8_filter_on; |
|
| 56 |
+is($dbi->bind_filter, $dbi->filters->{encode_utf8}, 'default bind filter');
|
|
| 57 |
+is($dbi->fetch_filter, $dbi->filters->{decode_utf8}, 'default fetch filter');
|
|
| 58 |
+ |
|
| 59 |
+$decoded_str = 'あ'; |
|
| 60 |
+$encoded_str = $dbi->bind_filter->($decoded_str); |
|
| 61 |
+is($encoded_str, encode('UTF-8', $decoded_str), "$test : encode utf8");
|
|
| 62 |
+is($decoded_str, $dbi->fetch_filter->($encoded_str), "$test : fetch_filter"); |
|
| 63 |
+ |
|
| 64 |
+$decoded_str = 'a'; |
|
| 65 |
+$encoded_str = $dbi->bind_filter->($decoded_str); |
|
| 66 |
+is($encoded_str, encode('UTF-8', $decoded_str), "$test : upgrade and encode utf8");
|
|
| 67 |
+is($decoded_str, $dbi->fetch_filter->($encoded_str), "$test : fetch_filter"); |
| ... | ... |
@@ -0,0 +1,36 @@ |
| 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 |
+use DBIx::Custom; |
|
| 13 |
+use Scalar::Util 'blessed'; |
|
| 14 |
+{
|
|
| 15 |
+ my $dbi = DBIx::Custom->new( |
|
| 16 |
+ user => $USER, |
|
| 17 |
+ password => $PASSWORD, |
|
| 18 |
+ data_source => "dbi:mysql:dbname=$DATABASE" |
|
| 19 |
+ ); |
|
| 20 |
+ $dbi->connect; |
|
| 21 |
+ |
|
| 22 |
+ ok(blessed $dbi->dbh); |
|
| 23 |
+ can_ok($dbi->dbh, qw/prepare/); |
|
| 24 |
+} |
|
| 25 |
+ |
|
| 26 |
+sub connect_info {
|
|
| 27 |
+ my $file = 'password.tmp'; |
|
| 28 |
+ open my $fh, '<', $file |
|
| 29 |
+ or return; |
|
| 30 |
+ |
|
| 31 |
+ my ($user, $password, $database) = split(/\s/, (<$fh>)[0]); |
|
| 32 |
+ |
|
| 33 |
+ close $fh; |
|
| 34 |
+ |
|
| 35 |
+ return ($user, $password, $database); |
|
| 36 |
+} |
| ... | ... |
@@ -0,0 +1,716 @@ |
| 1 |
+use Test::More; |
|
| 2 |
+use strict; |
|
| 3 |
+use warnings; |
|
| 4 |
+ |
|
| 5 |
+BEGIN {
|
|
| 6 |
+ eval { require DBD::SQLite; 1 }
|
|
| 7 |
+ or plan skip_all => 'DBD::SQLite required'; |
|
| 8 |
+ eval { DBD::SQLite->VERSION >= 1.25 }
|
|
| 9 |
+ or plan skip_all => 'DBD::SQLite >= 1.25 required'; |
|
| 10 |
+ |
|
| 11 |
+ plan 'no_plan'; |
|
| 12 |
+ use_ok('DBIx::Custom');
|
|
| 13 |
+} |
|
| 14 |
+ |
|
| 15 |
+# Function for test name |
|
| 16 |
+my $test; |
|
| 17 |
+sub test {
|
|
| 18 |
+ $test = shift; |
|
| 19 |
+} |
|
| 20 |
+ |
|
| 21 |
+# Constant varialbes for test |
|
| 22 |
+my $CREATE_TABLE = {
|
|
| 23 |
+ 0 => 'create table table1 (key1 char(255), key2 char(255));', |
|
| 24 |
+ 1 => 'create table table1 (key1 char(255), key2 char(255), key3 char(255), key4 char(255), key5 char(255));', |
|
| 25 |
+ 2 => 'create table table2 (key1 char(255), key3 char(255));' |
|
| 26 |
+}; |
|
| 27 |
+ |
|
| 28 |
+my $SELECT_TMPL = {
|
|
| 29 |
+ 0 => 'select * from table1;' |
|
| 30 |
+}; |
|
| 31 |
+ |
|
| 32 |
+my $DROP_TABLE = {
|
|
| 33 |
+ 0 => 'drop table table1' |
|
| 34 |
+}; |
|
| 35 |
+ |
|
| 36 |
+my $NEW_ARGS = {
|
|
| 37 |
+ 0 => {data_source => 'dbi:SQLite:dbname=:memory:'}
|
|
| 38 |
+}; |
|
| 39 |
+ |
|
| 40 |
+# Variables for test |
|
| 41 |
+my $dbi; |
|
| 42 |
+my $sth; |
|
| 43 |
+my $tmpl; |
|
| 44 |
+my @tmpls; |
|
| 45 |
+my $select_tmpl; |
|
| 46 |
+my $insert_tmpl; |
|
| 47 |
+my $update_tmpl; |
|
| 48 |
+my $params; |
|
| 49 |
+my $sql; |
|
| 50 |
+my $result; |
|
| 51 |
+my @rows; |
|
| 52 |
+my $rows; |
|
| 53 |
+my $query; |
|
| 54 |
+my @queries; |
|
| 55 |
+my $select_query; |
|
| 56 |
+my $insert_query; |
|
| 57 |
+my $update_query; |
|
| 58 |
+my $ret_val; |
|
| 59 |
+ |
|
| 60 |
+ |
|
| 61 |
+test 'disconnect'; |
|
| 62 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 63 |
+$dbi->connect; |
|
| 64 |
+$dbi->disconnect; |
|
| 65 |
+ok(!$dbi->dbh, $test); |
|
| 66 |
+ |
|
| 67 |
+ |
|
| 68 |
+test 'connected'; |
|
| 69 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 70 |
+ok(!$dbi->connected, "$test : not connected"); |
|
| 71 |
+$dbi->connect; |
|
| 72 |
+ok($dbi->connected, "$test : connected"); |
|
| 73 |
+ |
|
| 74 |
+ |
|
| 75 |
+test 'preapare'; |
|
| 76 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 77 |
+$sth = $dbi->prepare($CREATE_TABLE->{0});
|
|
| 78 |
+ok($sth, "$test : auto connect"); |
|
| 79 |
+$sth->execute; |
|
| 80 |
+$sth = $dbi->prepare($DROP_TABLE->{0});
|
|
| 81 |
+ok($sth, "$test : basic"); |
|
| 82 |
+ |
|
| 83 |
+ |
|
| 84 |
+test 'do'; |
|
| 85 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 86 |
+$ret_val = $dbi->do($CREATE_TABLE->{0});
|
|
| 87 |
+ok(defined $ret_val, "$test : auto connect"); |
|
| 88 |
+$ret_val = $dbi->do($DROP_TABLE->{0});
|
|
| 89 |
+ok(defined $ret_val, "$test : basic"); |
|
| 90 |
+ |
|
| 91 |
+ |
|
| 92 |
+# Prepare table |
|
| 93 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 94 |
+$dbi->connect; |
|
| 95 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 96 |
+$sth = $dbi->prepare("insert into table1 (key1, key2) values (?, ?);");
|
|
| 97 |
+$sth->execute(1, 2); |
|
| 98 |
+$sth->execute(3, 4); |
|
| 99 |
+ |
|
| 100 |
+ |
|
| 101 |
+test 'DBIx::Custom::Result test'; |
|
| 102 |
+$tmpl = "select key1, key2 from table1"; |
|
| 103 |
+$query = $dbi->create_query($tmpl); |
|
| 104 |
+$result = $dbi->execute($query); |
|
| 105 |
+ |
|
| 106 |
+@rows = (); |
|
| 107 |
+while (my $row = $result->fetch) {
|
|
| 108 |
+ push @rows, [@$row]; |
|
| 109 |
+} |
|
| 110 |
+is_deeply(\@rows, [[1, 2], [3, 4]], "$test : fetch scalar context"); |
|
| 111 |
+ |
|
| 112 |
+$result = $dbi->execute($query); |
|
| 113 |
+@rows = (); |
|
| 114 |
+while (my @row = $result->fetch) {
|
|
| 115 |
+ push @rows, [@row]; |
|
| 116 |
+} |
|
| 117 |
+is_deeply(\@rows, [[1, 2], [3, 4]], "$test : fetch list context"); |
|
| 118 |
+ |
|
| 119 |
+$result = $dbi->execute($query); |
|
| 120 |
+@rows = (); |
|
| 121 |
+while (my $row = $result->fetch_hash) {
|
|
| 122 |
+ push @rows, {%$row};
|
|
| 123 |
+} |
|
| 124 |
+is_deeply(\@rows, [{key1 => 1, key2 => 2}, {key1 => 3, key2 => 4}], "$test : fetch_hash scalar context");
|
|
| 125 |
+ |
|
| 126 |
+$result = $dbi->execute($query); |
|
| 127 |
+@rows = (); |
|
| 128 |
+while (my %row = $result->fetch_hash) {
|
|
| 129 |
+ push @rows, {%row};
|
|
| 130 |
+} |
|
| 131 |
+is_deeply(\@rows, [{key1 => 1, key2 => 2}, {key1 => 3, key2 => 4}], "$test : fetch hash list context");
|
|
| 132 |
+ |
|
| 133 |
+$result = $dbi->execute($query); |
|
| 134 |
+$rows = $result->fetch_all; |
|
| 135 |
+is_deeply($rows, [[1, 2], [3, 4]], "$test : fetch_all scalar context"); |
|
| 136 |
+ |
|
| 137 |
+$result = $dbi->execute($query); |
|
| 138 |
+@rows = $result->fetch_all; |
|
| 139 |
+is_deeply(\@rows, [[1, 2], [3, 4]], "$test : fetch_all list context"); |
|
| 140 |
+ |
|
| 141 |
+$result = $dbi->execute($query); |
|
| 142 |
+@rows = $result->fetch_hash_all; |
|
| 143 |
+is_deeply($rows, [[1, 2], [3, 4]], "$test : fetch_hash_all scalar context"); |
|
| 144 |
+ |
|
| 145 |
+$result = $dbi->execute($query); |
|
| 146 |
+@rows = $result->fetch_all; |
|
| 147 |
+is_deeply(\@rows, [[1, 2], [3, 4]], "$test : fetch_hash_all list context"); |
|
| 148 |
+ |
|
| 149 |
+ |
|
| 150 |
+test 'Insert query return value'; |
|
| 151 |
+$dbi->do($DROP_TABLE->{0});
|
|
| 152 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 153 |
+$tmpl = "insert into table1 {insert key1 key2}";
|
|
| 154 |
+$query = $dbi->create_query($tmpl); |
|
| 155 |
+$ret_val = $dbi->execute($query, {key1 => 1, key2 => 2});
|
|
| 156 |
+ok($ret_val, $test); |
|
| 157 |
+ |
|
| 158 |
+ |
|
| 159 |
+test 'Direct execute'; |
|
| 160 |
+$dbi->do($DROP_TABLE->{0});
|
|
| 161 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 162 |
+$insert_tmpl = "insert into table1 {insert key1 key2}";
|
|
| 163 |
+$dbi->execute($insert_tmpl, {key1 => 1, key2 => 2}, sub {
|
|
| 164 |
+ my $query = shift; |
|
| 165 |
+ $query->bind_filter(sub {
|
|
| 166 |
+ my ($value, $key) = @_; |
|
| 167 |
+ if ($key eq 'key2') {
|
|
| 168 |
+ return $value + 1; |
|
| 169 |
+ } |
|
| 170 |
+ return $value; |
|
| 171 |
+ }); |
|
| 172 |
+}); |
|
| 173 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 174 |
+$rows = $result->fetch_hash_all; |
|
| 175 |
+is_deeply($rows, [{key1 => 1, key2 => 3}], $test);
|
|
| 176 |
+ |
|
| 177 |
+ |
|
| 178 |
+test 'Filter basic'; |
|
| 179 |
+$dbi->do($DROP_TABLE->{0});
|
|
| 180 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 181 |
+ |
|
| 182 |
+$insert_tmpl = "insert into table1 {insert key1 key2};";
|
|
| 183 |
+$insert_query = $dbi->create_query($insert_tmpl); |
|
| 184 |
+$insert_query->bind_filter(sub {
|
|
| 185 |
+ my ($value, $key, $table, $column) = @_; |
|
| 186 |
+ if ($key eq 'key1' && $table eq '' && $column eq 'key1') {
|
|
| 187 |
+ return $value * 2; |
|
| 188 |
+ } |
|
| 189 |
+ return $value; |
|
| 190 |
+}); |
|
| 191 |
+$dbi->execute($insert_query, {key1 => 1, key2 => 2});
|
|
| 192 |
+$select_query = $dbi->create_query($SELECT_TMPL->{0});
|
|
| 193 |
+$select_query->fetch_filter(sub {
|
|
| 194 |
+ my ($value, $key, $type, $sth, $i) = @_; |
|
| 195 |
+ if ($key eq 'key2' && $type =~ /char/ && $sth->can('execute') && $i == 1) {
|
|
| 196 |
+ return $value * 3; |
|
| 197 |
+ } |
|
| 198 |
+ return $value; |
|
| 199 |
+}); |
|
| 200 |
+$result = $dbi->execute($select_query); |
|
| 201 |
+$rows = $result->fetch_hash_all; |
|
| 202 |
+is_deeply($rows, [{key1 => 2, key2 => 6}], "$test : bind_filter fetch_filter");
|
|
| 203 |
+ |
|
| 204 |
+$dbi->do("delete from table1;");
|
|
| 205 |
+$insert_query->no_bind_filters('key1');
|
|
| 206 |
+$select_query->no_fetch_filters('key2');
|
|
| 207 |
+$dbi->execute($insert_query, {key1 => 1, key2 => 2});
|
|
| 208 |
+$result = $dbi->execute($select_query); |
|
| 209 |
+$rows = $result->fetch_hash_all; |
|
| 210 |
+is_deeply($rows, [{key1 => 1, key2 => 2}], "$test : no_fetch_filters no_bind_filters");
|
|
| 211 |
+ |
|
| 212 |
+$dbi->do($DROP_TABLE->{0});
|
|
| 213 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 214 |
+$insert_tmpl = "insert into table1 {insert table1.key1 table1.key2}";
|
|
| 215 |
+$insert_query = $dbi->create_query($insert_tmpl); |
|
| 216 |
+$insert_query->bind_filter(sub {
|
|
| 217 |
+ my ($value, $key, $table, $column) = @_; |
|
| 218 |
+ if ($key eq 'table1.key1' && $table eq 'table1' && $column eq 'key1') {
|
|
| 219 |
+ return $value * 3; |
|
| 220 |
+ } |
|
| 221 |
+ return $value; |
|
| 222 |
+}); |
|
| 223 |
+$dbi->execute($insert_query, {table1 => {key1 => 1, key2 => 2}});
|
|
| 224 |
+$select_query = $dbi->create_query($SELECT_TMPL->{0});
|
|
| 225 |
+$result = $dbi->execute($select_query); |
|
| 226 |
+$rows = $result->fetch_hash_all; |
|
| 227 |
+is_deeply($rows, [{key1 => 3, key2 => 2}], "$test : insert with table name");
|
|
| 228 |
+ |
|
| 229 |
+test 'Filter in'; |
|
| 230 |
+$insert_tmpl = "insert into table1 {insert key1 key2};";
|
|
| 231 |
+$insert_query = $dbi->create_query($insert_tmpl); |
|
| 232 |
+$dbi->execute($insert_query, {key1 => 2, key2 => 4});
|
|
| 233 |
+$select_tmpl = "select * from table1 where {in table1.key1 2} and {in table1.key2 2}";
|
|
| 234 |
+$select_query = $dbi->create_query($select_tmpl); |
|
| 235 |
+$select_query->bind_filter(sub {
|
|
| 236 |
+ my ($value, $key, $table, $column) = @_; |
|
| 237 |
+ if ($key eq 'table1.key1' && $table eq 'table1' && $column eq 'key1' || $key eq 'table1.key2') {
|
|
| 238 |
+ return $value * 2; |
|
| 239 |
+ } |
|
| 240 |
+ return $value; |
|
| 241 |
+}); |
|
| 242 |
+$result = $dbi->execute($select_query, {table1 => {key1 => [1,5], key2 => [2,5]}});
|
|
| 243 |
+$rows = $result->fetch_hash_all; |
|
| 244 |
+is_deeply($rows, [{key1 => 2, key2 => 4}], "$test : bind_filter");
|
|
| 245 |
+ |
|
| 246 |
+ |
|
| 247 |
+test 'DBIx::Custom::SQL::Template basic tag'; |
|
| 248 |
+$dbi->do($DROP_TABLE->{0});
|
|
| 249 |
+$dbi->do($CREATE_TABLE->{1});
|
|
| 250 |
+$sth = $dbi->prepare("insert into table1 (key1, key2, key3, key4, key5) values (?, ?, ?, ?, ?);");
|
|
| 251 |
+$sth->execute(1, 2, 3, 4, 5); |
|
| 252 |
+$sth->execute(6, 7, 8, 9, 10); |
|
| 253 |
+ |
|
| 254 |
+$tmpl = "select * from table1 where {= key1} and {<> key2} and {< key3} and {> key4} and {>= key5};";
|
|
| 255 |
+$query = $dbi->create_query($tmpl); |
|
| 256 |
+$result = $dbi->execute($query, {key1 => 1, key2 => 3, key3 => 4, key4 => 3, key5 => 5});
|
|
| 257 |
+$rows = $result->fetch_hash_all; |
|
| 258 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : basic tag1");
|
|
| 259 |
+ |
|
| 260 |
+$tmpl = "select * from table1 where {= table1.key1} and {<> table1.key2} and {< table1.key3} and {> table1.key4} and {>= table1.key5};";
|
|
| 261 |
+$query = $dbi->create_query($tmpl); |
|
| 262 |
+$result = $dbi->execute($query, {table1 => {key1 => 1, key2 => 3, key3 => 4, key4 => 3, key5 => 5}});
|
|
| 263 |
+$rows = $result->fetch_hash_all; |
|
| 264 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : basic tag1 with table");
|
|
| 265 |
+ |
|
| 266 |
+$tmpl = "select * from table1 where {= table1.key1} and {<> table1.key2} and {< table1.key3} and {> table1.key4} and {>= table1.key5};";
|
|
| 267 |
+$query = $dbi->create_query($tmpl); |
|
| 268 |
+$result = $dbi->execute($query, {'table1.key1' => 1, 'table1.key2' => 3, 'table1.key3' => 4, 'table1.key4' => 3, 'table1.key5' => 5});
|
|
| 269 |
+$rows = $result->fetch_hash_all; |
|
| 270 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : basic tag1 with table dot");
|
|
| 271 |
+ |
|
| 272 |
+$tmpl = "select * from table1 where {<= key1} and {like key2};";
|
|
| 273 |
+$query = $dbi->create_query($tmpl); |
|
| 274 |
+$result = $dbi->execute($query, {key1 => 1, key2 => '%2%'});
|
|
| 275 |
+$rows = $result->fetch_hash_all; |
|
| 276 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : basic tag2");
|
|
| 277 |
+ |
|
| 278 |
+$tmpl = "select * from table1 where {<= table1.key1} and {like table1.key2};";
|
|
| 279 |
+$query = $dbi->create_query($tmpl); |
|
| 280 |
+$result = $dbi->execute($query, {table1 => {key1 => 1, key2 => '%2%'}});
|
|
| 281 |
+$rows = $result->fetch_hash_all; |
|
| 282 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : basic tag2 with table");
|
|
| 283 |
+ |
|
| 284 |
+$tmpl = "select * from table1 where {<= table1.key1} and {like table1.key2};";
|
|
| 285 |
+$query = $dbi->create_query($tmpl); |
|
| 286 |
+$result = $dbi->execute($query, {'table1.key1' => 1, 'table1.key2' => '%2%'});
|
|
| 287 |
+$rows = $result->fetch_hash_all; |
|
| 288 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : basic tag2 with table dot");
|
|
| 289 |
+ |
|
| 290 |
+ |
|
| 291 |
+test 'DIB::Custom::SQL::Template in tag'; |
|
| 292 |
+$dbi->do($DROP_TABLE->{0});
|
|
| 293 |
+$dbi->do($CREATE_TABLE->{1});
|
|
| 294 |
+$sth = $dbi->prepare("insert into table1 (key1, key2, key3, key4, key5) values (?, ?, ?, ?, ?);");
|
|
| 295 |
+$sth->execute(1, 2, 3, 4, 5); |
|
| 296 |
+$sth->execute(6, 7, 8, 9, 10); |
|
| 297 |
+ |
|
| 298 |
+$tmpl = "select * from table1 where {in key1 2};";
|
|
| 299 |
+$query = $dbi->create_query($tmpl); |
|
| 300 |
+$result = $dbi->execute($query, {key1 => [9, 1]});
|
|
| 301 |
+$rows = $result->fetch_hash_all; |
|
| 302 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : basic");
|
|
| 303 |
+ |
|
| 304 |
+$tmpl = "select * from table1 where {in table1.key1 2};";
|
|
| 305 |
+$query = $dbi->create_query($tmpl); |
|
| 306 |
+$result = $dbi->execute($query, {table1 => {key1 => [9, 1]}});
|
|
| 307 |
+$rows = $result->fetch_hash_all; |
|
| 308 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : with table");
|
|
| 309 |
+ |
|
| 310 |
+$tmpl = "select * from table1 where {in table1.key1 2};";
|
|
| 311 |
+$query = $dbi->create_query($tmpl); |
|
| 312 |
+$result = $dbi->execute($query, {'table1.key1' => [9, 1]});
|
|
| 313 |
+$rows = $result->fetch_hash_all; |
|
| 314 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : with table dot");
|
|
| 315 |
+ |
|
| 316 |
+ |
|
| 317 |
+test 'DBIx::Custom::SQL::Template insert tag'; |
|
| 318 |
+$dbi->do("delete from table1");
|
|
| 319 |
+$insert_tmpl = 'insert into table1 {insert key1 key2 key3 key4 key5}';
|
|
| 320 |
+$dbi->execute($insert_tmpl, {key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5});
|
|
| 321 |
+ |
|
| 322 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 323 |
+$rows = $result->fetch_hash_all; |
|
| 324 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : basic");
|
|
| 325 |
+ |
|
| 326 |
+$dbi->do("delete from table1");
|
|
| 327 |
+$dbi->execute($insert_tmpl, {'#insert' => {key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}});
|
|
| 328 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 329 |
+$rows = $result->fetch_hash_all; |
|
| 330 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : #insert");
|
|
| 331 |
+ |
|
| 332 |
+$dbi->do("delete from table1");
|
|
| 333 |
+$insert_tmpl = 'insert into table1 {insert table1.key1 table1.key2 table1.key3 table1.key4 table1.key5}';
|
|
| 334 |
+$dbi->execute($insert_tmpl, {table1 => {key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}});
|
|
| 335 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 336 |
+$rows = $result->fetch_hash_all; |
|
| 337 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : with table name");
|
|
| 338 |
+ |
|
| 339 |
+$dbi->do("delete from table1");
|
|
| 340 |
+$insert_tmpl = 'insert into table1 {insert table1.key1 table1.key2 table1.key3 table1.key4 table1.key5}';
|
|
| 341 |
+$dbi->execute($insert_tmpl, {'table1.key1' => 1, 'table1.key2' => 2, 'table1.key3' => 3, 'table1.key4' => 4, 'table1.key5' => 5});
|
|
| 342 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 343 |
+$rows = $result->fetch_hash_all; |
|
| 344 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : with table name dot");
|
|
| 345 |
+ |
|
| 346 |
+$dbi->do("delete from table1");
|
|
| 347 |
+$dbi->execute($insert_tmpl, {'#insert' => {table1 => {key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}}});
|
|
| 348 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 349 |
+$rows = $result->fetch_hash_all; |
|
| 350 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : #insert with table name");
|
|
| 351 |
+ |
|
| 352 |
+$dbi->do("delete from table1");
|
|
| 353 |
+$dbi->execute($insert_tmpl, {'#insert' => {'table1.key1' => 1, 'table1.key2' => 2, 'table1.key3' => 3, 'table1.key4' => 4, 'table1.key5' => 5}});
|
|
| 354 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 355 |
+$rows = $result->fetch_hash_all; |
|
| 356 |
+is_deeply($rows, [{key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5}], "$test : #insert with table name dot");
|
|
| 357 |
+ |
|
| 358 |
+ |
|
| 359 |
+test 'DBIx::Custom::SQL::Template update tag'; |
|
| 360 |
+$dbi->do("delete from table1");
|
|
| 361 |
+$insert_tmpl = "insert into table1 {insert key1 key2 key3 key4 key5}";
|
|
| 362 |
+$dbi->execute($insert_tmpl, {key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5});
|
|
| 363 |
+$dbi->execute($insert_tmpl, {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10});
|
|
| 364 |
+ |
|
| 365 |
+$update_tmpl = 'update table1 {update key1 key2 key3 key4} where {= key5}';
|
|
| 366 |
+$dbi->execute($update_tmpl, {key1 => 1, key2 => 1, key3 => 1, key4 => 1, key5 => 5});
|
|
| 367 |
+ |
|
| 368 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 369 |
+$rows = $result->fetch_hash_all; |
|
| 370 |
+is_deeply($rows, [{key1 => 1, key2 => 1, key3 => 1, key4 => 1, key5 => 5},
|
|
| 371 |
+ {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10}], "$test : basic");
|
|
| 372 |
+ |
|
| 373 |
+$dbi->execute($update_tmpl, {'#update' => {key1 => 2, key2 => 2, key3 => 2, key4 => 2}, key5 => 5});
|
|
| 374 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 375 |
+$rows = $result->fetch_hash_all; |
|
| 376 |
+is_deeply($rows, [{key1 => 2, key2 => 2, key3 => 2, key4 => 2, key5 => 5},
|
|
| 377 |
+ {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10}], "$test : #update");
|
|
| 378 |
+ |
|
| 379 |
+$update_tmpl = 'update table1 {update table1.key1 table1.key2 table1.key3 table1.key4} where {= table1.key5}';
|
|
| 380 |
+$dbi->execute($update_tmpl, {table1 => {key1 => 3, key2 => 3, key3 => 3, key4 => 3, key5 => 5}});
|
|
| 381 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 382 |
+$rows = $result->fetch_hash_all; |
|
| 383 |
+is_deeply($rows, [{key1 => 3, key2 => 3, key3 => 3, key4 => 3, key5 => 5},
|
|
| 384 |
+ {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10}], "$test : with table name");
|
|
| 385 |
+ |
|
| 386 |
+$update_tmpl = 'update table1 {update table1.key1 table1.key2 table1.key3 table1.key4} where {= table1.key5}';
|
|
| 387 |
+$dbi->execute($update_tmpl, {'table1.key1' => 4, 'table1.key2' => 4, 'table1.key3' => 4, 'table1.key4' => 4, 'table1.key5' => 5});
|
|
| 388 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 389 |
+$rows = $result->fetch_hash_all; |
|
| 390 |
+is_deeply($rows, [{key1 => 4, key2 => 4, key3 => 4, key4 => 4, key5 => 5},
|
|
| 391 |
+ {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10}], "$test : with table name dot");
|
|
| 392 |
+ |
|
| 393 |
+$dbi->execute($update_tmpl, {'#update' => {table1 => {key1 => 5, key2 => 5, key3 => 5, key4 => 5}}, table1 => {key5 => 5}});
|
|
| 394 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 395 |
+$rows = $result->fetch_hash_all; |
|
| 396 |
+is_deeply($rows, [{key1 => 5, key2 => 5, key3 => 5, key4 => 5, key5 => 5},
|
|
| 397 |
+ {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10}], "$test : update tag #update with table name");
|
|
| 398 |
+ |
|
| 399 |
+$dbi->execute($update_tmpl, {'#update' => {'table1.key1' => 6, 'table1.key2' => 6, 'table1.key3' => 6, 'table1.key4' => 6}, 'table1.key5' => 5});
|
|
| 400 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 401 |
+$rows = $result->fetch_hash_all; |
|
| 402 |
+is_deeply($rows, [{key1 => 6, key2 => 6, key3 => 6, key4 => 6, key5 => 5},
|
|
| 403 |
+ {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10}], "$test : update tag #update with table name dot");
|
|
| 404 |
+ |
|
| 405 |
+ |
|
| 406 |
+test 'run_tansaction'; |
|
| 407 |
+$dbi->do($DROP_TABLE->{0});
|
|
| 408 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 409 |
+$dbi->run_transaction(sub {
|
|
| 410 |
+ $insert_tmpl = 'insert into table1 {insert key1 key2}';
|
|
| 411 |
+ $dbi->execute($insert_tmpl, {key1 => 1, key2 => 2});
|
|
| 412 |
+ $dbi->execute($insert_tmpl, {key1 => 3, key2 => 4});
|
|
| 413 |
+}); |
|
| 414 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 415 |
+$rows = $result->fetch_hash_all; |
|
| 416 |
+is_deeply($rows, [{key1 => 1, key2 => 2}, {key1 => 3, key2 => 4}], "$test : commit");
|
|
| 417 |
+ |
|
| 418 |
+$dbi->do($DROP_TABLE->{0});
|
|
| 419 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 420 |
+$dbi->dbh->{RaiseError} = 0;
|
|
| 421 |
+eval{
|
|
| 422 |
+ $dbi->run_transaction(sub {
|
|
| 423 |
+ $insert_tmpl = 'insert into table1 {insert key1 key2}';
|
|
| 424 |
+ $dbi->execute($insert_tmpl, {key1 => 1, key2 => 2});
|
|
| 425 |
+ die "Fatal Error"; |
|
| 426 |
+ $dbi->execute($insert_tmpl, {key1 => 3, key2 => 4});
|
|
| 427 |
+ }) |
|
| 428 |
+}; |
|
| 429 |
+like($@, qr/Fatal Error.*Rollback is success/ms, "$test : Rollback success message"); |
|
| 430 |
+ok(!$dbi->dbh->{RaiseError}, "$test : restore RaiseError value");
|
|
| 431 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 432 |
+$rows = $result->fetch_hash_all; |
|
| 433 |
+is_deeply($rows, [], "$test : rollback"); |
|
| 434 |
+ |
|
| 435 |
+ |
|
| 436 |
+test 'Error case'; |
|
| 437 |
+$dbi = DBIx::Custom->new; |
|
| 438 |
+eval{$dbi->run_transaction};
|
|
| 439 |
+like($@, qr/Not yet connect to database/, "$test : Yet Connected"); |
|
| 440 |
+ |
|
| 441 |
+$dbi = DBIx::Custom->new(data_source => 'dbi:SQLit'); |
|
| 442 |
+eval{$dbi->connect;};
|
|
| 443 |
+ok($@, "$test : connect error"); |
|
| 444 |
+ |
|
| 445 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 446 |
+$dbi->connect; |
|
| 447 |
+$dbi->dbh->{AutoCommit} = 0;
|
|
| 448 |
+eval{$dbi->run_transaction()};
|
|
| 449 |
+like($@, qr/AutoCommit must be true before transaction start/, |
|
| 450 |
+ "$test : run_transaction auto commit is false"); |
|
| 451 |
+ |
|
| 452 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 453 |
+$sql = 'laksjdf'; |
|
| 454 |
+eval{$dbi->prepare($sql)};
|
|
| 455 |
+like($@, qr/$sql/, "$test : prepare fail"); |
|
| 456 |
+ |
|
| 457 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 458 |
+$sql = 'laksjdf'; |
|
| 459 |
+eval{$dbi->do($sql, qw/1 2 3/)};
|
|
| 460 |
+like($@, qr/$sql/, "$test : do fail"); |
|
| 461 |
+ |
|
| 462 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 463 |
+eval{$dbi->create_query("{p }")};
|
|
| 464 |
+ok($@, "$test : create_query invalid SQL template"); |
|
| 465 |
+ |
|
| 466 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 467 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 468 |
+$query = $dbi->create_query("select * from table1 where {= key1}");
|
|
| 469 |
+eval{$dbi->execute($query, {key2 => 1})};
|
|
| 470 |
+like($@, qr/Corresponding key is not found in your parameters/, |
|
| 471 |
+ "$test : execute corresponding key not found"); |
|
| 472 |
+ |
|
| 473 |
+ |
|
| 474 |
+test 'insert'; |
|
| 475 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 476 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 477 |
+$dbi->insert('table1', {key1 => 1, key2 => 2});
|
|
| 478 |
+$dbi->insert('table1', {key1 => 3, key2 => 4});
|
|
| 479 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 480 |
+$rows = $result->fetch_hash_all; |
|
| 481 |
+is_deeply($rows, [{key1 => 1, key2 => 2}, {key1 => 3, key2 => 4}], "$test : basic");
|
|
| 482 |
+ |
|
| 483 |
+$dbi->do('delete from table1');
|
|
| 484 |
+$dbi->insert('table1', {key1 => 1, key2 => 2}, sub {
|
|
| 485 |
+ my $query = shift; |
|
| 486 |
+ $query->bind_filter(sub {
|
|
| 487 |
+ my ($value, $key) = @_; |
|
| 488 |
+ if ($key eq 'key1') {
|
|
| 489 |
+ return $value * 3; |
|
| 490 |
+ } |
|
| 491 |
+ return $value; |
|
| 492 |
+ }); |
|
| 493 |
+}); |
|
| 494 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 495 |
+$rows = $result->fetch_hash_all; |
|
| 496 |
+is_deeply($rows, [{key1 => 3, key2 => 2}], "$test : edit_query_callback");
|
|
| 497 |
+ |
|
| 498 |
+ |
|
| 499 |
+test 'insert error'; |
|
| 500 |
+eval{$dbi->insert('table1')};
|
|
| 501 |
+like($@, qr/Key-value pairs for insert must be specified to 'insert' second argument/, "$test : insert key-value not specifed"); |
|
| 502 |
+ |
|
| 503 |
+eval{$dbi->insert('table1', {key1 => 1, key2 => 2}, 'aaa')};
|
|
| 504 |
+like($@, qr/Query edit callback must be code reference/, "$test : query edit callback not code ref"); |
|
| 505 |
+ |
|
| 506 |
+ |
|
| 507 |
+test 'update'; |
|
| 508 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 509 |
+$dbi->do($CREATE_TABLE->{1});
|
|
| 510 |
+$dbi->insert('table1', {key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5});
|
|
| 511 |
+$dbi->insert('table1', {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10});
|
|
| 512 |
+$dbi->update('table1', {key2 => 11}, {key1 => 1});
|
|
| 513 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 514 |
+$rows = $result->fetch_hash_all; |
|
| 515 |
+is_deeply($rows, [{key1 => 1, key2 => 11, key3 => 3, key4 => 4, key5 => 5},
|
|
| 516 |
+ {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10}],
|
|
| 517 |
+ "$test : basic"); |
|
| 518 |
+ |
|
| 519 |
+$dbi->do("delete from table1");
|
|
| 520 |
+$dbi->insert('table1', {key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5});
|
|
| 521 |
+$dbi->insert('table1', {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10});
|
|
| 522 |
+$dbi->update('table1', {key2 => 12}, {key2 => 2, key3 => 3});
|
|
| 523 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 524 |
+$rows = $result->fetch_hash_all; |
|
| 525 |
+is_deeply($rows, [{key1 => 1, key2 => 12, key3 => 3, key4 => 4, key5 => 5},
|
|
| 526 |
+ {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10}],
|
|
| 527 |
+ "$test : update key same as search key"); |
|
| 528 |
+ |
|
| 529 |
+$dbi->do("delete from table1");
|
|
| 530 |
+$dbi->insert('table1', {key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5});
|
|
| 531 |
+$dbi->insert('table1', {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10});
|
|
| 532 |
+$dbi->update('table1', {key2 => 11}, {key1 => 1}, sub {
|
|
| 533 |
+ my $query = shift; |
|
| 534 |
+ $query->bind_filter(sub {
|
|
| 535 |
+ my ($value, $key) = @_; |
|
| 536 |
+ if ($key eq 'key2') {
|
|
| 537 |
+ return $value * 2; |
|
| 538 |
+ } |
|
| 539 |
+ return $value; |
|
| 540 |
+ }); |
|
| 541 |
+}); |
|
| 542 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 543 |
+$rows = $result->fetch_hash_all; |
|
| 544 |
+is_deeply($rows, [{key1 => 1, key2 => 22, key3 => 3, key4 => 4, key5 => 5},
|
|
| 545 |
+ {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10}],
|
|
| 546 |
+ "$test : query edit callback"); |
|
| 547 |
+ |
|
| 548 |
+ |
|
| 549 |
+test 'update error'; |
|
| 550 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 551 |
+$dbi->do($CREATE_TABLE->{1});
|
|
| 552 |
+eval{$dbi->update('table1')};
|
|
| 553 |
+like($@, qr/Key-value pairs for update must be specified to 'update' second argument/, |
|
| 554 |
+ "$test : update key-value pairs not specified"); |
|
| 555 |
+ |
|
| 556 |
+eval{$dbi->update('table1', {key2 => 1})};
|
|
| 557 |
+like($@, qr/Key-value pairs for where clause must be specified to 'update' third argument/, |
|
| 558 |
+ "$test : where key-value pairs not specified"); |
|
| 559 |
+ |
|
| 560 |
+eval{$dbi->update('table1', {key2 => 1}, {key2 => 3}, 'aaa')};
|
|
| 561 |
+like($@, qr/Query edit callback must be code reference/, |
|
| 562 |
+ "$test : query edit callback not code reference"); |
|
| 563 |
+ |
|
| 564 |
+ |
|
| 565 |
+test 'update_all'; |
|
| 566 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 567 |
+$dbi->do($CREATE_TABLE->{1});
|
|
| 568 |
+$dbi->insert('table1', {key1 => 1, key2 => 2, key3 => 3, key4 => 4, key5 => 5});
|
|
| 569 |
+$dbi->insert('table1', {key1 => 6, key2 => 7, key3 => 8, key4 => 9, key5 => 10});
|
|
| 570 |
+$dbi->update_all('table1', {key2 => 10}, sub {
|
|
| 571 |
+ my $query = shift; |
|
| 572 |
+ $query->bind_filter(sub {
|
|
| 573 |
+ my ($value, $key) = @_; |
|
| 574 |
+ return $value * 2; |
|
| 575 |
+ }) |
|
| 576 |
+}); |
|
| 577 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 578 |
+$rows = $result->fetch_hash_all; |
|
| 579 |
+is_deeply($rows, [{key1 => 1, key2 => 20, key3 => 3, key4 => 4, key5 => 5},
|
|
| 580 |
+ {key1 => 6, key2 => 20, key3 => 8, key4 => 9, key5 => 10}],
|
|
| 581 |
+ "$test : query edit callback"); |
|
| 582 |
+ |
|
| 583 |
+ |
|
| 584 |
+test 'delete'; |
|
| 585 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 586 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 587 |
+$dbi->insert('table1', {key1 => 1, key2 => 2});
|
|
| 588 |
+$dbi->insert('table1', {key1 => 3, key2 => 4});
|
|
| 589 |
+$dbi->delete('table1', {key1 => 1});
|
|
| 590 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 591 |
+$rows = $result->fetch_hash_all; |
|
| 592 |
+is_deeply($rows, [{key1 => 3, key2 => 4}], "$test : basic");
|
|
| 593 |
+ |
|
| 594 |
+$dbi->do("delete from table1;");
|
|
| 595 |
+$dbi->insert('table1', {key1 => 1, key2 => 2});
|
|
| 596 |
+$dbi->insert('table1', {key1 => 3, key2 => 4});
|
|
| 597 |
+$dbi->delete('table1', {key2 => 1}, sub {
|
|
| 598 |
+ my $query = shift; |
|
| 599 |
+ $query->bind_filter(sub {
|
|
| 600 |
+ my ($value, $key) = @_; |
|
| 601 |
+ return $value * 2; |
|
| 602 |
+ }); |
|
| 603 |
+}); |
|
| 604 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 605 |
+$rows = $result->fetch_hash_all; |
|
| 606 |
+is_deeply($rows, [{key1 => 3, key2 => 4}], "$test : query edit callback");
|
|
| 607 |
+ |
|
| 608 |
+$dbi->delete_all('table1');
|
|
| 609 |
+$dbi->insert('table1', {key1 => 1, key2 => 2});
|
|
| 610 |
+$dbi->insert('table1', {key1 => 3, key2 => 4});
|
|
| 611 |
+$dbi->delete('table1', {key1 => 1, key2 => 2});
|
|
| 612 |
+$rows = $dbi->select('table1')->fetch_hash_all;
|
|
| 613 |
+is_deeply($rows, [{key1 => 3, key2 => 4}], "$test : delete multi key");
|
|
| 614 |
+ |
|
| 615 |
+ |
|
| 616 |
+test 'delete error'; |
|
| 617 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 618 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 619 |
+eval{$dbi->delete('table1')};
|
|
| 620 |
+like($@, qr/Key-value pairs for where clause must be specified to 'delete' second argument/, |
|
| 621 |
+ "$test : where key-value pairs not specified"); |
|
| 622 |
+ |
|
| 623 |
+eval{$dbi->delete('table1', {key1 => 1}, 'aaa')};
|
|
| 624 |
+like($@, qr/Query edit callback must be code reference/, |
|
| 625 |
+ "$test : query edit callback not code ref"); |
|
| 626 |
+ |
|
| 627 |
+ |
|
| 628 |
+test 'delete_all'; |
|
| 629 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 630 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 631 |
+$dbi->insert('table1', {key1 => 1, key2 => 2});
|
|
| 632 |
+$dbi->insert('table1', {key1 => 3, key2 => 4});
|
|
| 633 |
+$dbi->delete_all('table1');
|
|
| 634 |
+$result = $dbi->execute($SELECT_TMPL->{0});
|
|
| 635 |
+$rows = $result->fetch_hash_all; |
|
| 636 |
+is_deeply($rows, [], "$test : basic"); |
|
| 637 |
+ |
|
| 638 |
+ |
|
| 639 |
+test 'select'; |
|
| 640 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 641 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 642 |
+$dbi->insert('table1', {key1 => 1, key2 => 2});
|
|
| 643 |
+$dbi->insert('table1', {key1 => 3, key2 => 4});
|
|
| 644 |
+$rows = $dbi->select('table1')->fetch_hash_all;
|
|
| 645 |
+is_deeply($rows, [{key1 => 1, key2 => 2},
|
|
| 646 |
+ {key1 => 3, key2 => 4}], "$test : table");
|
|
| 647 |
+ |
|
| 648 |
+$rows = $dbi->select('table1', ['key1'])->fetch_hash_all;
|
|
| 649 |
+is_deeply($rows, [{key1 => 1}, {key1 => 3}], "$test : table and columns and where key");
|
|
| 650 |
+ |
|
| 651 |
+$rows = $dbi->select('table1', {key1 => 1})->fetch_hash_all;
|
|
| 652 |
+is_deeply($rows, [{key1 => 1, key2 => 2}], "$test : table and columns and where key");
|
|
| 653 |
+ |
|
| 654 |
+$rows = $dbi->select('table1', ['key1'], {key1 => 3})->fetch_hash_all;
|
|
| 655 |
+is_deeply($rows, [{key1 => 3}], "$test : table and columns and where key");
|
|
| 656 |
+ |
|
| 657 |
+$rows = $dbi->select('table1', "order by key1 desc limit 1")->fetch_hash_all;
|
|
| 658 |
+is_deeply($rows, [{key1 => 3, key2 => 4}], "$test : append statement");
|
|
| 659 |
+ |
|
| 660 |
+$rows = $dbi->select('table1', {key1 => 2}, sub {
|
|
| 661 |
+ my $query = shift; |
|
| 662 |
+ $query->bind_filter(sub {
|
|
| 663 |
+ my ($value, $key) = @_; |
|
| 664 |
+ if ($key eq 'key1') {
|
|
| 665 |
+ return $value - 1; |
|
| 666 |
+ } |
|
| 667 |
+ return $value; |
|
| 668 |
+ }); |
|
| 669 |
+})->fetch_hash_all; |
|
| 670 |
+is_deeply($rows, [{key1 => 1, key2 => 2}], "$test : query edit call back");
|
|
| 671 |
+ |
|
| 672 |
+$dbi->do($CREATE_TABLE->{2});
|
|
| 673 |
+$dbi->insert('table2', {key1 => 1, key3 => 5});
|
|
| 674 |
+$rows = $dbi->select([qw/table1 table2/], |
|
| 675 |
+ ['table1.key1 as table1_key1', 'table2.key1 as table2_key1', 'key2', 'key3'], |
|
| 676 |
+ {'table1.key2' => 2},
|
|
| 677 |
+ "where table1.key1 = table2.key1")->fetch_hash_all; |
|
| 678 |
+is_deeply($rows, [{table1_key1 => 1, table2_key1 => 1, key2 => 2, key3 => 5}], "$test : join");
|
|
| 679 |
+ |
|
| 680 |
+test 'Cache'; |
|
| 681 |
+$dbi = DBIx::Custom->new($NEW_ARGS->{0});
|
|
| 682 |
+DBIx::Custom->query_cache_max(2); |
|
| 683 |
+$dbi->do($CREATE_TABLE->{0});
|
|
| 684 |
+DBIx::Custom->delete_class_attr('_query_caches');
|
|
| 685 |
+DBIx::Custom->delete_class_attr('_query_cache_keys');
|
|
| 686 |
+$tmpls[0] = "insert into table1 {insert key1 key2}";
|
|
| 687 |
+$queries[0] = $dbi->create_query($tmpls[0]); |
|
| 688 |
+is(DBIx::Custom->_query_caches->{$tmpls[0]}{sql}, $queries[0]->sql, "$test : sql first");
|
|
| 689 |
+is(DBIx::Custom->_query_caches->{$tmpls[0]}{key_infos}, $queries[0]->key_infos, "$test : key_infos first");
|
|
| 690 |
+is_deeply(DBIx::Custom->_query_cache_keys, [@tmpls], "$test : cache key first"); |
|
| 691 |
+ |
|
| 692 |
+$tmpls[1] = "select * from table1"; |
|
| 693 |
+$queries[1] = $dbi->create_query($tmpls[1]); |
|
| 694 |
+is(DBIx::Custom->_query_caches->{$tmpls[0]}{sql}, $queries[0]->sql, "$test : sql first");
|
|
| 695 |
+is(DBIx::Custom->_query_caches->{$tmpls[0]}{key_infos}, $queries[0]->key_infos, "$test : key_infos first");
|
|
| 696 |
+is(DBIx::Custom->_query_caches->{$tmpls[1]}{sql}, $queries[1]->sql, "$test : sql second");
|
|
| 697 |
+is(DBIx::Custom->_query_caches->{$tmpls[1]}{key_infos}, $queries[1]->key_infos, "$test : key_infos second");
|
|
| 698 |
+is_deeply(DBIx::Custom->_query_cache_keys, [@tmpls], "$test : cache key second"); |
|
| 699 |
+ |
|
| 700 |
+$tmpls[2] = "select key1, key2 from table1"; |
|
| 701 |
+$queries[2] = $dbi->create_query($tmpls[2]); |
|
| 702 |
+ok(!exists DBIx::Custom->_query_caches->{$tmpls[0]}, "$test : cache overflow deleted key");
|
|
| 703 |
+is(DBIx::Custom->_query_caches->{$tmpls[1]}{sql}, $queries[1]->sql, "$test : sql cache overflow deleted key");
|
|
| 704 |
+is(DBIx::Custom->_query_caches->{$tmpls[1]}{key_infos}, $queries[1]->key_infos, "$test : key_infos cache overflow deleted key");
|
|
| 705 |
+is(DBIx::Custom->_query_caches->{$tmpls[2]}{sql}, $queries[2]->sql, "$test : sql cache overflow deleted key");
|
|
| 706 |
+is(DBIx::Custom->_query_caches->{$tmpls[2]}{key_infos}, $queries[2]->key_infos, "$test : key_infos cache overflow deleted key");
|
|
| 707 |
+is_deeply(DBIx::Custom->_query_cache_keys, [@tmpls[1, 2]], "$test : cache key third"); |
|
| 708 |
+ |
|
| 709 |
+$queries[1] = $dbi->create_query($tmpls[1]); |
|
| 710 |
+ok(!exists DBIx::Custom->_query_caches->{$tmpls[0]}, "$test : cache overflow deleted key");
|
|
| 711 |
+is(DBIx::Custom->_query_caches->{$tmpls[1]}{sql}, $queries[1]->sql, "$test : sql cache overflow deleted key");
|
|
| 712 |
+is(DBIx::Custom->_query_caches->{$tmpls[1]}{key_infos}, $queries[1]->key_infos, "$test : key_infos cache overflow deleted key");
|
|
| 713 |
+is(DBIx::Custom->_query_caches->{$tmpls[2]}{sql}, $queries[2]->sql, "$test : sql cache overflow deleted key");
|
|
| 714 |
+is(DBIx::Custom->_query_caches->{$tmpls[2]}{key_infos}, $queries[2]->key_infos, "$test : key_infos cache overflow deleted key");
|
|
| 715 |
+is_deeply(DBIx::Custom->_query_cache_keys, [@tmpls[1, 2]], "$test : cache key third"); |
|
| 716 |
+ |
| ... | ... |
@@ -0,0 +1,220 @@ |
| 1 |
+use Test::More 'no_plan'; |
|
| 2 |
+use strict; |
|
| 3 |
+use warnings; |
|
| 4 |
+ |
|
| 5 |
+use DBIx::Custom; |
|
| 6 |
+use DBIx::Custom::SQL::Template; |
|
| 7 |
+ |
|
| 8 |
+# Function for test name |
|
| 9 |
+my $test; |
|
| 10 |
+sub test {
|
|
| 11 |
+ $test = shift; |
|
| 12 |
+} |
|
| 13 |
+ |
|
| 14 |
+# Variables for test |
|
| 15 |
+our $SQL_TMPL = {
|
|
| 16 |
+ 0 => DBIx::Custom::SQL::Template->new->tag_start(0), |
|
| 17 |
+ 1 => DBIx::Custom::SQL::Template->new->tag_start(1), |
|
| 18 |
+ 2 => DBIx::Custom::SQL::Template->new->tag_start(2) |
|
| 19 |
+}; |
|
| 20 |
+my $dbi; |
|
| 21 |
+ |
|
| 22 |
+ |
|
| 23 |
+test 'Constructor'; |
|
| 24 |
+$dbi = DBIx::Custom->new( |
|
| 25 |
+ user => 'a', |
|
| 26 |
+ database => 'a', |
|
| 27 |
+ password => 'b', |
|
| 28 |
+ data_source => 'c', |
|
| 29 |
+ dbi_options => {d => 1, e => 2},
|
|
| 30 |
+ filters => {
|
|
| 31 |
+ f => 3, |
|
| 32 |
+ }, |
|
| 33 |
+ bind_filter => 'f', |
|
| 34 |
+ fetch_filter => 'g', |
|
| 35 |
+ result_class => 'g', |
|
| 36 |
+ sql_template => $SQL_TMPL->{0},
|
|
| 37 |
+); |
|
| 38 |
+is_deeply($dbi,{user => 'a', database => 'a', password => 'b', data_source => 'c',
|
|
| 39 |
+ dbi_options => {d => 1, e => 2}, filters => {f => 3}, bind_filter => 'f',
|
|
| 40 |
+ fetch_filter => 'g', result_class => 'g', |
|
| 41 |
+ sql_template => $SQL_TMPL->{0}}, $test);
|
|
| 42 |
+isa_ok($dbi, 'DBIx::Custom'); |
|
| 43 |
+ |
|
| 44 |
+ |
|
| 45 |
+test 'Sub class constructor'; |
|
| 46 |
+{
|
|
| 47 |
+ package DBIx::Custom::T1; |
|
| 48 |
+ use base 'DBIx::Custom'; |
|
| 49 |
+ |
|
| 50 |
+ __PACKAGE__ |
|
| 51 |
+ ->user('a')
|
|
| 52 |
+ ->database('a')
|
|
| 53 |
+ ->password('b')
|
|
| 54 |
+ ->data_source('c')
|
|
| 55 |
+ ->dbi_options({d => 1, e => 2})
|
|
| 56 |
+ ->filters( |
|
| 57 |
+ f => 3 |
|
| 58 |
+ ) |
|
| 59 |
+ ->formats( |
|
| 60 |
+ f => 3 |
|
| 61 |
+ ) |
|
| 62 |
+ ->bind_filter('f')
|
|
| 63 |
+ ->fetch_filter('g')
|
|
| 64 |
+ ->result_class('DBIx::Custom::Result')
|
|
| 65 |
+ ->sql_template($SQL_TMPL->{0})
|
|
| 66 |
+ ; |
|
| 67 |
+} |
|
| 68 |
+$dbi = DBIx::Custom::T1->new( |
|
| 69 |
+ user => 'ao', |
|
| 70 |
+ database => 'ao', |
|
| 71 |
+ password => 'bo', |
|
| 72 |
+ data_source => 'co', |
|
| 73 |
+ dbi_options => {do => 10, eo => 20},
|
|
| 74 |
+ filters => {
|
|
| 75 |
+ fo => 30, |
|
| 76 |
+ }, |
|
| 77 |
+ formats => {
|
|
| 78 |
+ fo => 30, |
|
| 79 |
+ }, |
|
| 80 |
+ bind_filter => 'fo', |
|
| 81 |
+ fetch_filter => 'go', |
|
| 82 |
+ result_class => 'ho', |
|
| 83 |
+ sql_template => $SQL_TMPL->{0},
|
|
| 84 |
+); |
|
| 85 |
+is($dbi->user, 'ao', "$test : user"); |
|
| 86 |
+is($dbi->database, 'ao', "$test : database"); |
|
| 87 |
+is($dbi->password, 'bo', "$test : passowr"); |
|
| 88 |
+is($dbi->data_source, 'co', "$test : data_source"); |
|
| 89 |
+is_deeply($dbi->dbi_options, {do => 10, eo => 20}, "$test : dbi_options");
|
|
| 90 |
+is_deeply(scalar $dbi->filters, {fo => 30}, "$test : filters");
|
|
| 91 |
+is_deeply(scalar $dbi->formats, {fo => 30}, "$test : formats");
|
|
| 92 |
+is($dbi->bind_filter, 'fo', "$test : bind_filter"); |
|
| 93 |
+is($dbi->fetch_filter, 'go', "$test : fetch_filter"); |
|
| 94 |
+is($dbi->result_class, 'ho', "$test : result_class"); |
|
| 95 |
+is($dbi->sql_template->tag_start, 0, "$test : sql_template"); |
|
| 96 |
+isa_ok($dbi, 'DBIx::Custom::T1'); |
|
| 97 |
+ |
|
| 98 |
+test 'Sub class constructor default'; |
|
| 99 |
+$dbi = DBIx::Custom::T1->new; |
|
| 100 |
+is($dbi->user, 'a', "$test : user"); |
|
| 101 |
+is($dbi->database, 'a', "$test : database"); |
|
| 102 |
+is($dbi->password, 'b', "$test : password"); |
|
| 103 |
+is($dbi->data_source, 'c', "$test : data_source"); |
|
| 104 |
+is_deeply($dbi->dbi_options, {d => 1, e => 2}, "$test : dbi_options");
|
|
| 105 |
+is_deeply({$dbi->filters}, {f => 3}, "$test : filters");
|
|
| 106 |
+is_deeply({$dbi->formats}, {f => 3}, "$test : formats");
|
|
| 107 |
+is($dbi->bind_filter, 'f', "$test : bind_filter"); |
|
| 108 |
+is($dbi->fetch_filter, 'g', "$test : fetch_filter"); |
|
| 109 |
+is($dbi->result_class, 'DBIx::Custom::Result', "$test : result_class"); |
|
| 110 |
+is($dbi->sql_template->tag_start, 0, "$test : sql_template"); |
|
| 111 |
+isa_ok($dbi, 'DBIx::Custom::T1'); |
|
| 112 |
+ |
|
| 113 |
+ |
|
| 114 |
+test 'Sub sub class constructor default'; |
|
| 115 |
+{
|
|
| 116 |
+ package DBIx::Custom::T1_2; |
|
| 117 |
+ use base 'DBIx::Custom::T1'; |
|
| 118 |
+} |
|
| 119 |
+$dbi = DBIx::Custom::T1_2->new; |
|
| 120 |
+is($dbi->user, 'a', "$test : user"); |
|
| 121 |
+is($dbi->database, 'a', "$test : database"); |
|
| 122 |
+is($dbi->password, 'b', "$test : passowrd"); |
|
| 123 |
+is($dbi->data_source, 'c', "$test : data_source"); |
|
| 124 |
+is_deeply($dbi->dbi_options, {d => 1, e => 2}, "$test : dbi_options");
|
|
| 125 |
+is_deeply(scalar $dbi->filters, {f => 3}, "$test : filters");
|
|
| 126 |
+is_deeply(scalar $dbi->formats, {f => 3}, "$test : formats");
|
|
| 127 |
+is($dbi->bind_filter, 'f', "$test : bind_filter"); |
|
| 128 |
+is($dbi->fetch_filter, 'g', "$test : fetch_filter"); |
|
| 129 |
+is($dbi->result_class, 'DBIx::Custom::Result', "$test : result_class"); |
|
| 130 |
+is($dbi->sql_template->tag_start, 0, "$test sql_template"); |
|
| 131 |
+isa_ok($dbi, 'DBIx::Custom::T1_2'); |
|
| 132 |
+ |
|
| 133 |
+ |
|
| 134 |
+test 'Customized sub class constructor default'; |
|
| 135 |
+{
|
|
| 136 |
+ package DBIx::Custom::T1_3; |
|
| 137 |
+ use base 'DBIx::Custom::T1'; |
|
| 138 |
+ |
|
| 139 |
+ __PACKAGE__ |
|
| 140 |
+ ->user('ao')
|
|
| 141 |
+ ->database('ao')
|
|
| 142 |
+ ->password('bo')
|
|
| 143 |
+ ->data_source('co')
|
|
| 144 |
+ ->dbi_options({do => 10, eo => 20})
|
|
| 145 |
+ ->filters( |
|
| 146 |
+ fo => 30 |
|
| 147 |
+ ) |
|
| 148 |
+ ->formats( |
|
| 149 |
+ fo => 30 |
|
| 150 |
+ ) |
|
| 151 |
+ ->bind_filter('fo')
|
|
| 152 |
+ ->fetch_filter('go')
|
|
| 153 |
+ ->result_class('ho')
|
|
| 154 |
+ ->sql_template($SQL_TMPL->{1})
|
|
| 155 |
+ ; |
|
| 156 |
+} |
|
| 157 |
+$dbi = DBIx::Custom::T1_3->new; |
|
| 158 |
+is($dbi->user, 'ao', "$test : user"); |
|
| 159 |
+is($dbi->database, 'ao', "$test : database"); |
|
| 160 |
+is($dbi->password, 'bo', "$test : password"); |
|
| 161 |
+is($dbi->data_source, 'co', "$test : data_source"); |
|
| 162 |
+is_deeply($dbi->dbi_options, {do => 10, eo => 20}, "$test : dbi_options");
|
|
| 163 |
+is_deeply(scalar $dbi->filters, {fo => 30}, "$test : filters");
|
|
| 164 |
+is_deeply(scalar $dbi->formats, {fo => 30}, "$test : formats");
|
|
| 165 |
+is($dbi->bind_filter, 'fo', "$test : bind_filter"); |
|
| 166 |
+is($dbi->fetch_filter, 'go', "$test : fetch_filter"); |
|
| 167 |
+is($dbi->result_class, 'ho', "$test : result_class"); |
|
| 168 |
+is($dbi->sql_template->tag_start, 1, "$test : sql_template"); |
|
| 169 |
+isa_ok($dbi, 'DBIx::Custom::T1_3'); |
|
| 170 |
+ |
|
| 171 |
+ |
|
| 172 |
+test 'Customized sub class constructor'; |
|
| 173 |
+$dbi = DBIx::Custom::T1_3->new( |
|
| 174 |
+ user => 'a', |
|
| 175 |
+ database => 'a', |
|
| 176 |
+ password => 'b', |
|
| 177 |
+ data_source => 'c', |
|
| 178 |
+ dbi_options => {d => 1, e => 2},
|
|
| 179 |
+ filters => {
|
|
| 180 |
+ f => 3, |
|
| 181 |
+ }, |
|
| 182 |
+ formats => {
|
|
| 183 |
+ f => 3, |
|
| 184 |
+ }, |
|
| 185 |
+ bind_filter => 'f', |
|
| 186 |
+ fetch_filter => 'g', |
|
| 187 |
+ result_class => 'h', |
|
| 188 |
+ sql_template => $SQL_TMPL->{2},
|
|
| 189 |
+); |
|
| 190 |
+is($dbi->user, 'a', "$test : user"); |
|
| 191 |
+is($dbi->database, 'a', "$test : database"); |
|
| 192 |
+is($dbi->password, 'b', "$test : password"); |
|
| 193 |
+is($dbi->data_source, 'c', "$test : data_source"); |
|
| 194 |
+is_deeply($dbi->dbi_options, {d => 1, e => 2}, "$test : dbi_options");
|
|
| 195 |
+is_deeply({$dbi->filters}, {f => 3}, "$test : filters");
|
|
| 196 |
+is_deeply({$dbi->formats}, {f => 3}, "$test : formats");
|
|
| 197 |
+is($dbi->bind_filter, 'f', "$test : bind_filter"); |
|
| 198 |
+is($dbi->fetch_filter, 'g', "$test : fetch_filter"); |
|
| 199 |
+is($dbi->result_class, 'h', "$test : result_class"); |
|
| 200 |
+is($dbi->sql_template->tag_start, 2, "$test : sql_template"); |
|
| 201 |
+isa_ok($dbi, 'DBIx::Custom'); |
|
| 202 |
+ |
|
| 203 |
+ |
|
| 204 |
+test 'add_filters'; |
|
| 205 |
+$dbi = DBIx::Custom->new; |
|
| 206 |
+$dbi->add_filter(a => sub {1});
|
|
| 207 |
+is($dbi->filters->{a}->(), 1, $test);
|
|
| 208 |
+ |
|
| 209 |
+test 'add_formats'; |
|
| 210 |
+$dbi = DBIx::Custom->new; |
|
| 211 |
+$dbi->add_format(a => sub {1});
|
|
| 212 |
+is($dbi->formats->{a}->(), 1, $test);
|
|
| 213 |
+ |
|
| 214 |
+test 'filter_off'; |
|
| 215 |
+$dbi = DBIx::Custom->new; |
|
| 216 |
+$dbi->bind_filter('a');
|
|
| 217 |
+$dbi->fetch_filter('b');
|
|
| 218 |
+$dbi->filter_off; |
|
| 219 |
+ok(!$dbi->bind_filter, "$test : bind_filter off"); |
|
| 220 |
+ok(!$dbi->fetch_filter, "$test : fetch_filter off"); |
| ... | ... |
@@ -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 |
+ |
| ... | ... |
@@ -0,0 +1,85 @@ |
| 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 |
+ eval { Time::Piece->VERSION >= 1.15 }
|
|
| 10 |
+ or plan skip_all => 'Time::Piece >= 1.15 requred'; |
|
| 11 |
+ |
|
| 12 |
+ plan 'no_plan'; |
|
| 13 |
+ use_ok('DBIx::Custom');
|
|
| 14 |
+} |
|
| 15 |
+ |
|
| 16 |
+# Function for test name |
|
| 17 |
+my $test; |
|
| 18 |
+sub test {
|
|
| 19 |
+ $test = shift; |
|
| 20 |
+} |
|
| 21 |
+ |
|
| 22 |
+# Varialbe for tests |
|
| 23 |
+ |
|
| 24 |
+my $format; |
|
| 25 |
+my $data; |
|
| 26 |
+my $timepiece; |
|
| 27 |
+my $dbi; |
|
| 28 |
+ |
|
| 29 |
+use DBIx::Custom::MySQL; |
|
| 30 |
+ |
|
| 31 |
+ |
|
| 32 |
+test 'SQL99 format'; |
|
| 33 |
+$dbi = DBIx::Custom::MySQL->new; |
|
| 34 |
+$data = '2009-01-02 03:04:05'; |
|
| 35 |
+$format = $dbi->formats->{'SQL99_datetime'};
|
|
| 36 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 37 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : datetime date");
|
|
| 38 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : datetime time");
|
|
| 39 |
+ |
|
| 40 |
+$data = '2009-01-02'; |
|
| 41 |
+$format = $dbi->formats->{'SQL99_date'};
|
|
| 42 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 43 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : date");
|
|
| 44 |
+ |
|
| 45 |
+$data = '03:04:05'; |
|
| 46 |
+$format = $dbi->formats->{'SQL99_time'};
|
|
| 47 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 48 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : time");
|
|
| 49 |
+ |
|
| 50 |
+ |
|
| 51 |
+test 'ISO-8601 format'; |
|
| 52 |
+$data = '2009-01-02T03:04:05'; |
|
| 53 |
+$format = $dbi->formats->{'ISO-8601_datetime'};
|
|
| 54 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 55 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : datetime date");
|
|
| 56 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : datetime time");
|
|
| 57 |
+ |
|
| 58 |
+$data = '2009-01-02'; |
|
| 59 |
+$format = $dbi->formats->{'ISO-8601_date'};
|
|
| 60 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 61 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : date");
|
|
| 62 |
+ |
|
| 63 |
+$data = '03:04:05'; |
|
| 64 |
+$format = $dbi->formats->{'ISO-8601_time'};
|
|
| 65 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 66 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : time");
|
|
| 67 |
+ |
|
| 68 |
+ |
|
| 69 |
+test 'default format'; |
|
| 70 |
+$data = '2009-01-02 03:04:05'; |
|
| 71 |
+$format = $dbi->formats->{'datetime'};
|
|
| 72 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 73 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : datetime date");
|
|
| 74 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : datetime time");
|
|
| 75 |
+ |
|
| 76 |
+$data = '2009-01-02'; |
|
| 77 |
+$format = $dbi->formats->{'date'};
|
|
| 78 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 79 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : date");
|
|
| 80 |
+ |
|
| 81 |
+$data = '03:04:05'; |
|
| 82 |
+$format = $dbi->formats->{'time'};
|
|
| 83 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 84 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : time");
|
|
| 85 |
+ |
| ... | ... |
@@ -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 |
+ |
| ... | ... |
@@ -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_hash_first'; |
|
| 99 |
+$result = query($dbh, $sql); |
|
| 100 |
+$row = $result->fetch_hash_first; |
|
| 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_hash_first list context'; |
|
| 107 |
+$result = query($dbh, $sql); |
|
| 108 |
+@row = $result->fetch_hash_first; |
|
| 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_hash_rows'; |
|
| 152 |
+$result = query($dbh, $sql); |
|
| 153 |
+$rows = $result->fetch_hash_rows(2); |
|
| 154 |
+is_deeply($rows, [{key1 => 1, key2 => 2},
|
|
| 155 |
+ {key1 => 3, key2 => 4}], "$test : fetch_rows first");
|
|
| 156 |
+$rows = $result->fetch_hash_rows(2); |
|
| 157 |
+is_deeply($rows, [{key1 => 5, key2 => 6},
|
|
| 158 |
+ {key1 => 7, key2 => 8}], "$test : fetch_rows secound");
|
|
| 159 |
+$rows = $result->fetch_hash_rows(2); |
|
| 160 |
+is_deeply($rows, [{key1 => 9, key2 => 10}], "$test : fetch_rows third");
|
|
| 161 |
+$rows = $result->fetch_hash_rows(2); |
|
| 162 |
+ok(!$rows); |
|
| 163 |
+ |
|
| 164 |
+ |
|
| 165 |
+test 'fetch_rows list context'; |
|
| 166 |
+$result = query($dbh, $sql); |
|
| 167 |
+@rows = $result->fetch_hash_rows(2); |
|
| 168 |
+is_deeply([@rows], [{key1 => 1, key2 => 2},
|
|
| 169 |
+ {key1 => 3, key2 => 4}], "$test : fetch_rows first");
|
|
| 170 |
+@rows = $result->fetch_hash_rows(2); |
|
| 171 |
+is_deeply([@rows], [{key1 => 5, key2 => 6},
|
|
| 172 |
+ {key1 => 7, key2 => 8}], "$test : fetch_rows secound");
|
|
| 173 |
+@rows = $result->fetch_hash_rows(2); |
|
| 174 |
+is_deeply([@rows], [{key1 => 9, key2 => 10}], "$test : fetch_rows third");
|
|
| 175 |
+@rows = $result->fetch_hash_rows(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_hash_rows};
|
|
| 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_hash_all'; |
|
| 198 |
+$result = query($dbh, $sql); |
|
| 199 |
+@rows = $result->fetch_hash_all; |
|
| 200 |
+is_deeply($rows, [[1, 2], [3, 4]], $test); |
|
| 201 |
+ |
|
| 202 |
+ |
|
| 203 |
+test 'fetch_hash_all 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 ($value, $key, $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_hash_all; |
|
| 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_hash_all; |
|
| 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 |
+ |
| ... | ... |
@@ -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 |
+ |
| ... | ... |
@@ -0,0 +1,85 @@ |
| 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 |
+ eval { Time::Piece->VERSION >= 1.15 }
|
|
| 10 |
+ or plan skip_all => 'Time::Piece >= 1.15 requred'; |
|
| 11 |
+ |
|
| 12 |
+ plan 'no_plan'; |
|
| 13 |
+ use_ok('DBIx::Custom');
|
|
| 14 |
+} |
|
| 15 |
+ |
|
| 16 |
+# Function for test name |
|
| 17 |
+my $test; |
|
| 18 |
+sub test {
|
|
| 19 |
+ $test = shift; |
|
| 20 |
+} |
|
| 21 |
+ |
|
| 22 |
+# Varialbe for tests |
|
| 23 |
+ |
|
| 24 |
+my $format; |
|
| 25 |
+my $data; |
|
| 26 |
+my $timepiece; |
|
| 27 |
+my $dbi; |
|
| 28 |
+ |
|
| 29 |
+use DBIx::Custom::SQLite; |
|
| 30 |
+ |
|
| 31 |
+ |
|
| 32 |
+test 'SQL99 format'; |
|
| 33 |
+$dbi = DBIx::Custom::SQLite->new; |
|
| 34 |
+$data = '2009-01-02 03:04:05'; |
|
| 35 |
+$format = $dbi->formats->{'SQL99_datetime'};
|
|
| 36 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 37 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : datetime date");
|
|
| 38 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : datetime time");
|
|
| 39 |
+ |
|
| 40 |
+$data = '2009-01-02'; |
|
| 41 |
+$format = $dbi->formats->{'SQL99_date'};
|
|
| 42 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 43 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : date");
|
|
| 44 |
+ |
|
| 45 |
+$data = '03:04:05'; |
|
| 46 |
+$format = $dbi->formats->{'SQL99_time'};
|
|
| 47 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 48 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : time");
|
|
| 49 |
+ |
|
| 50 |
+ |
|
| 51 |
+test 'ISO-8601 format'; |
|
| 52 |
+$data = '2009-01-02T03:04:05'; |
|
| 53 |
+$format = $dbi->formats->{'ISO-8601_datetime'};
|
|
| 54 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 55 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : datetime date");
|
|
| 56 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : datetime time");
|
|
| 57 |
+ |
|
| 58 |
+$data = '2009-01-02'; |
|
| 59 |
+$format = $dbi->formats->{'ISO-8601_date'};
|
|
| 60 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 61 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : date");
|
|
| 62 |
+ |
|
| 63 |
+$data = '03:04:05'; |
|
| 64 |
+$format = $dbi->formats->{'ISO-8601_time'};
|
|
| 65 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 66 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : time");
|
|
| 67 |
+ |
|
| 68 |
+ |
|
| 69 |
+test 'default format'; |
|
| 70 |
+$data = '2009-01-02 03:04:05'; |
|
| 71 |
+$format = $dbi->formats->{'datetime'};
|
|
| 72 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 73 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : datetime date");
|
|
| 74 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : datetime time");
|
|
| 75 |
+ |
|
| 76 |
+$data = '2009-01-02'; |
|
| 77 |
+$format = $dbi->formats->{'date'};
|
|
| 78 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 79 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : date");
|
|
| 80 |
+ |
|
| 81 |
+$data = '03:04:05'; |
|
| 82 |
+$format = $dbi->formats->{'time'};
|
|
| 83 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 84 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : time");
|
|
| 85 |
+ |
| ... | ... |
@@ -0,0 +1,69 @@ |
| 1 |
+use Test::More; |
|
| 2 |
+use strict; |
|
| 3 |
+use warnings; |
|
| 4 |
+use utf8; |
|
| 5 |
+ |
|
| 6 |
+BEGIN {
|
|
| 7 |
+ eval { require DBD::SQLite; 1 }
|
|
| 8 |
+ or plan skip_all => 'DBD::SQLite required'; |
|
| 9 |
+ eval { DBD::SQLite->VERSION >= 1.25 }
|
|
| 10 |
+ or plan skip_all => 'DBD::SQLite >= 1.25 required'; |
|
| 11 |
+ |
|
| 12 |
+ plan 'no_plan'; |
|
| 13 |
+ use_ok('DBIx::Custom::SQLite');
|
|
| 14 |
+} |
|
| 15 |
+ |
|
| 16 |
+# Function for test name |
|
| 17 |
+my $test; |
|
| 18 |
+sub test {
|
|
| 19 |
+ $test = shift; |
|
| 20 |
+} |
|
| 21 |
+ |
|
| 22 |
+# Constant varialbes for test |
|
| 23 |
+my $CREATE_TABLE = {
|
|
| 24 |
+ 0 => 'create table table1 (key1 char(255), key2 char(255));', |
|
| 25 |
+ 1 => 'create table table1 (key1 char(255), key2 char(255), key3 char(255), key4 char(255), key5 char(255));', |
|
| 26 |
+ 2 => 'create table table2 (key1 char(255), key3 char(255));' |
|
| 27 |
+}; |
|
| 28 |
+ |
|
| 29 |
+ |
|
| 30 |
+# Variables for tests |
|
| 31 |
+my $dbi; |
|
| 32 |
+my $ret_val; |
|
| 33 |
+my $rows; |
|
| 34 |
+my $db_file; |
|
| 35 |
+ |
|
| 36 |
+test 'connect_memory'; |
|
| 37 |
+$dbi = DBIx::Custom::SQLite->new; |
|
| 38 |
+$dbi->connect_memory; |
|
| 39 |
+$ret_val = $dbi->do($CREATE_TABLE->{0});
|
|
| 40 |
+ok(defined $ret_val, $test); |
|
| 41 |
+$dbi->utf8_filter_on; |
|
| 42 |
+$dbi->insert('table1', {key1 => 'あ', key2 => 2});
|
|
| 43 |
+$rows = $dbi->select('table1', {key1 => 'あ'})->fetch_hash_all;
|
|
| 44 |
+is_deeply($rows, [{key1 => 'あ', key2 => 2}], "$test : select rows");
|
|
| 45 |
+ |
|
| 46 |
+test 'connect_memory error'; |
|
| 47 |
+eval{$dbi->connect_memory};
|
|
| 48 |
+like($@, qr/Already connected/, "$test : already connected"); |
|
| 49 |
+ |
|
| 50 |
+test 'reconnect_memory'; |
|
| 51 |
+$dbi = DBIx::Custom::SQLite->new; |
|
| 52 |
+$dbi->reconnect_memory; |
|
| 53 |
+$ret_val = $dbi->do($CREATE_TABLE->{0});
|
|
| 54 |
+ok(defined $ret_val, "$test : connect first"); |
|
| 55 |
+$dbi->reconnect_memory; |
|
| 56 |
+$ret_val = $dbi->do($CREATE_TABLE->{2});
|
|
| 57 |
+ok(defined $ret_val, "$test : connect first"); |
|
| 58 |
+ |
|
| 59 |
+test 'connect'; |
|
| 60 |
+$db_file = 't/test.db'; |
|
| 61 |
+unlink $db_file if -f $db_file; |
|
| 62 |
+$dbi = DBIx::Custom::SQLite->new(database => $db_file); |
|
| 63 |
+$dbi->connect; |
|
| 64 |
+ok(-f $db_file, "$test : database file"); |
|
| 65 |
+$ret_val = $dbi->do($CREATE_TABLE->{0});
|
|
| 66 |
+ok(defined $ret_val, "$test : database"); |
|
| 67 |
+$dbi->disconnect; |
|
| 68 |
+unlink $db_file if -f $db_file; |
|
| 69 |
+ |
| ... | ... |
@@ -0,0 +1,67 @@ |
| 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 |
+ eval { Time::Piece->VERSION >= 1.15 }
|
|
| 10 |
+ or plan skip_all => 'Time::Piece >= 1.15 requred'; |
|
| 11 |
+ |
|
| 12 |
+ plan 'no_plan'; |
|
| 13 |
+ use_ok('DBIx::Custom');
|
|
| 14 |
+} |
|
| 15 |
+ |
|
| 16 |
+# Function for test name |
|
| 17 |
+my $test; |
|
| 18 |
+sub test {
|
|
| 19 |
+ $test = shift; |
|
| 20 |
+} |
|
| 21 |
+ |
|
| 22 |
+# Varialbe for tests |
|
| 23 |
+ |
|
| 24 |
+my $format; |
|
| 25 |
+my $data; |
|
| 26 |
+my $timepiece; |
|
| 27 |
+my $dbi; |
|
| 28 |
+ |
|
| 29 |
+use DBIx::Custom::Basic; |
|
| 30 |
+ |
|
| 31 |
+ |
|
| 32 |
+test 'SQL99 format'; |
|
| 33 |
+$dbi = DBIx::Custom::Basic->new; |
|
| 34 |
+$data = '2009-01-02 03:04:05'; |
|
| 35 |
+$format = $dbi->formats->{'SQL99_datetime'};
|
|
| 36 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 37 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : datetime date");
|
|
| 38 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : datetime time");
|
|
| 39 |
+ |
|
| 40 |
+$data = '2009-01-02'; |
|
| 41 |
+$format = $dbi->formats->{'SQL99_date'};
|
|
| 42 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 43 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : date");
|
|
| 44 |
+ |
|
| 45 |
+$data = '03:04:05'; |
|
| 46 |
+$format = $dbi->formats->{'SQL99_time'};
|
|
| 47 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 48 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : time");
|
|
| 49 |
+ |
|
| 50 |
+ |
|
| 51 |
+test 'ISO-8601 format'; |
|
| 52 |
+$data = '2009-01-02T03:04:05'; |
|
| 53 |
+$format = $dbi->formats->{'ISO-8601_datetime'};
|
|
| 54 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 55 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : datetime date");
|
|
| 56 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : datetime time");
|
|
| 57 |
+ |
|
| 58 |
+$data = '2009-01-02'; |
|
| 59 |
+$format = $dbi->formats->{'ISO-8601_date'};
|
|
| 60 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 61 |
+is($timepiece->strftime('%F'), '2009-01-02', "$test : date");
|
|
| 62 |
+ |
|
| 63 |
+$data = '03:04:05'; |
|
| 64 |
+$format = $dbi->formats->{'ISO-8601_time'};
|
|
| 65 |
+$timepiece = Time::Piece->strptime($data, $format); |
|
| 66 |
+is($timepiece->strftime('%T'), '03:04:05', "$test : time");
|
|
| 67 |
+ |
| ... | ... |
@@ -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(); |
| ... | ... |
@@ -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(); |