File Coverage

blib/lib/ORLite.pm

Criterion	Covered	Total	%
statement	340	374	90.9
branch	159	206	77.1
condition	26	39	66.6
subroutine	52	54	96.3
pod	1	2	50.0
total	578	675	85.6

package ORLite; # git description: v1.99-6-gde873f7

# See POD at end of file for documentation

use 5.006;
use strict;
use Carp              ();
use File::Spec   0.80 ();
use File::Path   2.08 ();
use File::Basename    ();
use Params::Util 1.00 ();
use DBI         1.607 ();
use DBD::SQLite  1.27 ();

our $VERSION = '2.00';

# Support for the 'prune' option
my @PRUNE = ();
END {
	foreach ( reverse @PRUNE ) {
		next unless -e $_;
		require File::Remove;
		File::Remove::remove( \1, $_ );
	}
}





#####################################################################
# Code Generation

sub import {
	my $class = ref($_[0]) || $_[0];

	# Check for debug mode
	my $DEBUG = 0;
	if ( defined Params::Util::_STRING($_[-1]) and $_[-1] eq '-DEBUG' ) {
		$DEBUG = 1;
		pop @_;
	}

	# Check params and apply defaults
	my %params = (
		# Simple defaults here, complex defaults later
		package    => scalar(caller),
		create     => 0,
		cleanup    => '',
		array      => 0,
		xsaccessor => 0,
		shim       => 0,
		tables     => 1,
		views      => 0,
		unicode    => 0,
	);
	if ( defined Params::Util::_STRING($_[1]) ) {
		# Support the short form "use ORLite 'db.sqlite'"
		$params{file} = $_[1];
	} elsif ( Params::Util::_HASHLIKE($_[1]) ) {
		%params = ( %params, %{$_[1]} );
	} else {
		Carp::croak("Missing, empty or invalid params HASH");
	}
	unless (
		defined Params::Util::_STRING($params{file})
		and (
			$params{create}
			or
			-f $params{file}
		)
	) {
		Carp::croak("Missing or invalid file param");
	}
	unless ( defined $params{readonly} ) {
		$params{readonly} = $params{create} ? 0 : ! -w $params{file};
	}
	unless ( Params::Util::_CLASS($params{package}) ) {
		Carp::croak("Missing or invalid package class");
	}

	# Check caching params
	my $cached = undef;
	my $pkg    = $params{package};
	if ( defined $params{cache} ) {
		# Caching is illogical or invalid in some situations
		if ( $params{prune} ) {
			Carp::croak("Cannot set a 'cache' directory while 'prune' enabled");
		}
		unless ( $params{user_version} ) {
			Carp::croak("Cannot set a 'cache' directory without 'user_version'");
		}

		# To make the caching work, the version be defined before ORLite is called.
		no strict 'refs';
		unless ( ${"$pkg\::VERSION"} ) {
			Carp::croak("Cannot set a 'cache' directory without a package \$VERSION");
		}

		# Build the cache file from the super path using an inlined Class::ISA
		my @queue = ( $class );
		my %seen  = ( $pkg => 1 );
		my @parts = ( $pkg => ${"$pkg\::VERSION"} );
		while ( @queue ) {
			my $c = Params::Util::_STRING(shift @queue) or next;
			push @parts, $c => ${"$c\::VERSION"};
			unshift @queue, grep { not $seen{$c}++ } @{"$c\::ISA"};
		}
		$cached = join '-', @parts, user_version => $params{user_version};
		$cached =~ s/[:.-]+/-/g;
		$cached = File::Spec->rel2abs(
			File::Spec->catfile( $params{cache}, "$cached.pm" )
		);
	}

	# Create the parent directory if needed
	my $file    = File::Spec->rel2abs($params{file});
	my $created = ! -f $params{file};
	if ( $created ) {
		my $dir = File::Basename::dirname($file);
		unless ( -d $dir ) {
			my @dirs = File::Path::mkpath( $dir, { verbose => 0 } );
			$class->prune(@dirs) if $params{prune};
		}
		$class->prune($file) if $params{prune};
	}

	# Connect to the database
	my $dsn = "dbi:SQLite:$file";
	my $dbh = DBI->connect( $dsn, undef, undef, {
		PrintError => 0,
		RaiseError => 1,
		ReadOnly   => $params{create} ? 0 : 1,
		$params{unicode} ? ( sqlite_unicode => 1 ) : ( ),
	} );

	# Schema custom creation support
	if ( $created and Params::Util::_CODELIKE($params{create}) ) {
		$params{create}->($dbh);
	}

	# Check the schema version before generating
	my $user_version = $dbh->selectrow_arrayref('pragma user_version')->[0];
	if ( exists $params{user_version} and $user_version != $params{user_version} ) {
		Carp::croak("Schema user_version mismatch (got $user_version, wanted $params{user_version})");
	}

	# If caching and the cached version exists, load and shortcut.
	# Don't try to catch exceptions, just let them blow up.
	if ( $cached and -f $cached ) {
		$dbh->disconnect;
		require $cached;
		return 1;
	}

	# Prepare to generate code
	my $cleanup    = $params{cleanup};
	my $readonly   = $params{readonly} ? "\n\t\tReadOnly => 1," : '';
	my $unicode    = $params{unicode} ? "\n\t\tsqlite_unicode => 1," : '';
	my $version    = $unicode ? '5.008005' : '5.006';

	# Generate the support package code
	my $code = <<"END_PERL";
package $pkg;

use $version;
use strict;
use Carp              ();
use DBI         1.607 ();
use DBD::SQLite  1.27 ();

my \$DBH = undef;

sub orlite { '$VERSION' }

sub sqlite { '$file' }

sub dsn { '$dsn' }

sub dbh {
	\$DBH or \$_[0]->connect;
}

sub connect {
	DBI->connect( \$_[0]->dsn, undef, undef, {
		PrintError => 0,
		RaiseError => 1,$readonly$unicode
	} );
}

sub connected {
	defined \$DBH;
}

sub prepare {
	shift->dbh->prepare(\@_);
}

sub do {
	shift->dbh->do(\@_);
}

sub selectall_arrayref {
	shift->dbh->selectall_arrayref(\@_);
}

sub selectall_hashref {
	shift->dbh->selectall_hashref(\@_);
}

sub selectcol_arrayref {
	shift->dbh->selectcol_arrayref(\@_);
}

sub selectrow_array {
	shift->dbh->selectrow_array(\@_);
}

sub selectrow_arrayref {
	shift->dbh->selectrow_arrayref(\@_);
}

sub selectrow_hashref {
	shift->dbh->selectrow_hashref(\@_);
}

sub pragma {
	\$_[0]->do("pragma \$_[1] = \$_[2]") if \@_ > 2;
	\$_[0]->selectrow_arrayref("pragma \$_[1]")->[0] if defined wantarray;
}

sub iterate {
	my \$class = shift;
	my \$call  = pop;
	my \$sth   = \$class->prepare(shift);
	\$sth->execute(\@_);
	while ( \$_ = \$sth->fetchrow_arrayref ) {
		\$call->() or return 1;;
	}
}

sub begin {
	\$DBH or
	\$DBH = \$_[0]->connect;
	\$DBH->begin_work;
}

sub rollback {
	\$DBH or return 1;
	\$DBH->rollback;
	\$DBH->disconnect;
	undef \$DBH;
	return 1;
}

sub rollback_begin {
	if ( \$DBH ) {
		\$DBH->rollback;
		\$DBH->begin_work;
	} else {
		\$_[0]->begin;
	}
	return 1;
}

END_PERL

	# If you are a read-write database, we even allow you
	# to commit your transactions.
	$code .= <<"END_PERL" unless $readonly;
sub commit {
	\$DBH or return 1;
	\$DBH->commit;
	\$DBH->disconnect;
	undef \$DBH;
	return 1;
}

sub commit_begin {
	if ( \$DBH ) {
		\$DBH->commit;
		\$DBH->begin_work;
	} else {
		\$_[0]->begin;
	}
	return 1;
}

END_PERL

	# Cleanup and shutdown operations
	if ( $cleanup ) {
		$code .= <<"END_PERL";
END {
	if ( \$DBH ) {
		\$DBH->rollback;
		\$DBH->do('$cleanup');
		\$DBH->disconnect;
		undef \$DBH;
	} else {
		$pkg->do('$cleanup');
	}
}

END_PERL
	} else {
		$code .= <<"END_PERL";
END {
	$pkg->rollback if \$DBH;
}

END_PERL
	}

	# Optionally generate the table classes
	my $tables = undef;
	if ( $params{tables} ) {
		# Capture the raw schema table information
		$tables = $dbh->selectall_arrayref(
			'select * from sqlite_master where name not like ? and type in ( ?, ? )',
			{ Slice => {} }, 'sqlite_%', 'table', 'view',
		);

		# Capture the raw schema information and do first-pass work
		foreach my $t ( @$tables ) {
			# Convenience pre-quoted form of the table name
			$t->{qname} = $dbh->quote_identifier(undef, undef, $t->{name});

			# What will be the class for this table
			$t->{class} = $t->{name};
			if ( $t->{class} ne lc $t->{class} ) {
				$t->{class} =~ s/([a-z])([A-Z])/${1}_${2}/g;
				$t->{class} =~ s/_+/_/g;
			}
			$t->{class} = ucfirst lc $t->{class};
			$t->{class} =~ s/_([a-z])/uc($1)/ge;
			$t->{class} = "${pkg}::$t->{class}";

			# Load the structural column list
			my $columns = $t->{columns} = $dbh->selectall_arrayref(
				"pragma table_info('$t->{name}')",
			 	{ Slice => {} },
			);

			# The list of columns we will select, which can
			# be different to the general list.
			my $select = $t->{select} = [ @$columns ];

			# Track array vs hash implementation on a per-table
			# basis so that we can force views to always be done
			# array-wise (to compensate for some weird SQLite
			# column quoting differences between tables and views
			$t->{array} = $params{array};
			if ( $t->{type} eq 'view' ) {
				$t->{array} = 1;
			}

			# Track usage of rowid on a per-table basis because
			# views don't always support rowid.
			$t->{rowid} = $t->{type} eq 'table';

			foreach my $c ( @$select ) {
				# Convenience escaping for the column names
				$c->{qname} = $dbh->quote_identifier($c->{name});

				# Affinity detection
				if ( $c->{type} =~ /INT/i ) {
					$c->{affinity} = 'INTEGER';
				} elsif ( $c->{type} =~ /(?:CHAR|CLOB|TEXT)/i ) {
					$c->{affinity} = 'TEXT';
				} elsif ( $c->{type} =~ /BLOB/i or not $c->{type} ) {
					$c->{affinity} = 'BLOB';

					# Unicode currently breaks BLOB columns
					if ( $unicode ) {
						die "BLOB column $t->{name}.$c->{name} is not supported in unicode database";
					}
				} elsif ( $c->{type} =~ /(?:REAL|FLOA|DOUB)/i ) {
					$c->{affinity} = 'REAL';
				} else {
					$c->{affinity} = 'NUMERIC';
				}
			}

			# Analyze the primary keys structure
			$t->{pk}  = [ grep { $_->{pk} } @$columns ];
			$t->{pkn} = scalar @{$t->{pk}};
			if ( $t->{pkn} == 1 ) {
				$t->{pk1} = $t->{pk}->[0];
				if ( $t->{pk1}->{affinity} eq 'INTEGER' ) {
					$t->{pki} = $t->{pk1};
				}
			}
			if ( $t->{pki} ) {
				$t->{rowid} &&= $t->{pki};
				if ( $t->{pki}->{name} eq $t->{name} . '_id' ) {
					$t->{id} = $t->{pki};
				}

			} elsif ( $t->{rowid} ) {
				# Add rowid to the query
				$t->{rowid} = {
					cid        => -1,
					name       => 'rowid',
					qname      => '"rowid"',
					type       => 'integer',
					affinity   => 'INTEGER',
					notnull    => 1,
					dflt_value => undef,
					pk         => 0,
				};
				push @$select, $t->{rowid};
			}

			# Do we allow object creation?
			$t->{create} = $t->{pkn};
			$t->{create} = 1 if $t->{rowid};
			$t->{create} = 0 if $readonly;

			# Generate the object keys for the columns
			if ( $t->{array} ) {
				foreach my $i ( 0 .. $#$select ) {
					$select->[$i]->{xs}  = $i;
					$select->[$i]->{key} = "[$i]";
				}
			} else {
				foreach my $c ( @$select ) {
					$c->{xs}  = "'$c->{name}'";
					$c->{key} = "{$c->{name}}";
				}
			}

			# Generate the main SQL fragments
			$t->{sql_scols}  = join ', ', map { $_->{qname} } @$select;
			$t->{sql_icols}  = join ', ', map { $_->{qname} } @$columns;
			$t->{sql_ivals}  = join ', ', ( '?' ) x scalar @$columns;
			$t->{sql_select} = "select $t->{sql_scols} from $t->{qname}";
			$t->{sql_insert} =
				"insert into $t->{qname} " .
				"( $t->{sql_icols} ) " .
				"values ( $t->{sql_ivals} )";
			$t->{sql_where} = join ' and ',
				map { "$_->{qname} = ?" } @{$t->{pk}};

			# Generate the new Perl fragments
			$t->{pl_new} = join "\n", map {
				$t->{array}
					? "\t\t\$attr{$_->{name}},"
					: "\t\t$_->{name} => \$attr{$_->{name}},"
			} @$columns;

			$t->{pl_insert} = join "\n", map {
				"\t\t\$self->$_->{key},"
			} @$columns;

			$t->{pl_fill} = '';
			if ( $t->{pki} ) {
				$t->{pl_fill} =
					"\t\$self->$t->{pki}->{key} " .
					"= \$dbh->func('last_insert_rowid') " .
					"unless \$self->$t->{pki}->{key};";
			} elsif ( $t->{rowid} ) {
				$t->{pl_fill} =
					"\t\$self->$t->{rowid}->{key} " .
					"= \$dbh->func('last_insert_rowid');";
			}
		}

		# Generate the foreign key metadata
		my %tindex = map { $_->{name} => $_ } @$tables;
		foreach my $t ( @$tables ) {
			# Locate the foreign keys
			my %fk     = ();
			my @fk_sql = $t->{sql} =~ /[(,]\s*(.+?REFERENCES.+?)\s*[,)]/g;

			# Extract the details
			foreach ( @fk_sql ) {
				unless ( /^(\w+).+?REFERENCES\s+(\w+)\s*\(\s*(\w+)/ ) {
					die "Invalid foreign key $_";
				}
				$fk{"$1"} = [ "$2", $tindex{"$2"}, "$3" ];
			}
			foreach ( @{$t->{columns}} ) {
				$_->{fk} = $fk{$_->{name}};
			}

			# One final code fragment we need the fk for
			$t->{pl_accessor} = join "\n",
				map { "\t\t$_->{name} => $_->{xs}," }
				grep { ! $_->{fk} } @{$t->{columns}};
		}

		# Generate the per-table code
		foreach my $t ( @$tables ) {
			my @select  = @{$t->{select}};
			my @columns = @{$t->{columns}};
			my $slice   = $t->{array}
				? '{}'
				: '{ Slice => {} }';

			# Generate the package header
			if ( $params{shim} ) {
				# Generate a shim-wrapper class
				$code .= <<"END_PERL";
package $t->{class};

\@$t->{class}::ISA = '$t->{class}::Shim';

package $t->{class}::Shim;

END_PERL
			} else {
				# Plain vanilla package header
				$code .= <<"END_PERL";
package $t->{class};

END_PERL
			}

			# Generate the common elements for all classes
			$code .= <<"END_PERL";
sub base { '$pkg' }

sub table { '$t->{name}' }

sub table_info {
	$pkg->selectall_arrayref(
		"pragma table_info('$t->{name}')",
		{ Slice => {} },
	);
}

sub select {
	my \$class = shift;
	my \$sql   = '$t->{sql_select} ';
	   \$sql  .= shift if \@_;
	my \$rows  = $pkg->selectall_arrayref( \$sql, $slice, \@_ );
	bless \$_, '$t->{class}' foreach \@\$rows;
	wantarray ? \@\$rows : \$rows;
}

sub count {
	my \$class = shift;
	my \$sql   = 'select count(*) from $t->{qname} ';
	   \$sql  .= shift if \@_;
	$pkg->selectrow_array( \$sql, {}, \@_ );
}

END_PERL

			# Handle different versions, because arrayref acts funny
			if ( $t->{array} ) {
				$code .= <<"END_PERL";
sub iterate {
	my \$class = shift;
	my \$call  = pop;
	my \$sql   = '$t->{sql_select} ';
	   \$sql  .= shift if \@_;
	my \$sth   = $pkg->prepare(\$sql);
	\$sth->execute(\@_);
	while ( \$_ = \$sth->fetchrow_arrayref ) {
		\$_ = bless [ \@\$_ ], '$t->{class}';
		\$call->() or last;
	}
	\$sth->finish;
}

END_PERL
			} else {
				$code .= <<"END_PERL";
sub iterate {
	my \$class = shift;
	my \$call  = pop;
	my \$sql   = '$t->{sql_select} ';
	   \$sql  .= shift if \@_;
	my \$sth   = $pkg->prepare(\$sql);
	\$sth->execute(\@_);
	while ( \$_ = \$sth->fetchrow_hashref ) {
		bless \$_, '$t->{class}';
		\$call->() or last;
	}
	\$sth->finish;
}

END_PERL
			}

			# Add the primary key based single object loader
			if ( $t->{pkn} ) {
				if ( $t->{array} ) {
					$code .= <<"END_PERL";
sub load {
	my \$class = shift;
	my \@row   = $pkg->selectrow_array(
		'$t->{sql_select} where $t->{sql_where}',
		undef, \@_,
	);
	unless ( \@row ) {
		Carp::croak("$t->{class} row does not exist");
	}
	bless \\\@row, '$t->{class}';
}

END_PERL
				} else {
					$code .= <<"END_PERL";
sub load {
	my \$class = shift;
	my \$row   = $pkg->selectrow_hashref(
		'$t->{sql_select} where $t->{sql_where}',
		undef, \@_,
	);
	unless ( \$row ) {
		Carp::croak("$t->{class} row does not exist");
	}
	bless \$row, '$t->{class}';
}

END_PERL
				}
			}

			# Generate the elements for tables with primary keys
			if ( $t->{create} ) {
				my $l   = $t->{array} ? '['  : '{';
				my $r   = $t->{array} ? ']'  : '}';
				my $set = $t->{array}
					? '$self->set( $_ => $set{$_} ) foreach keys %set;'
					: '$self->{$_} = $set{$_} foreach keys %set;';
				$code .= <<"END_PERL";
sub new {
	my \$class = shift;
	my \%attr  = \@_;
	bless $l
$t->{pl_new}
	$r, \$class;
}

sub create {
	shift->new(\@_)->insert;
}

sub insert {
	my \$self = shift;
	my \$dbh  = $pkg->dbh;
	\$dbh->do(
		'$t->{sql_insert}',
		{},
$t->{pl_insert}
	);
$t->{pl_fill}
	return \$self;
}

sub update {
	my \$self = shift;
	my \%set  = \@_;
	my \$rows = $pkg->do(
		'update $t->{qname} set ' .
		join( ', ', map { "\\"\$_\\" = ?" } keys \%set ) .
		' where "rowid" = ?',
		{},
		values \%set,
		\$self->rowid,
	);
	unless ( \$rows == 1 ) {
		Carp::croak("Expected to update 1 row, actually updated \$rows");
	}
	$set
	return 1;
}

sub delete {
	return $pkg->do(
		'delete from $t->{qname} where "rowid" = ?', {},
		shift->rowid,
	) if ref \$_[0];
	Carp::croak("Static $pkg->delete has been deprecated");
}

sub delete_where {
	shift; $pkg->do('delete from $t->{qname} where ' . shift, {}, \@_);
}

sub truncate {
	$pkg->do('delete from $t->{qname}');
}

END_PERL
			}

			if ( $t->{create} and $t->{array} ) {
				# Add an additional set method to avoid having
				# the user have to enter manual positions.
				$code .= <<"END_PERL";
sub set {
	my \$self = shift;
	my \$i    = {
$t->{pl_accessor}
	}->{\$_[0]};
	Carp::croak("Bad name '\$_[0]'") unless defined \$i;
	\$self->[\$i] = \$_[1];
}

END_PERL
			}

			# Generate the boring accessors
			if ( $params{xsaccessor} ) {
				my $type    = $t->{create} ? 'accessors' : 'getters';
				my $xsclass = $t->{array}
					? 'Class::XSAccessor::Array'
					: 'Class::XSAccessor';
				my $id = $t->{id}
					? "\t\t$t->{id}->{name} => $t->{id}->{xs},\n"
					: '';
				my $rowid = ($t->{id} and $t->{rowid})
					? "\t\t$t->{rowid}->{name} => $t->{rowid}->{xs},\n"
					: '';

				$code .= <<"END_PERL";
use $xsclass 1.05 {
	getters => {
${rowid}${id}$t->{pl_accessor}
	},
};

END_PERL
			} else {
				if ( $t->{pki} and $t->{rowid} ) {
					$code .= <<"END_PERL";
sub rowid {
	\$_[0]->$t->{rowid}->{key};
}

END_PERL
				}

				if ( $t->{id} ) {
					$code .= <<"END_PERL";
sub id {
	\$_[0]->$t->{id}->{key};
}

END_PERL
				}

				$code .= join "\n\n", map { <<"END_PERL" } grep { ! $_->{fk} } @select;
sub $_->{name} {
	\$_[0]->$_->{key};
}
END_PERL
			}

			# Generate the foreign key accessors
			$code .= join "\n\n", map { <<"END_PERL" } grep { $_->{fk} } @columns;
sub $_->{name} {
	($_->{fk}->[1]->{class}\->select('where \"$_->{fk}->[1]->{pk}->[0]->{name}\" = ?', \$_[0]->$_->{key}))[0];
}
END_PERL
		}
	}

	# We are finished with the database
	$dbh->disconnect;

	# Start the post-table content again
	$code .= "\npackage $pkg;\n" if $params{tables};

	# Append any custom code for the user
	$code .= "\n$params{append}" if defined $params{append};

	# Load the overload classes for each of the tables
	if ( $tables ) {
		$code .= join( "\n",
			"local \$@ = undef;",
			map {
				"eval { require $_->{class} };"
			} @$tables
		);
	}

	# End the class normally
	$code .= "\n\n1;\n";

	# Save to the cache location if caching is enabled
	if ( $cached ) {
		my $dir = File::Basename::dirname($cached);
		unless ( -d $dir ) {
			File::Path::mkpath( $dir, { verbose => 0 } );
		}

		# Save a copy of the code to the file
		local *FILE;
		open( FILE, ">$cached" ) or Carp::croak("open($cached): $!");
		print FILE $code;
		close FILE;
	}

	# Compile the code
	local $@;
	if ( $^P and $^V >= 5.008009 ) {
		local $^P = $^P | 0x800;
		eval($code);
		die $@ if $@;
	} elsif ( $DEBUG ) {
		dval($code);
	} else {
		eval($code);
		die $@ if $@;
	}

	return 1;
}

sub dval {
	# Write the code to the temp file
	require File::Temp;
	my ($fh, $filename) = File::Temp::tempfile();
	$fh->print($_[0]);
	close $fh;
	require $filename;
	unlink $filename;

	# Print the debugging output
	# my @trace = map {
		# s/\s*[{;]$//;
		# s/^s/  s/;
		# s/^p/\np/;
		# "$_\n"
	# } grep {
		# /^(?:package|sub)\b/
	# } split /\n/, $_[0];
	# print STDERR @trace, "\nCode saved as $filename\n\n";

	return 1;
}

sub prune {
	my $class = shift;
	push @PRUNE, map { File::Spec->rel2abs($_) } @_;
}

1;

__END__