view release on metacpan or  search on metacpan

lib/Acrux/DBI.pm  view on Meta::CPAN

    return $self->{url};
}
sub driver { # scheme
    my $self = shift;
    $self->{driver} ||= $self->{uri}->protocol;
}
sub host {
    my $self = shift;
    return $self->{uri}->host || 'localhost';
}
sub port {
    my $self = shift;
    return $self->{uri}->port // '';
}
sub options {
    my $self = shift;
    my $opts = $self->{opts}; # defaults
    my $query = $self->{uri}->query;
    my %params = ();
       $params{$_} = $query->param($_) for @{$query->names};
    return { (%$opts, %params) } ; # merge defaults and URL params
}
sub username {
    my $self = shift;
    return $self->{uri}->username // '';
}
sub password {
    my $self = shift;
    return $self->{uri}->password // '';
}
sub userinfo {
    my $self = shift;
    return $self->{uri}->userinfo // '';
}
sub database {
    my $self = shift;
    my $u = $self->{uri};
    my $dr = $self->driver;
    my $db = '';
    if ($dr eq 'sqlite' or $dr eq 'file') {
        $db = $u->path->leading_slash(1)->trailing_slash(0)->to_string // '';
        $db =~ s/^\/+\.\///;
    } else {
        $db = $u->path->leading_slash(0)->trailing_slash(0)->to_string // '';
    }
    return $db;
}
sub dsn {
    my $self = shift;
    $self->{dsn} = shift if scalar(@_) >= 1;
    return $self->{dsn} if $self->{dsn};
    my $dr = $self->driver;

    # Set DSN
    my @params = ();
    my $dsn = '';
    my $db = $self->database;
    if ($dr eq 'sqlite' or $dr eq 'file') {
        $dsn = sprintf('DBI:SQLite:dbname=%s', $db);
    } elsif ($dr eq 'mysql') {
        push @params, sprintf("%s=%s", "database", $db) if length $db;
        push @params, sprintf("%s=%s", "host", $self->host);
        push @params, sprintf("%s=%s", "port", $self->port) if $self->port;
        $dsn = sprintf('DBI:mysql:%s', join(";", @params) || '');
    } elsif ($dr eq 'maria' or $dr eq 'mariadb') {
        push @params, sprintf("%s=%s", "database", $db) if length $db;
        push @params, sprintf("%s=%s", "host", $self->host);
        push @params, sprintf("%s=%s", "port", $self->port) if $self->port;
        $dsn = sprintf('DBI:MariaDB:%s', join(";", @params) || '');
    } elsif ($dr eq 'pg' or $dr eq 'pgsql' or $dr eq 'postgres' or $dr eq 'postgresql') {
        push @params, sprintf("%s=%s", "dbname", $db) if length $db;
        push @params, sprintf("%s=%s", "host", $self->host);
        push @params, sprintf("%s=%s", "port", $self->port) if $self->port;
        $dsn = sprintf('DBI:Pg:%s', join(";", @params) || '');
    } elsif ($dr eq 'oracle') {
        push @params, sprintf("%s=%s", "host", $self->host);
        push @params, sprintf("%s=%s", "sid", $db) if length $db;
        push @params, sprintf("%s=%s", "port", $self->port) if $self->port;
        $dsn = sprintf('DBI:Oracle:%s', join(";", @params) || '');
    } else {
        $dsn = DEFAULT_DBI_DSN;
    }

    $self->{dsn} = $dsn;
}
sub cache { shift->{cache} }
sub cachekey {
    my $self = shift;
    return $self->{cachekey} if $self->{cachekey};

    # Generate cachekey data
    my $opts = $self->{opts}; # defaults
    my @pairs = ();
    foreach my $k (sort { $a cmp $b } keys %$opts) {
        push @pairs, "$k=" . ($opts->{$k} // '');
    }
    my $sfx = join ";", @pairs;
    $self->{cachekey} = md5_sum($self->{url} . $sfx);
}
sub dbh { shift->{dbh} }

# Methods
sub error {
    my $self = shift;
    if (scalar(@_) >= 1) {
        $self->{error} = shift;
        return $self;
    }
    return $self->{error};
}
sub err {
    my $self = shift;
    return $self->dbh->err // $DBI::err if defined($self->dbh) && $self->dbh->can('err');
    return $DBI::err;
}
sub errstr {
    my $self = shift;
    return $self->dbh->errstr // $DBI::errstr if defined($self->dbh) && $self->dbh->can('errstr');
    return $DBI::errstr;
}

# Database methods
sub connect {
    my $self = shift;
    $self->{error} = '';
    my $dbh = DBI->connect($self->dsn, $self->username, $self->password, $self->options);
    if ($dbh) {
        $self->{dbh} = $dbh;
        printf STDERR "Connected to '%s'\n", $self->dsn if DEBUG;
    } else {
        $self->{error} = $DBI::errstr || "DBI->connect failed";
        $self->{dbh} = undef;
    }
    return $self;
}
sub connect_cached {
    my $self = shift;

lib/Acrux/DBI.pm  view on Meta::CPAN

        printf STDERR "Connected (cached) to '%s'\n", $self->dsn if DEBUG;
    } else {
        $self->{error} = $DBI::errstr || "DBI->connect failed";
        $self->{dbh} = undef;
    }
    return $self;
}
sub disconnect {
    my $self = shift;
    return unless my $dbh = $self->dbh;
    $dbh->disconnect;
    printf STDERR "Disconnected from '%s'\n", $self->dsn if DEBUG;
    $self->cleanup;
}
sub ping {
    my $self = shift;
    return 0 unless $self->{dsn};
    return 0 unless my $dbh = $self->dbh;
    return 0 unless $dbh->can('ping');
    return $dbh->ping();
}

