File Coverage

blib/lib/Dimedis/Sql.pm

Criterion	Covered	Total	%
statement	18	284	6.3
branch	0	184	0.0
condition	0	67	0.0
subroutine	6	35	17.1
pod	0	28	0.0
total	24	598	4.0

package Dimedis::Sql;

use strict;
use vars qw($VERSION);
use Carp;
use FileHandle;
use Encode;

$VERSION = '0.44';

my $exc = "Dimedis::Sql:";	# Exception-Type prefix

my %known_data_types = (	# bekannte Datentypen
	'serial'  => 1,
	'date'    => 1,
	'clob'    => 1,
	'blob'    => 1,
	'varchar' => 1,
	'char'    => 1,
	'integer' => 1,
	'numeric' => 1,
);

my %known_operators = (		# bekannte Operatoren
	'='	 => 1,
	'!='	 => 1,
	'like'	 => 1
);

sub get_dbh			{ shift->{dbh}				}
sub get_debug			{ shift->{debug}			}
sub get_type			{ shift->{type}				}
sub get_cache			{ shift->{cache}			}
sub get_serial_write		{ shift->{serial_write}			}
sub get_utf8			{ shift->{utf8}				}

sub set_debug			{ shift->{debug}		= $_[1]	}
sub set_type			{ shift->{type}			= $_[1]	}
sub set_cache			{ shift->{cache}		= $_[1]	}
sub set_serial_write		{ shift->{serial_write}		= $_[1]	}
sub set_utf8			{ shift->{utf8}			= $_[1]	}

# Kann, muss aber nicht von Drivern implementiert werden
sub db_init 			{ 1 }

# Konstruktor --------------------------------------------------------

sub new {
	my $class = shift;
	my %par = @_;
	my  ($dbh, $debug, $type, $cache, $serial_write, $utf8) =
	@par{'dbh','debug','type','cache','serial_write','utf8'};

	$type ||= {};

	# Abwärtskompatibilität: wenn cache nicht angegeben ist,
	# wird das Caching eingeschaltet.

	if ( not exists $par{cache} ) {
		$cache = 1;
	}

	# Parametercheck

	croak "$exc:new\tmissing dbh" if not $dbh;

	# Datenbanktyp ermitteln

	my $db_type = $dbh->{Driver}->{Name};

	# Sonderbehandlung fuer das Proxymodul
	if ( $db_type eq "Proxy") {
	  # Aus dem DSN die eigentlichen Datenbanktyp ermitteln
	  $dbh->{Name} =~ m/;dsn=dbi:([^:]+):/;
	  $db_type     = $1;
	}

	# Instanzhash zusammenbauen

	my $self = {
		dbh          => $dbh,
		debug        => $debug,
		db_type      => $db_type,
		db_features  => undef,
		type_href    => $type,
		cache        => $cache,
		serial_write => $serial_write,
		utf8         => $utf8,
	};

	$debug && print STDERR "$exc:new\tdb_type=$db_type\n";

	# datenbankspezifische Methoden definieren
	require "Dimedis/SqlDriver/$db_type.pm";

	# diese Klasse in die Vererbungshierarchie einfügen
	my $driver_isa = "Dimedis::SqlDriver::$db_type:\:ISA";
	{ no strict; @{$driver_isa} = ( $class ); }

	# diese Instanz auf die SqlDriver Klasse setzen
	bless $self, "Dimedis::SqlDriver::$db_type";

	# Initialisierungsmethode aufrufen
	$self->db_init;

	# features Hash initialisieren
	$self->{db_features} = $self->db_get_features;

	# ggf. Encode Modul laden
	require Encode if $utf8;

	return $self;
}

# Datentyp-Check -----------------------------------------------------

