File Coverage

web/cgi-bin/yatt.lib/YATT/DBSchema.pm
Criterion Covered Total %
statement 36 437 8.2
branch 0 208 0.0
condition 0 66 0.0
subroutine 12 68 17.6
pod 0 47 0.0
total 48 826 5.8


line stmt bran cond sub pod time code
1             package YATT::DBSchema;
2 1     1   11480 use strict;
  1         3  
  1         37  
3 1     1   4 use warnings qw(FATAL all NONFATAL misc);
  1         2  
  1         64  
4 1     1   5 use Carp;
  1         2  
  1         64  
5              
6 1     1   6 use File::Basename;
  1         2  
  1         65  
7 1     1   554 use YATT::Util::CmdLine;
  1         3  
  1         58  
8              
9 1     1   5 use base qw(YATT::Class::Configurable);
  1         2  
  1         117  
10 1         11 use YATT::Fields (qw(schemas tables cf_DBH
11             cf_user
12             cf_auth
13             ^cf_connection_spec
14             ^cf_verbose
15             )
16             , ['^cf_dbtype' => 'sqlite']
17             , ['^cf_NULL' => '']
18             , ['^cf_name' => 'DBSchema']
19             , qw(
20             cf_no_header
21             cf_auto_create
22             cf_as_base
23             )
24 1     1   7 );
  1         3  
25              
26 1     1   6 use YATT::Types [Item => [qw(cf_name)]];
  1         2  
  1         9  
27              
28 1         17 use YATT::Types -base => Item
29             , [Table => [qw(pk raw_create chk_unique chk_index chk_check colNames)]
30             , [Column => [qw(colnum
31             cf_type
32             cf_hidden
33             cf_unique
34             cf_indexed
35             cf_decode_depth
36             cf_encoded_by
37             cf_updated
38             cf_primary_key
39             cf_auto_increment
40 1     1   6 )]]];
  1         2  
41 1     1   6 use YATT::Util::Symbol;
  1         2  
  1         96  
42 1     1   5 use YATT::Util qw(coalesce);
  1         3  
  1         6390  
