File Coverage

lib/File/Properties/Database.pm

Criterion	Covered	Total	%
statement	189	221	85.5
branch	51	80	63.7
condition	21	51	41.1
subroutine	26	30	86.6
pod	13	14	92.8
total	300	396	75.7

# ----------------------------------------------------------------------------
#
# This module provides an interface to the SQLite database used to
# cache data for File::Properties modules.
#
# Copyright © 2010,2011 Brendt Wohlberg
# See distribution LICENSE file for license details.
#
# Most recent modification: 5 November 2011
#
# ----------------------------------------------------------------------------

package File::Properties::Database;
our $VERSION = 0.01;

use File::Properties::Error;

require 5.005;
use strict;
use warnings;
use DBI qw(:sql_types);
use DBD::SQLite;
use Error qw(:try);


# ----------------------------------------------------------------------------
# Constructor
# ----------------------------------------------------------------------------
sub new {
  my $clss = shift;

  my $self = {};
  bless $self, $clss;
  $self->_init(@_);
  return $self;
}


# ----------------------------------------------------------------------------
# Initialiser
# ----------------------------------------------------------------------------
sub _init {
  my $self = shift;
  my $dbfp = shift; # Database file path
  my $opts = shift; # Options hash

  $opts = {} if undef $opts;
  # Throw exception if DB file $dpfp does not exist and 'NoCreate'
  # option is true.
  throw File::Properties::Error("DBI file $dbfp not found")
    if $opts->{'NoCreate'} and (not defined $dbfp or not -f $dbfp);
  # If DB file not specified, construct it in memory
  $dbfp = ':memory:' if (not defined $dbfp);
  ## Throw exception if error encountered opening DBI connection
  my $dbh = _dbopen($dbfp, $opts->{'ReadOnly'}?1:0);
  throw File::Properties::Error("Error opening DBI interface to file $dbfp")
      if not defined($dbh);
  # Record constructor options
  $self->opts($opts);
  # Record SQLite DBI interface
  $self->dbi($dbh);
  # Table column specifications
  $self->definedcolumns(undef,{});
}


# ----------------------------------------------------------------------------
# Destructor
# ----------------------------------------------------------------------------
sub DESTROY {
  my $self = shift;

  _dbclose($self->dbi);
}


# ----------------------------------------------------------------------------
# Get (or set) options specified at initialisation
# ----------------------------------------------------------------------------
sub opts {
  my $self = shift;

  $self->{'opts'} = shift if (@_);
  return $self->{'opts'}
}


# ----------------------------------------------------------------------------
# Get (or set) dbi handle
# ----------------------------------------------------------------------------
sub dbi {
  my $self = shift;

  $self->{'dbih'} = shift if (@_);
  return $self->{'dbih'}
}


# ----------------------------------------------------------------------------
# Get (or set) table column specification hash or hash entry
# ----------------------------------------------------------------------------
sub definedcolumns {
  my $self = shift;
  my $tbnm = shift; # Table name

  ## If table name is defined, additional parameter specifies new
  ## value for that hash entry, otherwise the additional parameter
  ## specifies new value for entire hash
  if (@_) {
    if (defined $tbnm) {
      $self->{'tblc'}->{$tbnm} = shift;
    } else {
      $self->{'tblc'} = shift;
    }
  }

  ## If table name is specified and the corresponding entry is not
  ## defined, obtain the column names from the SQL database
  if (defined $tbnm and not defined $self->{'tblc'}->{$tbnm}) {
    $self->{'tblc'}->{$tbnm} = $self->columns($tbnm);
  }

  # Return hash reference, or hash entry if table name specified
  return (defined $tbnm)? $self->{'tblc'}->{$tbnm}:$self->{'tblc'};
}


# ----------------------------------------------------------------------------
# Execute SQL command
# ----------------------------------------------------------------------------
sub sql {
  my $self = shift;
  my $sqlc = shift; # SQL command text

  return $self->dbi->do($sqlc);
}


# ----------------------------------------------------------------------------
# Define (and initialise) table
# ----------------------------------------------------------------------------
sub definetable {
  my $self = shift;
  my $tbnm = shift; # Table name
  my $cols = shift; # Column specification

  ## Create table if it doesn't exist. WARNING: when the table already
  ## exists, there is currently not a test to ensure that the existing
  ## layout matches the column specification in the arguments to this
  ## method
  my $sqlc = "CREATE TABLE IF NOT EXISTS $tbnm (" . join(',',@$cols) . ');';
  my $drtv = $self->sql($sqlc);
  # Record column names for this table
  $self->definedcolumns($tbnm, [map { /^[^\s]+/; $& } @$cols]);
  return $drtv;
}


