DBIx-AutoUpgrade-NativeStrings

 view release on metacpan or  search on metacpan

lib/DBIx/AutoUpgrade/NativeStrings.pm  view on Meta::CPAN

  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

lib/DBIx/AutoUpgrade/NativeStrings.pm  view on Meta::CPAN

          $debug->($i, "upgrading string in array arg [$i] ($val)");
          $do_upgrade->($val);
        }
      }
    }

    return; # must end with an empty return (see L<DBI> 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;

lib/DBIx/AutoUpgrade/NativeStrings.pm  view on Meta::CPAN

=head1 SYNOPSIS

  use utf8;
  use DBI;
  use DBIx::AutoUpgrade::NativeStrings;
  use Encode;
  
  my $injector = DBIx::AutoUpgrade::NativeStrings->new(native => 'cp1252');
  my $dbh = DBI->connect(@dbi_connection_params);
  $injector->inject_callbacks($dbh);
  
  # these strings are semantically equal, but have different internal representations
  my $str_utf8   = "il était une bergère, elle vendait ses œufs en ¥, ça paie 5¾ ‰ de mieux qu’en €",
  my $str_native = decode('cp1252', $str_utf8, Encode::LEAVE_SRC);
  
  # Oracle example : check if strings passed to the database are equal
  my $sql = "SELECT CASE WHEN ?=? THEN 'EQ' ELSE 'NE' END FROM DUAL";
  my ($result) = $dbh->selectrow_array($sql, {}, $str_native, $str_utf8); # returns 'EQ'

lib/DBIx/AutoUpgrade/NativeStrings.pm  view on Meta::CPAN

upgraded if needed, like arguments to other method calls; if the coderef returns false, the C<$value> is left intact.

The default coderef returns true when the C<$bind_type> is one of the DBI constants
C<SQL_CHAR>, C<SQL_VARCHAR>, C<SQL_LONGVARCHAR>, C<SQL_WLONGVARCHAR>, C<SQL_WVARCHAR>, C<SQL_WCHAR> or C<SQL_CLOB>.

=back




=head2 inject_callbacks

  $injector->inject_callbacks($dbh);

Injects callbacks into the given database handle.
If that handle already has callbacks for the same methods, the system will arrange for those
other callbacks to be called I<after> all string arguments have been upgraded to utf8.


=head1 ARCHITECTURAL NOTES

=head2 Object-orientedness

Although I'm a big fan of L<Moose> and its variants, the present module is implemented
in POPO (Plain Old Perl Object) : since the object model is extremely simple, there was
no ground for using a sophisticated object system.

=head2 Strings are modified in-place

String arguments to DBI methods are modified I<in-place>.
It is unlikely that this would affect your client program, but
if it does, you need to make your own string copies before passing them to the DBI methods.

=head2 Possible redundancies

L<DBI> does not precisely document which of its public methods call each other.
For example, one would think that C<execute()> internally calls C<bind_param()>, but this does
not seem to be the case. So, to be on the safe side, callbacks installed here make no assumptions
about string transformations performed by other callbacks. There might be some redundancies,
but it does no harm since strings are never upgraded twice.

=head2 Caveats

The C<bind_param_inout()> method is not covered -- the client program must do the proper updates
if that method is used to send strings to the database.

=head1 AUTHOR

Laurent Dami, E<lt>dami at cpan.orgE<gt>

t/autoupgrade_nativestrings.t  view on Meta::CPAN

  my ($downgrade, $upgrade)
    = $encoding eq 'default' ? (sub {my $str = shift; utf8::downgrade($str); $str},
                                sub {my $str = shift; utf8::upgrade($str)  ; $str})
                             : (sub {my $str = shift; encode($encoding, $str)},
                                sub {my $str = shift; decode($encoding, $str)});

  # connect to the database
  my $dbh = DBI->connect(@opt{qw/data_source user passwd connect_attr/}) or die $DBI::errstr;
  note "testing $encoding encoding on DBD driver $dbh->{Driver}{Name}";

  # first check how tests behave without the callbacks. This proves that semantically equivalent strings
  # are considered not equal by some drivers, and CP1252 strings are never considered equal to their UTF8
  # equivalent, because they need an explicit decode()
  my $expected_without_callbacks 
    = $encoding eq 'cp1252' || !$driver_autoupgrades_latin1{$dbh->{Driver}{Name}} ? 'NE' : 'EQ';
  run_tests($dbh, $encoding, without_callbacks => $expected_without_callbacks, $str, $downgrade, $upgrade);

  # now inject callbacks and test again, this time expecting 'EQ' results.
  my @debug_msgs;
  my $injector = DBIx::AutoUpgrade::NativeStrings->new(
    native => $encoding,
    debug  => sub {push @debug_msgs, join "", @_},
   );
  $injector->inject_callbacks($dbh);
  run_tests($dbh, $encoding, with_callbacks => 'EQ',    $str, $downgrade, $upgrade);


  # check a few simple things on debug messages
  like $debug_msgs[0],  qr/^triggering 'selectrow_array'.*?\[SELECT.*?in main at.*?line \d+/, "first debug msg";
  like $debug_msgs[-1], qr/^triggering 'execute_array'/,                                      "last debug msg";
}



sub run_tests {
  my ($dbh, $encoding, $have_callbacks, $expected, $str, $downgrade, $upgrade) = @_;

  my $context    = "$encoding, $have_callbacks: expecting $expected";
  my $str_native = $downgrade->($str);
  my $str_utf8   = $upgrade->($str_native);
  my ($sth, $result);
  my $maybe_from_dual = sub {my $sql = shift; $sql .= " FROM DUAL" if $dbh->{Driver}{Name} eq 'Oracle'; $sql};
  my $sql             = $maybe_from_dual->("SELECT CASE WHEN ?=? THEN 'EQ' ELSE 'NE' END CMP_RESULT");

  # testing dbh methods -- direct select from dbh
  ($result) = $dbh->selectrow_array(clonestr($sql), {}, clonestr($str_native, $str_utf8));
  is $result, $expected,                          "[$context] (selectrow_array)";

t/autoupgrade_nativestrings.t  view on Meta::CPAN

  is $result, $expected,                          "[$context] (prepare / execute)";

  $sth = $dbh->prepare(clonestr($sql));
  $sth->bind_param(1, clonestr($str_native));
  $sth->bind_param(2, clonestr($str_utf8));
  $sth->execute;
  ($result) = $sth->fetchrow_array;
  is $result, $expected,                          "[$context] (prepare / bind_param / execute)";

  # testing interpolated strings without bind values -- native and utf8.
  # Note: eval is needed because the result of interpolation without the callbacks may yield invalid SQL
  my $sql1 = $downgrade->($maybe_from_dual->("SELECT CASE WHEN '$str'=? THEN 'EQ' ELSE 'NE' END"));
  ($result) = eval {$dbh->selectrow_array(clonestr($sql1), {}, clonestr($str_utf8))};
  is $result, $expected,                          "[$context] (interpolated native string)" if $result;

  my $sql2 = $upgrade->($sql1);
  ($result) = eval {$dbh->selectrow_array(clonestr($sql2), {}, clonestr($str_native))};
  is $result, $expected,                          "[$context] (interpolated utf8 string)" if $result;

  # if there is a table we can write into, test the 'do' method and a roundtrip to the database
  if (!($opt{TABLE} && $opt{KEY_COL} && $opt{VAL_COL})) {