src/newslash_web/lib/Newslash/Model/Cowrapper.pm

   1 package Newslash::Model::Cowrapper;
   2 # Cowrapper - Connection Wrapper for MySQL
   3
   4 use strict;
   5 use warnings;
   6 use utf8;
   7 use feature ':5.10';
   8
   9 use Carp qw(croak);
  10 use FileHandle;
  11
  12 use List::Util qw(any);
  13 use DBI;
  14 use Data::Dumper;
  15 use DateTime;
  16 use DateTime::Format::MySQL;
  17 use JSON;
  18
  19 sub import {
  20     my $class = shift;
  21     return unless my $flag = shift;
  22
  23     if ($flag eq '-base') {
  24         $flag = $class;
  25     } elsif ($flag eq '-strict') {
  26         $flag = undef;
  27     }
  28
  29     if ($flag) {
  30         my $caller = caller;
  31         no strict 'refs';
  32         push @{"${caller}::ISA"}, $flag;
  33     }
  34
  35     $_->import for qw(strict warings utf8);
  36     feature->import(':5.10');
  37 }
  38
  39 sub options {
  40     my ($self, @rest) = @_;
  41     return $self->{options} if @rest == 0;
  42
  43     my $hash = $self->{options} || {};
  44     my $node;
  45     for $node (@rest) {
  46         $node = $hash->{$node};
  47         return if !$node;
  48     }
  49     return $node;
  50 }
  51
  52 sub new {
  53     my $class = shift;
  54     my $options = shift || {};
  55     my $params = {@_};
  56
  57     bless {options => {%$options, @_},
  58            _error => "",
  59            _errorno => 0,
  60            _last_sql => "",
  61            _last_attr => [],
  62           }, $class;
  63 }
  64
  65 sub _last_sql {
  66     my ($self, $value) = @_;
  67     if (defined $value) {
  68         $self->{_last_sql} = $value;
  69     }
  70     return $self->{_last_sql};
  71 }
  72
  73 sub _last_attr {
  74     my ($self, $value) = @_;
  75     if (defined $value) {
  76         $self->{_last_attr} = $value;
  77     }
  78     return $self->{_last_attr};
  79 }
  80
  81 sub _last_query {
  82     my ($self, $sql, $attr) = @_;
  83     if (defined $sql) {
  84         $self->{_last_sql} = $sql;
  85         $self->{_last_attr} = $attr;
  86     }
  87     return ($self->{_last_sql}, $self->{_last_attr});
  88 }
  89
  90 sub _dumper {
  91     my $self = shift;
  92     return Dumper @_;
  93 }
  94
  95 sub _dump_last_query {
  96     my $self = shift;
  97     my $cls = ref($self);
  98     return "+---------\n>> LAST QUERY of $cls: \n" .
  99       $self->_last_sql . Dumper($self->_last_attr) .
 100       "+---------\n";
 101 }
 102
 103 ######### connect/disconnect functions
 104
 105 sub connect_db {
 106     my $self = shift;
 107     my $options = shift || {};
 108
 109     if ($self->transaction_mode) {
 110         return $self->{_tr_dbh};
 111     }
 112
 113     my $DB_HOST = $self->{options}->{Database}->{host};
 114     my $DB_NAME = $self->{options}->{Database}->{name};
 115     my $DB_USER = $self->{options}->{Database}->{user};
 116     my $DB_PASSWORD = $self->{options}->{Database}->{password};
 117
 118     my $settings = 'mysql_read_default_group=libmysqlclient;mysql_read_default_file=/etc/mysql/my.cnf';
 119     my $attr = {
 120                 mysql_enable_utf8 => 1,
 121                 ShowErrorStatement => 1,
 122                 Callbacks => { # hack to use utf8mb4. see http://d.hatena.ne.jp/hirose31/20141028/1414496347
 123                               connected => sub {
 124                                   shift->do('SET NAMES utf8mb4');
 125                                   return;
 126                               }
 127                              },
 128                 %$options,
 129                };
 130
 131     my $dbh = DBI->connect("DBI:mysql:$DB_NAME:$DB_HOST;$settings", $DB_USER, $DB_PASSWORD, $attr);
 132
 133     $self->{_tr_dbh} = $dbh;
 134     return $dbh;
 135
 136 }
 137
 138 sub disconnect_db {
 139     my $self = shift;
 140     return if $self->transaction_mode;
 141     return if !$self->{_tr_dbh};
 142
 143     return $self->{_tr_dbh}->disconnect;
 144 }
 145
 146
 147 ########## Transaction related functions
 148
 149 sub transaction_mode {
 150     my $self = shift;
 151     return 0 if !defined $self->{_transactions};
 152     return ($self->{_transactions} > 0);
 153 }
 154
 155 sub start_transaction {
 156     my $self = shift;
 157     my $options = shift || {};
 158
 159     if (!defined $self->{_transactions}) {
 160         $self->{_transactions} = 0;
 161     }
 162
 163     # already transaction mode
 164     if ($self->transaction_mode) {
 165         $self->{_transactions} += 1;
 166         return $self->{_tr_dbh};
 167     }
 168
 169     # start new transaction
 170     $options->{AutoCommit} = 0;
 171     $self->connect_db($options);
 172     $self->{_transactions} = 1;
 173
 174     return $self->{_tr_dbh};
 175 }
 176
 177 # use external defined dbh
 178 sub use_transaction {
 179     my $self = shift;
 180     my $dbh = shift;
 181
 182     if ($dbh) {
 183         $self->{_transactions} = 2;
 184         $self->{_tr_dbh} = $dbh;
 185         return $dbh;
 186     }
 187     return;
 188 }
 189
 190 sub commit {
 191     my $self = shift;
 192     return if !$self->transaction_mode;
 193
 194     if ($self->{_transactions} == 1) {
 195         $self->{_tr_dbh}->commit;
 196         $self->{_tr_dbh}->disconnect;
 197
 198         delete $self->{_tr_dbh};
 199     }
 200     $self->{_transactions} -= 1;
 201 }
 202
 203 sub rollback {
 204     my $self = shift;
 205     return if !$self->transaction_mode;
 206
 207     #$self->set_error($self->{_tr_dbh}->errstr);
 208
 209     $self->{_tr_dbh}->rollback;
 210     $self->{_tr_dbh}->disconnect;
 211     delete $self->{_tr_dbh};
 212     $self->{_transactions} = 0;
 213 }
 214
 215 ########## Utility functions
 216
 217 sub table_exists {
 218     my ($self, $table) = @_;
 219
 220     my $dbh = $self->connect_db;
 221     my $DB_NAME = $self->{options}->{Database}->{name};
 222
 223     my $sql = <<"EOSQL";
 224 SELECT * FROM information_schema.TABLES
 225   WHERE TABLE_SCHEMA = ?
 226     AND TABLE_NAME = ?
 227 EOSQL
 228
 229     my $sth = $dbh->prepare($sql);
 230     $sth->execute($DB_NAME, $table);
 231     my $rs = $sth->fetchall_arrayref({});
 232     $self->disconnect_db;
 233     if (@$rs == 0) {
 234         return;
 235     }
 236     return 1;
 237 }
 238
 239 sub check_readonly {
 240     my $self = shift;
 241     if ($self->options->{readonly}) {
 242         $self->set_error("readonly mode");
 243         return 1;
 244     }
 245     return;
 246 }
 247
 248 ########## error handling
 249 sub clear_error {
 250     my $self = shift;
 251     $self->{_error} = undef;
 252     $self->{_errorno} = undef;
 253 }
 254
 255 sub set_error {
 256     my ($self, $error, $errorno) = @_;
 257     $self->{_error} = $error;
 258     $self->{_errorno} = $errorno if $errorno;
 259 }
 260 sub set_errorno {
 261     my ($self, $errorno) = @_;
 262     $self->{_errorno} = $errorno;
 263 }
 264
 265 sub last_error {
 266     my ($self, $err) = @_;
 267     $self->{_error} = $err if defined $err;
 268     return $self->{_error};
 269 }
 270
 271 sub last_errorno {
 272     my ($self, $errno) = @_;
 273     $self->{_errorno} = $errno if defined $errno;
 274     return $self->{_errorno};
 275 }
 276
 277 ########## Utility functions
 278 sub calculate_time_range {
 279     my ($self, $params) = @_;
 280
 281     my $date = $params->{date};
 282     my $year = $params->{year};
 283     my $month = $params->{month};
 284     my $day = $params->{day};
 285
 286     my $years = $params->{years};
 287     my $months = $params->{months};
 288     my $days = $params->{days};
 289     my $weeks = $params->{weeks};
 290     my $hours = $params->{hours};
 291     my $minutes = $params->{minutes};
 292
 293     my $until = $params->{until};
 294     my $since = $params->{since};
 295
 296     my $offset_sec = $params->{offset_sec};
 297     my ($dt_since, $dt_until);
 298
 299     my $range_mode = ($years || $months || $days || $weeks || $hours || $minutes);
 300
 301     # check parameters
 302     if ($since) {
 303         if (ref($since) eq 'HASH') {
 304             $dt_since = $since;
 305         }
 306         elsif ($since =~ m/^\d{4}-\d{2}-\d{2}$/) {
 307             $dt_since = DateTime::Format::MySQL->parse_date($since);
 308         }
 309         else {
 310             $dt_since = DateTime::Format::MySQL->parse_datetime($since);
 311         }
 312     }
 313     if ($until) {
 314         if (ref($until) eq 'HASH') {
 315             $dt_until = $until;
 316         }
 317         elsif ($until =~ m/^\d{4}-\d{2}-\d{2}$/) {
 318             $dt_until = DateTime::Format::MySQL->parse_date($until);
 319         }
 320         else {
 321             $dt_until = DateTime::Format::MySQL->parse_datetime($until);
 322         }
 323     }
 324     if ($year) {
 325         $dt_since = DateTime->new(year => $year,
 326                                  month => $month || 1,
 327                                  day => $day || 1);
 328     }
 329     if ($date) {
 330         if ($date eq 'today') {
 331             $dt_since = DateTime->today;
 332         }
 333         else {
 334             $dt_since = DateTime::Format::MySQL->parse_date($date);
 335         }
 336         if (!$range_mode) {
 337             $days = 1;
 338             $range_mode = 1;
 339         }
 340     }
 341
 342     # check time range
 343     if ($range_mode) {
 344         if ($dt_since) {
 345             $dt_until = $dt_since->clone;
 346             $dt_until->add("years" => $years) if $years;
 347             $dt_until->add("months" => $months) if $months;
 348             $dt_until->add("days" => $days) if $days;
 349             $dt_until->add("weeks" => $weeks) if $weeks;
 350             $dt_until->add("hours" => $hours) if $hours;
 351             $dt_until->add("minutes" => $minutes) if $minutes;
 352         }
 353         else {
 354             $dt_until = DateTime->now;
 355             $dt_since = $dt_until->clone;
 356             $dt_since->add("years" => -$years) if $years;
 357             $dt_since->add("months" => -$months) if $months;
 358             $dt_since->add("days" => -$days) if $days;
 359             $dt_since->add("weeks" => -$weeks) if $weeks;
 360             $dt_since->add("hours" => -$hours) if $hours;
 361             $dt_since->add("minutes" => -$minutes) if $minutes;
 362         }
 363     }
 364     elsif ($year) {
 365         my $term = "year";
 366         $term = "month" if $month;
 367         $term = "day" if $day;
 368
 369         $dt_until = $dt_since->clone;
 370         $dt_until->add("${term}s" => 1);
 371     }
 372
 373     if ($offset_sec) {
 374         $dt_since->add(seconds => -$offset_sec) if $dt_since;
 375         $dt_until->add(seconds => -$offset_sec) if $dt_until;
 376     }
 377
 378     my ($from, $to);
 379     $from = DateTime::Format::MySQL->format_datetime($dt_since) if $dt_since;
 380     $to = DateTime::Format::MySQL->format_datetime($dt_until) if $dt_until;
 381
 382     return ($from, $to);
 383 }
 384
 385
 386 =head2 build_where_clause(unique_keys => $unique_keys,
 387                           keys => $keys,
 388                           timestamps => $timestamps,
 389                           where => $where_params,
 390                           params => \%params,)
 391
 392 build SQL WHERE clause.
 393
 394 =over 4
 395
 396 =item Parameters
 397
 398 =over 4
 399
 400 =item $unique_keys
 401
 402 STRING or ARRAYREF or HASHREF.
 403 If STRING, $keys contains unique keys.
 404 If ARRAREF, @$keys contains unique keys.
 405 If HASHREF, %$keys is { key1 => alias1, key2 => alias2, ... }.
 406
 407 'unique key' is a column name defined with 'UNIQUE' or 'PRIMARY'.
 408
 409 If you want to use key which is not correspod to table's column,
 410 use alias. When aliases given, the aliases are replaced to keys in SQL.
 411
 412 =back
 413
 414 =item $keys
 415
 416 STRING or ARRAYREF or HASHREF.
 417 If STRING, $keys contains non-unique keys.
 418 If ARRAREF, @$keys contains non-unique keys.
 419 If HASHREF, %$keys is { key1 => alias1, key2 => alias2, ... }.
 420
 421 =back
 422
 423 =item \%params
 424
 425 HASHREF to query parameters
 426
 427 =item Return value
 428
 429 when list context, returns ($clause, \@values, $unique).
 430 when scalar context, return hashref like:
 431  { clause => $clause, values => \@values, unique => $unique };
 432
 433 =back
 434
 435 =cut
 436
 437 sub build_where_clause {
 438     my $self = shift;
 439     my $args = {@_};
 440
 441     my $uniques = {};
 442     my $keys = {};
 443     if ($args->{keys} || $args->{unique_keys}) {
 444         $uniques = $args->{unique_keys};
 445         $keys = $args->{keys};
 446     }
 447     else {
 448         $uniques = $self->unique_keys;
 449         $keys = $self->get_keys("non-unique");
 450     }
 451     my $timestamp = $args->{timestamp} || $self->{timestamp};
 452
 453     my $params = $args->{params};
 454     my $where = $args->{where} || $params;
 455
 456     my @clauses;
 457     my @values;
 458
 459     # check and process "OR" parameter
 460     if (defined $where->{OR}) {
 461         my $sub_params = $where->{OR};
 462         croak "invalid OR parameter" if (ref($sub_params) ne "HASH");
 463
 464         my ($sub_clause, $sub_values, $sub_unique) = $self->_parse_where_clause($uniques, $keys, $timestamp, $sub_params);
 465         my $or_clause = join(" OR ", @$sub_clause);
 466         if ($or_clause) {
 467             push @clauses, "( $or_clause )";
 468             push @values, @$sub_values;
 469         }
 470     }
 471
 472     my ($sub_clauses, $sub_values, $unique) = $self->_parse_where_clause($uniques, $keys, $timestamp, $where);
 473     push @clauses, @$sub_clauses;
 474     push @values, @$sub_values;
 475
 476     my $clause = "";
 477     if (@clauses != 0) {
 478         $clause = "WHERE " . join(" AND ", @clauses);
 479     }
 480
 481     return wantarray ? ($clause, \@values, $unique)
 482       : { clause => $clause,
 483           values => \@values,
 484           unique => $unique, };
 485 }
 486
 487
 488 ## subfunctions
 489 sub _parse_where_clause {
 490     my ($self, $uniques, $keys, $timestamp, $params) = @_;
 491
 492     my @clauses;
 493     my @values;
 494     my $unique = 0;
 495
 496     # subfunctions
 497     my $decode_param = sub {
 498         my ($k, $v) = @_;
 499
 500         # simply equal clause
 501         if (!ref($v)) {
 502             return ("$k = ?", $v);
 503         }
 504
 505         # multiple items
 506         if (ref($v) eq 'ARRAY') {
 507             my $placeholder = join(", ", map { "?" } @$v);
 508             return ("$k IN ($placeholder)", $v);
 509         }
 510
 511         # gt/lt/ge/le (>, <, >=, <=)
 512         if (ref($v) eq 'HASH') {
 513             return ("$k > ?", $v->{gt}) if defined $v->{gt};
 514             return ("$k < ?", $v->{lt}) if defined $v->{lt};
 515             return ("$k >= ?", $v->{ge}) if defined $v->{ge};
 516             return ("$k <= ?", $v->{le}) if defined $v->{le};
 517         }
 518
 519         die "invalid query parameter: $k, $v";
 520     };
 521
 522     # define closure
 523     my $decode_and_set_params = sub {
 524         my ($k, $p, $is_unique) = @_;
 525         my ($c, $v) = $decode_param->($k, $p);
 526         push @clauses, $c if $c;
 527         if (defined $v) {
 528             if (ref($v) eq 'ARRAY') {
 529                 push @values, @$v;
 530             }
 531             else {
 532                 push @values, $v;
 533                 $unique = 1 if $is_unique;
 534             }
 535         }
 536     };
 537
 538
 539     # reqularize keys to hashref
 540     my $ky = $self->_keys_to_hash($keys);
 541     if ($ky) {
 542         for my $k (keys(%$ky)) {
 543             if (defined $params->{$k}) {
 544                 $decode_and_set_params->($ky->{$k}, $params->{$k});
 545             }
 546         }
 547     }
 548     # reqularize uniques to hashref
 549     my $u = $self->_keys_to_hash($uniques);
 550     if ($u) {
 551         for my $k (keys(%$u)) {
 552             if (defined $params->{$k}) {
 553                 $decode_and_set_params->($u->{$k}, $params->{$k}, 1);
 554             }
 555         }
 556     }
 557
 558     # year, month, day, years, months, days, date
 559     if ($timestamp) {
 560         my ($begin, $end) = $self->calculate_time_range($params);
 561         if ($begin) {
 562             push @clauses, "$timestamp >= ?";
 563             push @values, $begin;
 564         }
 565         if ($end) {
 566             push @clauses, "$timestamp < ?";
 567             push @values, $end;
 568         }
 569     }
 570
 571     return (\@clauses, \@values, $unique);
 572 }
 573
 574 # reqularize keys to hashref
 575 sub _keys_to_hash {
 576     my ($self, $keys) = @_;
 577     return if !defined $keys;
 578
 579     my $ky;
 580     if(ref($keys) eq 'HASH') {
 581         $ky = $keys;
 582     }
 583     elsif (ref($keys) eq 'ARRAY') {
 584         $ky = {};
 585         for my $k (@$keys) {
 586             $ky->{$k} = $k;
 587         }
 588     }
 589     elsif (!ref($keys)) {
 590         $ky = { $keys => $keys };
 591     }
 592     return $ky;
 593 }
 594
 595 =head2 build_limit_clause(params => \@params)
 596
 597 build SQL's LIMIT clause.
 598
 599 =over 4
 600
 601 =item Parameters
 602
 603 =over 4
 604
 605 =item \@params
 606
 607 HASHREF to query parameters
 608
 609 =item Return value
 610
 611 when list context, returns ($clause, \@values).
 612 when scalar context, return hashref like:
 613  { clause => $clause, values => \@values };
 614
 615 =back
 616
 617 =cut
 618
 619 sub build_limit_clause {
 620     my $self = shift;
 621     my $args = {@_};
 622
 623     my $params = $args->{params};
 624     my $limit = $args->{default};
 625     my $offset = $args->{default_offset};
 626
 627     $limit = $args->{default_limit} if defined $args->{default_limit};
 628     $limit = $params->{limit} if defined $params->{limit};
 629     $offset = $params->{offset} if defined $params->{offset};
 630
 631     my @clauses;
 632     my @values;
 633     if (defined $limit) {
 634         push @clauses, "LIMIT ?";
 635         push @values, $limit;
 636     }
 637     if (defined $offset) {
 638         push @clauses, "OFFSET ?";
 639         push @values, $offset;
 640     }
 641
 642     my $clause = join(" ", @clauses);
 643
 644     return wantarray ? ($clause, \@values)
 645       : { clause => $clause, values => \@values };
 646 }
 647
 648 =head2 build_order_by_clause(keys => $keys, params => \@params)
 649
 650 build SQL ORDER BY clause.
 651
 652 =over 4
 653
 654 =item Parameters
 655
 656 =over 4
 657
 658 =item $keys
 659
 660 ARRAYREF or HASHREF.
 661 If ARRAREF, @$keys contains selectSable columns.
 662 If HASHREF, %$keys is { key1 => alias1, key2 => alias2, ... }.
 663
 664 =item \@params
 665
 666 HASHREF to query parameters
 667
 668 =item Return value
 669
 670 when list context, returns ($clause, \@values).
 671 when scalar context, return hashref like:
 672  { clause => $clause, values => \@values };
 673
 674 =back
 675
 676 =cut
 677
 678 sub build_order_by_clause {
 679     my $self = shift;
 680     my $args = {@_};
 681
 682     my $unique_keys = $args->{unique_keys} || $self->unique_keys;
 683     my $keys = $args->{keys} || $self->get_keys("all");
 684
 685     my $params = $args->{params};
 686     my $order_by = $params->{order_by};
 687
 688     if (!$keys || !$params || !$order_by) {
 689         return wantarray ? ("", [])
 690           : { clause => "", values => [] };
 691     }
 692
 693     my @clauses;
 694     my @values;
 695
 696     my $k_names;
 697     my $use_alias = 0;
 698     # convert $keys to hash style
 699     if (ref($keys) eq 'HASH') {
 700         $k_names = [keys %$keys];
 701         $use_alias = 1;
 702     }
 703     if (ref($keys) eq 'ARRAY') {
 704         $k_names = $keys;
 705     }
 706     elsif (!ref($keys)) {
 707         $k_names = [$keys];
 708     }
 709
 710     # convert $order_by to hash style
 711     if (ref($order_by) eq "ARRAY") {
 712         my $hash = {};
 713         for my $item (@$order_by) {
 714             $hash->{$item} = "ASC";
 715         }
 716         $order_by = $hash;
 717     }
 718     elsif (!ref($order_by)) {
 719         $order_by = {$order_by => "ASC"};
 720     }
 721
 722     # when $order_by is not ARRAY or SCALAR or HASH,
 723     # this block is passed.
 724     if (ref($order_by) eq "HASH") {
 725         for my $k (keys %$order_by) {
 726             next if !any {$_ eq $k} @$k_names;
 727
 728             my $order = uc($order_by->{$k});
 729             my $target = $k;
 730             if ($use_alias && $keys->{$k}) {
 731                 $target = $keys->{$k};
 732             }
 733             push @clauses, "$target $order" if $target;
 734         }
 735     }
 736
 737     my $clause = "";
 738     if (@clauses) {
 739         $clause = "ORDER BY " . join(", ", @clauses);
 740     }
 741
 742     return wantarray ? ($clause, \@values)
 743       : { clause => $clause, values => \@values };
 744 }
 745
 746 ########## Insert method
 747
 748 sub generic_insert {
 749     my $self = shift;
 750     return if $self->check_readonly;
 751     my $args = {@_};
 752
 753     my $table = $args->{table} || $self->primary_table;
 754     if (!$table) {
 755         $self->set_error("table not given", -1);
 756         return;
 757     }
 758
 759     my $keys;
 760     if ($args->{keys}) {
 761         $keys = $self->_build_keys($args->{keys});
 762     }
 763     else {
 764         $keys = $self->get_keys("all");
 765     }
 766
 767     my $params = $args->{params};
 768     if (!$params) {
 769         $self->set_error("params not given", -1);
 770         return;
 771     };
 772
 773     my @cols;
 774     my @values;
 775     my @placeholders;
 776
 777     # extract key and values
 778     for my $k (keys %$keys) {
 779         next if !defined $params->{$k};
 780         if (!ref($params->{$k})) {
 781             push @cols, $keys->{$k};
 782             push @values, $params->{$k};
 783             push @placeholders, "?";
 784         }
 785         elsif(ref($params->{$k}) eq "HASH") {
 786             for my $subkey (keys %{$params->{$k}}) {
 787                 if (lc($subkey) eq "function") {
 788                     push @cols, $keys->{$k};
 789                     push @placeholders, $params->{$k}->{$subkey};
 790                 }
 791             }
 792         }
 793     }
 794
 795     if (!@cols || !@values) {
 796         $self->set_error("no valid values", -1);
 797         return;
 798     }
 799
 800     my $cols_clause = join(", ", @cols);
 801     my $values_clause = join(", ", @placeholders);
 802
 803
 804     my $sql = "INSERT INTO $table ($cols_clause) VALUES ($values_clause)";
 805     $self->_last_query($sql, \@values);
 806
 807     #warn $sql;
 808     #warn Dumper @values;
 809
 810     my $dbh = $self->connect_db;
 811     my $rs = $dbh->do($sql, undef, @values);
 812     $self->disconnect_db;
 813     return $rs;
 814
 815 }
 816
 817
 818 ########## Select method
 819
 820 =head2 generic_select(table => $table, uniques => $uniques, keys => $keys, params => $params)
 821
 822 build SQL's ORDER BY clause.
 823
 824 =over 4
 825
 826 =item Parameters
 827
 828 =over 4
 829
 830 =item $table
 831
 832 table name
 833
 834 =item $uniques
 835
 836 ARRAYREF to unique keys. 'unique key' is a column name
 837 defined with 'UNIQUE' or 'PRIMARY'.
 838
 839 =back
 840
 841 =item $keys
 842
 843 ARRAYREF to acceptable keys (column names)
 844
 845 =back
 846
 847 =item $params
 848
 849 HASHREF to query parameters
 850
 851 =item Return value
 852
 853 when list context, returns ($clause, \@values).
 854 when scalar context, return hashref like:
 855  { clause => $clause, values => \@values };
 856
 857 =back
 858
 859 =cut
 860
 861 sub generic_select {
 862     my $self = shift;
 863     my $args = {@_};
 864     my $table = $args->{table} || $self->primary_table;
 865     if (!$table) {
 866         $self->set_error("table no given");
 867         return;
 868     }
 869     my $params = $args->{params} || {};
 870
 871     if ($args->{uniques}) {
 872         warn "Cowrapper::generic_select(): 'uniques' parameter is deprecated. use 'unique_keys'.";
 873         $args->{unique_keys} ||= $args->{uniques};
 874     }
 875     my $uniques = $args->{unique_keys};
 876     my $keys = $args->{keys};
 877     my $timestamp = $args->{timestamp};
 878
 879     my @arguments;
 880     my ($values, $orderby, $limit, $where, $unique_query);
 881
 882     ($where, $values, $unique_query) = $self->build_where_clause(unique_keys => $uniques,
 883                                                                  keys => $keys,
 884                                                                  timestamp => $timestamp,
 885                                                                  params => $params);
 886     push @arguments, @$values if @$values;
 887
 888     ($orderby, $values) = $self->build_order_by_clause(keys => $keys, params => $params);
 889     push @arguments, @$values if @$values;
 890
 891     ($limit, $values) = $self->build_limit_clause(params => $params);
 892     push @arguments, @$values if @$values;
 893
 894     my $dbh = $self->connect_db;
 895     my $generic_sql = <<"EOSQL";
 896 SELECT * FROM $table
 897   $where
 898   $orderby
 899   $limit
 900 EOSQL
 901
 902     my $sql = $args->{sql} || $generic_sql;
 903     $self->_last_query($sql, \@arguments);
 904
 905     my $sth = $dbh->prepare($sql);
 906     $sth->execute(@arguments);
 907     my $rs = $sth->fetchall_arrayref(+{});
 908     if (!defined $rs) {
 909         $self->set_error("select failed", $dbh->errstr, $dbh->err);
 910         $self->disconnect_db;
 911         return;
 912     }
 913     $self->disconnect_db;
 914
 915     if ($unique_query) {
 916         $self->clear_error;
 917         return $rs->[0] if @$rs;
 918         return;
 919     }
 920     return $rs;
 921 }
 922
 923 ########## Count method
 924
 925 =head2 generic_count(
 926  table => $table,
 927  target => $target_column,
 928  timestamp => $timestamp_column,
 929  year => $year,
 930  month => $month,
 931  day => $day,
 932  offset_sec => $offset_sec,
 933  join => $join_clause,
 934  where => $where_clause)
 935
 936 count items
 937
 938 =over 4
 939
 940 =item Parameters
 941
 942 =over 4
 943
 944 =item $table
 945
 946 table name
 947
 948 =item $target_column
 949
 950 count target column
 951
 952 =item $timestamp_column
 953
 954 timestamp column
 955
 956 =item $year
 957
 958 target year
 959
 960 =item $month
 961
 962 target month (omissible)
 963
 964 =item $day
 965
 966 target day (omissible)
 967
 968 =item $whare_clause
 969
 970 additional WHERE clause (must not include 'WHERE' !; omissible)
 971
 972 =item $join_clause
 973
 974 additional JOIN clause (must include 'JOIN' !; omissible)
 975
 976 =item Return value
 977
 978 count of items
 979
 980 =back
 981
 982 =cut
 983
 984 sub generic_count {
 985     my $self = shift;
 986     my $params = {@_};
 987
 988     my $table = $params->{table} || $self->primary_table;
 989     my $target = $params->{target};
 990     my $timestamp = $params->{timestamp} || $self->timestamp;
 991
 992     return if (!$table || !$target || !$timestamp || !$params->{year});
 993
 994     my $term = "day";
 995     $term = "month" if !$params->{day};
 996     $term = "year" if !$params->{month};
 997
 998     my ($year, $month, $day) = ($params->{year}, $params->{month}, $params->{day});
 999     $year  = 1 if (!$year  || $year  !~ m/^[0-9]{4}$/);
1000     $month = 1 if (!$month || $month !~ m/^(1[0-2]|0?[0-9])$/);
1001     $day   = 1 if (!$day   || $day   !~ m/^(3[0-1]|[1-2][0-9]|0?[0-9])$/);
1002
1003     my $offset = $params->{offset_sec} || 0;
1004     $offset = 0 if $offset !~ m/^[+-]?[0-9]+$/;
1005
1006     my $dt = DateTime->new(year => $year,
1007                            month => $month,
1008                            day => $day);
1009     $dt->add(seconds => -$offset);
1010     my $dt_string = DateTime::Format::MySQL->format_datetime($dt);
1011
1012     # create end of term datetime
1013     # we must consider timezone offset, so use relative day/month.
1014     # why use "DATE_ADD(?, INTERVAL 1 MONTH)" ? bacause, DATE_ADD function add simply 30 days...
1015     my $dt_end = DateTime->new(year => $year,
1016                                month => $month,
1017                                day => $day);
1018     if ($term eq "month") {
1019         $dt_end->add(months => 1);
1020     }
1021     elsif ($term eq "year") {
1022         $dt_end->add(years => 1);
1023     }
1024     $dt->add(seconds => -$offset);
1025     my $dt_end_string = DateTime::Format::MySQL->format_datetime($dt_end);
1026
1027     # build SQL
1028     my $sql;
1029     my $where_clause = "";
1030     if ($params->{where}) {
1031         $where_clause = "$params->{where} AND ";
1032     }
1033     my $join_clause = $params->{join} || "";
1034
1035     my @attrs;
1036     if ($term eq "day") {
1037         # `stories` table not contain display/non-display flag,
1038         # so use firehose.
1039         $sql = <<"EOSQL";
1040 SELECT COUNT($table.$target) AS count FROM $table
1041     $join_clause
1042   WHERE $where_clause
1043         $table.$timestamp >= ?
1044     AND $table.$timestamp < DATE_ADD(?, INTERVAL 1 DAY)
1045 EOSQL
1046         push @attrs, $dt_string, $dt_string;
1047     }
1048     elsif ($term eq "month") {
1049         $sql = <<"EOSQL";
1050 SELECT TIMESTAMPDIFF(DAY, ?, $table.$timestamp) AS day,
1051        COUNT($table.$target) AS count
1052   FROM $table
1053     $join_clause
1054   WHERE $where_clause
1055         $table.$timestamp >= ?
1056     AND $table.$timestamp < ?
1057   GROUP BY TIMESTAMPDIFF(DAY, ?, $table.$timestamp)
1058   ORDER BY day ASC
1059 EOSQL
1060         push @attrs, $dt_string, $dt_string, $dt_end_string, $dt_string;
1061     }
1062     elsif ($term eq "year") {
1063         $sql = <<"EOSQL";
1064 SELECT TIMESTAMPDIFF(MONTH, ?, $table.$timestamp) AS month,
1065        COUNT($table.$target) AS count
1066   FROM $table
1067     $join_clause
1068   WHERE $where_clause
1069         $table.$timestamp >= ?
1070     AND $table.$timestamp < ?
1071   GROUP BY TIMESTAMPDIFF(MONTH, ?, $table.$timestamp)
1072   ORDER BY month ASC
1073 EOSQL
1074         push @attrs, $dt_string, $dt_string, $dt_end_string, $dt_string;
1075     }
1076     my $dbh = $self->connect_db;
1077     my $sth = $dbh->prepare($sql);
1078
1079     $self->_last_query($sql, \@attrs);
1080     $sth->execute(@attrs);
1081     my $rs = $sth->fetchall_arrayref({});
1082
1083     if (!$rs) {
1084         $self->disconnect_db;
1085         return;
1086     }
1087     $self->disconnect_db;
1088
1089     my $hash = {};
1090     my $key;
1091     if ($term eq "day") {
1092         return $rs->[0]->{count};
1093     }
1094     elsif ($term eq "month") {
1095         $key = "day";
1096     }
1097     elsif ($term eq "year") {
1098         $key = "month";
1099     }
1100     else {
1101         return;
1102     }
1103
1104     for my $counts (@$rs) {
1105         # day / month is differential from base datetime, so add 1
1106         $hash->{$counts->{$key} + 1} = $counts->{count};
1107     }
1108     return $hash;
1109 }
1110
1111
1112
1113
1114 ########## Update method
1115
1116 =head2 generic_update(table => $table,
1117                       updatable_keys => $updatables,
1118                       addable_keys => $addables,
1119                       condition_keys => $conditions,
1120                       params => $params)
1121
1122 execute UPDATE SQL command.
1123
1124 =over 4
1125
1126 =item Parameters
1127
1128 =over 4
1129
1130 =item $table
1131
1132 table name
1133
1134 =item $updatables
1135
1136 ARRAYREF or HASHREF to updatable keys. 'updatable key' is a updatable column name.
1137
1138 =item $addables
1139
1140 ARRAYREF or HASHREF to addable keys. 'addable key' is a addable column name.
1141
1142 =item $conditions
1143
1144 ARRAYREF or HASHREF to conditional keys. 'conditional key' is a column name which can use in WHERE clause.
1145
1146 =item $params
1147
1148 HASHREF to query parameters
1149
1150 =item Return value
1151
1152 when list context, returns ($clause, \@values).
1153 when scalar context, return hashref like:
1154  { clause => $clause, values => \@values };
1155
1156 =back
1157
1158 =cut
1159
1160 sub generic_update {
1161     my $self = shift;
1162     return if $self->check_readonly;
1163     my $args = {@_};
1164     return if !%$args;
1165
1166     my $table = $args->{table} || $self->primary_table;
1167     if (!$table) {
1168         $self->set_error("table given", -1);
1169         return;
1170     }
1171
1172     my $updatables = $args->{updatable_keys} || $self->get_keys("updatable");
1173     my $addables = $args->{addable_keys} || $self->get_keys("addable");
1174
1175     my $conditions = $args->{condition_keys};
1176     my $params = $args->{params} || {};
1177     my $where = $args->{where} || $params->{where};
1178
1179     if ($where) {
1180         $conditions = $args->{condition_keys} || $self->get_keys("all");
1181     }
1182     else {
1183         $conditions = $args->{condition_keys} || $self->get_keys("primary");
1184     }
1185
1186     if (!$conditions || !%$conditions) {
1187         $self->set_error("no_condition_keys", -1);
1188         return;
1189     }
1190     my $u_hash = $self->_keys_to_hash($updatables);
1191     #my $a_hash = $self->_keys_to_hash($addables);
1192
1193     # first, create WHERE clause
1194     my ($where_clause, $where_values) = $self->build_where_clause(keys => $conditions,
1195                                                                   params => $params,
1196                                                                   where => $where);
1197     if (!$where_clause) {
1198         $self->set_error("no_where_clauses", -1);
1199         return;
1200     }
1201
1202     # build SET clause
1203     my @set_clauses;
1204     my @values;
1205
1206     for my $col (keys %$u_hash) {
1207         next if !defined $params->{$col};
1208         my $c = $u_hash->{$col};
1209
1210         # if $params->{$col} is SCALAR, set to the value
1211         if (!ref($params->{$col})) {
1212             push @values, $params->{$col};
1213             push @set_clauses, "$c = ?";
1214         }
1215         # if $params->{$col} is HASH, do given operation
1216         elsif (ref($params->{$col}) eq 'HASH') {
1217             # key to lc
1218             my $p = {};
1219             for my $k (keys %{$params->{$col}}) {
1220                 $p->{lc($k)} = $params->{$col}->{$k};
1221             }
1222             if ($p->{add}) {
1223                 if (defined $p->{max} && defined $p->{min}) {
1224                     push @values, $p->{min};
1225                     push @values, $p->{max};
1226                     push @values, $p->{add};
1227                     push @set_clauses, "$c = GREATEST(?, LEAST(?, $c + ?))";
1228                 }
1229                 elsif (defined $p->{max}) {
1230                     push @values, $p->{min};
1231                     push @values, $p->{add};
1232                     push @set_clauses, "$c = GREATEST(?, $c + ?)";
1233                 }
1234                 elsif (defined $p->{min}) {
1235                     push @values, $p->{min};
1236                     push @values, $p->{add};
1237                     push @set_clauses, "$c = LEAST(?, $c + ?)";
1238                 }
1239                 else {
1240                     push @values, $p->{add};
1241                     push @set_clauses, "$c = $c + ?";
1242                 }
1243             }
1244             if ($p->{function}) {
1245                 push @set_clauses, "$c = ($p->{function})";
1246             }
1247         }
1248     }
1249
1250     return 0 if !@set_clauses;
1251     my $set_clause = join(", ", @set_clauses);
1252
1253     my $sql = "UPDATE $table SET $set_clause $where_clause";
1254     push @values, @$where_values;
1255     $self->_last_query($sql, \@values);
1256
1257     #warn $sql;
1258     #warn Dumper @values;
1259
1260     my $dbh = $self->connect_db;
1261     my $rs = $dbh->do($sql, undef, @values);
1262     $self->disconnect_db;
1263     return $rs;
1264
1265 }
1266
1267 ########## count helper
1268
1269 sub build_interval_times {
1270     my $self = shift;
1271     my $attr = {@_};
1272     my $params = $attr->{params} || {};
1273
1274     my $target = "day";
1275     return if !$params->{year};
1276     $target = "month" if !$params->{day};
1277     $target = "year" if !$params->{month};
1278
1279     my ($year, $month, $day) = ($params->{year}, $params->{month}, $params->{day});
1280     $year = 1 if (!$year || $year !~ m/^[0-9]{4}$/);
1281     $month = 1 if (!$month || $month !~ m/^(1[0-2]|0?[0-9])$/);
1282     $day = 1 if (!$day || $day !~ m/^(3[0-1]|[1-2][0-9]|0?[0-9])$/);
1283
1284     my $offset = $params->{offset_sec} || 0;
1285     $offset = 0 if $offset !~ m/^[+-]?[0-9]+$/;
1286
1287     my $dt = DateTime->new(year => $year,
1288                              month => $month,
1289                              day => $day);
1290     $dt->add(seconds => -$offset);
1291     my $dt_string = DateTime::Format::MySQL->format_datetime($dt);
1292
1293     # create end of term datetime
1294     # why use "DATE_ADD(?, INTERVAL 1 MONTH)" ? bacause, this function add simply 30 days...
1295     my $dt_end = DateTime->new(year => $year,
1296                                month => $month,
1297                                day => $day);
1298     if ($target eq "month") {
1299         $dt_end->add(months => 1);
1300     }
1301     elsif ($target eq "year") {
1302         $dt_end->add(years => 1);
1303     }
1304     $dt->add(seconds => -$offset);
1305     my $dt_end_string = DateTime::Format::MySQL->format_datetime($dt_end);
1306
1307     return wantarray ? ($target, $dt_string, $dt_end_string)
1308       : { target => $target,
1309           start => $dt_string,
1310           end => $dt_end_string };
1311 }
1312
1313
1314 ########## Delete method
1315
1316 =head2 generic_delete(table => $table, uniques => $uniques, keys => $keys, params => $params)
1317
1318 DELETE item from table
1319
1320 =over 4
1321
1322 =item Parameters
1323
1324 =over 4
1325
1326 =item $table
1327
1328 table name
1329
1330 =item $uniques
1331
1332 ARRAYREF to unique keys. 'unique key' is a column name
1333 defined with 'UNIQUE' or 'PRIMARY'.
1334
1335 =back
1336
1337 =item $keys
1338
1339 ARRAYREF to acceptable keys (column names)
1340
1341 =back
1342
1343 =item $params
1344
1345 HASHREF to query parameters
1346
1347 =item Return value
1348
1349 when list context, returns ($clause, \@values).
1350 when scalar context, return hashref like:
1351  { clause => $clause, values => \@values };
1352
1353 =back
1354
1355 =cut
1356
1357 sub generic_delete {
1358     my $self = shift;
1359     my $args = {@_};
1360     my $table = $args->{table} || $self->primary_table;
1361     if (!$table) {
1362         $self->set_error("table no given");
1363         return;
1364     }
1365     my $params = $args->{params} || {};
1366
1367     if ($args->{uniques}) {
1368         warn "Cowrapper::generic_select(): 'uniques' parameter is deprecated. use 'unique_keys'.";
1369         $args->{unique_keys} ||= $args->{uniques};
1370     }
1371     my $uniques = $args->{unique_keys};
1372     my $keys = $args->{keys};
1373     my $timestamp = $args->{timestamp};
1374
1375     my @arguments;
1376     my ($values, $orderby, $limit, $where, $unique_query);
1377
1378     ($where, $values, $unique_query) = $self->build_where_clause(unique_keys => $uniques,
1379                                                                  keys => $keys,
1380                                                                  timestamp => $timestamp,
1381                                                                  params => $params);
1382     push @arguments, @$values if @$values;
1383
1384     my $dbh = $self->connect_db;
1385     my $generic_sql = <<"EOSQL";
1386 DELETE FROM $table
1387   $where
1388 EOSQL
1389
1390     my $sql = $args->{sql} || $generic_sql;
1391     $self->_last_query($sql, \@arguments);
1392
1393     my $rs = $dbh->do($sql, undef, @arguments);
1394     if (!defined $rs) {
1395         $self->set_error("delete_failed", $dbh->errstr, $dbh->err);
1396         $self->disconnect_db;
1397         return;
1398     }
1399     $self->disconnect_db;
1400
1401     return $rs;
1402 }
1403
1404 ######### data export / import functions
1405
1406 =head2 export_json()
1407
1408 export as json data.
1409
1410 $obj->export_json(file => "foobar.json",
1411                   table => "foo",
1412                   exclude => [qw(foo bar)],
1413                   sort_key => [qw(hoge moge)],
1414                  );
1415
1416 =over 4
1417
1418 =item Parameters
1419
1420 =over 4
1421
1422 =back
1423
1424 =back
1425
1426 =cut
1427
1428 sub export_json {
1429     my $self = shift;
1430     my $params = {@_};
1431
1432     my $table = $params->{table};
1433     return if !$table;
1434
1435     my $keys = $params->{sort_key} || [];
1436     if (!ref($keys)) {
1437         $keys = [$keys];
1438     }
1439
1440     my $query_params = {};
1441     if ($params->{sort_key}) {
1442         $query_params->{order_by} = $keys;
1443     }
1444
1445     my $datas = $self->generic_select(table => $table, keys => $keys, params => $query_params);
1446     return if !$datas;
1447
1448     my $exclude = $params->{exclude} || [];
1449     if (!ref($exclude)) {
1450         $exclude = [$exclude];
1451     }
1452
1453     for my $data (@$datas) {
1454         for my $k (@$exclude) {
1455             delete $data->{$k};
1456         }
1457     }
1458
1459     #warn Dumper($datas);
1460
1461     my $j = JSON->new;
1462     $j->indent(1);
1463     $j->space_after(1);
1464     $j->canonical(1);
1465     if ($params->{file}) {
1466         my $bin_data = $j->utf8->encode($datas);
1467         my $fh = FileHandle->new($params->{file}, "w");
1468         if (!defined $fh) {
1469             $self->set_error($!);
1470             return;
1471         }
1472         $fh->print($bin_data);
1473         $fh->close;
1474         return 1;
1475     }
1476     return JSON::to_json($datas);
1477 }
1478
1479 =head2 import_json()
1480
1481 export as json data.
1482
1483 $obj->export_json(file => "foobar.json",
1484                   table => "foo",
1485                   exclude => [qw(foo bar)],
1486                   unique_key => "id",
1487                  );
1488
1489 $obj->export_json(json => '{ "foo": "bar", "hoge": 1 }',
1490                   table => "foo",
1491                   exclude => [qw(foo bar)],
1492                   unique_key => "id",
1493                  );
1494
1495 =over 4
1496
1497 =item Parameters
1498
1499 =over 4
1500
1501 =back
1502
1503 =back
1504
1505 =cut
1506
1507 sub import_json {
1508     my $self = shift;
1509     my $params = {@_};
1510
1511     my $table = $params->{table};
1512     return if !$table;
1513
1514     if ($params->{json} && $params->{file}) {
1515         return;
1516     }
1517
1518     my $datas;
1519     if ($params->{file}) {
1520         my $fh = FileHandle->new($params->{file}, "r");
1521         if (!defined $fh) {
1522             $self->set_error($!);
1523             return;
1524         }
1525         my $json = do { local $/; <$fh> };
1526         $fh->close;
1527         $datas = JSON::decode_json($json);
1528     }
1529     if ($params->{json}) {
1530         $datas = JSON::from_json($params->{json});
1531     }
1532
1533     return if !$datas;
1534     return if ref($datas) ne "ARRAY";
1535
1536     my $primary_key = $params->{unique_key};
1537     my $exclude = $params->{exclude} || [];
1538     if (!ref($exclude)) {
1539         $exclude = [$exclude];
1540     }
1541     # insert data
1542     my $dbh = $self->start_transaction;
1543     my $updated = 0;
1544     for my $data (@$datas) {
1545         for my $k (@$exclude) {
1546             delete $data->{$k};
1547         }
1548         my @cols;
1549         my @plhs;
1550         my @vals;
1551         my @updates;
1552         my @update_vals;
1553         for my $k (keys(%$data)) {
1554             #my $quoted_k = '`' . $k . '`';
1555             my $quoted_k = $dbh->quote_identifier($k);
1556             push @cols, $quoted_k;
1557             push @plhs, '?';
1558             push @vals, $data->{$k};
1559             if ($k ne $primary_key) {
1560                 push @updates, "$quoted_k = ?";
1561                 push @update_vals, $data->{$k};
1562             }
1563         }
1564         my $cols_clause = join(", ", @cols);
1565         my $placeholders = join(", ", @plhs);
1566         my $update_clauses = join(", ", @updates);
1567
1568         my $sql = <<"EOSQL";
1569 INSERT INTO $table
1570     ($cols_clause)
1571   VALUES
1572     ($placeholders)
1573   ON DUPLICATE KEY UPDATE
1574     $update_clauses
1575 EOSQL
1576         push @vals, @update_vals;
1577         $self->_last_query($sql, \@vals);
1578         #warn $sql;
1579         my $rs = $dbh->do($sql, undef, @vals);
1580         if (!defined $rs) {
1581             $self->rollback;
1582             return;
1583         }
1584         $updated += $rs;
1585     }
1586     $self->commit;
1587     return $updated;
1588 }
1589
1590 ########## virtual method for O/R mapping function
1591 sub key_definition { return {}; }
1592
1593 sub _build_keys {
1594     my ($self, $target) = @_;
1595     return {} if !$target;
1596     return $target if ref($target) eq "HASH";
1597     if (!ref($target)) {
1598         $target = [$target];
1599     }
1600
1601     my $def = $self->key_definition || {};
1602     my $basename = "";
1603     if ($def->{basename}) {
1604         $basename = "$def->{basename}.";
1605     }
1606     elsif ($def->{table}) {
1607         $basename = "$def->{table}.";
1608     }
1609
1610     my $rs = {};
1611     for my $uk (@$target) {
1612         $rs->{$uk} = "$basename$uk";
1613         for my $k (keys %{$def->{aliases}}) {
1614             if ($uk eq $def->{aliases}->{$k}) {
1615                 $rs->{$k} = "$basename$uk";
1616             }
1617         }
1618     }
1619
1620     return $rs;
1621 }
1622
1623 sub primary_table {
1624     my $self = shift;
1625     my $def = $self->key_definition || {};
1626     return $def->{table};
1627 }
1628
1629 sub primary_key {
1630     my $self = shift;
1631     my $def = $self->key_definition || {};
1632     return $self->_build_keys($def->{primary});
1633 }
1634
1635 sub timestamp_key {
1636     my $self = shift;
1637     my $def = $self->key_definition || {};
1638     return $self->_build_keys($def->{timestamp});
1639 }
1640
1641 sub datetime_keys {
1642     my $self = shift;
1643     my $def = $self->key_definition || {};
1644     return $self->_build_keys($def->{datetime});
1645 }
1646
1647 sub other_keys {
1648     my $self = shift;
1649     my $def = $self->key_definition || {};
1650     return $self->_build_keys($def->{other});
1651 }
1652
1653 sub unique_keys {
1654     my $self = shift;
1655     my $def = $self->key_definition || {};
1656     my $uniq = $self->_build_keys($def->{unique});
1657     my $primary = $self->_build_keys($def->{primary});
1658     return $self->_merge_keys($uniq, $primary);
1659 }
1660
1661 sub addable_keys {
1662     my $self = shift;
1663     my $def = $self->key_definition || {};
1664     return $self->_build_keys($def->{addable});
1665 }
1666
1667 sub get_keys {
1668     my $self = shift;
1669     my @keys;
1670     my $def = $self->key_definition || {};
1671     while (@_) {
1672         my $target = shift;
1673         if (defined $def->{$target}) {
1674             push @keys, @{_to_array($def->{$target})};
1675         }
1676         elsif ($target eq "all") {
1677             push @keys, $def->{primary} if $def->{primary};
1678             push @keys,
1679               @{_to_array($def->{unique})},
1680               @{_to_array($def->{datetime})},
1681               @{_to_array($def->{addable})},
1682               @{_to_array($def->{other})};
1683         }
1684         elsif ($target eq "non-unique") {
1685             push @keys,
1686               @{_to_array($def->{datetime})},
1687               @{_to_array($def->{addable})},
1688               @{_to_array($def->{other})};
1689         }
1690         elsif ($target eq "updatable") {
1691             push @keys,
1692               @{_to_array($def->{unique})},
1693               @{_to_array($def->{datetime})},
1694               @{_to_array($def->{addable})},
1695               @{_to_array($def->{other})};
1696         }
1697     }
1698     return $self->_build_keys(\@keys) if @keys;
1699     return;
1700 }
1701
1702 sub _to_array {
1703     my $item = shift;
1704     return [] if !defined $item;
1705     return $item if (ref($item) eq 'ARRAY');
1706     return [$item] if !ref($item);
1707 }
1708
1709 sub _merge_keys {
1710     my $self = shift;
1711     my $rs = {};
1712
1713     while(@_) {
1714         my $keys = shift;
1715         next if !defined $keys;
1716         if (ref($keys) eq 'ARRAY') {
1717             for my $k (@$keys) {
1718                 $rs->{$k} = $k;
1719             }
1720         }
1721         elsif (ref($keys) eq 'HASH') {
1722             for my $k (keys %$keys) {
1723                 $rs->{$k} = $keys->{$k};
1724             }
1725         }
1726         elsif (!ref($keys)) {
1727             $rs->{$keys} = $keys;
1728         }
1729     }
1730
1731     return $rs;
1732 }
1733
1734 ########## END OF FILE
1735 1;