# ----------------------------------------------------------------------------
# Insert rows into table
# ----------------------------------------------------------------------------
sub insert {
  my $self = shift;
  my $tbnm = shift; # Table name
  my $opts = shift; # Insert options

  # Determine column names for insert
  my $clnm = $self->_optioncols($tbnm, $opts);
  # Determine data for insert
  my $data = _optiondata($tbnm, $clnm, $opts);
  # Start transaction (autocommit off)
  $self->dbi->begin_work or
    throw File::Properties::Error("DBI error ".$self->dbi->errstr);
  # Construct string describing columns corresponding to row data,
  # using either specified array of column names, or recorded column
  # names for this table
  my $clst = join(',',@$clnm);
  # Construct insert statement
  my $sqlc = "INSERT INTO $tbnm ($clst) VALUES (" .
    join(',', map { '?' } @$clnm) . ');';
  # Prepare for insertion
  my $sth = $self->dbi->prepare($sqlc);
  # Execute insertion
  return $self->_executedata($sth, $data);
}


# ----------------------------------------------------------------------------
# Update rows in table
# ----------------------------------------------------------------------------
sub update {
  my $self = shift;
  my $tbnm = shift; # Table name
  my $opts = shift; # Update options

  # Determine column names for update
  my $clnm = $self->_optioncols($tbnm, $opts);
  # Determine data for update
  my $data = _optiondata($tbnm, $clnm, $opts);
  # Start transaction (autocommit off)
  $self->dbi->begin_work or
    throw File::Properties::Error("DBI error ".$self->dbi->errstr);
  # Construct update statement
  my $sqlc = "UPDATE $tbnm SET " . join(',', map { "$_=?" } @$clnm);
  $sqlc .= _optionwhere($opts);
  # Prepare for update
  my $sth = $self->dbi->prepare($sqlc);
  # Execute update
  return $self->_executedata($sth, $data);
}


# ----------------------------------------------------------------------------
# Select data from table
# ----------------------------------------------------------------------------
sub retrieve {
  my $self = shift;
  my $tbnm = shift; # Table name
  my $opts = shift; # Select options

  my $slc = 'SELECT ';
  # Select statement includes DISTINCT if 'Distint' option true
  $slc .= 'DISTINCT ' if (ref($opts) eq 'HASH' and $opts->{'Distinct'});
  my ($ncl, $cln);
  ## List of returned columns is constructed from the array provided
  ## with the 'Columns' option, otherwise all columns are returned
  if (ref($opts) eq 'HASH' and ref($opts->{'Columns'}) eq 'ARRAY') {
    $slc .= join(',',@{$opts->{'Columns'}}) . ' ';
    $cln = $opts->{'Columns'};
    $ncl = scalar @$cln;
  } else {
    $slc .= '* ';
    $cln = $self->definedcolumns($tbnm);
    $ncl = scalar @$cln;
  }
  # Append FROM and WHERE clauses to select statement
  $slc .= "FROM $tbnm " . _optionwhere($opts);
  # Append optional additional clauses to select statement
  $slc .= $opts->{'Suffix'} if (ref($opts) eq 'HASH' and $opts->{'Suffix'});
  # Check option 'ReturnType' for invalid values
  throw File::Properties::Error("Option 'ReturnType' may only have".
				"values 'Array' or 'Hash'")
    if (ref($opts) eq 'HASH' and defined($opts->{'ReturnType'}) and
        not($opts->{'ReturnType'} eq 'Array' or
	    $opts->{'ReturnType'} eq 'Hash'));
  ## DBI method for retrieving data depends on options 'ReturnType'
  ## and 'FirstRow'. If 'ReturnType' is not specified, data is
  ## retrieved as an array. If 'FirstRow' option is unspecified, or is
  ## false, a single row is returned.
  my $dat = undef;
  if (ref($opts) eq 'HASH' and defined($opts->{'ReturnType'}) and
      $opts->{'ReturnType'} eq 'Hash') {
    if (ref($opts) eq 'HASH' and $opts->{'FirstRow'}) {
      # Retrieve single row as a hash indexed by column names
      $dat = $self->dbi->selectrow_hashref($slc);
    } else {
      # Retrieve rows as an array of arrays
      my $adt = $self->dbi->selectall_arrayref($slc);
      ## Map array to hash of arrays indexed by column names
      $dat = {};
      map { $dat->{$_} = [] } @$cln;
      map { my $r = $_; map { push @{$dat->{$cln->[$_]}}, $r->[$_] }
	      @{[0 .. (scalar @$cln-1)]} } @$adt;
    }
  } else {
    if (ref($opts) eq 'HASH' and $opts->{'FirstRow'}) {
      # Retrieve single row as an array
      $dat = $self->dbi->selectrow_arrayref($slc);
    } else {
      # Retrieve rows as an array of arrays
      $dat = $self->dbi->selectall_arrayref($slc);
    }
  }

  return $dat;
}


