File Coverage

blib/lib/DBIx/AutoUpgrade/NativeStrings.pm

Criterion	Covered	Total	%
statement	79	84	94.0
branch	23	34	67.6
condition	22	34	64.7
subroutine	13	15	86.6
pod	2	5	40.0
total	139	172	80.8

use 5.10.0;
package DBIx::AutoUpgrade::NativeStrings;
use utf8;
use strict;
use warnings;
use Scalar::Util qw/looks_like_number/;
use Encode       qw/decode/;
use DBI          (),

our $VERSION = 1.02;

my @default_dbh_methods = qw/do
                             prepare
                             selectrow_array
                             selectrow_arrayref
                             selectrow_hashref
                             selectall_arrayref
                             selectall_array
                             selectall_hashref
                             selectcol_arrayref/;

my @default_sth_methods = qw/bind_param
                             bind_param_array
                             execute
                             execute_array/;

my @sql_string_types    = (DBI::SQL_CHAR, DBI::SQL_VARCHAR, DBI::SQL_LONGVARCHAR, DBI::SQL_WLONGVARCHAR,
                           DBI::SQL_WVARCHAR, DBI::SQL_WCHAR, DBI::SQL_CLOB);


my %valid_options = (
# name                    expected reftype    default value
# ====                    ================    =============
  native              => ['NOREF' ,           'default'                    ],
  decode_check        => ['NOREF' ,                                        ],
  debug               => ['CODE'  ,                                        ],
  dbh_methods         => ['ARRAY' ,           \@default_dbh_methods        ],
  sth_methods         => ['ARRAY' ,           \@default_sth_methods        ],
  bind_type_is_string => ['ARRAY' ,           \&default_bind_type_is_string],
);



sub new {
  my ($class, %options) = @_;

  # build object internals, checking validity of input args and supplying default values
  my $self = {};
  while (my ($option, $details) = each %valid_options) {
    my ($expected_reftype, $default_val) = @$details;
    my $val = delete $options{$option};
    !$val or (ref $val || 'NOREF') eq $expected_reftype
          or die "$class->new(): '$option' should be a $expected_reftype";
    $val //= $default_val;
    $self->{$option} = $val if $val;
  }

  # check that there are no remaining input args
  my @invalid_options = keys %options;
  die "$class->new(): invalid options : " . join " / ", @invalid_options if @invalid_options;

  # make sure that Encode::Locale is loaded if needed
  require Encode::Locale if $self->{native} eq 'locale';

  # return object
  bless $self, $class;
}


sub inject_callbacks {
  my ($self, $dbh, @invalid_args) = @_;

  # check input args
  $dbh->isa('DBI::db') or die '->inject_callbacks() : arg is not a DBI database handle';
  !@invalid_args       or die '->inject_callbacks() : too many args';

  # coderef to be installed as common callback for all methods. This is a closure on $self.
  my $upgrade_string_args = sub {
    # NOTES: - here there is no unpacking of @_ because DBI callbacks must work directly on @_
    #        - $_ is the name of the DBI method

    # for calls to bind_param() with an explicit bind type, some types should be left untouched (for ex. SQL_BLOB)
    return if $_ eq 'bind_param' && $_[3] && !$self->{bind_type_is_string}->($_[3]);

    # vars to be used in the loop
    my $do_upgrade = $self->{native} eq 'default' ? sub {utf8::upgrade($_[0])}
                                                  : sub {$_[0] = decode($self->{native}, $_[0], $self->{decode_check})};
    my $dbi_method = $_;
    my $sql        = !ref($_[1]) && $_[1];    # for $dbh methods, SQL is in this position; otherwise undef
    my $debug      = sub {
      return if !$self->{debug}; # client wants no debugging

      my ($arg_pos, $end_msg) = @_;
      my $start_msg = "triggering '$dbi_method' callback";
      $start_msg   .= " for [$sql]" if $sql and $arg_pos > 1;

      # try to find the 1st stack frame above DBI and DBIx
      my $stack_level = 0;
      while (my ($package, $file, $line) = caller $stack_level) {
        $start_msg .= " in $package at $file line $line" and last if $package !~ /^DBI/;
        $stack_level += 1;
      }

      $self->{debug}->("$start_msg; $end_msg");
    };


    # loop over members of @_; start only at 1 because $_[0] is the DBI handle
  ARG:
    foreach my $i (1  .. $#_) {

      # if arg is undef or empty string or 0, there is nothing to do
      next ARG if !$_[$i];

      # if arg is a scalar and needs upgrading, do it
      if (! ref $_[$i]) {
        next ARG if dont_need_upgrade($_[$i]);
        $debug->($i, "upgrading arg [$i] ($_[$i])");
        $do_upgrade->($_[$i]);
      }

      # if arg is an arrayref (used by the *_array methods), upgrade strings in that array
      elsif (ref $_[$i] eq 'ARRAY') {
        for my $val (grep {!dont_need_upgrade($_)} @{$_[$i]}) {
          $debug->($i, "upgrading string in array arg [$i] ($val)");
          $do_upgrade->($val);
        }
      }
    }

    return; # must end with an empty return (see L documentation)
  };

  # now inject the callback for $dbh methods and for $sth methods
  my $parent_callbacks = $dbh->{Callbacks}                   //= {};
  my $child_callbacks  = $parent_callbacks->{ChildCallbacks} //= {};
  inject_callback($parent_callbacks, $_ => $upgrade_string_args)  for @{$self->{dbh_methods}};
  inject_callback($child_callbacks,  $_ => $upgrade_string_args)  for @{$self->{sth_methods}};
}


sub inject_callback {
  my ($hash, $key, $coderef) = @_;

  # in case a previous callback was already installed, we replace it with a sub that combines both
  my $previous_cb = $hash->{$key};
  my $new_cb      = $previous_cb ? sub {&$coderef; &$previous_cb} : $coderef;

  $hash->{$key} = $new_cb;
}

sub dont_need_upgrade {
  my $scalar = shift;
                                     # no need to upgrade if ..
  return looks_like_number($scalar)  # .. it's a number
      || utf8::is_utf8($scalar)      # .. it's already a utf8 string
      || $scalar !~ /\P{ASCII}/;     # .. it only contains ASCII chars
}

sub default_bind_type_is_string {
  my $bind_type = shift;

  # according to L, the bind type can be given either as a scalar or as a hashref with a TYPE key
  $bind_type = $bind_type->{TYPE} if (ref $bind_type || '') eq 'HASH';

  return looks_like_number($bind_type) && grep {$bind_type == $_} @sql_string_types;
}

1;


__END__