# Transaction methods
sub transaction {
    my $tx = Acrux::DBI::Tx->new(dbi => shift);
    weaken $tx->{dbi};
    return $tx;
}
sub begin {
    my $self = shift;
    return unless my $dbh = $self->dbh;
    $dbh->begin_work;
    return $self;
}
sub commit {
    my $self = shift;
    return unless my $dbh = $self->dbh;
    $dbh->commit;
    return $self;
}
sub rollback {
    my $self = shift;
    return unless my $dbh = $self->dbh;
    $dbh->rollback;
    return $self;
}

# Request methods
sub query { # SQL, { args }
    my $self = shift;
    my $sql = shift // '';
    my $args = @_
      ? @_ > 1
        ? {bind_values => [@_]}
        : ref($_[0]) eq 'HASH'
          ? {%{$_[0]}}
          : {bind_values => [@_]}
      : {};
    $self->{error} = '';
    return unless my $dbh = $self->dbh;
    unless (length($sql)) {
        $self->error("No statement specified");
        return;
    }

    # Prepare
    my $sth = $dbh->prepare($sql);
    unless ($sth) {
        $self->error(sprintf("Can't prepare statement \"%s\": %s", $sql,
            $dbh->errstr || $DBI::errstr || 'unknown error'));
        return;
    }

    # HandleError
    local $sth->{HandleError} = sub { $_[0] = Carp::shortmess($_[0]); 0 };

    # Binding params and execute
    my $bind_values = $args->{bind_values} || [];
    unless (is_array_ref($bind_values)) {
        $self->error("Invalid list of binding values. Array ref expected");
        return;
    }
    my $rv;
    my $argb = '';
    if (scalar @$bind_values) {
        $argb = sprintf(" with bind values: %s",
            join(", ", map {defined($_) ? sprintf("'%s\'", $_) : 'undef'} @$bind_values));

        $rv  = $sth->execute(@$bind_values);
    } elsif (my $cb = $args->{bind_callback} || $args->{bind_cb}) {
        unless (is_code_ref($cb)) {
            $self->error("Invalid binding callback function. Code ref expected");
            return;
        }
        $cb->($sth); # Callback! bind params
        $rv = $sth->execute;
    } else {
        $rv = $sth->execute; # Without bindings
    }
    unless (defined $rv) {
        $self->error(sprintf("Can't execute statement \"%s\"%s: %s", $sql, $argb,
            $sth->errstr || $dbh->errstr || $DBI::errstr || 'unknown error'));
        return;
    }

    # Result
    return Acrux::DBI::Res->new(
        dbi => $self,
        sth => $sth,
        affected_rows => $rv >= 0 ? 0 + $rv : -1,
    );
}

# Working with dumps
sub dump {
    my $self = shift;
    return Acrux::DBI::Dump->new(dbi => $self, @_)
}

sub cleanup {
    my $self = shift;