# ----------------------------------------------------------------------------
# Remove data from table
# ----------------------------------------------------------------------------
sub remove {
  my $self = shift;
  my $tbnm = shift; # Table name
  my $opts = shift; # Delete options

  # Throw exception if options hash includes neither a 'Where'
  # constraint nor the 'RemoveAll' flag
  throw File::Properties::Error("Method remove called without row selection")
    if (ref($opts) ne 'HASH' or (not defined $opts->{'Where'}
				 #and not defined $opts->{'Suffix'}
				 and not $opts->{'RemoveAll'}));
  # Set up SQL DELETE statement
  my $sqlc = "DELETE FROM $tbnm "._optionwhere($opts);
  ## Append optional additional clauses to delete statement
  #$sqlc .= $opts->{'Suffix'} if (ref($opts) eq 'HASH' and $opts->{'Suffix'});
  # Execute SQL DELETE statement
  return $self->sql($sqlc);
}


# ----------------------------------------------------------------------------
# Determine names of all tables
# ----------------------------------------------------------------------------
sub tables {
  my $self = shift;

  # Set up SQL statement
  my $sqlc = "SELECT * FROM sqlite_master WHERE type = 'table'";
  # Execute SQL statement
  my $rar = $self->dbi->selectall_arrayref($sqlc);
  return [map { $_->[1] } @$rar];
}


# ----------------------------------------------------------------------------
# Determine names of columns in specified table
# ----------------------------------------------------------------------------
sub columns {
  my $self = shift;
  my $tbnm = shift; # Table name

  # Set up SQL statement
  my $sqlc = "PRAGMA table_info($tbnm)";
  # Execute SQL statement
  my $rar = $self->dbi->selectall_arrayref($sqlc);
  return [map { $_->[1] } @$rar];
}


# ----------------------------------------------------------------------------
# Determine number of rows in specified table
# ----------------------------------------------------------------------------
sub numrows {
  my $self = shift;
  my $tbnm = shift; # Table name

  # Set up SQL statement
  my $sqlc = "SELECT Count(*) FROM $tbnm";
  # Execute SQL statement
  my $rar = $self->dbi->selectall_arrayref($sqlc);
  return $rar->[0]->[0];
}


# ----------------------------------------------------------------------------
# Determine whether table exists
# ----------------------------------------------------------------------------
sub tableexists {
  my $self = shift;
  my $tbnm = shift; # Table name

  return _tableexists($self->dbi, $tbnm);
}


# ----------------------------------------------------------------------------
# Create column name array for insert and update operations
# ----------------------------------------------------------------------------
sub _optioncols {
  my $self = shift;
  my $tbnm = shift; # Table name
  my $opts = shift; # Options hash

  ## Column names are taken from keys of the 'Data' option if it is a
  ## hash, otherwise from 'Columns' option if provided, otherwise
  ## assumed to be all columns in table order
  my $clnm;
  if (ref($opts) eq 'HASH') {
    if (ref($opts->{'Data'}) eq 'HASH') {
      $clnm = [sort keys %{$opts->{'Data'}}];
    } elsif (ref($opts->{'Columns'}) eq 'ARRAY') {
      $clnm = $opts->{'Columns'};
    } else {
      $clnm = $self->definedcolumns($tbnm);
    }
  } else {
    $clnm = $self->definedcolumns($tbnm);
  }

  return $clnm;
}


