File Coverage

blib/lib/IPC/Lite.pm

Criterion	Covered	Total	%
statement	345	446	77.3
branch	154	234	65.8
condition	11	23	47.8
subroutine	42	47	89.3
pod	2	22	9.0
total	554	772	71.7

package IPC::Lite;

# Combination of vars.pm, Tie::DBI, and IPC
# Wanted to called it "shared" .... ie: "use shared qw($var)"
# but shared memory is sketchy at best, whereas SQLite works
# on most platforms

our $VERSION = '0.5.' . [qw$Revision: 40 $]->[1];

use warnings::register;
use strict;

#use strict qw(vars subs);

use DBI;
use DBD::SQLite;

# Can set this directly if desired

our %DEFAULT_PATH;
our %DEFAULT_TTL;
our %DEFAULT_KEY;
our $DEBUG;

my %DBS;

#$SIG{__DIE__} = \&fatalerror;

# this code from vars.pm, since we can't adjust the "callpack"
sub import {
#hereiam();
    my $callpack = caller;
    my ($pack, @imports) = @_;
    my ($sym, $ch, $sym_n);
    my %opts;

    my $imps;

    my $i = -1;
    foreach (@imports) {
	++$i;
        if (($ch, $sym) = /^([\$\@\%])(.+)/) {
	    no strict 'refs';
	    no warnings 'uninitialized';
	    if ($sym =~ /\W/) {
		# time for a more-detailed check-up
		if ($sym =~ /^\w+[[{].*[]}]$/) {
		    require Carp;
		    Carp::croak("Can't declare individual elements of hash or array");
		} elsif (warnings::enabled() and length($sym) == 1 and $sym !~ tr/a-zA-Z//) {
		    warnings::warn("No need to declare built-in vars");
		} elsif  (($^H &= strict::bits('vars'))) {
		    require Carp;
		    Carp::croak("'$_' is not a valid variable name under strict vars");
		}
	    }
	    # don't put "main::" on every table entry, too ugly
	    $sym_n = $sym;
	    $sym = "${callpack}::$sym" unless $sym =~ /::/;
	    $sym_n = $sym unless $callpack eq 'main';
	    *$sym =
		(  $ch eq "\$" ? \$$sym
		 : $ch eq "\@" ? \@$sym
		 : $ch eq "\%" ? \%$sym
		 : do {
		     require Carp;
		     Carp::croak("'$_' is not a valid variable name");
		 });
	    eval("tie ${ch}$sym, '$pack', \%opts, sym=>'$sym_n';");
	    if ($@) {
                    require Carp;
                    Carp::croak("'$_' problem with tie: $@");
	    }
	    ++$imps;
	} else {
	    if ($_ =~ /^(ttl|timeout)$/i) {
		$opts{ttl} = splice @imports, $i+1, 1;
		$opts{ttl} = $1 if $opts{ttl} =~ s/\s*\b(\d+)(s|\s*seconds)\b\s*//;
		$opts{ttl} = 86400 * $1 + ($opts{ttl} ? $opts{ttl} : 0) if $opts{ttl} =~ s/\s*\b(\d+)(d|\s*days)\b\s*//;
		next;
	    }
            if ($_ =~ /^path$/i) {
                $opts{path} = splice @imports, $i+1, 1;
                next;
            }
            if ($_ =~ /^key$/i) {
                $opts{key} = splice @imports, $i+1, 1;
                next;
            }
	    require Carp;
	    Carp::croak("'$_' is not a valid variable name for $pack");
	}
    }

    # assume user wanted to set global defaults instead
    if (!$imps) {
    	$DEFAULT_PATH{$callpack} = $opts{path} if $opts{path};
    	$DEFAULT_TTL{$callpack} = $opts{ttl} if $opts{ttl};
    	$DEFAULT_KEY{$callpack} = $opts{key} if $opts{key};
    }
};


#### public methods

sub path {
	return $_[0]->{path};
}

sub db {
        return $_[0]->{db};
}

#### create tables

sub create_vars_table {
	my ($db) = @_;
	create_table($db, "vars",  "(styp text, sym text int, exp int, primary key (styp, sym))");
}

sub create_scalar_table {
        my ($db) = @_;
        create_table($db, "scalar","(sym text primary key, val text, vtyp text)");
}

