Perl/DBIx-NamedParams.md
... ...
@@ -1,6 +1,8 @@
1 1
[[_TOC_]]
2 2
3 3
# 概要
4
+- [DBIx::NamedParams - metacpan.org](https://metacpan.org/pod/DBIx::NamedParams)
5
+- [p-DBIx-NamedParams - GitHub](https://github.com/TakeAsh/p-DBIx-NamedParams)
4 6
- mysql でも prepare でプレースホルダとして ? じゃなく名前で指定できるようにする。
5 7
- 同じ名前を繰り返し使ってもエラーにならない。
6 8
- こっちより [CPAN:DBIx-Custom](http://search.cpan.org/dist/DBIx-Custom) の方が柔軟で高機能だなー。どうしたもんか。
... ...
@@ -82,210 +84,6 @@ my %DrvTypeToSQLType = $dbh->driver_typename_map();
82 84
- prepare_ex のときに @_NamedParams をクリアするようにした。
83 85
84 86
# ソース
85
-- [NamedParams.zip](NamedParams.zip)
86
-
87
-## NamedParams.pm
88
-```perl
89
-# DBI::db::prepare, DBI::st::bind_param を拡張する。
90
-# http://www.TakeAsh.net/wiki/?Perl/DBIx-NamedParams
91
-#
92
-# prepare_ex では「:名前-型」形式のようにプレースホルダを書く。
93
-# bind_param_ex では名前と値の対応を示すハッシュを渡す。
94
-
95
-package DBIx::NamedParams;
96
-
97
-use strict;
98
-use warnings;
99
-use utf8;
100
-use Encode;
101
-use Carp qw( croak );
102
-use parent qw( DBI );
103
-use DBI::Const::GetInfoType;
104
-use Log::Dispatch;
105
-use POSIX qw( strftime );
106
-
107
-use version; our $VERSION = qv( '0.0.5' );
108
-
109
-( $ENV{'LANG'} || '' ) =~ /\.(.*)$/; # ja_JP.UTF-8
110
-my $charsetConsole = $1 || 'CP932';
111
-my $charsetFile = 'UTF-8';
112
-
113
-my $_default_log_filename = ( $ENV{'HOME'} || $ENV{'USERPROFILE'} );
114
-$_default_log_filename =~ s#\\#/#g;
115
-$_default_log_filename .= '/DBIx-NamedParams.log';
116
-
117
-my %_SQL_TypeRefs = ();
118
-my %_SQL_TypeInvs = ();
119
-my $_SQL_Types = "";
120
-my @_NamedParams = ();
121
-my $_index;
122
-my $_log = undef;
123
-
124
-sub import {
125
- DBI->import(); # 不要か？
126
- _init();
127
- *{DBI::db::driver_typename_map} = \&driver_typename_map;
128
- *{DBI::db::prepare_ex} = \&prepare_ex;
129
- *{DBI::st::bind_param_ex} = \&bind_param_ex;
130
-}
131
-
132
-sub _init
133
-{
134
- foreach( @{ $DBI::EXPORT_TAGS{sql_types} } ){
135
- my $refFunc = \&{"DBI::$_"};
136
- if ( /^SQL_(.*)$/i ){
137
- $_SQL_TypeRefs{ $1 } = &{ $refFunc };
138
- $_SQL_TypeInvs{ &{ $refFunc } } = $1;
139
- }
140
- }
141
- $_SQL_Types = all_sql_types();
142
-}
143
-
144
-sub debug_log
145
-{
146
- my( $filename ) = @_;
147
- $filename = encode( $charsetConsole, ( $filename || $_default_log_filename ) );
148
- $_log = Log::Dispatch->new(
149
- outputs => [ [
150
- 'File',
151
- min_level => 'debug',
152
- filename => $filename,
153
- binmode => ":encoding($charsetFile)",
154
- permissions => 0666,
155
- newline => 1,
156
- ], ],
157
- );
158
- $_log->info( _thisFuncName(), strftime( "%Y-%m-%d %H:%M:%S", localtime ) );
159
-}
160
-
161
-sub _thisFuncName
162
-{
163
- ( caller( 1 ) )[3] =~ /([^:]+)$/;
164
- return $1;
165
-}
166
-
167
-sub all_sql_types
168
-{
169
- return wantarray
170
- ? sort( keys( %_SQL_TypeRefs ) )
171
- : join( "|", sort( keys( %_SQL_TypeRefs ) ) );
172
-}
173
-sub driver_typename_map
174
-{
175
- my( $self ) = @_;
176
- my %map = ();
177
- foreach my $refType ( $self->type_info() ){
178
- my $datatype = $refType->{ 'SQL_DATA_TYPE' } # MS SQL Server
179
- || $refType->{ 'SQL_DATATYPE' }; # MySQL
180
- $map{ $refType->{ 'TYPE_NAME' } } = $_SQL_TypeInvs{ $datatype } || 'WVARCHAR';
181
- }
182
- if ( $self->get_info( $GetInfoType{ 'SQL_DBMS_NAME' } ) eq 'Microsoft SQL Server' ){
183
- $map{ 'datetime' } = 'WVARCHAR';
184
- $map{ 'smalldatetime' } = 'WVARCHAR';
185
- }
186
- return %map;
187
-}
188
-
189
-sub prepare_ex
190
-{
191
- my( $self, $sqlex, $refHash ) = @_;
192
- my $ret = undef;
193
- my $validHash = defined( $refHash ) && ref( $refHash ) eq 'HASH';
194
- if ( $sqlex =~ /\:([\w]+)\+-($_SQL_Types)\b/ ){
195
- if ( $validHash ){
196
- $sqlex =~ s/\:([\w]+)\+-($_SQL_Types)\b/_parse_ex1($refHash,$1,$2);/ge;
197
- } else {
198
- croak( "prepare_ex need a hash reference when SQL is variable length.\n" );
199
- }
200
- }
201
- @_NamedParams = ();
202
- $_index = 1;
203
- $sqlex =~ s/\:([\w]+)(?:\{(\d+)\})?-($_SQL_Types)\b/_parse_ex2($1,$2,$3);/ge;
204
- if ( $_log ){
205
- $_log->info( _thisFuncName(), 'sql_raw', "{{$sqlex}}" );
206
- }
207
- $ret = $self->prepare( $sqlex ) or croak( "$DBI::errstr" );
208
- if ( $validHash ){
209
- $ret->bind_param_ex( $refHash );
210
- }
211
- return $ret;
212
-}
213
-
214
-sub _parse_ex1
215
-{
216
- my( $refHash, $name, $type ) = @_;
217
- return ":${name}{" . scalar( @{ $refHash->{ $name } } ) . "}-$type";
218
-}
219
-
220
-sub _parse_ex2
221
-{
222
- my $name = shift || '';
223
- my $repeat = shift || 0;
224
- my $type = shift || '';
225
- my $ret = '';
226
- # '' や 0 も有効値として使いたい場合 (Perl 5.9 以降)
227
- # my $param = shift // -1;
228
- if ( $_log ){
229
- $_log->info(
230
- _thisFuncName(),
231
- "[$_index]",
232
- "\"$name\"",
233
- (!$repeat) ? "scalar" : "array[$repeat]",
234
- $type
235
- );
236
- }
237
- if ( !$repeat ){
238
- # scalar
239
- $_NamedParams[ $_index++ ] = {
240
- Name => $name,
241
- Type => $_SQL_TypeRefs{ $type },
242
- Array => -1,
243
- };
244
- $ret = '?';
245
- } else {
246
- # array
247
- for( my $i=0; $i<$repeat; ++$i ){
248
- $_NamedParams[ $_index++ ] = {
249
- Name => $name,
250
- Type => $_SQL_TypeRefs{ $type },
251
- Array => $i,
252
- };
253
- }
254
- $ret = substr( '?,' x $repeat, 0, -1 );
255
- }
256
- return $ret;
257
-}
258
-
259
-sub bind_param_ex
260
-{
261
- no warnings 'uninitialized';
262
- my( $self, $refHash ) = @_;
263
- if ( !defined( $refHash ) || ref( $refHash ) ne 'HASH' ){
264
- croak( "bind_param_ex need a hash reference.\n" );
265
- }
266
- my $thisFunc = _thisFuncName();
267
- for( my $i=1; $i<@_NamedParams; ++$i ){
268
- my $idx = $_NamedParams[ $i ]{ 'Array' };
269
- my $value1 = $refHash->{ $_NamedParams[ $i ]{ 'Name' } };
270
- my $value2 = ( $idx < 0 || ref( $value1 ) ne 'ARRAY' )
271
- ? $value1
272
- : @{ $value1 }[ $idx ];
273
- my $datatype = $_NamedParams[ $i ]{ 'Type' };
274
- if ( $_log ){
275
- $_log->info(
276
- $thisFunc, "[$i]", "\"$value2\"", $_SQL_TypeInvs{ $datatype }
277
- );
278
- }
279
- $self->bind_param( $i, $value2 , { TYPE => $datatype } )
280
- or croak( "$DBI::errstr\n" );
281
- }
282
- return $self;
283
-}
284
-
285
-1;
286
-
287
-# EOF
288
-```
289 87
290 88
## testNamedParams_MySQL.pl
291 89
```perl