Acrux-DBI

 view release on metacpan or  search on metacpan

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

    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 {

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

    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;

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

    my $self = shift;
    my $s = shift;
    return $self unless defined $s;
    my $pool = $self->{pool} = {};
    my $tag = TAG_DEFAULT;
    my $delimiter = DELIMITER;
    my $is_new = 1;
    my $buf = '';

    # String processing
    while (length($s)) {
        my $chunk;

        # get fragments (chunks) from string
        if ($s =~ /^$delimiter/x) { # any delimiter char(s)
            $is_new = 1;
            $chunk = $delimiter;
        } elsif ($s =~ /^delimiter\s+(\S+)\s*(?:\n|\z)/ip) { # set new delimiter
            $is_new = 1;
            $chunk = ${^MATCH};
            $delimiter = $1;

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

                or $s =~ /^\/\*(?:[^\*]|\*[^\/])*(?:\*\/|\*\z|\z)/p # C-style comment
                or $s =~ /^'(?:[^'\\]*|\\(?:.|\n)|'')*(?:'|\z)/p    # single-quoted literal text
                or $s =~ /^"(?:[^"\\]*|\\(?:.|\n)|"")*(?:"|\z)/p    # double-quoted literal text
                or $s =~ /^`(?:[^`]*|``)*(?:`|\z)/p ) {             # schema-quoted literal text
            $chunk = ${^MATCH};
        } else {
            $chunk = substr($s, 0, 1);
        }
        #say STDERR ">$chunk<";

        # cut string by chunk length
        substr($s, 0, length($chunk), '');

        # marker
        if ($chunk =~ /^--\s+[#]+\s*(\w+)/i) {
            my $_tag = $1 // TAG_DEFAULT;
            push @{$pool->{$tag} //= []}, $buf if length($tag) and $buf !~ /^\s*$/s;
            $tag = $_tag;
            $is_new = 0;
            $buf = '';
            $delimiter = DELIMITER; # flush delimiter to default
        }

        # make new block
        if ($is_new) {
            push @{$pool->{$tag} //= []}, $buf if length($tag) and $buf !~ /^\s*$/s;
            $is_new = 0;
            $buf = '';
        } else { # Or add cur chunk to section
            $buf .= $chunk;
        }
    }

    # add buf line to block
    push @{$pool->{$tag} //= []}, $buf if length($tag) and $buf !~ /^\s*$/s;

    return $self;
}
sub from_data {
    my $self = shift;
    my $class = shift;
    my $name = shift;
    return $self->from_string(data_section($class //= caller, $name // $self->name));
}
sub from_file {