sub create_array_table {
        my ($db) = @_;
        create_table($db, "array", "(sym text, ind int, val text, vtyp text, primary key (sym, ind));")
}

sub create_hash_table {
        my ($db) = @_;
        create_table($db, "hash" , "(sym text, key text, val text, vtyp text, primary key (sym, key));");
}

sub create_hash_subtable {
        my ($db, $name) = @_;
        create_table($db, $name,   "(key text primary key, val text, vtyp text);");
}

sub create_array_subtable {
        my ($db, $name) = @_;
        create_table($db, $name,   "(ind text primary key, val text, vtyp text);");
}


sub create_table {
        my ($db, $name, $fds) = @_;
	$db->do("create table if not exists $name $fds");
	return 1;
}

## connect to db

sub open_pathdb {
	my ($self) = @_;
	my $path = $self->{path};
	my $db = {};
	my $tid = threadid();
	if (!($db = $DBS{$tid}{$path})) {
		my $connstr;
		$db = DBI->connect("dbi:SQLite:dbname=$path", "", "", {PrintError=>0, AutoCommit=>1});
		if ($db) {
			$db->{PrintError} = 0;
		} else {
			require Carp;
		    	Carp::croak("Can't create db at $path: " . DBI->errstr);
		}
		$db->{RaiseError} = 1;
		$DBS{$tid}{$path} = $db;
	}
	$self->{tid} = $tid;
	$self->{db} = $db;
}

# get caller's package... ignoring IPC::Lite

sub getcallpack {
	my $self = shift;
        my ($callpack, $callframe) = ('', 2);

        while (($callpack = scalar caller($callframe)) eq ref($self)) {
                ++$callframe;
        }
	return $callpack;
}

# generic tie_var, called by TIESCALAR, TIEHASH, TIEARRAY

sub tie_var {
	my $type = shift;
        my $pack = shift;

        my $self = {};

	my %opts = @_;
	for (keys(%opts)) {
		$self->{lc($_)} = $opts{$_};
	}

        bless $self, $pack;
	$self->{type} = $type;

	my $callpack;

	# get package defaults

	if (!defined($self->{ttl})) {
		$callpack = $self->getcallpack() unless $callpack;
		$self->{ttl} = $DEFAULT_TTL{$callpack};
	}

	# if there's no path or key, check for default key
        if (!$self->{path} && !$self->{key}) {
		$callpack = $self->getcallpack() unless $callpack;
		$self->{key} = $DEFAULT_KEY{$callpack};
	}

	if ($self->{key}) {
		$self->{path} = nametopath($self->{key});
		delete $self->{key};	# don't inherit
	}

	# still no path, get default path
        if (!$self->{path}) {
		$callpack = $self->getcallpack() unless $callpack;
                $self->{path} = $self->defaultpath($callpack);
        };

        $self->open_pathdb();

	if ($self->{sym}) {
		print "tie: '$self->{sym}' styp '$self->{type}'\n" if $DEBUG;
		if ($self->{ttl}) {
			create_vars_table($self->{db});
			my $exp = time() + $self->{ttl};
			my $up = $self->dbexec('refincr', "update vars set exp=? where sym=? and styp=?",
					$exp, $self->{sym}, $self->{type});
			if ($up == 0) {
				$self->dbexec('refins', "insert into vars (sym, styp, exp) values (?, ?, ?);",
					$self->{sym}, $self->{type}, $exp);
			}
		}
	} elsif ($self->{table}) {
		if ($self->{type} eq '$') {
			require Carp;
			croak("Won't bind scalar to its own table");
		}
		print "tie: '$self->{table}' styp '$self->{type}'\n" if $DEBUG;
	} else {
		require Carp;
		Carp::croak("Need sym or table for IPC::Lite");
	}

	return $self;
}

sub cleanup {
	for my $tid_dbs (values(%DBS)) {
	for my $db (values(%$tid_dbs)) {
		my $st = dbexec($db, 'cleanup1', "select sym, styp from vars where exp > 0 and exp < ?", time());
		while (my $row=$st->fetchrow_arrayref()) {
			my ($sym, $styp) = @$row;
			print "cleanup: $sym, $styp\n" if $DEBUG;
			if ($styp eq '$') {
				dbexec($db, 'clearscalar', "delete from scalar where sym=?", $sym);
			} elsif ($styp eq '%') {
				dbexec($db, 'clearhash', "delete from hash where sym=?", $sym);
			} elsif ($styp eq '@') {
				dbexec($db, 'cleararray', "delete from array where sym=?", $sym);
			}
		}
	}
	}
}

