File Coverage

lib/DBIx/Oro/Driver/SQLite.pm

Criterion	Covered	Total	%
statement	253	296	85.4
branch	91	152	59.8
condition	51	89	57.3
subroutine	33	35	94.2
pod	18	18	100.0
total	446	590	75.5

package DBIx::Oro::Driver::SQLite;
use warnings;
use strict;
use DBIx::Oro;
our @ISA;
BEGIN { @ISA = 'DBIx::Oro' };

use v5.10.1;

# Todo: use 'truncate' for table deletion

# Defaults to 500 for SQLITE_MAX_COMPOUND_SELECT
our $MAX_COMP_SELECT;

BEGIN {
  $MAX_COMP_SELECT = 500;
};

use Carp qw/carp/;

# Find and create database file
use File::Path;
use File::Basename;

# Default arguments for snippet function
my @arguments =
  qw/start end ellipsis column token/;

my $arguments = qr/^(?:start|end|ellipsis|column|token)$/;

my @default = ('', '', '...', -1, -15);


# Constructor
sub new {
  my $class = shift;
  my %param = @_;
  $param{created} //= 0;

  my $autocommit = delete $param{autocommit};

  # Bless object with hash
  my $self = bless \%param, $class;

  # Store filename
  my $file = $self->{file} = $param{file} // '';

  # Temporary or memory file
  if (!$file || $file eq ':memory:') {
    $self->{created} = 1;
  }

  # Create path for file - based on ORLite
  elsif (!-e $file) {

    my $dir = File::Basename::dirname($file);
    unless (-d $dir) {
      File::Path::mkpath( $dir, { verbose => 0 } );
    };

    # Touch the file
    if (open(TOUCH,'>' . $file)) {
      $self->{created} = 1;
      close(TOUCH);
    };
  };

  # Data source name
  $self->{dsn} = 'dbi:SQLite:dbname=' . $self->{file};

  # Attach hash
  $self->{attached} = {} unless exists $self->{attached};

  # Autocommit
  ${$self->{autocommit}} =
    ${$self->{_autocounter}} = 0;

  # Set autocommit
  $self->autocommit($autocommit) if $autocommit;

  # Return object
  $self;
};


# Initialize database if newly created
sub _init {
  my $self = shift;

  # Get callback
  my $cb = delete $self->{init} if $self->{init} &&
    (ref $self->{init} || '') eq 'CODE';

  # Import SQL file
  my $import    = delete $self->{import};
  my $import_cb = delete $self->{import_cb};

  # Initialize database if newly created
  if ($self->created && ($import || $cb)) {

    # Start creation transaction
    unless (
      $self->txn(
	sub {

	  # Import SQL file
	  if ($import) {
	    $self->import_sql($import, $import_cb) or return -1;
	  };

	  # Release callback
	  if ($cb) {
	    local $_ = $self;
	    return $cb->($self);
	  };
	  return 1;
	})
    ) {

      # Unlink SQLite database
      if (index($self->file, ':') != 0) {
	unlink $self->file;
      };

      # Not successful
      $self = undef;
      return;
    };
  };

  return 1;
};


# Connect to database
sub _connect {
  my $self = shift;
  my $dbh = $self->SUPER::_connect(
    sqlite_unicode => defined $self->{unicode} ? $self->{unicode} : 1
  );

  # Turn foreign keys on as default
  $dbh->do('PRAGMA foreign_keys = ON') unless $self->{foreign_keys};

  # Set busy timeout
  $dbh->sqlite_busy_timeout( $self->{busy_timeout} || 300 );

  # Reattach possibly attached databases
  while (my ($db_name, $file) = each %{$self->{attached}}) {
    $self->prep_and_exec("ATTACH '$file' AS ?", [$db_name]);
  };

  # Return database handle
  $dbh;
};


