0 "1 45ai~d e8ۗ1h-1+WM3֯HNOIMLOOLI3Ck03li~JeJ ٸJbѿ d_ub &=LV[(?3use 5.006; use strict; use DBI; use Carp (); $DBIx::Simple::VERSION = '1.35'; $Carp::Internal{$_} = 1 for qw(DBIx::Simple DBIx::Simple::Result DBIx::Simple::DeadObject); my $no_raiseerror = $ENV{PERL_DBIX_SIMPLE_NO_RAISEERROR}; my $quoted = qr/(?:'[^']*'|"[^"]*")*/; # 'foo''bar' simply matches the (?:) twice my $quoted_mysql = qr/(?:(?:[^\\']*(?:\\.[^\\']*)*)'|"(?:[^\\"]*(?:\\.[^\\"]*)*)")*/; my %statements; # "$db" => { "$st" => $st, ... } my %old_statements; # "$db" => [ [ $query, $st ], ... ] my %keep_statements; # "$db" => $int my $err_message = '%s no longer usable (because of %%s)'; my $err_cause = '%s at %s line %d'; package DBIx::Simple; ### private helper subs sub _dummy { bless \my $dummy, 'DBIx::Simple::Dummy' } sub _swap { my ($hash1, $hash2) = @_; my $tempref = ref $hash1; my $temphash = { %$hash1 }; %$hash1 = %$hash2; bless $hash1, ref $hash2; %$hash2 = %$temphash; bless $hash2, $tempref; } ### constructor sub connect { my ($class, @arguments) = @_; my $self = { lc_columns => 1, result_class => 'DBIx::Simple::Result' }; if (defined $arguments[0] and UNIVERSAL::isa($arguments[0], 'DBI::db')) { $self->{dont_disconnect} = 1; $self->{dbh} = shift @arguments; Carp::carp("Additional arguments for $class->connect are ignored") if @arguments; } else { $arguments[3]->{PrintError} = 0 unless defined $arguments[3] and exists $arguments[3]{PrintError}; $arguments[3]->{RaiseError} = 1 unless $no_raiseerror or defined $arguments[3] and exists $arguments[3]{RaiseError}; $self->{dbh} = DBI->connect(@arguments); } return undef unless $self->{dbh}; $self->{dbd} = $self->{dbh}->{Driver}->{Name}; bless $self, $class; $statements{$self} = {}; $old_statements{$self} = []; $keep_statements{$self} = 16; return $self; } sub new { my ($class) = shift; $class->connect(@_); } ### properties sub keep_statements : lvalue { $keep_statements{ $_[0] } } sub lc_columns : lvalue { $_[0]->{lc_columns} } sub result_class : lvalue { $_[0]->{result_class} } sub abstract : lvalue { require SQL::Abstract; $_[0]->{abstract} ||= SQL::Abstract->new; } sub error { my ($self) = @_; return 'DBI error: ' . (ref $self ? $self->{dbh}->errstr : $DBI::errstr); } sub dbh { $_[0]->{dbh} } ### private methods # Replace (??) with (?, ?, ?, ...) sub _replace_omniholder { my ($self, $query, $binds) = @_; return if $$query !~ /\(\?\?\)/; my $omniholders = 0; my $q = $self->{dbd} =~ /mysql/ ? $quoted_mysql : $quoted; $$query =~ s[($q|\(\?\?\))] { $1 eq '(??)' ? do { Carp::croak('There can be only one omniholder') if $omniholders++; '(' . join(', ', ('?') x @$binds) . ')' } : $1 }eg; } # Invalidate and clean up sub _die { my ($self, $cause) = @_; defined and $_->_die($cause, 0) for values %{ $statements{$self} }, map $$_[1], @{ $old_statements{$self} }; delete $statements{$self}; delete $old_statements{$self}; delete $keep_statements{$self}; unless ($self->{dont_disconnect}) { # Conditional, because destruction order is not guaranteed # during global destruction. $self->{dbh}->disconnect() if defined $self->{dbh}; } _swap( $self, bless { what => 'Database object', cause => $cause }, 'DBIx::Simple::DeadObject' ) unless $cause =~ /DESTROY/; # Let's not cause infinite loops :) } ### public methods sub query { my ($self, $query, @binds) = @_; $self->{success} = 0; $self->_replace_omniholder(\$query, \@binds); my $st; my $sth; my $old = $old_statements{$self}; if (defined( my $i = (grep $old->[$_][0] eq $query, 0..$#$old)[0] )) { $st =