File Coverage

lib/DBIx/Oro.pm

Criterion	Covered	Total	%
statement	567	733	77.3
branch	316	510	61.9
condition	87	182	47.8
subroutine	37	47	78.7
pod	19	21	90.4
total	1026	1493	68.7

package DBIx::Oro;
use strict;
use warnings;

our $VERSION = '0.31_2';

# See the bottom of this file for the POD documentation.

# Todo: Fix treatments in joined tables!

# Todo: Are combined indices necessarily in the same order?
#       In that case update and select etc. need ordered
#       keys!

# Todo: Improve documentation
#       - =head1 ADVANCED CONCEPTS
#         - Joined tables
#         - Treatments
#         - Caching
#         - Injected SQL
#         - explain
#         - on_connect

# Todo: -prefix is not documented!
# Todo: Put 'created' in SQLite driver
#       implement ->errstr
#       implement "-with" (?)
# Debug: $lemma_oro->insert({
#          wcl => $_,
#          lemma => $inter
#        },{
#          token => $search_for
#        });
#        (Should raise error)
# Todo: Support left outer join (Maybe with id => 1, maybe => 1 in join hash)
# Todo: Create all Queries in DBIx::Oro::Query
# Todo: To change queries from different drivers,
#       use events.
# Todo: Return key -column_order => [] with fetchall_arrayref.
# Todo: my $value = $oro->value(Table => 'Field') # Ähnlich wie count
# Todo: Oder my ($value) = $oro->value(Table => Field => { -limit => 1 }) # und es gibt ein Array zurück
# Todo: Check for BDB-support:
#   http://charlesleifer.com/blog/sqlite-small-fast-reliable-choose-any-three-/

use v5.10.1;

use Scalar::Util qw/blessed/;
use Carp qw/carp croak/;
our @CARP_NOT;

# Database connection
use DBI;

our $AS_REGEX = qr/(?::~?`?[-_a-zA-Z0-9]+`?)/;

our $OP_REGEX = qr/^(?i:
		     (?:[\<\>\!=]?\=?)|<>|
		     (?:!|not[_ ])?
		     (?:match|like|glob|regex|between)|
		     (?:eq|ne|[gl][te]|not)
		   )$/x;

our $KEY_REGEX = qr/`?[_\.0-9a-zA-Z]+`?/;

our $KEY_REGEX_NOPREF = qr/`?[_0-9a-zA-Z]+`?/;

our $NUM_RE = qr/^\s*(\d+)\s*$/;

our $SFIELD_REGEX =
  qr/(?:$KEY_REGEX|(?:$KEY_REGEX\.)?\*|"[^"]*"|'[^']*')/;

our $FIELD_OP_REGEX = qr/[-\+\/\%\*,]/;

our $FUNCTION_REGEX =
  qr/([_a-zA-Z0-9]*
      \(\s*(?:$SFIELD_REGEX|(?-1))
           (?:\s*$FIELD_OP_REGEX\s*(?:$SFIELD_REGEX|(?-1)))*\s*\))/x;

our $VALID_FIELD_REGEX =
  qr/^(?:$SFIELD_REGEX|$FUNCTION_REGEX)$AS_REGEX?$/;

our $VALID_GROUPORDER_REGEX =
  qr/^[-\+]?(?:$KEY_REGEX|$FUNCTION_REGEX)$/;

our $FIELD_REST_RE = qr/^(.+?)(:~?)([^:"~][^:"]*?)$/;

our $CACHE_COMMENT = 'From Cache';

our $ITEMS_PER_PAGE = 25;

our @EXTENSIONS = ();

# Import extension
sub import {
  my $class = shift;

  # Load extensions
  foreach (@_) {

    # Load extensions
    my $module = qq{DBIx::Oro::Extension::$_};
    unless (eval "require $module; 1;") {
      croak qq{Unable to load extension "$_"} and return;
    };

    # Push to extension array
    push(@EXTENSIONS, $_);

    # Start import for extensions
    $module->import;
  };
};


# Constructor
sub new {
  my $class = shift;
  my ($self, %param);

  # SQLite - one parameter
  if (@_ == 1) {
    @param{qw/driver file/} = ('SQLite', shift);
  }

  # SQLite - two parameter
  elsif (@_ == 2 && ref $_[1] && ref $_[1] eq 'CODE') {
    @param{qw/driver file init/} = ('SQLite', @_);
  }

  # Hash
  else {
    %param = @_;
  };

  # Init by default
  ${$param{in_txn}} = 0;
  $param{last_sql} = '';

  my $pwd = delete $param{password};

  # Set default to SQLite
  $param{driver} //= 'SQLite';

  # Load driver
  my $package = 'DBIx::Oro::Driver::' . $param{driver};
  unless (eval 'require ' . $package . '; 1;') {
    croak 'Unable to load ' . $package;
    return;
  };

  # On_connect event
  my $on_connect = delete $param{on_connect};

  # Get driver specific handle
  $self = $package->new( %param );

  # No database created
  return unless $self;

  # Connection identifier (for _password)
  $self->{_id} = "$self";

  # Set password securely
  $self->_password($pwd) if $pwd;

  # On connect events
  $self->{on_connect} = {};
  $self->{_connect_cb} = 1;

  if ($on_connect) {
    $self->on_connect(
      ref $on_connect eq 'HASH' ?
      %$on_connect : $on_connect
    ) or return;
  };

  # Connect to database
  $self->_connect or croak 'Unable to connect to database';

  # Savepoint array
  # First element is a counter
  $self->{savepoint} = [1];

  # Initialize database and return Oro instance
  return $self if $self->_init;

  # Fail
  return;
};


# New table object
sub table {
  my $self = shift;

  # Joined table
  my %param = (
    table => do {
      if (ref($_[0])) {
	[ _join_tables( shift(@_) ) ];
      }

      # Table name
      else {
	shift;
      };
    }
  );

  # Clone parameters
  foreach (qw/dbh created in_txn savepoint pid tid
	      dsn _connect_cb on_connect/) {
    $param{$_} = $self->{$_};
  };

  # Connection identifier (for _password)
  $param{_id} = "$self";

  # Bless object with hash
  bless \%param, ref $self;
};