# File of database
sub file { $_[0]->{file} // '' };


# Database driver
sub driver { 'SQLite' };


# Database was just created
sub created {
  my $self = shift;

  # Creation state is 0
  return 0 unless $self->{created};

  # Check for thread id
  if (defined $self->{tid} && $self->{tid} != threads->tid) {
    return ($self->{created} = 0);
  }

  # Check for process id
  elsif ($self->{pid} != $$) {
    return ($self->{created} = 0);
  };

  # Return creation state
  return 1;
};


# Explain query plan
sub explain {
  my $self = shift;

  # Prepare and execute explain query plan
  my ($rv, $sth) = $self->prep_and_exec(
    'EXPLAIN QUERY PLAN ' . shift, @_
  );

  # Query was not succesfull
  return unless $rv;

  # Create string
  my $string;
  foreach ( @{ $sth->fetchall_arrayref([]) }) {
    $string .= sprintf("%3d | %3d | %3d | %-60s\n", @$_);
  };

  # Return query plan string
  return $string;
};


# Delete with SQLite feature
sub delete {
  my $self = shift;
  my $secure;

  # Check if -secure parameter is set
  if ($_[-1] && ref $_[-1] && ref $_[-1] eq 'HASH') {
    $secure = delete $_[-1]->{-secure} || 0;
  };

  # Delete
  unless ($secure) {

    my $rv = $self->SUPER::delete(@_);

    # Decrement autocommit
    $self->_decr_commit if $rv;

    return $rv;
  }

  # Delete securely
  else {

    # Security value
    my $sec_value;

    # Retrieve secure delete pragma
    my ($rv, $sth) = $self->prep_and_exec('PRAGMA secure_delete');
    $sec_value = $sth->fetchrow_array if $rv;
    $sth->finish;

    # Set secure_delete pragma
    $self->do('PRAGMA secure_delete = ON') unless $sec_value;

    # Delete
    $rv = $self->SUPER::delete(@_);

    # Decrement autocommit
    $self->_decr_commit if $rv;

    # Reset secure_delete pragma
    $self->do('PRAGMA secure_delete = OFF') unless $sec_value;

    # Return value
    return $rv;
  };
};


# Insert values to database
sub insert {
  my $self  = shift;

  # Get table name
  my $table = $self->_table_name(\@_) 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, $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 (' . DBIx::Oro::_q(\@values) . ')';

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

    # Decrement autocommit
    $self->_decr_commit if $rv;

    return $rv;
  }

  # 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, $value);
    };

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

    my $sql = 'INSERT INTO ' . $table . ' (' . join(', ', map { "`$_`" } @keys) . ') ';
    my $union = 'SELECT ' . DBIx::Oro::_q(\@keys);

    # Maximum bind variables
    my $max = ($MAX_COMP_SELECT / @keys) - @keys;

    if (scalar @_ <= $max) {

      # Add data unions
      $sql .= $union . ((' UNION ' . $union) x ( scalar(@_) - 1 ));

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

      # Decrement autocommit
      $self->_decr_commit if $rv[0];

      return @rv;
    }

    # More than SQLite MAX_COMP_SELECT insertions
    else {

      my ($rv, @v_array);
      my @values = @_;

      # Start transaction
      $self->txn(
	sub {
	  while (@v_array = splice(@values, 0, $max - 1)) {

	    # Delete undef values
	    @v_array = grep($_, @v_array) unless @_;

	    # Add data unions
	    my $sub_sql = $sql . $union .
	      ((' UNION ' . $union) x ( scalar(@v_array) - 1 ));

	    # Prepare and execute
	    my $rv_part = $self->prep_and_exec(
	      $sub_sql,
	      [ map { (@default, @$_); } @v_array ]
	    );

	    # Rollback transaction
	    return -1 unless $rv_part;
	    $rv += $rv_part;
	  };

	}) or return;

      # Decrement autocommit
      $self->_decr_commit if $rv;

      # Everything went fine
      return $rv;
    };
  };

  # Unknown query
  return;
};


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

  my $rv = $self->SUPER::update(@_);

  # Decrement autocommit
  $self->_decr_commit if $rv;

  return $rv;
};


sub merge {
  my $self = shift;

  my ($rv, $type) = $self->SUPER::merge(@_);

  if ($rv && $type eq 'insert' && ${$self->{autocommit}}) {
    ${$self->{_autocounter}}--;
  };

  return wantarray ? ($rv, $type) : $rv;
};

# Attach database
sub attach {
  my ($self, $db_name, $file) = @_;

  $file //= '';

  # Attach file, memory or temporary database
  my $rv = scalar $self->prep_and_exec("ATTACH '$file' AS ?", [$db_name]);

  $self->{attached}->{$db_name} = $file;

  return $rv;
};


# Detach database
sub detach {
  my $self = shift;
  return unless $_[0];

  # Detach all databases
  foreach my $db_name (@_) {
    delete $self->{attached}->{$db_name};
    return unless $self->prep_and_exec('DETACH ?', [$db_name]);
  };

  return 1;
};


# Wrapper for sqlite last_insert_row_id
sub last_insert_id {
  shift->dbh->sqlite_last_insert_rowid;
};


# Create matchinfo function
sub matchinfo {
  my $self   = shift;

  # Use no multibyte characters
  # use bytes;

  # Format string
  my $format = lc(shift) if $_[0] && $_[0] =~ /^[pcnalsx]+$/i;

  # Return anonymous subroutine
  return sub {
    my $column;
    if (@_) {
      $column = shift || 'content';

      # Format string
      $format = lc(shift) if $_[0] && $_[0] =~ /^[pcnalsx]+$/i;
    };

    # Sort format for leading 'pc' if needed
    if ($format) {
      for ($format) {

	# Sort alphabetically
	$_ = join('', sort split('', $_));

	# Delete repeating characters
	s/(.)\1+/$1/g;

	# Prepend 'pc' if necessary
	if (/[xals]/) {
	  tr/pc//d;             # Delete 'pc'
	  $_ = 'pc' . $format;  # Prepend 'pc'
	};
      };
    }

    # No format given
    else {
      $format = 'pcx';
    };

    # Return anonymous subroutine
    return sub {
      return
	'matchinfo(' . $column . ', "' . $format . '")',
	  \&_matchinfo_return,
	    $format;
    };
  };
};