sub TIESCALAR {
#hereiam();
	my $self = tie_var('$', @_);
        create_scalar_table($self->{db});
	return $self;
}

sub TIEHASH {
#hereiam();
	my $self = tie_var('%', @_);
	if ($self->{sym}) {
        	create_hash_table($self->{db});
	} elsif ($self->{table}) {
	        create_hash_subtable($self->{db}, $self->{table});
	} else {
		require Carp;
		Carp::croak("Need table or sym for explicit tie");
	}
        return $self;
}

sub TIEARRAY {
#hereiam();
        my $self = tie_var('@', @_);
        if ($self->{sym}) {
                create_array_table($self->{db});
	} elsif ($self->{table}) {
                create_array_subtable($self->{db}, $self->{table});
        } else {
		require Carp;
		Carp::croak("Need table or sym for explicit tie");
        }
        return $self;
}


sub canonical {
#hereiam();
	my ($self, $key) = @_;
	$self->checkdb();
	my $canon;

	if ($self->{sym}) {
		$canon = '$' . $self->{sym};
	} else {
		$canon = '#' . $self->{table};
	}

	if ($self->{type} eq '%') {
		$canon .= '{' . $key . '}';
	} elsif ($self->{type} eq '@') {
		$canon .= '[' . $key . ']';
	}

	return $canon;
}

sub FIRSTKEY {
#hereiam();
	my ($self) = @_;
	$self->checkdb();
	if ($self->{sym}) {
	        $self->{keyst} = $self->dbexec('enumkey', "select key, val, vtyp from hash where sym=?", $self->{sym});
	} else {
	        $self->{keyst} = $self->dbexec('', "select key, val, vtyp from $self->{table}");
	}
	return $self->NEXTKEY();
}

sub NEXTKEY {
#hereiam();
        my ($self) = @_;
	$self->checkdb();
	my $row = $self->{keyst}->fetchrow_arrayref();
	if (!$row) {
		$self->{keyst} = undef;
		return ();
	}

        my ($key, $val, $vtyp) = @{$row};
	if (wantarray) {
		return ($key, tiesubrefs($self, $key, $val, $vtyp));
	} else {
        	return $key;
	}
}

sub CLEAR {
#hereiam();
        my ($self) = @_;
	$self->checkdb();
	if ($self->{sym}) {
		if ($self->{type} eq '%') {
			$self->dbexec('clearhash', "delete from hash where sym=?", $self->{sym});
		} elsif ($self->{type} eq '@') {
			$self->dbexec('cleararray', "delete from array where sym=?", $self->{sym});
		}
	} else {
                $self->dbexec('', "delete from $self->{table}");
	}
}

sub SPLICE {
#hereiam();
        my ($self, $offset, $length, @new) = @_;
	$self->checkdb();
        $offset = 0 unless defined $offset;
        $length = $self->FETCHSIZE() - $offset unless defined $length;

	my @ret;

	$self->{db}->begin_work();

	my $n = 0;
	while (@new && $length > 0) {
		# replace
		push @ret, $self->FETCH($offset);
		$self->STORE($offset, $new[$n]);
		$offset += 1;
		$length -= 1;
		++$n;
	}

	# either new was more or length was more
	if ($n <= $#new) {
		for (my $i=($self->FETCHSIZE-1); $i >= $offset; --$i) {
		    # constraints prevent us from doing this in 1 call to the db, consider turning them off for speed?
		    if ($self->{sym}) {
			$self->dbexec('arrayind', "update array set ind=ind+? where sym=? and ind = ?", scalar @new, $self->{sym}, $i);
		    } else {
			$self->dbexec('arrayind.' . $self->{table}, "update $self->{table} set ind=ind+? where ind = ?", scalar @new, $i);
		    }
		}
		for (; $n <= $#new; ++$n) {
			$self->STORE($n + $offset, $new[$n]);
		}
	} elsif ($length > 0) {
		for ( my $i = $offset ; $i < ( $offset + $length ) ; ++$i ) {
			push @ret, $self->FETCH($i);
		}
		if ($self->{sym}) {
			$self->dbexec('delarrayrange', "delete from array where sym=? and ind>=? and ind < ?",
					$self->{sym}, $offset, $offset + $length);
		} else {
			$self->dbexec('', "delete from $self->{table} where ind>=? and ind < ?",
					$offset, $offset + $length);
		}
                # shift indexes down in storage
		for (my $i = $offset+1; $i < $self->FETCHSIZE; ++$i) {
			if ($self->{sym}) {
				$self->dbexec('indarray', "update array set ind=ind-? where sym=? and ind=?",
					$length, $self->{sym}, $i);
			} else {
				$self->dbexec('indarray.' . $self->{table}, "update $self->{table} set ind=ind-? where ind=?",
					$length, $i);
			}
		}
	}

	$self->{db}->commit();

	return wantarray ? @ret : $ret[@ret];
}