# Database handle
# Based on DBIx::Connector
sub dbh {
  my $self = shift;

  # Store new database handle
  return ($self->{dbh} = shift) if $_[0];

  return $self->{dbh} if ${$self->{in_txn}};

  state $c = 'Unable to connect to database';

  # Check for thread id
  if (defined $self->{tid} && $self->{tid} != threads->tid) {
    return $self->_connect or croak $c;
  }

  # Check for process id
  elsif ($self->{pid} != $$) {
    return $self->_connect or croak $c;
  }

  elsif ($self->{dbh}->{Active}) {
    return $self->{dbh};
  };

  # Return handle if active
  return $self->_connect or croak $c;
};


# Last executed SQL
sub last_sql {
  my $self = shift;
  my $last_sql = $self->{last_sql};

  # Check for recurrent placeholders
  if ($last_sql =~ m/(?:UNION|\?(?:, \?){3,}|(?:\(\?(?:, \?)*\), ){3,})/) {

    our $c;

    # Count Union selects
    state $UNION_RE =
      qr/(?{$c=1})(SELECT \?(?:, \?)*)(?: UNION \1(?{$c++})){3,}/;

    # Count Union selects
    state $BRACKET_RE =
      qr/(?{$c=1})(\(\?(?:, \?)*\))(?:, \1(?{$c++})){3,}/;

    # Count recurring placeholders
    state $PLACEHOLDER_RE =
      qr/(?{$c=1})\?(?:, \?(?{$c++})){3,}/;

    # Rewrite placeholders with count
    for ($last_sql) {
      s/$UNION_RE/WITH $c x UNION $1/og;
      s/$BRACKET_RE/$c x $1/og;
      s/$PLACEHOLDER_RE/$c x ?/og;
    };
  };

  return $last_sql || '' unless wantarray;

  # Return as array
  return ('', 0) unless $last_sql;

  # Check if database request
  state $offset = -1 * length $CACHE_COMMENT;

  return (
    $last_sql,
    substr($last_sql, $offset) eq $CACHE_COMMENT
  );
};


# Database driver
sub driver { '' };


# Extensions
sub extension {
  return @EXTENSIONS;
};


# Insert values to database
# This is the MySQL way
sub insert {
  my $self  = shift;

  # Get table name
  my $table = _table_name($self, \@_) or return;

  # No parameters
  return unless $_[0];

  # Properties
  my $prop = shift if ref $_[0] eq 'HASH' && ref $_[1];

  # Single insert
  if (ref $_[0] eq 'HASH') {

    # Param
    my %param = %{ shift(@_) };

    # Create insert arrays
    my (@keys, @values);

    while (my ($key, $value) = each %param) {
      # Insert pairs
      next if !ref $key && $key !~ $DBIx::Oro::KEY_REGEX;
      push @keys,   $key;
      push @values, _stringify($value);
   };

    # Nothing to insert
    return unless @keys;

    # Create insert string
    my $sql = 'INSERT ';

    if ($prop && (my $oc = $prop->{-on_conflict})) {
      if ($oc eq 'replace') {
	$sql = 'REPLACE '
      }
      elsif ($oc eq 'ignore')  {
	$sql .= 'IGNORE '
      };
    };

    $sql .= 'INTO ' . $table .
      ' (' . join(', ', map { "`$_`" } @keys) . ') VALUES (' . _q(\@values) . ')';

    # Prepare and execute
    return scalar $self->prep_and_exec( $sql, \@values );
  }

  # Multiple inserts
  elsif (ref($_[0]) eq 'ARRAY') {

    return unless $_[1];

    my @keys = @{ shift(@_) };

    # Default values
    my @default = ();

    # Check if keys are defaults
    my $i = 0;
    my @default_keys;
    while ($keys[$i]) {

      # No default - next
      $i++, next unless ref $keys[$i];

      # Has default value
      my ($key, $value) = @{ splice( @keys, $i, 1) };
      push(@default_keys, $key);
      push(@default, _stringify($value));
    };

    # Unshift default keys to front
    unshift(@keys, @default_keys);

    my $sql .= 'INSERT INTO ' . $table .
      ' (' . join(', ',  map { "`$_`" } @keys) . ') ' .
	'VALUES ';

    # Add data in brackets
    $sql .= join(', ', ('(' ._q(\@keys) . ')') x scalar @_ );

    # Prepare and execute with prepended defaults
    return $self->prep_and_exec(
      $sql,
      [ map { (@default, @$_); } @_ ]
    );
  };

  # Unknown query
  return;
};


# Update existing values in the database
sub update {
  my $self  = shift;

  # Get table name
  my $table = _table_name($self, \@_) or return;

  # No parameters
  return unless $_[0];

  # Get pairs
  my ($pairs, $values) = _get_pairs( shift(@_) );

  # Nothing to update
  return unless @$pairs;

  # No arrays or operators allowed
  foreach (@$pairs) {
    return unless $_ =~ /^$KEY_REGEX\s+(?:=|IS\s)/o;
  };

  # Set undef to pairs
  my @pairs = map { $_ =~ s{ IS NULL$}{ = NULL}io; $_ } @$pairs;

  # Generate sql
  my $sql = 'UPDATE ' . $table . ' SET ' . join(', ', @pairs);

  # Condition
  if ($_[0]) {
    my ($cond_pairs, $cond_values) = _get_pairs( shift(@_) );

    # No conditions given
    if (@$cond_pairs) {

      # Append condition
      $sql .= ' WHERE ' . join(' AND ', @$cond_pairs);

      # Append values
      push(@$values, @$cond_values);
    };
  };

  # Prepare and execute
  my $rv = $self->prep_and_exec($sql, $values);

  # Return value
  return (!$rv || $rv eq '0E0') ? 0 : $rv;
};