# Treat matchinfo return
sub _matchinfo_return {
  my ($blob, $format) = @_;

  # Get 32-bit blob chunks
  my @matchinfo = unpack('l' . (length($blob) * 4), $blob);

  # Parse format character
  my %match;
  foreach (split '', $format) {

    # Characters: p, c, n
    if ($_ eq 'p' or $_ eq 'c' or $_ eq 'n') {
      $match{$_} = shift @matchinfo;
    }

    # Characters: a, l, s
    elsif ($_ eq 'a' or $_ eq 'l' or $_ eq 's') {
      $match{$_} = [ splice(@matchinfo, 0, $match{c}) ];
    }

    # Characters: x
    elsif ($_ eq 'x') {
      my @match;
      for (1 .. ($match{p} * $match{c})) {
	push(@match, [ splice(@matchinfo, 0, 3) ]);
      };

      $match{$_} = \@match;
    }

    # Unknown character
    else {
      shift @matchinfo;
    };
  };
  return \%match;
};


# Create offsets function
sub offsets {
  my $self = shift;
  my $field = shift;

  # Use no multibyte characters
  # use bytes;

  # subroutine
  return sub {
    my $column = shift;
    'offsets(' . ($column // $field // 'content') . ')',
      sub {
	my $blob = shift;
	my @offset;
	my @array = split(/\s/, $blob);
	while (@array) {
	  push(@offset, [ splice(@array, 0, 4) ]);
	};
	return \@offset;
      }
    };
};


# Create snippet function
sub snippet {
  my $self = shift;

  # Snippet parameters
  my @snippet;

  # Parameters are given
  if ($_[0]) {
    my %snippet = ();

    # Parameters are given as a hash
    if ($_[0] =~ $arguments) {
      %snippet = @_;
      foreach (keys %snippet) {
	carp "Unknown snippet parameter '$_'" unless $_ =~ $arguments;
      };
    }

    # Parameters are given as an array
    else {
      @snippet{@arguments} = @_;
    };

    # Trim parameter array and fill gaps with defaults
    my ($s, $i) = (0, 0);
    foreach (reverse @arguments) {
      $s = 1 if defined $snippet{$_};
      unshift(@snippet, $snippet{$_} // $default[$i]) if $s;
      $i++;
    };
  };

  # Return anonymous subroutine
  my $sub = 'sub {
  my $column = $_[0] ? shift : \'content\';
  my $str = "snippet(" . $column ';

  if ($snippet[0]) {
    $sub .= ' . ", ' . join(',', map { '\"' . $_ . '\"' } @snippet) . '"';
  };

  $sub .= " . \")\";\n};";

  return eval( $sub );
};


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

  # Get object from superclass
  my $table = $self->SUPER::table(@_);

  # Add autocommit parameters
  foreach (qw/autocommit _autocounter
	     foreign_keys/) {
    $table->{$_} = $self->{$_};
  };

  # Return blessed object
  return $table;
};


# Set foreign_key pragma
sub foreign_keys {
  my $self = shift;

  # Get pragma
  unless (defined $_[0]) {
    return $self->{foreign_keys};
  }

  # Turn foreign keys on
  elsif ($_[0] && !$self->{foreign_keys}) {
    $self->dbh->do('PRAGMA foreign_keys = ON');
    return ($self->{foreign_keys} = 1);
  }

  # Turn foreign keys off
  elsif (!$_[0] && $self->{foreign_keys}) {
    $self->dbh->do('PRAGMA foreign_keys = OFF');
    return ($self->{foreign_keys} = 0);
  };

  return;
};


# Set autocommit
sub autocommit {
  my $self = shift;

  # Get autocommit
  unless (defined $_[0]) {
    return ${$self->{autocommit}} || 0;
  }

  # Set autocommit
  else {
    my $num = shift;
    my $dbh = $self->dbh;

    # Is a number
    if ($num && $num =~ m/^\d+/o) {
      if ($num > 1) {
	$dbh->{AutoCommit} = 0;
	${$self->{autocommit}} =
	  ${$self->{_autocounter}} = $num;
	return 1;
      }

      else {
	$dbh->{AutoCommit} = 1;
	${$self->{_autocounter}} =
	  ${$self->{autocommit}} = 0;
	return 1;
      };
    }

    # Is null
    elsif (!$num) {
      ${$self->{autocommit}} = 0;
      if (${$self->{_autocounter}}) {
	${$self->{_autocounter}} = 0;
	$dbh->commit;
      };
      $dbh->{AutoCommit} = 1 unless ${$self->{in_txn}};
      return 1;
    }

    # Failure
    else {
      return;
    };
  };
};


# Decrement commit counter
sub _decr_commit {
  my $self = shift;

  # Autocounter is set
  if (${$self->{_autocounter}}) {
    my $auto = --${$self->{_autocounter}};

    # Commit is null
    unless ($auto) {

      $self->dbh->commit unless ${$self->{in_txn}};
      ${$self->{_autocounter}} = ${$self->{autocommit}};
    };
  };
};


1;


__END__