# ----------------------------------------------------------------------------
# Create data array for insert and update operations
# ----------------------------------------------------------------------------
sub _optiondata {
  my $tbnm = shift; # Table name
  my $clnm = shift; # Column names
  my $opts = shift; # Options hash

  ## If 'Data' option provided, process it into a form ready for
  ## insertion
  my $data = undef;
  if (ref($opts) eq 'HASH' and ref($opts->{'Data'})) {
    # Data is provided as a hash
    if (ref($opts->{'Data'}) eq 'HASH') {
      # If first column in hash is an array reference, assume all
      # columns are array references, specifying multiple insertion
      # rows
      if (ref($opts->{'Data'}->{$clnm->[0]}) eq 'ARRAY') {
	$data = [];
	my $nrow = scalar @{$opts->{'Data'}->{$clnm->[0]}};
	for (my $n = 0; $n < $nrow; $n++) {
	  push @$data, [map { $opts->{'Data'}->{$_}->[$n] } @$clnm];
	}
      }
      # Assume that only a single row is to be inserted
      else {
	$data = [[map { $opts->{'Data'}->{$_} } @$clnm]];
      }
    }
    # Data is provided as an array
    elsif (ref($opts->{'Data'}) eq 'ARRAY') {
      # If the first entry in the array is an array reference, assume
      # multiple insertion rows are provided
      if (ref($opts->{'Data'}->[0]) eq 'ARRAY') {
	$data = $opts->{'Data'};
      }
      # Assume that only a single row is to be inserted
      else {
	$data = [[@{$opts->{'Data'}}]];
      }
    } else {
      throw File::Properties::Error("Data option must be a hash or an array");
    }
  }

  return $data;
}


# ----------------------------------------------------------------------------
# Create where statement for retrieve and remove operations
# ----------------------------------------------------------------------------
sub _optionwhere {
  my $opts = shift; # Options hash

  my $whr = '';
  ## If option 'Where' is a hash reference, key/value pairs are
  ## assumed to correspond to column name/value pairs in a conjunction
  ## of equality constraints in a WHERE clause. If it is not a hash
  ## reference, the value is assume to be a string containing the
  ## WHERE clause.
  if (ref($opts) eq 'HASH' and defined $opts->{'Where'}) {
    if (ref($opts->{'Where'}) eq 'HASH') {
      $whr .= " WHERE " . join ' AND ',
	map { "$_='$opts->{'Where'}->{$_}'" } keys %{$opts->{'Where'}};
    } else {
      $whr .= " WHERE " . $opts->{'Where'};
    }
  }

  return $whr;
}


# ----------------------------------------------------------------------------
# Execute statement handle object over specified data
# ----------------------------------------------------------------------------
sub _executedata {
  my $self = shift;
  my $sth = shift;  # Statement handle object
  my $data = shift; # Data array

  ## If data provided, insert each row and then commit,
  ## otherwise return the statement handle object from prepare
  if (defined $data) {
    my $row;
    foreach $row (@$data) {
      $sth->execute(@$row) or
	throw File::Properties::Error("DBI error ".$self->dbi->errstr);
    }
    if (not $self->dbi->commit) {
      my $err = $self->dbi->errstr;
      $self->dbi->rollback;
      throw File::Properties::Error("DBI error $err");
    }
    return $data;
  } else {
    return $sth;
  }
}


# ----------------------------------------------------------------------------
# Connect to SQLite database
# ----------------------------------------------------------------------------
sub _dbopen {
  my $dbf = shift; # DB file path
  my $rof = shift; # Read only flag

  my $dbh = DBI->connect("dbi:SQLite:dbname=$dbf",'','',
			 { ReadOnly   => $rof,
			   AutoCommit => 1,
			   PrintError => 0,
			   RaiseError => 1,
			   HandleError =>
			     sub {throw File::Properties::Error($_[0])} });
  $dbh->{sqlite_unicode} = 1 if defined $dbh;
  return $dbh;
}


# ----------------------------------------------------------------------------
# Disconnect from SQLite database
# ----------------------------------------------------------------------------
sub _dbclose {
  my $dbh = shift; # DBI handle

  $dbh->disconnect();
}


# ----------------------------------------------------------------------------
# Determine whether specified table exists in database
# ----------------------------------------------------------------------------
sub _tableexists {
  my $dbs = shift; # DBI handle or DB file path
  my $tbl = shift; # Table name

  my $dbh;
  ## If $dbs is a DBI handle, use that handle for database access,
  ## otherwise assume it is the path to an SQLite DB file and attempt
  ## to open it.
  if (ref($dbs) eq 'DBI::db') {
    $dbh = $dbs;
  } else {
    my $dbf = $dbs;
    return 0 if not -f $dbf;
    $dbh = DBI->connect("dbi:SQLite:$dbf",'','', {PrintError => 0,
						  RaiseError => 0});
    return 0 if not defined $dbh;
  }
  ## Determine whether named table exists
  my $slc = "SELECT NAME FROM sqlite_master WHERE TYPE='table' ".
            "AND NAME='$tbl'";
  my $a = $dbh->selectrow_arrayref($slc);
  # Close database connection if it was opened in this function
  $dbh->disconnect() if not ref($dbs) eq 'DBI::db';
  return (defined $a)?(@$a > 0):0;
}


# ----------------------------------------------------------------------------
# End of method definitions
# ----------------------------------------------------------------------------


1;
__END__