# Select from table
sub select {
  my $self  = shift;

  # Get table object
  my ($tables,
      $fields,
      $join_pairs,
      $treatment,
      $field_alias) = _table_obj($self, \@_);

  my @pairs = @$join_pairs;

  # Fields to select
  if ($_[0] && ref($_[0]) eq 'ARRAY') {

    # Not allowed for join selects
    return if $fields->[0];

    ($fields, $treatment) = _fields($tables->[0], shift(@_) );

    $fields = [ $fields ];
  };

  # Default
  $fields->[0] ||= '*';

  # Create sql query
  my $sql = join(', ', @$fields) . ' FROM ' . join(', ', @$tables);

  # Append condition
  my @values;

  my ($cond, $prep);
  if (($_[0] && ref($_[0]) eq 'HASH') || @$join_pairs) {

    # Condition
    my ($pairs, $values);
    if ($_[0] && ref($_[0]) eq 'HASH') {
      ($pairs, $values, $prep) = _get_pairs( shift(@_), $field_alias);

      push(@values, @$values);

      # Add to pairs
      push(@pairs, @$pairs) if $pairs->[0];
    };

    # Add where clause
    $sql .= ' WHERE ' . join(' AND ', @pairs) if @pairs;

    # Add distinct information
    if ($prep) {
      $sql = 'DISTINCT ' . $sql if delete $prep->{'distinct'};

      # Apply restrictions
      $sql .= _restrictions($prep, \@values);
    };
  };

  my $result;

  # Check cache
  my ($chi, $key, $chi_param);
  if ($prep && $prep->{cache}) {

    # Cache parameters
    ($chi, $key, $chi_param) = @{delete $prep->{cache}};

    # Generate key
    $key = 'SELECT ' . $sql . '-' . join('-', @values) unless $key;

    # Get cache result
    $result = $chi->get($key);
  };

  # Unknown restrictions
  if (scalar keys %$prep) {
    carp 'Unknown restriction option: ' . join(', ', keys %$prep);
  };

  my ($rv, $sth);

  # Result was not cached
  unless ($result) {

    # Prepare and execute
    ($rv, $sth) = $self->prep_and_exec('SELECT ' . $sql, \@values);

    # No statement created
    return unless $sth;
  }

  else {
    # Last sql command
    $self->{last_sql} = 'SELECT ' . $sql . ' -- ' . $CACHE_COMMENT;
  };

  # Prepare treatments
  my (@treatment, %treatsub);
  if ($treatment) {
    @treatment = keys %$treatment;
    foreach (@treatment) {
      $treatsub{$_} = shift(@{$treatment->{$_}});
    };
  };

  # Release callback
  if ($_[0] && ref $_[0] && ref $_[0] eq 'CODE' ) {
    my $cb = shift;

    carp 'Calling select with an iteration callback is deprecated since v0.31';

    # Iterate through dbi result
    my ($i, $row) = (0);
    while ($row = $sth ? $sth->fetchrow_hashref : $result->[$i]) {

      # Iterate for cache result
      push(@$result, $row) if $chi && $sth;

      # Increment for cached results
      $i++;

      # Treat result
      if ($treatment) {

	# Treat each treatable row value
	foreach ( grep { exists $row->{$_} } @treatment) {
	  $row->{$_} = $treatsub{$_}->(
	    $row->{$_}, @{ $treatment->{$_} }
	  );
	};
      };

      # Finish if callback returns -1
      local $_ = $row;
      my $rv = $cb->($row);
      if ($rv && $rv eq '-1') {
	$result = undef;
	last;
      };
    };

    # Save to cache
    if ($sth && $chi && $result) {
      $chi->set($key => $result, $chi_param);
    };

    # Came from cache
    return if !$sth && $chi;

    # Finish statement
    $sth->finish;
    return;
  };

  # Create array ref
  unless ($result) {
    $result = $sth->fetchall_arrayref({});

    # Save to stash
    if ($chi && $result) {
      $chi->set($key => $result, $chi_param);
    };
  };

  # Return array ref
  return $result unless $treatment;

  # Treat each row
  foreach my $row (@$result) {

    # Treat each treatable row value
    foreach (@treatment) {
      $row->{$_} = $treatsub{$_}->(
	$row->{$_}, @{$treatment->{$_}}
      ) if $row->{$_};
    };
  };

  # Return result
  $result;
};