43             require YATT::Inc;
44              
45             #----------------------------------------
46              
47             sub YATT::DBSchema::Table::rowid_spec {
48 0     0 0   (my Table $tab, my $schema) = @_;
49 0 0         if (my Column $pk = $tab->{pk}) {
50             $pk->{cf_name}
51 0           } else {
52 0           $schema->rowid_col;
53             }
54             }
55              
56 0     0 0   sub rowid_col { 'rowid' }
57              
58             #========================================
59             # Class Hierarchy in case of 'package YourSchema; use YATT::DBSchema':
60             #
61             # YATT::DBSchema (or its subclass)
62             # ↑
63             # YourSchema::DBSchema (holds singleton $SCHEMA and &SCHEMA)
64             # ↑
65             # YourSchema
66             #
67              
68             sub import {
69 0     0     my ($pack) = shift;
70 0 0         return unless @_;
71 0           my MY $schema = $pack->define(@_);
72              
73 0           $schema->export_and_rebless_with(caller);
74             }
75              
76             sub export_and_rebless_with {
77 0     0 0   (my MY $schema, my ($callpack)) = @_;
78              
79             # Allocate new class.
80 0           my $classFullName = join("::", $callpack, $schema->name);
81 0           YATT::Inc->add_inc($classFullName);
82 0           eval sprintf q{use strict; package %s; use base qw(%s)}
83             , $classFullName, ref $schema;
84             # MY->add_isa($classFullName, $pack);
85             eval qq{use strict; package $callpack; use base qw($classFullName)}
86 0 0         if $schema->{cf_as_base};
87             # MY->add_isa($callpack, $classFullName);
88              
89 0           my $glob = globref($classFullName, "SCHEMA");
90 0           *{$glob} = \ $schema;
  0            
91 0           define_const($glob, $schema);
92              
93 0           $schema->export_to($callpack);
94              
95             $schema->rebless_with($callpack)
96 0 0         if $schema->{cf_as_base};
97             }
98              
99             sub export_to {
100 0     0 0   (my MY $schema, my ($callpack)) = @_;
101             # Install to caller
102 0           define_const(globref($callpack, $schema->name), $schema);
103             # XXX: special new for singleton. (for schema->new->run)
104 0           *{globref($callpack, 'new')} = sub {
105 0     0     shift;
106 0 0         $schema->configure(@_) if @_;
107 0           $schema;
108 0           };
109             }
110              
111             #========================================
112             sub DESTROY {
113 0     0     my MY $schema = shift;
114 0 0         if ($schema->{cf_DBH}) {
115             # XXX: sqlite specific commit.
116 0           $schema->{cf_DBH}->commit;
117             }
118             }
119              
120             #========================================
121              
122             sub define {
123 0     0 0   my ($pack) = shift;
124 0           $pack->parse_import(\@_, \ my %opts);
125 0           my MY $self = $pack->new(%opts);
126 0           foreach my $item (@_) {
127 0 0         if (ref $item) {
128 0           $self->add_table(@$item);
129             } else {
130 0           croak "Invalid schema item: $item";
131             }
132             }
133 0           $self;
134             }
135              
136             sub parse_import {
137 0     0 0   my ($pack, $list, $opts) = @_;
138             # -bool_flag
139             # key => value
140 0           for (; @$list; shift @$list) {
141 0 0         last if ref $list->[0];
142 0 0         if ($list->[0] =~ /^-(\w+)/) {
143 0           $opts->{$1} = 1;
144             } else {
145 0 0         croak "Option value is missing for $list->[0]"
146             unless @$list >= 2;
147 0           $opts->{$list->[0]} = $list->[1];
148 0           shift @$list;
149             }
150             }
151             }
152              
153             #========================================
154              
155             sub has_connection {
156 0     0 0   my MY $schema = shift;
157             $schema->{cf_DBH}
158 0           }
159              
160             sub dbh {
161 0     0 0   (my MY $schema, my $spec) = @_;
162 0 0         unless ($schema->{cf_DBH}) {
163 0 0 0       unless (defined ($spec ||= $schema->connection_spec)) {
164 0           croak "connection_spec is empty";
165             }
166 0 0         if (ref $spec eq 'ARRAY') {
    0          
167 0           $schema->connect_to(@$spec);
168             } elsif (ref $spec eq 'CODE') {
169 0           $schema->{cf_DBH} = $spec->($schema);
170             } else {
171 0           croak "Unknown connection spec obj: $spec";
172             }
173             };
174              
175             $schema->{cf_DBH}
176 0           }
177              
178             sub connect_to {
179 0     0 0   (my MY $schema, my ($dbtype)) = splice @_, 0, 2;
180 0 0         if (my $sub = $schema->can("connect_to_$dbtype")) {
181 0           $sub->($schema, @_);
182             } else {
183 0           croak sprintf("%s: Unknown dbtype: %s", MY, $dbtype);
184             }
185             }
186              
187             sub connect_to_sqlite {
188 0     0 0   (my MY $schema, my ($dbname, $rwflag)) = @_;
189 0   0       my $ro = defined $rwflag && $rwflag =~ /ro/i;
190 0           my $dbi_dsn = "dbi:SQLite:dbname=$dbname";
191 0           $schema->{cf_auto_create} = 1;
192 0           $schema->connect_to_dbi
193             ($dbi_dsn, undef, undef
194             , RaiseError => 1, PrintError => 0, AutoCommit => $ro);
195             }
196              
197             sub connect_to_dbi {
198 0     0 0   (my MY $schema, my ($dbi_dsn, $user, $auth, %param)) = @_;
199 0 0         map {$param{$$_[0]} = $$_[1] unless defined $param{$$_[0]}}
  0            
200             ([RaiseError => 1], [PrintError => 0], [AutoCommit => 0]);
201 0           require DBI;
202 0 0         if ($dbi_dsn =~ m{^dbi:(\w+):}) {
203 0           $schema->configure(dbtype => lc($1));
204             }
205 0           my $dbh = $schema->{cf_DBH} = DBI->connect($dbi_dsn, $user, $auth, \%param);
206 0 0         $schema->create if $schema->{cf_auto_create};
207 0           $dbh;
208             }
209              
210             #
211             # ./lib/MyApp.pm create sqlite data/myapp.db3
212             #
213             sub create {
214 0     0 0   (my MY $schema, my @spec) = @_;
215 0 0         my $dbh = $schema->dbh(@spec ? \@spec : ());
216 0           foreach my Table $table (@{$schema->{schemas}}) {
  0            
217 0 0         next if $schema->has_table($table->{cf_name}, $dbh);
218 0           foreach my $create ($schema->sql_create_table($table)) {
219 0 0         print STDERR "$create\n" if $schema->{cf_verbose};
220 0           $dbh->do($create);
221             }
222             }
223             }
224              
225             sub has_table {
226 0     0 0   (my MY $schema, my ($table, $dbh)) = @_;
227 0   0       $dbh ||= $schema->dbh;
228 0           $dbh->tables("", "", $table, 'TABLE');
229             }
230              
231             sub tables {
232 0     0 0   my MY $schema = shift;
233 0           keys %{$schema->{tables}};
  0            
234             }
235              
236             sub has_column {
237 0     0 0   (my MY $schema, my ($table, $column, $dbh)) = @_;
238 0   0       my $hash = $schema->columns_hash($table, $dbh || $schema->dbh);
239 0           exists $hash->{$column};
240             }
241              
242             sub columns_hash {
243 0     0 0   (my MY $schema, my ($table, $dbh)) = @_;
244 0   0       $dbh ||= $schema->dbh;
245 0           my $sth = $dbh->prepare("select * from $table limit 0");
246 0           $sth->execute;
247 0           my %hash = %{$sth->{NAME_hash}};
  0            
248 0           \%hash;
249             }
250              
251             sub drop {
252 0     0 0   (my MY $schema) = @_;
253 0           foreach my $sql ($schema->sql_drop) {
254 0           $schema->dbh->do($sql);
255             }
256             }
257              
258             #========================================
259              
260             sub add_table {
261 0     0 0   (my MY $self, my ($name, $opts, @columns)) = @_;
262 0   0       $self->{tables}{$name} ||= do {
263 0           push @{$self->{schemas}}
  0            
264             , my Table $tab = $self->Table->new;
265              
266 0           $tab->{cf_name} = $name;
267 0 0         if (@columns) {
    0          
268             # XXX: 拡張の余地あり
269 0           $tab->{raw_create} = $opts;
270 0           my $fields = $tab->fields_hash;
271 0           foreach my $desc (@columns) {
272 0 0         if (ref (my $kw = $desc->[0])) {
273 0 0         unless ($fields->{my $fname = "chk_$$kw"}) {
274 0           croak "Invalid column constraint $kw for table $name";
275             } else {
276 0           push @{$tab->{$fname}}, [@{$desc}[1 .. $#$desc]];
  0            
  0            
277             }
278             } else {
279 0           my ($col, $type, @desc) = @$desc;
280             $self->add_table_column($tab, $col, $type, map {
281 0 0         if (/^-(\w+)/) {
  0            
282 0           $1 => 1
283             } else {
284 0           $_
285             }
286             } @desc);
287             }
288             }
289             } elsif (not ref $opts) {
290             # $opts is used as column type.
291             # XXX: SQLite specific.
292 0           $self->add_table_column($tab, $name . 'no', 'integer'
293             , primary_key => 1);
294 0           $self->add_table_column($tab, $name, $opts
295             , unique => 1);
296             } else {
297 0           die "Unknown table desc $name $opts";
298             }
299 0           $tab;
300             };
301             }
302              
303             sub add_table_column {
304 0     0 0   (my MY $self, my Table $tab, my ($colName, $type, @opts)) = @_;
305 0 0         if ($tab->{colNames}{$colName}) {
306 0           croak "Conflicting column name $colName for table $tab->{cf_name}";
307             }
308 0           push @{$tab->{Column}}, my Column $col = $self->Column->new(@opts);
  0            
309 0           $tab->{colNames}{$colName} = $col->{colnum} = @{$tab->{Column}};
  0            
310              
311             $col->{cf_hidden} = ($colName =~ s/^-//
312 0   0       || $col->{cf_auto_increment});
313 0           $col->{cf_name} = $colName;
314             # if ref $type, else
315 0           $col->{cf_type} = do {
316 0 0         if (ref $type) {
317 0           $col->{cf_encoded_by} = $self->add_table(@$type);
318             # XXX: SQLite specific.
319 0           'int'
320             } else {
321 0           $type
322             }
323             };
324 0 0         if ($col->{cf_primary_key}) {
325 0           $tab->{pk} = $col;
326             }
327             # XXX: Validation: name/option conflicts and others.
328 0           $col;
329             }
330              
331             #========================================
332              
333             sub sql_create {
334 0     0 0   (my MY $schema, my %opts) = @_;
335 0           $schema->foreach_tables_do('sql_create_table', \%opts)
336             }
337              
338             sub sql_create_table {
339 0     0 0   (my MY $schema, my Table $tab, my $opts) = @_;
340 0           my (@cols, @indices);
341 0   0       my $dbtype = $opts->{dbtype} || $schema->dbtype;
342 0   0       my $sub = $schema->can($dbtype.'_sql_create_column')
343             || $schema->can('sql_create_column');
344 0           foreach my Column $col (@{$tab->{Column}}) {
  0            
345 0           push @cols, $sub->($schema, $tab, $col, $opts);
346 0 0         push @indices, $col if $col->{cf_indexed};
347             }
348 0 0         foreach my $constraint (map {$_ ? @$_ : ()} $tab->{chk_unique}) {
  0            
349 0           push @cols, sprintf q{unique(%s)}, join(", ", @$constraint);
350             }
351              
352             # XXX: SQLite specific.
353             push my @create
354             , sprintf qq{CREATE TABLE %s\n(%s)}, $tab->{cf_name}
355 0           , join "\n, ", @cols;
356              
357 0           foreach my Column $ix (@indices) {
358             push @create
359             , sprintf q{CREATE INDEX %1$s_%2$s on %1$s(%2$s)}
360 0           , $tab->{cf_name}, $ix->{cf_name};
361             }
362              
363             # insert が有っても、構わない。
364 0 0         push @create, map {$_ ? @$_ : ()} $tab->{raw_create};
  0            
365              
366 0 0         wantarray ? @create : join(";\n", @create);
367             }
368              
369             # XXX: text => varchar(80)
370             sub map_coltype {
371 0     0 0   (my MY $schema, my $typeName) = @_;
372             }
373              
374             sub sql_create_column {
375 0     0 0   (my MY $schema, my Table $tab, my Column $col, my $opts) = @_;
376             join(" ", $col->{cf_name}
377             , $col->{cf_type}
378             , ($col->{cf_primary_key} ? "primary key" : ())
379             , ($col->{cf_unique} ? "unique" : ())
380 0 0         , ($col->{cf_auto_increment} ? "auto_increment" : ()));
    0          
    0          
381             }
382              
383             sub sqlite_sql_create_column {
384 0     0 0   (my MY $schema, my Table $tab, my Column $col, my $opts) = @_;
385 0 0 0       if ($col->{cf_type} =~ /^int/i && $col->{cf_primary_key}) {
386 0           "$col->{cf_name} integer primary key"
387             } else {
388 0           $schema->sql_create_column($tab, $col, $opts);
389             }
390             }
391              
392             sub sql_drop {
393             shift->foreach_tables_do
394             (sub {
395 0     0     (my Table $tab) = @_;
396 0           qq{drop table $tab->{cf_name}};
397             })
398 0     0 0   }
399              
400             sub foreach_tables_do {
401 0     0 0   (my MY $self, my $method, my $opts) = @_;
402             my $code = ref $method ? $method : sub {
403 0     0     $self->$method(@_);
404 0 0         };
405 0           my @result;
406 0           my $wantarray = wantarray;
407 0           foreach my Table $tab (@{$self->{schemas}}) {
  0            
408             push @result, map {
409 0 0         $wantarray ? $_ . "\n" : $_
  0            
410             } $code->($tab, $opts);
411             }
412 0 0         wantarray ? @result : join(";\n", @result);
413             }
414              
415             #========================================
416              
417             sub sql_insert {
418 0     0 0   (my MY $schema, my ($tabName, @fields)) = @_;
419 0 0         my Table $tab = $schema->{tables}{$tabName}
420             or croak "No such table: $tabName";
421 0           my (@insNames, @insEncs);
422 0 0         foreach my Column $col (@fields ? (map {
423 0 0         unless (my $colno = $tab->{colNames}{$_}) {
424 0           die "No such column $_ in $tabName\n";
425             } else {
426 0           $tab->{Column}[$colno - 1];
427             }
428 0           } @fields) : @{$tab->{Column}}) {
429 0 0         push @insNames, $col->{cf_name} unless $col->{cf_hidden};
430 0 0         if (my Table $encTab = $col->{cf_encoded_by}) {
431 0           push @insEncs, [$#insNames => $encTab->{cf_name}];
432             }
433             }
434              
435 0           my $sql = <
436 0           INSERT INTO $tabName(@{[join ", ", @insNames]})
437 0           values(@{[join ", ", map {q|?|} @insNames]})
  0            
438             END
439              
440 0 0         wantarray ? ($sql, @insEncs) : $sql;
441             }
442              
443             sub to_insert {
444 0     0 0   (my MY $schema, my ($tabName, $fields)) = @_;
445 0           my $dbh = $schema->dbh;
446             my ($sql, @insEncs) = $schema->sql_insert
447 0           ($tabName, do {
448 0 0         unless ($fields) {
    0          
449             ()
450 0           } elsif (ref $fields) {
451 0           @$fields
452             } else {
453 0           $fields
454             }
455             });
456 0 0         print STDERR "$sql\n" if $schema->{cf_verbose};
457 0           my $sth = $dbh->prepare($sql);
458             # ここで encode 用の sql/sth も生成せよと?
459 0           my @encoder;
460 0           foreach my $item (@insEncs) {
461 0           my ($i, $table) = @$item;
462 0           push @encoder, [$schema->to_encode($table, $dbh), $i];
463             }
464 0           my $rowid = $schema->{tables}{$tabName}->rowid_spec($schema);
465             sub {
466 0     0     my (@values) = @_;
467 0           foreach my $enc (@encoder) {
468 0           $enc->[0]->(\@values, $enc->[1]);
469             }
470 0           $sth->execute(@values);
471 0           $dbh->last_insert_id(undef, undef, $tabName, $rowid);
472             }
473 0           }
474              
475             sub to_encode {
476 0     0 0   (my MY $schema, my ($encDesc, $dbh)) = @_;
477 0   0       $dbh ||= $schema->dbh;
478 0 0         my ($table, $column) = ref $encDesc ? @$encDesc : ($encDesc, $encDesc);
479 0           my Table $tab = $schema->{tables}{$table};
480 0           my $rowid = $tab->rowid_spec($schema);
481 0           my $check_sql = <
482             select $rowid from $table where $column = ?
483             END
484 0 0         print STDERR "$check_sql\n" if $schema->{cf_verbose};
485              
486 0           my $ins_sql = <
487             INSERT INTO $table($column) values(?)
488             END
489 0 0         print STDERR "$ins_sql\n" if $schema->{cf_verbose};
490              
491             # XXX: sth にまでするべきか。prepare_cached 廃止案。
492             sub {
493 0     0     my ($list, $nth) = @_;
494 0           my ($rowid) = do {
495 0           my $check = $dbh->prepare_cached($check_sql);
496 0           $dbh->selectrow_array($check, {}, $list->[$nth]);
497             };
498 0 0         unless (defined $rowid) {
499 0           my $ins = $dbh->prepare_cached($ins_sql, undef, 1);
500 0           $ins->execute($list->[$nth]);
501 0           $rowid = $dbh->last_insert_id(undef, undef, $table, $rowid);
502             }
503 0           $list->[$nth] = $rowid;
504             }
505 0           }
506              
507             #========================================
508              
509             sub sql {
510 0     0 0   (my MY $self, my ($mode, $table)) = splice @_, 0, 3;
511 0           unshift @_, $self->parse_params(\@_);
512 0           $self->can("sql_${mode}")->($self, $table, @_);
513             }
514              
515             # XXX: explain を。 cf_explain で?
516             sub cmd_select {
517 0     0 0   my MY $self = shift;
518 0           $self->parse_opts(\@_, \ my %opts);
519 0           my $table = shift;
520 0           $self->parse_opts(\@_, \ %opts);
521 0 0         $self->configure(%opts) if %opts;
522 0           $self->parse_params(\@_, \ my %param);
523 0           my ($sth, $bind) = do {
524 0 0         if (my $sub = $self->can("select_$table")) {
    0          
525             # XXX: select_zzz は execute してはいけない
526 0           $sub->($self, \%param, @_);
527             } elsif ($sub = $self->can("sql_select_$table")) {
528 0           $self->dbh->prepare($sub->($self, \%param));
529             } else {
530 0           $self->prepare_select($table, \@_, %param);
531             }
532             };
533 0 0         $sth->execute($bind ? @$bind : @_);
534 0           my $null = $self->NULL;
535 0           my $format = $self->can('tsv_with_null');
536 0 0         print $format->($null, @{$sth->{NAME}}) unless $self->{cf_no_header};
  0            
537 0           while (my (@res) = $sth->fetchrow_array) {
538 0           print $format->($null, @res);
539             }
540             }
541              
542             sub select {
543 0     0 0   (my MY $schema, my ($tabName, $columns, %param)) = @_;
544              
545 0           my $is_text = delete $param{text};
546 0   0       my $separator = delete $param{separator} || "\t";
547 0 0         ($is_text, $separator) = (1, "\t") if delete $param{tsv};
548              
549 0           my (@fetch) = grep {delete $param{$_}} qw(hashref arrayref array);
  0            
550 0 0         die "Conflict! @fetch" if @fetch > 1;
551              
552 0           my ($sth, $bind) = $schema->prepare_select($tabName, $columns, %param);
553              
554 0 0         if ($is_text) {
555             # Debugging aid.
556 0           my $null = $schema->NULL;
557 0           my $header; $header = $schema->format_line($sth->{NAME}, $separator, $null)
558 0 0         if $schema->{cf_no_header};
559 0 0         my $res = $sth->fetchall_arrayref
560             or return;
561             join("", defined $header ? $header : ()
562 0 0         , map { $schema->format_line($_, $separator, $null) } @$res)
  0            
563             } else {
564 0   0       my $method = $fetch[0] || 'arrayref';
565 0 0         $sth->execute($bind ? @$bind : ());
566 0           $sth->can("fetchrow_$method")->($sth);
567             }
568             }
569              
570             # XXX: to_selectrow/selectall に分ければいいかも?
571             sub to_select {
572 0     0 0   (my MY $schema, my ($tabName, $columns, %params)) = @_;
573 0           my $type = do {
574 0           my (@fetch) = grep {delete $params{$_}} qw(hashref arrayref array);
  0            
575 0 0         die "Conflict! @fetch" if @fetch > 1;
576 0 0         $fetch[0] || 'arrayref';
577             };
578 0           my ($sth, $bind) = $schema->prepare_select($tabName, $columns, %params);
579             my $sub = sub {
580 0 0   0     $sth->execute($bind ? @$bind : @_);
581 0 0         my $method = wantarray ? "fetchall_$type" : "fetchrow_$type";
582 0           $sth->$method;
583 0           };
584 0 0         wantarray ? ($sub, ($bind ? $bind : ())) : $sub;
    0          
585             }
586              
587             # 後は fetchrow するだけ、の sth を返す。
588             sub to_fetch {
589 0     0 0   (my MY $schema, my ($tabName, $columns, %params)) = @_;
590 0           my ($sth, $bind) = $schema->prepare_select($tabName, $columns, %params);
591 0 0         $sth->execute($bind ? @$bind : ());
592 0           $sth;
593             }
594              
595             # $sth 返しなのは、$sth->{NAME} を取りたいから。でも、単純なケースでは不便よね。
596             sub prepare_select {
597 0     0 0   (my MY $schema, my ($tabName, $columns, %params)) = @_;
598 0 0         my ($sql, $bind) = $schema->sql_select($tabName, \%params
599             , ref $columns ? @$columns : $columns);
600 0           my $sth = $schema->dbh->prepare($sql);
601 0 0         wantarray ? ($sth, ($bind ? $bind : ())) : $sth;
    0          
602             }
603              
604             sub sql_decode {
605 0     0 0   (my MY $schema, my Table $tab
606             , my ($selJoins, $depth, $alias, $until)) = @_;
607 0 0         $depth = 0 unless defined $depth;
608 0   0       $alias ||= $tab->{cf_name};
609 0           my @selCols;
610 0           foreach my Column $col (@{$tab->{Column}}) {
  0            
611 0           my Table $enc = $col->{cf_encoded_by};
612 0 0 0       if ($depth || $enc) {
613             # primary key は既に積まれている。
614             push @selCols, "$alias.$col->{cf_name}"
615 0 0         unless $col->{cf_primary_key};
616             } else {
617 0           push @selCols, $col->{cf_name};
618             }
619              
620 0 0 0       if ($enc && $depth < coalesce($until, 1)) {
621             # alias と rowid と…
622 0           my $enc_alias = $col->{cf_name};
623 0           push @$selJoins, "\nLEFT JOIN $enc->{cf_name} $enc_alias"
624             . " on $alias.$col->{cf_name}"
625             . " = $enc_alias." . $enc->rowid_spec($schema);
626              
627             push @selCols, $schema->sql_decode
628             ($enc, $selJoins, $depth + 1, $col->{cf_name}
629 0           , $col->{cf_decode_depth});
630             }
631             }
632 0           @selCols;
633             }
634              
635             sub sql_join {
636 0     0 0   (my MY $schema, my ($tabName, $params)) = @_;
637              
638 0 0         if (my $sub = $schema->can("sql_select_$tabName")) {
639 0           return $sub->($schema, $params);
640             }
641              
642 0 0         my Table $tab = $schema->{tables}{$tabName}
643             or croak "No such table: $tabName";
644              
645 0           my @selJoins = $tab->{cf_name};
646 0           my @selCols = $schema->sql_decode($tab, \@selJoins);
647              
648 0           my (@appendix, @bind);
649 0 0         if (my $where = delete $params->{where}) {
650 0           push @appendix, do {
651 0 0         if (ref $where) {
652 0           require SQL::Abstract;
653 0           (my $stmt, @bind) = SQL::Abstract->new->where($where);
654 0           $stmt;
655             } else {
656 0           $where;
657             }
658             };
659             }
660              
661             {
662 0 0 0       if ($params->{offset} and not $params->{limit}) {
  0            
663 0           die "offset needs limit!";
664             }
665              
666 0           foreach my $kw (qw(group_by order_by limit offset)) {
667 0 0         if (my $val = delete $params->{$kw}) {
668 0           push @appendix, join(" ", map(do {s/_/ /; $_}, uc($kw)), $val);
  0            
  0            
669             }
670             }
671              
672             die "Unknown param(s) for select $tabName: "
673 0 0         , join(", ", map {"$_=" . $params->{$_}} keys %$params) if %$params;
  0            
674             }
675              
676 0 0         (\@selCols, \@selJoins, \@appendix, @bind ? \@bind : ());
677             }
678              
679             sub sql_select {
680 0     0 0   (my MY $schema, my ($tabName, $params)) = splice @_, 0, 3;
681              
682 0           my $raw = delete $params->{raw};
683 0           my $colExpr = do {
684 0 0         if (@_) {
    0          
685 0           join(", ", @_);
686             } elsif ($raw) {
687 0           '*';
688             }
689             };
690              
691 0           my ($selCols, $selJoins, $where, $bind)
692             = $schema->sql_join($tabName, $params);
693              
694 0 0 0       my $sql = join("\n", sprintf(q{SELECT %s FROM %s}
695             , $colExpr || join(", ", @$selCols)
696             , $raw ? $tabName : join("", @$selJoins))
697             , @$where);
698              
699 0 0         wantarray ? ($sql, (defined $bind ? $bind : ())) : $sql;
    0          
700             }
701              
702             #----------------------------------------
703              
704             sub indexed {
705 0     0 0   (my MY $schema, my ($tabName, $colName, $value, $params)) = @_;
706 0   0       my $dbh = delete $params->{dbh} || $schema->dbh;
707 0           my $sql = $schema->sql_indexed($tabName, $colName);
708 0           $dbh->selectrow_hashref($sql, undef, $value);
709             }
710              
711             sub sql_indexed {
712 0     0 0   (my MY $schema, my ($tabName, $colName)) = @_;
713 0           <<"END";
714             select _rowid_, * from $tabName where $colName = ?
715             END
716             }
717              
718             sub format_line {
719 0     0 0   (my MY $schema, my ($rec, $separator, $null)) = @_;
720             join($separator, map {
721 0 0         unless (defined $_) {
  0 0          
722 0           $null
723             } elsif ((my $val = $_) =~ s/[\t\n]/ /g) {
724 0           $val
725             } else {
726 0           $_
727             }
728             } @$rec). "\n";
729             }
730              
731             #========================================
732              
733             sub to_update {
734 0     0 0   (my MY $schema, my ($tabName, $colName)) = @_;
735 0           my $sql = $schema->sql_update($tabName, $colName);
736 0 0         print STDERR "$sql\n" if $schema->{cf_verbose};
737 0           my $sth = $schema->dbh->prepare($sql);
738             sub {
739 0     0     my ($colValue, $rowId) = @_;
740 0           $sth->execute($colValue, $rowId);
741             }
742 0           }
743              
744             sub sql_update {
745 0     0 0   (my MY $schema, my ($tabName, $colName)) = @_;
746 0           my $rowid = $schema->{tables}{$tabName}->rowid_spec($schema);
747 0           "UPDATE $tabName SET $colName = ? WHERE $rowid = ?";
748             }
749              
750             ########################################
751              
752             sub tsv_with_null {
753 0     0 0   my $null = shift;
754 0 0         join("\t", map {defined $_ ? $_ : $null} @_). "\n";
  0            
755             }
756              
757              
758             ########################################
759              
760             sub run {
761 0     0 0   my $pack = shift;
762 0 0         $pack->cmd_help unless @_;
763 0           my MY $obj = $pack->new(MY->parse_opts(\@_));
764 0   0       my $cmd = shift || "help";
765 0           $obj->configure(MY->parse_opts(\@_));
766 0           my $method = "cmd_$cmd";
767 0 0         if (my $sub = $obj->can("cmd_$cmd")) {
    0          
768 0           $sub->($obj, @_);
769             } elsif ($sub = $obj->can($cmd)) {
770 0           my @res = $sub->($obj, @_);
771 0 0         exit 1 unless @res;
772 0 0 0       unless (@res == 1 and defined $res[0] and $res[0] eq "1") {
      0        
773 0 0         if (grep {defined $_ && ref $_} @res) {
  0 0          
774 0           require Data::Dumper;
775             print Data::Dumper->new([$_])->Indent(0)->Terse(1)->Dump
776 0           , "\n" for @res;
777             } else {
778 0           print join("\n", @res), "\n";
779             }
780             }
781             } else {
782 0           die "No such method $cmd for $pack\n";
783             }
784 0           $obj->DESTROY; # To make sure committed.
785             }
786              
787             sub cmd_help {
788 0     0 0   my ($self) = @_;
789 0   0       my $pack = ref($self) || $self;
790 0           my $stash = do {
791 0           my $pkg = $pack . '::';
792 1     1   10 no strict 'refs';
  1         3  
  1         258  
793 0           \%{$pkg};
  0            
794             };
795 0           my @methods = sort grep s/^cmd_//, keys %$stash;
796 0           die "Usage: @{[basename($0)]} method args..\n "
  0            
797             . join("\n ", @methods) . "\n";
798             }
799              
800             #========================================
801              
802             sub ymd_hms {
803 0     0 0   my ($pack, $time, $as_utc) = @_;
804             my ($S, $M, $H, $d, $m, $y) = map {
805 0 0         $as_utc ? gmtime($_) : localtime($_)
  0            
806             } $time;
807 0           sprintf q{%04d-%02d-%02d %02d:%02d:%02d}, 1900+$y, $m+1, $d, $H, $M, $S;
808             }
809              
810             1;
811             # -for_dbic
812             # -for_sqlengine
813             # -for_sqlt
814