view release on metacpan or  search on metacpan

lib/App/Sqitch/Engine/firebird.pm  view on Meta::CPAN

use utf8;
use Try::Tiny;
use App::Sqitch::X qw(hurl);
use Locale::TextDomain qw(App-Sqitch);
use App::Sqitch::Plan::Change;
use Path::Class;
use File::Basename;
use Time::Local;
use Time::HiRes qw(sleep);
use Moo;
use App::Sqitch::Types qw(DBH URIDB ArrayRef Maybe Int);
use namespace::autoclean;

extends 'App::Sqitch::Engine';

our $VERSION = 'v1.6.1'; # VERSION

has registry_uri => (
    is       => 'ro',
    isa      => URIDB,
    lazy     => 1,
    default  => sub {
        my $self = shift;
        my $uri  = $self->uri->clone;
        my $reg  = $self->registry;

        if ( file($reg)->is_absolute ) {
            # Just use an absolute path.
            $uri->dbname($reg);
        } elsif (my @segs = $uri->path_segments) {
            # Use the same name, but replace $name.$ext with $reg.$ext.
            my $reg = $self->registry;
            if ($reg =~ /[.]/) {
                $segs[-1] =~ s/^[^.]+(?:[.].+)?$/$reg/;
            } else {
                $segs[-1] =~ s{^[^.]+([.].+)?$}{$reg . ($1 // '')}e;
            }
            $uri->path_segments(@segs);
        } else {
            # No known path, so no name.
            $uri->dbname(undef);
        }

        return $uri;
    },
);

sub registry_destination {
    my $uri = shift->registry_uri;
    if ($uri->password) {
        $uri = $uri->clone;
        $uri->password(undef);
    }
    return $uri->as_string;
}

sub _def_user { $ENV{ISC_USER} }
sub _def_pass { $ENV{ISC_PASSWORD} }
sub _dsn {
    my $uri = shift->registry_uri;
    return $uri->dbi_dsn . ';ib_dialect=3;ib_charset=UTF8';
}

has dbh => (
    is      => 'rw',
    isa     => DBH,
    lazy    => 1,
    clearer => '_clear_dbh',
    default => sub {
        my $self = shift;
        $self->use_driver;

        return DBI->connect($self->_dsn, scalar $self->username, scalar $self->password, {
            PrintError       => 0,
            RaiseError       => 0,
            AutoCommit       => 1,
            ib_enable_utf8   => 1,
            FetchHashKeyName => 'NAME_lc',
            HandleError       => $self->error_handler,
        });
    }
);

# Need to wait until dbh is defined.
with 'App::Sqitch::Role::DBIEngine';

has _isql => (
    is         => 'ro',
    isa        => ArrayRef,
    lazy       => 1,
    default    => sub {
        my $self = shift;
        my $uri  = $self->uri;
        my @ret  = ( $self->client );
        for my $spec (
            [ user     => $self->username ],
            [ password => $self->password ],
        ) {
            push @ret, "-$spec->[0]" => $spec->[1] if $spec->[1];
        }

        push @ret => (
            '-quiet',
            '-bail',
            '-sqldialect' => '3',
            '-pagelength' => '16384',
            '-charset'    => 'UTF8',
            $self->connection_string($uri),
        );

        return \@ret;
    },
);

sub isql { @{ shift->_isql } }

has tz_offset => (
    is       => 'ro',
    isa      => Maybe[Int],
    lazy     => 1,
    default => sub {
        # From: https://stackoverflow.com/questions/2143528/whats-the-best-way-to-get-the-utc-offset-in-perl
        my @t = localtime(time);
        my $gmt_offset_in_seconds = timegm(@t) - timelocal(@t);
        my $offset = -($gmt_offset_in_seconds / 3600);
        return $offset;
    },
);

sub key    { 'firebird' }
sub name   { 'Firebird' }
sub driver { 'DBD::Firebird 1.11' }

sub _char2ts {
    my $dt = $_[1];
    $dt->set_time_zone('UTC');
    return join ' ', $dt->ymd('-'), $dt->hms(':');
}

sub _ts2char_format {
    return qq{'year:' || CAST(EXTRACT(YEAR   FROM %s) AS SMALLINT)
        || ':month:'  || CAST(EXTRACT(MONTH  FROM %1\$s) AS SMALLINT)
        || ':day:'    || CAST(EXTRACT(DAY    FROM %1\$s) AS SMALLINT)
        || ':hour:'   || CAST(EXTRACT(HOUR   FROM %1\$s) AS SMALLINT)
        || ':minute:' || CAST(EXTRACT(MINUTE FROM %1\$s) AS SMALLINT)
        || ':second:' || FLOOR(CAST(EXTRACT(SECOND FROM %1\$s) AS NUMERIC(9,4)))
        || ':time_zone:UTC'};
}

sub _ts_default {
    my $offset = shift->tz_offset;
    sleep 0.01; # give Firebird a little time to tick microseconds.
    return qq(DATEADD($offset HOUR TO CURRENT_TIMESTAMP(3)));
}

sub _version_query {
    # Turns out, if you cast to varchar, the trailing 0s get removed. So value
    # 1.1, represented as 1.10000002384186, returns as preferred value 1.1.
    'SELECT CAST(ROUND(MAX(version), 1) AS VARCHAR(24)) AS v FROM releases',
}

sub is_deployed_change {
    my ( $self, $change ) = @_;
    return $self->dbh->selectcol_arrayref(
        'SELECT 1 FROM changes WHERE change_id = ?',
        undef, $change->id
    )->[0];