/usr/share/perl5/DBM/Deep/Storage/DBI.pm is in libdbm-deep-perl 2.0011-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 | package DBM::Deep::Storage::DBI;
use 5.008_004;
use strict;
use warnings FATAL => 'all';
use base 'DBM::Deep::Storage';
use DBI;
sub new {
my $class = shift;
my ($args) = @_;
my $self = bless {
autobless => 1,
dbh => undef,
dbi => undef,
}, $class;
# Grab the parameters we want to use
foreach my $param ( keys %$self ) {
next unless exists $args->{$param};
$self->{$param} = $args->{$param};
}
if ( $self->{dbh} ) {
$self->{driver} = lc $self->{dbh}->{Driver}->{Name};
}
else {
$self->open;
}
# Foreign keys are turned off by default in SQLite3 (for now)
#q.v. http://search.cpan.org/~adamk/DBD-SQLite-1.27/lib/DBD/SQLite.pm#Foreign_Keys
# for more info.
if ( $self->driver eq 'sqlite' ) {
$self->{dbh}->do( 'PRAGMA foreign_keys = ON' );
}
return $self;
}
sub open {
my $self = shift;
return if $self->{dbh};
$self->{dbh} = DBI->connect(
$self->{dbi}{dsn}, $self->{dbi}{username}, $self->{dbi}{password}, {
AutoCommit => 1,
PrintError => 0,
RaiseError => 1,
%{ $self->{dbi}{connect_args} || {} },
},
) or die $DBI::error;
# Should we use the same method as done in new() if passed a $dbh?
(undef, $self->{driver}) = map defined($_) ? lc($_) : undef, DBI->parse_dsn( $self->{dbi}{dsn} );
return 1;
}
sub close {
my $self = shift;
$self->{dbh}->disconnect if $self->{dbh};
return 1;
}
sub DESTROY {
my $self = shift;
$self->close if ref $self;
}
# Is there a portable way of determining writability to a DBH?
sub is_writable {
my $self = shift;
return 1;
}
sub lock_exclusive {
my $self = shift;
}
sub lock_shared {
my $self = shift;
}
sub unlock {
my $self = shift;
# $self->{dbh}->commit;
}
#sub begin_work {
# my $self = shift;
# $self->{dbh}->begin_work;
#}
#
#sub commit {
# my $self = shift;
# $self->{dbh}->commit;
#}
#
#sub rollback {
# my $self = shift;
# $self->{dbh}->rollback;
#}
sub read_from {
my $self = shift;
my ($table, $cond, @cols) = @_;
$cond = { id => $cond } unless ref $cond;
my @keys = keys %$cond;
my $where = join ' AND ', map { "`$_` = ?" } @keys;
return $self->{dbh}->selectall_arrayref(
"SELECT `@{[join '`,`', @cols ]}` FROM $table WHERE $where",
{ Slice => {} }, @{$cond}{@keys},
);
}
sub flush {}
sub write_to {
my $self = shift;
my ($table, $id, %args) = @_;
my @keys = keys %args;
my $sql =
"REPLACE INTO $table ( `id`, "
. join( ',', map { "`$_`" } @keys )
. ") VALUES ("
. join( ',', ('?') x (@keys + 1) )
. ")";
$self->{dbh}->do( $sql, undef, $id, @args{@keys} );
return $self->{dbh}->last_insert_id("", "", "", "");
}
sub delete_from {
my $self = shift;
my ($table, $cond) = @_;
$cond = { id => $cond } unless ref $cond;
my @keys = keys %$cond;
my $where = join ' AND ', map { "`$_` = ?" } @keys;
$self->{dbh}->do(
"DELETE FROM $table WHERE $where", undef, @{$cond}{@keys},
);
}
sub driver { $_[0]{driver} }
sub rand_function {
my $self = shift;
my $driver = $self->driver;
$driver eq 'sqlite' and return 'random()';
$driver eq 'mysql' and return 'RAND()';
die "rand_function undefined for $driver\n";
}
1;
__END__
|