view release on metacpan or  search on metacpan

lib/DBIx/Oracle/UpgradeUtf8.pm  view on Meta::CPAN

  # check that all options have been consumed
  my @invalid_options = keys %options;
  die "$error: invalid options : " . join " / ", @invalid_options if @invalid_options;

  # 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 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 $debug.
  my $debug = $self->{debug};                 # Copy for easier reference. The coderef will be a closure on $debug.
  my $upgrade_string_args = sub {
    $debug->("$_ callback") if $debug;        # Note: $_ is the method name

    # all strings in @_ will be upgraded (in-place, not copies)
  ARG:
    foreach my $i (1  .. $#_) {               # start only at 1 because $_[0] is the DBI handle

lib/DBIx/Oracle/UpgradeUtf8.pm  view on Meta::CPAN

        for my $val (grep {$_ && !ref $_ && !looks_like_number($_) && !utf8::is_utf8($_)} @{$_[$i]}) {
          $debug->("upgrading string in array arg [$i] ($val)") if $debug;
          utf8::upgrade($val);
        }
      }
    }

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

  # inject callbacks 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;

t/upgrade_utf8.t  view on Meta::CPAN

if (!$opt{oradb}) {
  note "no Oracle database connection, skipping all tests";
  note "to run the tests, pass options -oradb, -user, -passwd on the command line";
}
else {
  # connect to the database
  my $dbh = DBI->connect("dbi:Oracle:$opt{oradb}", $opt{user}, $opt{passwd},
                         {RaiseError => 1, PrintError => 1, AutoCommit => 1})
    or die $DBI::errstr;

  # prove that tests indeed do fail without the callbacks
  run_tests_in_context($dbh, without_callbacks => 'NE');

  # inject callbacks and test again, this time getting 'EQ' results
  my $injector = DBIx::Oracle::UpgradeUtf8->new(debug => sub {warn @_, "\n"});
  $injector->inject_callbacks($dbh);
  run_tests_in_context($dbh, with_callbacks => 'EQ');
}

# the end
done_testing;

#======================================================================
# SUBROUTINES
#======================================================================