sub SHIFT {
    my ($self) = @_;
    my @val = $self->SPLICE( 0, 1 );
    return $val[0];
}

sub DELETE {
        my ($self, $key) = @_;
	$self->checkdb();
	if ($self->{type} eq '%') {
		if ($self->{sym}) {
			$self->dbexec('delhash', "delete from hash where sym=? and key=?", $self->{sym}, $key);
		} else {
			$self->dbexec('', "delete from $self->{table} where key=?", $key);
		}
	} else {
		$self->store($key, undef);
	}
}

sub FETCHSIZE {
        my ($self) = @_;
	$self->checkdb();
	my $st;
        if ($self->{sym}) {
                $st = $self->dbexec('arraysize', "select max(ind) from array where sym=?", $self->{sym});
        } else {
                $st = $self->dbexec('', "select max(ind) from $self->{table}");
        }
	my ($ind) = $st->fetchrow_array();
	return defined $ind ? ($ind+1) : 0;
}

sub EXTEND {
#hereiam();
	my ($self, $count) = @_;
	$self->checkdb();
	if ($count >= 0) {
        if ($self->{sym}) {
                $self->dbexec('extarray', "delete from array where sym=? and ind >= ?", $self->{sym}, $count);
        } else {
                $self->dbexec('', "delete from $self->{table} where ind >= ?", $count);
        }
	}
}

sub POP {
        my ($self) = @_;
	$self->checkdb();
	$self->{db}->begin_work();
	my $ind = $self->FETCHSIZE()-1;
	my $val = $self->FETCH($ind);
	if ($self->{sym}) {
		$self->dbexec('arraypop', "delete from array where sym=? and ind = ?", $self->{sym}, $ind);
	} else {
		$self->dbexec('', "delete from $self->{table} where ind = ?", $ind);
	}
	$self->{db}->commit();
	return $val;
}

sub PUSH {
	my ($self, @list) = @_;
	$self->checkdb();
	$self->{db}->begin_work();
	for (@list) {
		my $st;
		if ($self->{sym}) {
			$self->dbexec('arraypush', "insert into array (sym, ind) values (?, (select 1+coalesce(max(ind),-1) from array where sym=?))", $self->{sym}, $self->{sym});
			$st = $self->dbexec('maxind', "select max(ind) from array where sym=?", $self->{sym});
		} else {
			$self->dbexec('arraypush.' . $self->{table}, "insert into $self->{table} (ind) values ((select 1+coalesce(max(ind),-1) from $self->{table}))");
			$st = $self->dbexec('maxind.' . $self->{table}, "select max(ind) from $self->{table}");
		}
		my ($key) = $st->fetchrow_array();
		$self->STORE($key, $_);
	}
	$self->{db}->commit();
	return $self->FETCHSIZE();
}

sub UNSHIFT {
        my ($self, @list) = @_;
        $self->checkdb();
        return $self->SPLICE(0, 0, @list);
}


sub EXISTS {
	my ($self, $key) = @_;
	return $self->FETCH($key, 'EXISTS');
}