sub check_data_types {
	my $self = shift;

	my ($type_href, $data_href, $action) = @_;

	my $serial_found;
	my $blob_found;

	my ($col, $type);
	while ( ($col,$type) = each %{$type_href} ) {

		# Nur der Datentyp ohne Groessenangabe
		$type =~ s/\([^\(]+\)$//;

		croak "$exc:check_data_types\ttype $type unknown"
			unless defined $known_data_types{$type};

		if ( $type eq 'serial' ) {
			# Serials dürfen nur 1x vorkommen
			if ( exists $data_href->{$col} ) {
				croak "$exc:check_data_types\tmultiple serial type"
					if $serial_found;
				$serial_found = $col;
			}
			# wurde was anderes als undef übergeben,
			# dann Exception
			croak "$exc:check_data_types\t".
			    "only the undef value allowed for serial columns"
			    	if defined $data_href->{$col} and
				   not $self->{serial_write};

		} elsif ( $type eq 'date') {
			# GROBER Datumsformatcheck
			croak "$exc:check_data_types\t".
			    "illegal date: $col=$data_href->{$col}"
				if $data_href->{$col} and
				   $data_href->{$col} !~
				   /^\d\d\d\d\d\d\d\d\d\d:\d\d:\d\d$/;
		} elsif ( $type eq 'blob' or $type eq 'clob' ) {
			$blob_found = 1 if exists $data_href->{$col};
		}
	}

	croak "$exc:check_data_types\tblob/clob handling only with serial column"
		if $action eq 'insert' and $blob_found and
		   (not $serial_found or
		    not exists $data_href->{$serial_found});

	return $serial_found;
}

# INSERT -------------------------------------------------------------

sub insert {
	my $self = shift;
	my %par = @_;

	$par{type} ||= $self->{type_href}->{$par{table}}; # wenn undef, globales Type Hash holen

	# Parametercheck

	croak "$exc:insert\tmissing table" unless defined $par{table};
	croak "$exc:insert\tmissing data"  unless defined $par{data};

	$self->check_data_types (
		$par{type}, $par{data}, 'insert'
	);

	# Hier kein UTF8 Upgrading, wird beim späteren
	# $self->do ( sql => ... ) gemacht. Die Werte
	# in Data sind noch nicht unbedingt die finalen
	# Werte (z.B. bei Blobs können hier Filenamen
	# drin stehen, die an dieser Stelle also noch
	# nicht zu UTF8 gewandelt werden dürfen).

	# Driver-Methode aufrufen
	my $serial;
	eval {
		$serial = $self->db_insert (\%par);
	};
	croak "$exc:insert\t$@" if $@;

	return $serial;
}

# UPDATE -------------------------------------------------------------

sub update {
	my $self = shift;
	my %par = @_;

	$par{type}   ||= $self->{type_href}->{$par{table}}; # wenn undef, globales Type Hash holen
	$par{params} ||= [];	# wenn undef, leeres Listref draus machen

	# Parametercheck

	croak "$exc:insert\tmissing table" unless defined $par{table};
	croak "$exc:insert\tmissing data"  unless defined $par{data};
	croak "$exc:insert\tmissing where" unless defined $par{where};

	my $serial_found = $self->check_data_types (
		$par{type}, $par{data}, 'update'
	);

	croak "$exc:insert\tserial in update not allowed" if $serial_found;

	# ggf. UTF8 Konvertierung vornehmen
	if ( $self->{utf8} ) {
		foreach my $p ( $par{where}, @{$par{params}} ) {
			utf8::upgrade($p);
		}
	}

	# Kein UTF8 Upgrading auf %{$data}, wird beim späteren
	# $self->do ( sql => ... ) gemacht. Die Werte
	# in %{$data} sind noch nicht unbedingt die finalen
	# Werte (z.B. bei Blobs können hier Filenamen
	# drin stehen, die an dieser Stelle also noch
	# nicht zu UTF8 gewandelt werden dürfen).

	# Driver-Methode aufrufen

	my $modified;
	eval {
		$modified = $self->db_update (\%par);
	};
	croak "$exc:update\t$@" if $@;

	return $modified;
}

# BLOB_READ ----------------------------------------------------------

sub blob_read {
	my $self = shift;
	my %par = @_;

	$par{params} ||= [];	# wenn undef, leeres Listref draus machen

	# Parametercheck

	croak "$exc:blob_read\tmissing table" unless defined $par{table};
	croak "$exc:blob_read\tmissing where" unless defined $par{where};
	croak "$exc:blob_read\tmissing col"   unless defined $par{col};
	croak "$exc:blob_read\tgot filehandle and filename parameter"
		if defined $par{filehandle} and defined $par{filename};

	# ggf. UTF8 Konvertierung vornehmen
	if ( $self->{utf8} ) {
		foreach my $p ( $par{where}, @{$par{params}} ) {
			utf8::upgrade($p);
		}
	}

	# Driver-Methode aufrufen
	my $blob;
	eval {
		$blob = $self->db_blob_read (\%par);
	};

	croak "$exc:blob_read\t$@" if $@;

	# ggf. UTF8 Flag setzen, wenn clob
	if ( $blob and $self->{utf8} and
	     $self->{type_href}->{$par{table}}->{$par{col}} eq 'clob' ) {
	        $self->{debug} && print STDERR "$exc:db_blob_read: Encode::_utf8_on($par{col})\n";
		Encode::_utf8_on($$blob);
	}

	return $blob;
}

# DO -----------------------------------------------------------------

sub do {
        my $self = shift;
	my %par = @_;
	my  ($sql, $par_cache, $no_utf8, $params, $no_nulling) =
	@par{'sql','par_cache','no_utf8','params','no_nulling'};

	$params ||= [];

	# ggf. UTF8 Konvertierung vornehmen
	if ( $self->{utf8} and not $no_utf8 ) {
		foreach my $p ( $par{sql}, @{$params} ) {
			utf8::upgrade($p);
		}
	}
	elsif ( not $self->{utf8} and not $no_utf8 ) {
		foreach my $p ( $par{sql}, @{$params} ) {
			$p = Encode::encode("windows-1252", $p)
				if Encode::is_utf8($p);
		}
	}

	# Normalerweise werden SQL Statements hier von DBI gecached.
	# Es gibt aber Befehle, bei denen das keinen Sinn macht.
	# Deshalb gibt es drei Mechanismen, die das Caching steuern:

	# 1. wenn keine SQL Parameter übergeben wurden, gehen wir davon
	#    aus, daß das Statement die Parameter enthält. In diesem
	#    Fall wollen wir das Statement nicht cachen.
	my $use_prepare_cached = @{$params};

	# 2. über den Parameter cache kann das Caching explizit
	#    gesteuert werden
	if ( exists $par{cache} ) {
		$use_prepare_cached = $par_cache;
	}

	# 3. wenn das Caching beim Erzeugen des Dimedis::Sql Instanz
	#    abgeschaltet wurde, gibt's kein Caching!

	$use_prepare_cached = 0 if not $self->{cache};

        $self->{debug} && print STDERR "$exc:do: sql = $sql\n";
        $self->{debug} && print STDERR "$exc:do: params = ".
		join(",", @{$params}), "\n";

	my $sth;
	if ( $use_prepare_cached ) {
		$self->{debug} && print STDERR "$exc:do: statement is cached\n";
		$sth = $self->{dbh}->prepare_cached ($sql);
	} else {
		$self->{debug} && print STDERR "$exc:do: statement is NOT cached\n";
		$sth = $self->{dbh}->prepare ($sql);
	}
	croak "$exc:do\t$DBI::errstr\n$sql" if $DBI::errstr;

	if ( not $no_nulling ) {
		for ( @{$params} ) {
			$_ = undef if $_ eq ''
		};
	}

	my $modified = $sth->execute (@{$params});
	croak "$exc:do\t$DBI::errstr\n$sql" if $DBI::errstr;

	$sth->finish;

	return $modified;
}

sub do_without_cache {
        my $self = shift;
	my %par  = @_;

        my $sql    = $par{sql};
	my $params = $par{params} ||= [];

	# ggf. UTF8 Konvertierung vornehmen
	if ( $self->{utf8} ) {
		foreach my $p ( $par{sql}, @{$params} ) {
			utf8::upgrade($p);
		}
	}
	elsif ( not $self->{utf8} ) {
		foreach my $p ( $par{sql}, @{$params} ) {
			$p = Encode::encode("windows-1252", $p)
				if Encode::is_utf8($p);
		}
	}

        $self->{debug} && print STDERR "$exc:do: sql = $sql\n";
        $self->{debug} && print STDERR "$exc:do: params = ".
		join(",", @{$params}), "\n";

        my $modified = $self->{dbh}->do ($sql, undef, @{$params});

	croak "$exc:do\t$DBI::errstr\n$sql" if $DBI::errstr;

	return $modified;
}

# GET ----------------------------------------------------------------

sub get {
        my $self = shift;

 	my %par = @_;

        my $sql       = $par{sql};
	my $par_cache = $par{cache};
	my $params    = $par{params};

	# ggf. UTF8 Konvertierung vornehmen
	if ( $self->{utf8} ) {
		foreach my $p ( $par{sql}, @{$params} ) {
			utf8::upgrade($p);
		}
	}

        my $dbh = $self->{dbh};

	# Normalerweise werden SQL Statements hier von DBI gecached.
	# Es gibt aber Befehle, bei denen das keinen Sinn macht.
	# Deshalb gibt es drei Mechanismen, die das Caching steuern:

	# 1. wenn keine SQL Parameter übergeben wurden, gehen wir davon
	#    aus, daß das Statement die Parameter enthält. In diesem
	#    Fall wollen wir das Statement nicht cachen.
	my $use_prepare_cached = defined $params;

	# 2. über den Parameter cache kann das Caching explizit
	#    gesteuert werden
	if ( exists $par{cache} ) {
		$use_prepare_cached = $par_cache;
	}

	# 3. wenn das Caching beim Erzeugen des Dimedis::Sql Instanz
	#    abgeschaltet wurde, gibt's kein Caching!

	$use_prepare_cached = 0 if not $self->{cache};

        $self->{debug} && print STDERR "$exc:get sql = $sql\n";

        my $sth;

	if ( $use_prepare_cached ) {
		$self->{debug} && print STDERR "$exc:get: statement is cached\n";
		$sth = $dbh->prepare_cached ($sql)
			or croak "$exc:get\t$DBI::errstr\n$sql";
	} else {
		$self->{debug} && print STDERR "$exc:get: statement is NOT cached\n";
		$sth = $dbh->prepare ($sql)
			or croak "$exc:get\t$DBI::errstr\n$sql";
	}

        $sth->execute (@{$params})
		or croak "$exc:get\t$DBI::errstr\n$sql";

        if ( wantarray ) {
		my $lref = $sth->fetchrow_arrayref;
		# ggf. UTF8 Flag setzen
		if ( $self->{utf8} and defined $lref ) {
			foreach my $p ( @{$lref} ) {
				Encode::_utf8_on($p);
			}
		}
                $sth->finish or croak "$exc:get\t$DBI::errstr\n$sql";
                return defined $lref ? @{$lref} : undef;
        } else {
                my $href = $sth->fetchrow_hashref;
                $sth->finish or croak "$exc:get\t$DBI::errstr\n$sql";
		return if not keys %{$href};
		my %lc_hash;
		map { Encode::_utf8_on($href->{$_}) if $self->{utf8};
		      $lc_hash{lc($_)} = $href->{$_} } keys %{$href};
                return \%lc_hash;
        }
}

# LEFT_OUTER_JOIN ----------------------------------------------------

sub left_outer_join {
        my $self = shift;

	# ggf. UTF8 Konvertierung vornehmen
	if ( $self->{utf8} ) {
		_utf8_upgrade_lref (\@_);
	}

	return $self->db_left_outer_join (\@_);
}

sub _utf8_upgrade_lref {
	my ($lref) = @_;

	foreach my $p ( @{$lref} ) {
		if ( ref $p ) {
			_utf8_upgrade_lref($p);
		} else {
			utf8::upgrade($p);
		}
	}

	1;
}

# CMPI ---------------------------------------------------------------

sub cmpi {
        my $self = shift;

	my %par = @_;

	# Parametercheck

	croak "$exc:cmpi\tmissing col" unless defined $par{col};
	croak "$exc:cmpi\tmissing val" unless defined $par{val};
	croak "$exc:cmpi\tmissing op"  unless defined $par{op};

	croak "$exc:cmpi\tunknown op '$par{op}'"
		unless defined $known_operators{$par{op}};

	# ggf. UTF8 Konvertierung vornehmen
	if ( $self->{utf8} ) {
		utf8::upgrade($par{col});
		utf8::upgrade($par{val});
	}

	return $self->db_cmpi (\%par);
}

# USE_DB -------------------------------------------------------------

sub use_db {
        my $self = shift;

	my %par = @_;

	# Parametercheck

	croak "$exc:cmpi\tmissing db" unless defined $par{db};

	return $self->db_use_db (\%par);
}

# DB_PREFIX ----------------------------------------------------------

sub db_prefix {
        my $self = shift;

	my %par = @_;

	# Parametercheck

	croak "$exc:cmpi\tmissing db" unless defined $par{db};

	return $self->db_db_prefix (\%par);
}

# INSTALL ------------------------------------------------------------

sub install {
	my $self = shift;

	my %par = @_;

	eval {
		$self->db_install (\%par);
	};
	croak "$exc:install\t$@" if $@;

	1;
}

# LEFT_OUTER_JOIN ----------------------------------------------------

sub contains {
        my $self = shift;

	my %par = @_;

	croak "$exc:contains\tmissing col"        unless defined $par{col};
	croak "$exc:contains\tmissing vals"       unless defined $par{vals};
	croak "$exc:contains\tmissing search_op"  unless defined $par{search_op};

	croak "$exc:contains\tunsupported search_op '$par{search_op}'"
		if $par{search_op} ne 'sub';

	croak "$exc:contains\tmissing logic_op (number of vals > 1)"
		if @{$par{vals}} > 1 and not defined $par{logic_op};

	croak "$exc:contains\tunknown logic_op ($par{logic_op})"
		if defined $par{logic_op} and $par{logic_op} !~ /^(and|or)$/;

	# ggf. UTF8 Konvertierung vornehmen
	if ( $self->{utf8} ) {
		foreach my $p ( @{$par{vals}} ) {
			utf8::upgrade($p);
		}
	}

	$self->db_contains (\%par);
}

# GET_FEATURES -------------------------------------------------------

sub get_features {
	my $self = shift;

	return $self->{db_features};
}

# HELPDER METHODS FOR DRIVERS ----------------------------------------

sub blob2memory {
	my $self = shift;
	my ($val, $col, $type, $layer) = @_;

	$layer ||= $self->{utf8} && $type eq 'clob' ? ":utf8" : ":raw";

	$self->{debug} && print STDERR "$exc:db_blob2memory col=$col type=$type layer=$layer\n";

	my $blob;
	if ( ref $val and ref $val ne 'SCALAR' ) {
		# Referenz und zwar keine Scalarreferenz
		# => das ist ein Filehandle
		# => reinlesen den Kram
		binmode $val, $layer;
		{ local $/ = undef; $blob = <$val> }

	} elsif ( not ref $val ) {
		# keine Referenz
		# => Dateiname
		# => reinlesen den Kram
		my $fh = new FileHandle;
		open ($fh, $val) or croak "can't open file '$val'";
		binmode $fh, $layer;
		{ local $/ = undef; $blob = <$fh> }
		close $fh;

	} else {
		# andernfalls ist val eine Skalarreferenz mit dem Blob
		# => nur ggf. upgraden
		utf8::upgrade($$val) if $layer eq ':utf8';
		return $val;
	}

	return \$blob;
}

1;

__END__