# List elements
sub list {
  my $self = shift;

  # Get callback
  my $cb = pop if ref $_[-1] && ref $_[-1] eq 'CODE';

  # Get param hash reference
  my $param = pop if ref $_[-1] && ref $_[-1] eq 'HASH';

  # Get table object
  $self = $self->table( @_ ) if $_[0];

  my (%condition, %pagination);

  # Check numerical values
  my $start_index = _check_param($param, 'startIndex', 'num') // 0;
  my $count       = _check_param($param, 'count',      'num');
  my $start_page  = _check_param($param, 'startPage',  'num') // 1;

  # Set caching condition
  $condition{-cache} = delete $param->{-cache} if $param->{-cache};

  ### Sorting parameters
  my %sort;

  # Check, if parameter is a field
  my $sort_by = _check_param($param, 'sortBy');
  if ($sort_by && $sort_by =~ s/^\s*($KEY_REGEX)\s*$/$1/) {

    $param->{sortOrder} //= 'ascending';
    my $sort_order = index(lc($param->{sortOrder}), 'desc') == 0 ? 'descending' : undef;

    # Set SQL limitation
    $pagination{-order} = $sort_order ? "-$sort_by" : $sort_by;

    # Set sort information
    $sort{sortBy}    = $sort_by;
    $sort{sortOrder} = $sort_order if $sort_order;
  };

  # Set SQL limitations
  $pagination{-offset} = $start_index;
  $pagination{-limit}  = $count || $ITEMS_PER_PAGE;

  # Not first page
  if ($start_page > 1) {

    # Set SQL limitations
    $pagination{-offset} //= 0;
    $pagination{-offset} += (($start_page - 1) * $pagination{-limit});
  };


  ### Filter parameters
  my %filter;

  # Filter parameter is set
  my $filter_by = _check_param($param, 'filterBy');
  if ($filter_by) {

    # Filter operation is set
    my $filter_op = _check_param($param, 'filterOp');
    if ($filter_op) {
      $filter_op = lc $filter_op;

      # Set parameters for response
      $filter{filterBy} = $filter_by;
      $filter{filterOp} = $filter_op;

      # Check for presence
      if ($filter_op eq 'present') {

	# Create SQL condition
	$condition{$filter_by} = { not => undef };
      }

      # Check for absence
      elsif ($filter_op eq 'absent') {

	# Create SQL condition
	$condition{$filter_by} = undef;
      }

      # Check with filterValue
      else {

	# Get filterValue
	if (my $fv = _check_param($param, 'filterValue')) {

	  # Set filter value for response
	  $filter{filterValue} = $fv;

	  # Check for equality
	  if ($filter_op eq 'equals') {

	    # Equals the value
	    $condition{$filter_by} = $fv;
	  }

	  # Check for disparaty
	  elsif ($filter_op eq 'disparate') {

	    # Equals the value
	    $condition{$filter_by} = { ne => $fv };
	  }

	  # Check with SQL like
	  else {
	    $fv =~ s/([\%_])/\\$1/g;

	    # Check for containing
	    if ($filter_op eq 'contains') {
	      $condition{$filter_by} = { like => "%${fv}%" };
	    }

	    # Check for beginning
	    elsif ($filter_op eq 'startswith') {

	      # Set response operation
	      $filter{filterOp} = 'startsWith';
	      $condition{$filter_by} = { like => "${fv}%" };
	    };
	  };
	}

	# No filterValue - reset
	else {
	  %filter = ();
	};
      };
    };
  };

  # Get count
  my $total_results = $self->count(\%condition);

  # Something went wrong
  return unless defined $total_results;

  # Check fields
  my @fields;
  if ($param->{fields}) {

    # Fields is a reference
    if (ref $param->{fields}) {
      @fields = @{ $param->{fields} };
    }

    # Fields is a string
    else {
      @fields =
	grep { /^$KEY_REGEX$/ }
	  map { s/\s//g; $_ }
	    split /\s*,\s*/, $param->{fields};
    };
  };

  my $entry;

  # More than one result
  if ($total_results) {

    # Table is joined and there are fields existing
    if (ref $self->{table} && @fields) {

      # Is a joined table, filter fields afterwards
      my $select = $self->select({ %condition, %pagination });

      # Iterate for filtering
      foreach my $row (@$select) {

	# Filter
	my %new;
	foreach (@fields) {
	  $new{$_} = $row->{$_} if exists $row->{$_};
	};
	push(@$entry, \%new);
      };

      # Define fields
      $filter{fields} = \@fields;
    }

    # Fields in simple table
    elsif (@fields) {
      # Just prepend field to select
      $filter{fields} = \@fields;
      $entry = $self->select(\@fields, { %condition, %pagination });
    }

    # No fields
    else {
      $entry = $self->select({ %condition, %pagination });
    };

    # Use callback for each entry
    if ($cb && @$entry) {
      my @entry_cb;
      push( @entry_cb, $cb->($_) ) foreach @$entry;
      $entry = \@entry_cb;
    };
  };

  # Return response
  {
    totalResults => $total_results,
    startIndex   => $start_index,
    itemsPerPage => $pagination{-limit},
    startPage    => $start_page,
    entry        => $entry || [],
    %filter,
    %sort
  };
};


# Load one line
sub load {
  my $self  = shift;
  my @param = @_;

  # Has a condition
  if ($param[-1] && ref($param[-1])) {

    # Add limitation to the condition
    if (ref($param[-1]) eq 'HASH') {
      $param[-1]->{-limit} = 1;
    }

    # Load is malformed
    elsif (ref($param[-1]) ne 'ARRAY') {
      carp 'Load is malformed';
      return;
    };
  }

  # Has no condition yet
  else {
    push(@param, { -limit => 1 });
  };

  # Select with limit
  my $row = $self->select(@param);

  # Error or not found
  return unless $row;

  # Return row
  $row->[0];
};


# Delete entry
sub delete {
  my $self  = shift;

  # Get table name
  my $table = _table_name($self, \@_) or return;

  # Build sql
  my $sql = 'DELETE FROM ' . $table;

  # Condition
  my ($pairs, $values, $prep, $secure);
  if ($_[0]) {

    # Add condition
    ($pairs, $values, $prep) = _get_pairs( shift(@_) );

    # Add where clause to sql
    $sql .= ' WHERE ' . join(' AND ', @$pairs) if @$pairs || $prep;

    # Apply restrictions
    $sql .= _restrictions($prep, $values) if $prep;
  };

  # Prepare and execute deletion
  my $rv = $self->prep_and_exec($sql, $values);

  # Return value
  return (!$rv || $rv eq '0E0') ? 0 : $rv;
};


# Update or insert a value
sub merge {
  my $self  = shift;

  # Get table name
  my $table = _table_name($self, \@_) or return;

  my %param = %{ shift( @_ ) };
  my %cond  = $_[0] ? %{ shift( @_ ) } : ();

  # Prefix with table if necessary
  my @param = ( \%param, \%cond );
  unshift(@param, $table) unless $self->{table};

  my $rv;
  my $job = 'update';
  $self->txn(
    sub {

      # Update
      $rv = $self->update( @param );

      return 1 if $rv;

      # Delete all element conditions
      delete $cond{$_} foreach grep {
	ref($cond{$_}) && !blessed($cond{$_})
      } keys %cond;

      # Insert
      @param = ( { %param, %cond } );
      unshift(@param, $table) unless $self->{table};

      $rv = $self->insert(@param) or return -1;

      $job = 'insert';

      return;
    }) or return;

  # Return value is bigger than 0
  if ($rv && $rv > 0) {
    return wantarray ? ($rv, $job) : $rv;
  };

  return;
};


# Count results
sub count {
  my $self  = shift;

  # Init arrays
  my ($tables, $fields, $join_pairs, $treatment, $field_alias) =
    _table_obj($self, \@_);

  my @pairs = @$join_pairs;

  # Build sql
  my $sql =
    'SELECT ' . join(', ', 'count(1)', @$fields) .
      ' FROM '  . join(', ', @$tables);

  # Ignore fields
  shift if $_[0] && ref $_[0] eq 'ARRAY';

  # Get conditions
  my ($pairs, $values, $prep);
  if ($_[0] && ref $_[0] eq 'HASH') {
    ($pairs, $values, $prep) = _get_pairs( shift(@_), $field_alias );
    push(@pairs, @$pairs) if $pairs->[0];
  };

  # Add where clause
  $sql .= ' WHERE ' . join(' AND ', @pairs) if @pairs;
  $sql .= ' LIMIT 1';

  my $result;

  # Check cache
  my ($chi, $key, $chi_param);
  if ($prep && $prep->{cache}) {

    # Cache parameters
    ($chi, $key, $chi_param) = @{$prep->{cache}};

    # Generate key
    $key = $sql . '-' . join('-', @$values) unless $key;

    # Get cache result
    if ($result = $chi->get($key)) {

      # Last sql command
      $self->{last_sql} = $sql . ' -- ' . $CACHE_COMMENT;

      # Return cache result
      return $result;
    };
  };

  # Prepare and execute
  my ($rv, $sth) = $self->prep_and_exec($sql, $values || []);

  # Return value is empty
  return undef if !$rv;

  # Return count
  $result = $sth->fetchrow_arrayref->[0] || 0;
  $sth->finish;

  # Save to cache
  $chi->set($key => $result, $chi_param) if $chi && $result;

  # Return result
  $result;
};


# Prepare and execute
sub prep_and_exec {
  my ($self, $sql, $values, $cached) = @_;
  my $dbh = $self->dbh;

  # Last sql command
  $self->{last_sql} = $sql;

  # Prepare
  my $sth =
    $cached ? $dbh->prepare_cached( $sql ) :
      $dbh->prepare( $sql );

  # Check for errors
  if ($dbh->err) {

    if (index($dbh->errstr, 'database') <= 0) {
      carp $dbh->errstr . ' in "' .  _trim_last_sql($self->last_sql) . '"';
      return;
    };

    # Retry with reconnect
    $dbh = $self->_connect;

    $sth =
      $cached ? $dbh->prepare_cached( $sql ) :
	$dbh->prepare( $sql );

    if ($dbh->err) {
      carp $dbh->errstr . ' in "' . _trim_last_sql($self->last_sql) . '"';
      return;
    };
  };

  # No statement handle established
  return unless $sth;

  # Execute
  my $rv = $sth->execute( @$values );

  # Check for errors
  if ($dbh->err) {
    carp $dbh->errstr . ' in "' . _trim_last_sql($self->last_sql) . '"';
    return;
  };

  # Return value and statement
  return ($rv, $sth) if wantarray;

  # Finish statement
  $sth->finish;

  # Return value
  $rv;
};


# Wrapper for DBI do
sub do {
  $_[0]->{last_sql} = $_[1];

  # Database connection
  my $dbh = shift->dbh;

  my $rv = $dbh->do( @_ );

  # Error
  carp $dbh->errstr . ' in "' . $_[0] . '"' if !$rv && $dbh->err;
  return $rv;
};


# Explain query plan
sub explain {
  'Not implemented for ' . $_[0]->driver;
};


# Wrap a transaction
sub txn {
  my $self = shift;

  # No callback defined
  return unless $_[0] && ref($_[0]) eq 'CODE';

  my $dbh = $self->dbh;

  # Outside transaction
  if ($dbh->{AutoCommit}) {

    # Start new transaction
    $dbh->begin_work;

    ${$self->{in_txn}} = 1;

    # start
    local $_ = $self;
    my $rv = $_[0]->($self);
    if (!$rv || $rv ne '-1') {
      ${$self->{in_txn}} = 0;
      $dbh->commit;
      return 1;
    };

    # Rollback
    ${$self->{in_txn}} = 0;
    $dbh->rollback;
    return;
  }

  # Inside transaction
  else {
    ${$self->{in_txn}} = 1;

    # Push savepoint on stack
    my $sp_array = $self->{savepoint};

    # Use PID for concurrent accesses
    my $sp = "orosp_${$}_";

    # Use TID for concurrent accesses
    $sp .= threads->tid . '_' if $self->{tid};

    $sp .= $sp_array->[0]++;

    # Push new savepoint to array
    push(@$sp_array, $sp);

    # Start transaction
    $self->do("SAVEPOINT $sp");

    # Run wrap actions
    my $rv = $_[0]->($self);

    # Pop savepoint from stack
    my $last_sp = pop(@$sp_array);
    if ($last_sp eq $sp) {
      $sp_array->[0]--;
    }

    # Last savepoint does not match
    else {
      carp "Savepoint $sp is not the last savepoint on stack";
    };

    # Commit savepoint
    if (!$rv || $rv ne '-1') {
      $self->do("RELEASE SAVEPOINT $sp");
      return 1;
    };

    # Rollback
    $self->do("ROLLBACK TO SAVEPOINT $sp");
    return;
  };
};


# Add connect event
sub on_connect {
  my $self = shift;
  my $cb   = pop;

  # Parameter is no subroutine
  return unless ref $cb && ref $cb eq 'CODE';

  my $name = shift || '_cb_' . $self->{_connect_cb}++;

  # Push subroutines on_connect
  unless (exists $self->{on_connect}->{$name}) {
    $self->{on_connect}->{$name} = $cb;
    return 1;
  };

  # Event was not newly established
  return;
};


# Wrapper for DBI last_insert_id
sub last_insert_id {
  my $dbh = shift->dbh;
  @_ = (undef) x 4 unless @_;
  $dbh->last_insert_id(@_);
};


# Import files
sub import_sql {
  my $self = shift;

  carp 'import_sql is deprecated and will be deleted in further versions';

  # Get callback
  my $cb = pop @_ if ref $_[-1] && ref $_[-1] eq 'CODE';

  my $files = @_ > 1 ? \@_ : shift;

  return unless $files;

  # Import subroutine
  my $import = sub {
    my $file = shift;

    # No file given
    return unless $file;

    if (open(SQL, '<:utf8', $file)) {
      my @sql = split(/^--\s-.*?$/m, join('', ));
      close(SQL);

      # Start transaction
      return $self->txn(
	sub {
	  my ($sql, @sql_seq);;
	  foreach $sql (@sql) {
	    $sql =~ s/^(?:--.*?|\s*)?$//mg;
	    $sql =~ s/\n\n+/\n/sg;

	    # Use callback
	    @sql_seq = $cb->($sql) if $cb && $sql;

	    next unless $sql;

	    # Start import
	    foreach (@sql_seq) {
	      $self->do($_) or return -1;
	    };
	  };
	}
      );
    }

    # Unable to read SQL file
    else {
      carp "Unable to import file '$file'";
      return;
    };
  };

  # Multiple file import
  if (ref $files) {
    return $self->txn(
      sub {
	foreach (@$files) {
	  $import->($_) or return -1;
	};
      });
  };

  # Single file import
  return $import->($files);
};


# Disconnect on destroy
sub DESTROY {
  my $self = shift;

  # Check if table is parent
  unless (exists $self->{table}) {

    # No database connection
    return $self unless $self->{dbh};

    # Delete password
    $self->_password(0);

    # Delete cached kids
    if (blessed $self->{dbh}) {
      local $SIG{__WARN__} = \&_no_warn;
      my $kids = $self->{dbh}->{CachedKids};
      %$kids = () if $kids;
    };

    # Disconnect
    # $self->{dbh}->disconnect unless $self->{dbh}->{Kids};
    $self->{dbh}->disconnect;

    # Delete parameters
    delete $self->{$_} foreach qw/dbh on_connect _connect_cb/;
  };

  # Return object
  $self;
};


# Initialize database
sub _init { 1 };


# Connect with database
sub _connect {
  my $self = shift;

  croak 'No database given' unless $self->{dsn};

  # DBI Connect
  my $dbh = DBI->connect(
    $self->{dsn},
    $self->{user} // undef,
    $self->_password,
    {
      PrintError => 0,
      RaiseError => 0,
      AutoCommit => 1,
      @_
    });

  # Unable to connect to database
  carp $DBI::errstr and return unless $dbh;

  # Store database handle
  $self->{dbh} = $dbh;

  # Save process id
  $self->{pid} = $$;

  # Save thread id
  $self->{tid} = threads->tid if $INC{'threads.pm'};

  # Emit all on_connect events
  foreach (values %{ $self->{on_connect} }) {
    $_->( $self, $dbh );
  };

  # Return handle
  $dbh;
};


# Password closure should prevent accidentally overt passwords
{
  # Password hash
  my %pwd;

  # Password method
  sub _password {
    my $id = shift->{_id};
    my $pwd_set = shift;

    my ($this) = caller(0);

    # Request only allowed in this namespace
    return if index(__PACKAGE__, $this) != 0;

    # Return password
    unless (defined $pwd_set) {
      return $pwd{$id};
    }

    # Delete password
    unless ($pwd_set) {
      delete $pwd{$id};
    }

    # Set password
    else {

      # Password can only be set on construction
      for ((caller(1))[3]) {
	m/::new$/o or return;
	index($_, __PACKAGE__) == 0 or return;
	!$pwd{$id} or return;
	$pwd{$id} = $pwd_set;
      };
    };
  };
};


# Get table name
sub _table_name {
  my $self = shift;

  # Table name
  my $table;
  unless (exists $self->{table}) {
    return shift(@{ $_[0] }) unless ref $_[0]->[0];
  }

  # Table object
  else {

    # Join table object not allowed
    return $self->{table} unless ref $self->{table};
  };

  return;
};


# Get table object
sub _table_obj {
  my $self = shift;

  my $tables;
  my ($fields, $pairs) = ([], []);

  # Not a table object
  unless (exists $self->{table}) {

    my $table = shift( @{ shift @_ } );

    # Table name as a string
    unless (ref $table) {
      $tables = [ $table ];
    }

    # Joined tables
    else {
      return _join_tables( $table );
    };
  }

  # A table object
  else {

    # joined table
    if (ref $self->{table}) {
      return @{ $self->{table} };
    }

    # Table name
    else {
      $tables = [ $self->{table} ];
    };
  };

  return ($tables, $fields, $pairs);
};


# Join tables
sub _join_tables {
  my @join = @{ shift @_ };

  my (@tables, @fields, @pairs, $treatment);
  my %field_alias;
  my %marker;

  # Parse table array
  while (@join) {

    # Table name
    my $table = shift @join;

    # Check table name
    my $t_alias = $2 if $table =~ s/^([^:]+?):([^:]+?)$/$1 $2/o;

    # Push table
    push(@tables, $table);

    # Set prefix
    my $prefix = $t_alias ? $t_alias : $table;

    if (my $ref = ref $join[0]) {

      # Remember aliases
      my %alias;

      # Field array
      if ($ref eq 'ARRAY') {

	my $field_array = shift @join;

	my $f_prefix = '';

	# Has a hash next to it
	if (ref $join[0] && ref $join[0] eq 'HASH') {

	  # Set Prefix if given
	  # Todo: Is this documented?
	  if (exists $join[0]->{-prefix}) {
	    $f_prefix = delete $join[0]->{-prefix};
	    $f_prefix = _clean_alias($prefix) . '_' if $f_prefix eq '*';
	  };
	};

	# Reformat field values
	my $reformat = [
	  map {

	    # Is a reference
	    unless (ref $_) {

	      # Set alias semi explicitely
	      if (index($_, ':') == -1) {
		$_ .= ':~' . $f_prefix . _clean_alias($_);
	      };

	      # Field is not a function
	      if (index($_, '(') == -1) {
		$_ = "$prefix.$_" if index($_, '.') == -1;
	      }

	      # Field is a function
	      else {
		s/((?:\(|$FIELD_OP_REGEX)\s*)($KEY_REGEX_NOPREF)
                  (\s*(?:$FIELD_OP_REGEX|\)))/$1$prefix\.$2$3/ogx;
	      };

	    };

	    $_;
	  } @$field_array
	];

	# Automatically prepend table and, if not given, alias
	(my $fields, $treatment, my $alias) = _fields($t_alias, $reformat);

	# Set alias for markers
	# $alias{$_} = 1 foreach keys %$alias;
	while (my ($key, $val) = each %$alias) {
	  $field_alias{$key} = $alias{$key} = $val ;
	};

	# TODO: only use alias if necessary, as they can't be used in WHERE!

	push(@fields, $fields) if $fields;
      }

      # Add prepended *
      else {
	push(@fields, "$prefix.*");
      };

      # Marker hash reference
      if (ref $join[0] && ref $join[0] eq 'HASH') {
	my $hash = shift @join;

	# Add database fields to marker hash
	while (my ($key, $value) = each %$hash) {

	  # TODO: Does this work?
	  unless ($alias{$key}) {
	    $key = "$prefix.$key" if $key =~ $KEY_REGEX_NOPREF;
	  }
	  else {
	    $key = $alias{$key};
	  };

	  # Prefix, if not an explicite alias
	  foreach (ref $value ? @$value : $value) {

	    my $array = ($marker{$_} //= []);
	    push(@$array, $key);
	  };
	};
      };
    };
  };

  # Create condition pairs based on markers
  my ($ind, $fields);
  while (($ind, $fields) = each %marker) {
    my $field = shift(@$fields);
    foreach (@$fields) {
      push(
	@pairs,
	"$field " . ($ind < 0 ? '!' : '') . "= $_"
      );
    };
  };

  # Return join initialised values
  return (\@tables, \@fields, \@pairs, $treatment, \%field_alias);
};


# Get pairs and values
sub _get_pairs {
  my (@pairs, @values, %prep);

  # Get alias for fields
  my $alias = @_ == 2 ? pop @_ : {};

  while (my ($key, $value) = each %{ $_[0] }) {

    # Not a valid key
    unless ($key =~ m/^-?$KEY_REGEX$/o) {
      carp "$key is not a valid Oro key" and next;
    };

    # Normal key
    if (substr($key, 0, 1) ne '-') {

      # Get alias
      $key = exists $alias->{$key} ? $alias->{$key} : (index($key, '.') >= 0 ? $key : '`' . $key . '`');

      # Equality
      unless (ref $value) {

	# NULL value
	unless (defined $value) {
	  push(@pairs, "$key IS NULL");
	}

	# Simple value
	else {

	  push(@pairs, "$key = ?"),
	    push(@values, $value);
	}
      }

      # Element of or SQL
      elsif (ref $value eq 'ARRAY') {

	# Escaped SQL
	if (ref $value->[0] && ref $value->[0] eq 'SCALAR') {
	  push(@pairs, "$key = (" . ${$value->[0]} . ')'),
	    push(@values, map { _stringify($_) } @{$value}[ 1 .. $#$value ]);
	  next;
	};

	# Undefined values in the array are not specified
	# as ' IN (NULL, ...)' does not work
	push (@pairs, "$key IN (" . _q($value) . ')' ),
	  push(@values, map { _stringify($_) } @$value);
      }

      # Operators
      elsif (ref $value eq 'HASH') {
	while (my ($op, $val) = each %$value) {
	  if ($op =~ $OP_REGEX) {
	    for ($op) {

	      # Uppercase
	      $_ = uc;

	      # Translate negation
	      s{^(?:NOT_|!(?=[MLGRB]))}{NOT };

	      # Translate literal compare operators
	      tr/GLENTQ/><=!/d if $_ =~ m/^(?:[GL][TE]|NE|EQ)$/o;
	      s/==/=/o;
	    };

	    # Array operators
	    if (ref $val && ref $val eq 'ARRAY') {

	      # Between operator
	      if (index($op, 'BETWEEN') >= 0) {
		push(@pairs, "$key $op ? AND ?"),
		  push(@values, map { _stringify($_) } @{$val}[0, 1]);
	      }

	      # Not element of
	      elsif ($op =~ /^NOT( IN)?$/) {
		# Undefined values in the array are not specified
		# as ' NOT IN (NULL, ...)' does not work

		push(@pairs, "$key NOT IN (" . _q($val) . ')' ),
		  push(@values, map { _stringify($_) } @$val);
	      };
	    }

	    # Simple operator
	    else {
	      my $p = "$key $op ";

	      # Value is an object
	      if (blessed $val) {
		$val = _stringify($val) or
		  carp "Unknown Oro value $key $op $val" and next;
	      };

	      # Defined value
	      if (defined $val) {
		$p .= '?';
		push(@values, $val);
	      }

	      # Null value
	      else {
		$p .= 'NULL';
	      };

	      # Add LIKE escape sequence
	      if ($op eq 'LIKE') {
		$p .= q! ESCAPE '\'!;
	      };

	      push(@pairs, $p);
	    };

	  }

	  # Unknown operator
	  else {
	    $val //= '?';
	    carp "Unknown Oro operator $key $op $val" and next;
	  }
	}
      }

      # Escaped SQL
      elsif (ref $value eq 'SCALAR') {
	push(@pairs, "$key = ($$value)"),
      }

      # Stringifiable object
      elsif ($value = _stringify($value)) {
	# Simple object
	push(@pairs, "$key = ?"),
	  push(@values, $value);
      }

      # Unknown pair
      else {
	carp "Unknown Oro pair $key, " . ($value ? $value : '[undef]' ) and next;
      };
    }

    # Restriction of the result set
    else {
      $key = lc $key;

      # No value existing
      next unless defined $value;

      # Limit and Offset restriction
      if ($key =~ m/^-(?:limit|offset|distinct)$/) {
	$prep{substr($key, 1)} = $value if $value =~ m/^\d+$/o;
      }

      # Order restriction
      elsif ($key =~ s/^-(order|group)(?:[-_]by)?$/$1/) {

	# Already array and group
	if ($key eq 'group' && ref $value) {
	  if (ref $value->[-1] && ref $value->[-1] eq 'HASH') {
	    $prep{having} = pop @$value;

	    unless (@$value) {
	      carp '"Having" without "Group" is not allowed' and next;
	    };
	  };
	};

	my @field_array;

	# Check group values
	foreach (ref $value ? @$value : $value) {

	  # Valid order/group_by value
	  if ($_ =~ $VALID_GROUPORDER_REGEX) {
	    s/^([\-\+])//o;
	    push(@field_array, $1 && $1 eq '-' ? "$_ DESC" : $_ );
	  }

	  # Invalid order/group_by value
	  else {
	    carp "$_ is not a valid Oro $key restriction";
	  };
	};

	$prep{$key} = join(', ', @field_array) if scalar @field_array;
      }

      # And or or
      elsif ($key =~ m/^-(or|and)$/) {
	my $op = uc $1;
	my @array = @$value;

	my (@or_pairs, @or_values);
	while (@array) {

	  # Not a hash
	  if (!ref $array[0]) {
	    unshift(@array, {
	      shift @array => shift @array
	    });
	  };

	  # Ignore prep
	  my ($or_pairs, $or_values) = _get_pairs(shift(@array), $alias);

	  # Push values
	  push(@values, @$or_values);

	  # Push local pairs
	  if (@$or_pairs > 1) {
	    push(@or_pairs, '(' . join (' AND ', @$or_pairs) . ')');
	  }

	  # Push single local pair
	  else {
	    push(@or_pairs, $or_pairs->[0]);
	  };
	};

	# Join with chosen operator
	push(@pairs, '(' . join(" $op ", @or_pairs) . ')');
      }

      # Cache
      elsif ($key eq '-cache') {
	my $chi = $value->{chi};

	# Check chi existence
	if ($chi) {
	  $prep{cache} = [ $chi, $value->{key} // '', $value ];
	}

	# No chi given
	else {
	  carp 'No CHI driver given for cache';
	};
      }
      else {
	carp "$key is an unknown restriction";
      };
    };
  };

  return (\@pairs, \@values, (keys %prep ? \%prep : undef));
};


# Get fields
sub _fields {
  my $table = shift;

  my (%treatment, %alias, @fields);

  foreach ( @{$_[0]} ) {

    # Ordinary String
    unless (ref $_) {

      # Valid field
      if ($_ =~ $VALID_FIELD_REGEX) {
	push(@fields, $_);
      }

      # Invalid field
      else {
	carp "$_ is not a valid Oro field value"
      };
    }

    # Treatment
    elsif (ref $_ eq 'ARRAY') {
      my ($sub, $alias) = @$_;
      my ($sql, $inner_sub) = $sub->($table);
      ($sql, $inner_sub, my @param) = $sql->($table) if ref $sql;

      $treatment{ $alias } = [$inner_sub, @param ] if $inner_sub;
      push(@fields, "$sql:$alias");
    };
  };

  my $fields = join(', ', @fields);

  # Return if no alias fields exist
  return $fields unless $fields =~ m/[\.:=]/o;

  # Join with alias fields
  return (
    join(
      ', ',
      map {
	# Explicite field alias
	if ($_ =~ $FIELD_REST_RE) {

	  # ~ indicates rather not explicite alias
	  # Will only be set in case of agregate functions
	  # TODO: if ($2 eq ':' && index($1,'(') >= 0);
	  $alias{$3} = $1;
	  qq{$1 AS `$3`};
	}

	# Implicite field alias
	elsif (m/^(?:.+?)\.(?:[^\.]+?)$/) {
	  my $cl = _clean_alias $_;
	  $alias{$cl} = qq{$_ AS `$cl`};
	}

	# Field value
	else {
	  $_
	};
      } @fields
    ),
    (%treatment ? \%treatment : undef),
    \%alias
  );
};


# Restrictions
sub _restrictions {
  my ($prep, $values) = @_;
  my $sql = '';

  # Group restriction
  if ($prep->{group}) {
    $sql .= ' GROUP BY ' . delete $prep->{group};

    # Having restriction
    if ($prep->{having}) {

      # Get conditions
      my ($cond_pairs, $cond_values) = _get_pairs(
	delete $prep->{having}
      );

      # Conditions given
      if (@$cond_pairs) {

	# Append having condition
	$sql .= ' HAVING ' . join(' AND ', @$cond_pairs);

	# Append values
	push(@$values, @$cond_values);
      };
    };
  };

  # Order restriction
  if (exists $prep->{order}) {
    $sql .= ' ORDER BY ' . delete $prep->{order};
  };

  # Limit restriction
  if ($prep->{limit}) {
    $sql .= ' LIMIT ?';
    push(@$values, delete $prep->{limit});

    # Offset restriction
    if (defined $prep->{offset}) {
      $sql .= ' OFFSET ?';
      push(@$values, delete $prep->{offset});
    };
  };

  $sql;
};


# Check for stringification of blessed values
sub _stringify {
  my $ref = blessed $_[0] or return $_[0];
  if (index(($_ = "$_[0]"), $ref) != 0) {
    return $_;
  };
  undef;
}


# Clean alias string
sub _clean_alias {
  for (my $x = shift) {
    tr/ ()[]"$@#./_/s;
    s/[_\s]+$//;
    return lc $x;
  };
};


# Check list param
sub _check_param {
  if ($_[0]->{$_[1]} && !ref $_[0]->{ $_[1] }) {

    # Check for numerical value
    if ($_[2]) {
      return $_[0]->{$_[1]} =~ $NUM_RE ? $1 : undef;
    };

    # Return value
    return $_[0]->{$_[1]};
  };

  # Fail
  return;
};


# Questionmark string
sub _q {
  my ($s, $i, $r);

  # Loop over all values
  for ($i = 0; $i < scalar(@{$_[0]});) {
    $r = $_[0]->[$i];

    # Append key
    unless (ref $r) {
      $s .= '?,';
      $i++;
      next;
    };

    # Scalar for direct SQL input
    if (ref $r eq 'SCALAR') {
      $s .= "($$r),";
      splice(@{$_[0]}, $i, 1, ());
    }

    # Array for direct SQL input
    elsif (ref $r eq 'ARRAY') {

      # Check for scalar reference
      unless (ref $r->[0]) {
	carp 'First element of array insertion needs to be a scalar reference';
	splice(@{$_[0]}, $i++, 1);
	next;
      };

      # Embed SQL statement directly
      $s .= '(' . ${ shift @$r } . '),';
      splice(@{$_[0]}, $i++, scalar @$r, @$r);
    }

    # Stringifyable objects
    else {
      $i++;
      $s .= '?,' and next;
    };
  };

  # Delete final ','
  chop $s;

  # Return value
  $s;
};


# Trim last_sql message for reporting
sub _trim_last_sql {
  my $last_sql = shift;

  return $last_sql if length($last_sql) <= 500;
  return substr($last_sql, 0, 497) . ' ...';
};


# Empty code ref
sub _no_warn {};


1;


__END__