sub FETCH {
	my ($self, $key, $act) = @_;
	$self->checkdb();

	my $st;

	if ($self->{type} eq '$') {
		$st = $self->dbexec('fetchscalar', "select val, vtyp from scalar where sym=?", $self->{sym});
	} elsif ($self->{type} eq '%') {
		if ($self->{sym}) {
			$st = $self->dbexec('fetchhash',  "select val, vtyp from hash where sym=? and key=?",
				$self->{sym}, $key);
		} else {
			$st = $self->dbexec('',  "select val, vtyp from $self->{table} where key=?", $key);
		}
	} elsif ($self->{type} eq '@') {
		if ($self->{sym}) {
			$st = $self->dbexec('fetcharray', "select val, vtyp from array where sym=? and ind=?",
				$self->{sym}, $key);
		} else {
			$st = $self->dbexec('',  "select val, vtyp from $self->{table} where ind=?", $key);
		}
	} else {
		die;
	}

	my ($val, $vtyp) = $st->fetchrow_array();

	if (defined $act && $act eq 'EXISTS') {
		return defined $vtyp;
	}

	return tiesubrefs($self, $key, $val, $vtyp);
}

sub tiesubrefs {
#hereiam();
	my ($self, $key, $val, $vtyp) = @_;

        return undef if ! defined $vtyp;

	if ($vtyp eq '$') {
		return $val;
	}

	if ($vtyp eq '*') {
		$key = '' if !defined $key;
		if ($self->{ref}{$key}) {
			# already tied my ref
			return $self->{ref}{$key};
		} else {
			# create a new ref
			my $canon = canonical($self, $key);
			if ($val eq '$') {
				my $var;
				my $sub = tie $var, ref($self), %{$self}, sym=>$canon;
				$val = \$var;
			} elsif ($val eq '%') {
				my %var;
				my $sub = tie %var, ref($self), %{$self}, sym=>$canon;
				$val = \%var;
                        } elsif ($val eq '@') {
				my @var;
				my $sub = tie @var, ref($self), %{$self}, sym=>$canon;
				$val = \@var;
                        } else {
				require Carp;
		    		Carp::croak("Unknown reference type '$val' in $canon");
			}
		}
		die unless ref($val);
		return $self->{ref}{$key}=$val;
        }
	return undef;
}

sub STORE {
#hereiam();
	my $self = shift;
	$self->checkdb();

	my ($key, $val);

	if ($self->{type} eq '$') {
		($val) = @_;
	} else {
		($key, $val) = @_;
	}

	my $vtyp;

	if (ref($val)) {
		$key = '' if !defined $key;
		my $canon = canonical($self, $key);
		$self->{ref}{$key} = $val;
		$vtyp = '*';
		my $sub;
		if (ref($val) eq 'SCALAR') {
			my $sav = ${$val};
			tie ${$val}, ref($self), %{$self}, sym=>$canon;
			${$val} = $sav if defined $sav;
			$val = '$';
		} elsif (ref($val) eq 'HASH') {
			my %sav = %{$val};
                        tie %{$val}, ref($self), %{$self}, sym=>$canon;
			%{$val} = %sav if %sav;
                        $val = '%';
		} elsif (ref($val) eq 'ARRAY') {
			my @sav = @{$val};
                        $sub = tie @{$val}, ref($self), %{$self}, sym=>$canon;
			@{$val} = @sav if @sav;
                        $val = '@';
                } else {
			require Carp;
		    	Carp::croak("Can't store reference to " . ref($val) . " in $canon, try Data::Dumper instead");
		}
	} else {
		$vtyp = '$';
	}

	if ($DEBUG) {
		require Carp;
		Carp::cluck "store: $self->{type}:$self->{sym}($key) = $vtyp:$val\n"
	}

	if ($self->{ttl}) {
		my $exp = time() + $self->{ttl};
		my $up = $self->dbexec('updateexp',    "update vars set exp=? where sym=? and styp=?",
				$exp, $self->{sym}, $self->{type});
	}

	if ($self->{type} eq '$') {
		if (!defined ($val)) {
        		$self->dbexec('delscalar', "delete from scalar where sym=?", $self->{sym});
		} else {
			my $up = $self->dbexec('updatescalar', "update scalar set val=?,vtyp=? where sym=?",
					$val, $vtyp, $self->{sym});
			if ($up == 0) {
				$self->dbexec('insertscalar',  "insert into scalar (sym, val, vtyp) values (?, ?, ?)",
					$self->{sym}, $val, $vtyp);
			}
		}
        } elsif ($self->{type} eq '%') {
		if ($self->{sym}) {
		    if (!defined ($val)) {
        		$self->dbexec('delscalar', "delete from hash where sym=? and key=?", $self->{sym}, $key);
		    } else {
                	my $up = $self->dbexec('updatehash', "update hash set val=?,vtyp=? where sym=? and key=?",
				$val, $vtyp, $self->{sym}, $key);
                	if ($up == 0) {
                		$self->dbexec('inserthash', "insert into hash (sym, key, val, vtyp) values (?, ?, ?, ?)",
					$self->{sym}, $key, $val, $vtyp);
                	}
		    }
		} else {
		    if (!defined ($val)) {
        		$self->dbexec('', "delete from $self->{table} where key=?", $key);
		    } else {
                	my $up = $self->dbexec('', "update $self->{table} set val=?,vtyp=? where key=?", $val, $vtyp, $key);
                	if ($up == 0) {
                		$self->dbexec('', "insert into $self->{table} (key, val, vtyp) values (?, ?, ?)",
					$key, $val, $vtyp);
                	}
		    }
		}
        } elsif ($self->{type} eq '@') {
                if ($self->{sym}) {
			my $up = $self->dbexec('updatearray', "update array set val=?,vtyp=? where sym=? and ind=?",
					$val, $vtyp, $self->{sym}, $key);
			if ($up == 0) {
				$self->dbexec('insertarray', "insert into array (sym, ind, val, vtyp) values (?, ?, ?, ?)",
					$self->{sym}, $key, $val, $vtyp);
			}
                } else {
                        my $up = $self->dbexec('', "update $self->{table} set val=?,vtyp=? where ind=?", $val, $vtyp, $key);
                        if ($up == 0) {
                                $self->dbexec('', "insert into $self->{table} (ind, val, vtyp) values (?, ?, ?)",
                                        $key, $val, $vtyp);
                        }
		}
	} else {
		die "Unknown type $self->{type}\n";
	}

	return $val;
}

