diff --git a/.circleci/config.yml b/.circleci/config.yml deleted file mode 100644 index 47cae8f..0000000 --- a/.circleci/config.yml +++ /dev/null @@ -1,21 +0,0 @@ -version: 2 - -jobs: - build: - docker: - - image: perl:5.28.1 - steps: - - checkout - - run: - name: "Install CPAN dependencies and build" - command: | - export PERL_MM_USE_DEFAULT=1 - cpan App::mymeta_requires - perl Makefile.PL - cpan $(mymeta-requires) - make - - run: - name: "Run Test Suite" - command: | - make test - diff --git a/.github/workflows/build-and-test.yml b/.github/workflows/build-and-test.yml new file mode 100644 index 0000000..3726104 --- /dev/null +++ b/.github/workflows/build-and-test.yml @@ -0,0 +1,18 @@ +name: Build and Test + +on: + push: + +jobs: + test: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + - name: Install system dependencies + run: sudo apt-get update -qq && sudo apt-get install -y --no-install-recommends cpanminus libncurses-dev libsqlite3-dev + - name: Install Perl dependencies + run: sudo cpanm --notest --installdeps . && sudo chown -R "$USER:$USER" . + - name: Build + run: perl Makefile.PL && make + - name: Test + run: make test diff --git a/lib/DBR/Config/Instance.pm b/lib/DBR/Config/Instance.pm index dcc26e9..52038f2 100644 --- a/lib/DBR/Config/Instance.pm +++ b/lib/DBR/Config/Instance.pm @@ -298,6 +298,10 @@ sub _new_connection{ my $config = $INSTANCES_BY_GUID{ $self->{guid} }; my @params = ($config->{connectstring}, $config->{user}, $config->{password}); + if ( $config->{connectstring} =~ /^dbi:mysql:/i ) { + push @params, { RootClass => 'DBR::Misc::DBI::Compat' }; + } + my $dbh = DBI->connect(@params); unless ($dbh) { $self->_log("DBI error attempting to connect to db $config->{handle},$config->{class}: $DBI::errstr"); diff --git a/lib/DBR/Misc/DBI/Compat.pm b/lib/DBR/Misc/DBI/Compat.pm new file mode 100644 index 0000000..661009f --- /dev/null +++ b/lib/DBR/Misc/DBI/Compat.pm @@ -0,0 +1,64 @@ +package DBR::Misc::DBI::Compat; + +# DBI RootClass that restores DBD::mysql 4.036 behavior: all values returned +# by fetch methods are string scalars (SVp_POK), regardless of MySQL column type. +# +# Required because DBD::mysql 4.050 returns IV/NV scalars for numeric columns, +# changing JSON::XS output from quoted strings ("42") to bare numbers (42). +# Remove this shim once all consumers are verified safe with bare-number encoding. + +package DBR::Misc::DBI::Compat::db; +use parent -norequire, 'DBI::db'; + +package DBR::Misc::DBI::Compat::st; +use parent -norequire, 'DBI::st'; + +sub fetchrow_arrayref { + my $row = $_[0]->SUPER::fetchrow_arrayref; + return undef unless $row; + @$row = map { defined $_ ? "$_" : $_ } @$row; + return $row; +} + +*fetch = \&fetchrow_arrayref; + +sub fetchrow_array { + my @row = $_[0]->SUPER::fetchrow_array; + return map { defined $_ ? "$_" : $_ } @row; +} + +sub fetchrow_hashref { + my $row = $_[0]->SUPER::fetchrow_hashref(@_[1..$#_]); + return undef unless $row; + $row->{$_} = "$row->{$_}" for grep { defined $row->{$_} } keys %$row; + return $row; +} + +sub fetchall_arrayref { + my $self = shift; + my $slice = $_[0]; + my $rows = $self->SUPER::fetchall_arrayref(@_); + return $rows unless $rows && @$rows; + if ( ref($slice) eq 'HASH' ) { + for my $row (@$rows) { + $row->{$_} = "$row->{$_}" for grep { defined $row->{$_} } keys %$row; + } + } else { + for my $row (@$rows) { + @$row = map { defined $_ ? "$_" : $_ } @$row; + } + } + return $rows; +} + +sub fetchall_hashref { + my ($self, $key_field) = @_; + my $result = $self->SUPER::fetchall_hashref($key_field); + return $result unless $result; + for my $row (values %$result) { + $row->{$_} = "$row->{$_}" for grep { defined $row->{$_} } keys %$row; + } + return $result; +} + +1;