sub dbexec {
	my ($self, $name, $sql, @args) = @_;
	my $db = $self->{db} ? $self->{db} : $self;
	my $st;
	if ($name) {
		if (!($st = ($db->{private_ipc_lite_prep}||{})->{$name})) {
			$st = $db->{private_ipc_lite_prep}->{$name} = $db->prepare($sql);
		}
	} else {
		$st = $db->prepare($sql);
	}
	my $ok = $st->execute(@args);
	if ($ok && $st->{NUM_OF_FIELDS}) {
		return $st;
	} else {
		return $ok;
	}
}

sub END {
	# no refs to statement handles
	for my $tid_dbs (values(%DBS)) {
	for (values(%{$tid_dbs})) {
		$_->{private_ipc_lite_prep} = undef;
	}
	}
}

sub defaultpath {
	my ($self, $callpack) = @_;

        if (!$DEFAULT_PATH{$callpack}) {
		require Cwd;
                my $prog = Cwd::abs_path($0);
		#my $prog = $0;
		#require File::Spec;
		#$prog = (File::Spec->splitpath($prog))[2];
		$DEFAULT_PATH{$callpack} = nametopath($prog);
	}
	return $DEFAULT_PATH{$callpack};
}

sub nametopath {
	my ($name) = @_;
        $name =~ s/[\/\\\:\!\&\*]/_/g;
        require File::Spec;
        my $tmp = File::Spec->tmpdir;
        $tmp = File::Spec->catfile($tmp, "$name.ipclitedb");
        return $tmp;
}


sub fatalerror
{
    $SIG{__DIE__} = undef;
    require Carp;
    Carp::confess();
}

sub checkdb {
	my $self = shift;
	my $tid = threadid();
	if ($tid != $self->{tid}) {
	        $self->open_pathdb();
	}
}

sub threadid {
	my $tid = 0;

	# todo add more methods

	$tid = eval {
		require threads;
		threads->self->tid();
	};

	if (!$tid && $^O =~ /win32/i) {
	$tid = eval {
		require Win32;
		Win32::GetCurrentThreadId();
	};
	}

	if (!$tid) {
		#this fixes forking issues on older perls
		$tid = $$;
	}

	return $tid;
}

sub hereiam {
	my ($package, $filename, $line, $subroutine) = caller(1);
	print "$package $line: $subroutine (";
	($package, $filename, $line, $subroutine) = caller(2);
	print "$package $line: $subroutine)\n";
}

1;

__END__