view release on metacpan or  search on metacpan

lib/DBD/PgLite.pm  view on Meta::CPAN

	  return $Currval->{$sn};
  }
  sub Lastval {
	  $LastvalSeq = lc(shift) if @_;
	  return $Currval->{$LastvalSeq};
  }
}
sub setTime { Time(Time::HiRes::time); }
sub getTime { Time(); }
sub setTransaction { Transaction(shift); }
sub getTransaction { Transaction(); }
sub setDbh { Dbh(shift); }
sub getDbh { Dbh(); }
sub getCurrval { Currval(shift); }
sub setCurrval { Currval(@_); }
sub getLastval { Lastval(); }
sub setLastval { Lastval(shift); }

### Main package methods/subs ######

sub driver {
	return $drh if ($drh);
	my ($class, $attr) = @_;
	$class .= "::dr";
	($drh) = DBI::_new_drh ($class, {
		'Name' => 'PgLite',
		'Version' => $VERSION,
		'Attribution' => 'DBD::PgLite by Baldur Kristinsson',
	});
	return $drh;
}

sub disconnect_all { } # required by DBI
sub DESTROY {
	my $dbh = getDbh();
	$dbh->disconnect if $dbh;
}


# Localeorder function legwork

my (@chars,%chars);
for (1..254) {
	push @chars, chr($_);
}
@chars = sort { lc($a) cmp lc($b) } @chars;
%chars = map { ($chars[$_] => sprintf("%x",$_)) } 0..$#chars;
my $localeorder_func = sub {
	my $str = shift;
	return join('', map { $chars{$_} } split //, $str);
};

# Make sure sequence environment is sane and yield a
# database handle to sequence functions
sub _seq_init {
	my $sn = lc(shift);
	my $dbh = getDbh();
	# Create sequence table if it does not exist
	my $check_tbl = "select name from sqlite_master where name = ? and type = 'table'";
	unless ($dbh->selectrow_array($check_tbl, {}, 'pglite_seq')) {
		$dbh->do("create table pglite_seq (sequence_name text primary key, last_value int, is_locked int, is_called int)");
	}
	my $check_seq = "select sequence_name from pglite_seq where sequence_name = ?";
	# Autocreate sequence if it does not exist
	unless ($dbh->selectrow_array($check_seq,{},$sn)) {
		$dbh->do("insert into pglite_seq (sequence_name, last_value, is_locked, is_called) values (?,?,?,?)",
				 {}, $sn, 1, 1, 0);
		# Find a matching table, if possible, and set last_value based on that
		my $tn = $sn;
		$tn =~ s/_seq$//;
		my ($val,$col) = (0,'');
		while (!$val && $tn=~/_+[a-z]*$/) {
			$col = ($col ? "${1}_$col" : $1) if $tn =~ s/_+([a-z]*)$//;
			if ($dbh->selectrow_array($check_tbl, {}, $tn)) {
				eval {
					$val = $dbh->selectrow_array("select max($col) from $tn");
				};
			}
		}
		if (int($val) > 0) {
			$dbh->do("update pglite_seq set last_value = ?, is_called = 1 where sequence_name = ?",
					 {}, int($val), $sn);
		}
		# unlock sequence before we continue
		$dbh->do("update pglite_seq set is_locked = 0 where sequence_name = ?",{},$sn);
	}
	return $dbh;
}


# Advance the sequence object to its next value and return that
# value.
sub _nextval {
	my $sn = lc(shift);
	my $dbh = _seq_init($sn);
	my $tries;
	while (1) {
		my $rc = $dbh->do("update pglite_seq set last_value = last_value + 1, is_locked = 1 where sequence_name = ? and is_locked = 0 and is_called = 1",{},$sn);
		last if $rc && $rc > 0;
		$rc = $dbh->do("update pglite_seq set is_locked = 1 where sequence_name = ? and is_locked = 0 and is_called = 0",{},$sn);
		last if $rc && $rc > 0;
		Time::HiRes::sleep(0.05);
		die "Too many tries trying to update sequence '$sn' - need manual fix?" if ++$tries > 20;
	}
	my $sval = $dbh->selectrow_array("select last_value from pglite_seq where sequence_name = ?",{},$sn);
	$dbh->do("update pglite_seq set is_locked = 0, is_called = 1 where sequence_name = ? and is_locked = 1",{},$sn);
	setLastval($sn);
	setCurrval($sn,$sval);
	return $sval;
}

# Return the value most recently obtained by nextval for this sequence
# in the current session.
sub _currval {
	my $sn = lc(shift);
	my $val = getCurrval($sn);
	die qq[ERROR: currval of sequence "$sn" is not yet defined in this session] unless $val;
	return $val;
}


# Return the value most recently returned by nextval in the current
# session.
sub _lastval {
	my $val = getLastval();
	die qq[ERROR: lastval is not yet defined in this session] unless $val;
	return $val;
}


# Reset the sequence object's counter value.
sub _setval {
	my ($sn,$val,$called) = @_;
	$sn = lc($sn);
	$val = int($val);
	die "ERROR: Value of sequence '$sn' must be a positive integer" unless $val;
	$called = 1 unless defined($called);
	$called = $called ? 1 : 0;
	my $dbh = _seq_init($sn);
	my $tries;
	while (1) {
		my $rc = $dbh->do("update pglite_seq set last_value = ?, is_called = ? where sequence_name = ? and is_locked = 0",
						  {}, $val, $called, $sn);
		last if $rc && $rc > 0;
		Time::HiRes::sleep(0.05);
		die "Too many tries trying to update sequence '$sn' - need manual fix?" if ++$tries > 20;
	}
	return $val;
}


# Utility functions for succinct expression below

sub _trim {
	my ($mode,$str,$chars) = @_;
	$mode ||= 'both';
	$chars ||= " \n\t\r";
	my ($left,$right);
	$left = $mode =~ /both|leading|left/i ? 1 : 0;
	$right = $mode =~ /both|trailing|right/i ? 1 : 0;
	$chars = "[".quotemeta($chars)."]+";
	$str =~ s/^$chars// if $left;
	$str =~ s/$chars$// if $right;
	return $str;
}

my %_encode = ( 'base64' => sub { my $x = MIME::Base64::encode_base64(shift); chomp $x; return $x; },
				'hex'    => sub { unpack("H*",shift) },
				'escape' => sub { $_[0]=~s/\0/\\000/g; return $_[0]; }, );
my %_decode = ( 'base64' => sub { MIME::Base64::decode_base64(shift) },
				'hex'    => sub { pack("H*",shift) },
				'escape' => sub { $_[0]=~s/\\000/\0/g; return $_[0]; }, );

sub _convert {
	my ($txt,$from,$to) = @_;
	return $txt unless $txt;
	return $txt if $from eq $to;
	my $c = Text::Iconv->new($from,$to) or die "No conversion possible: $from -> $to\n";
	$txt = $c->convert($txt) or die "Could not convert $from -> $to";
	return $txt;
}

# Guess what Latin-1 is called in the iconv() implementation of this OS
sub _latin1_symbol {
	my ($kernel) = POSIX::uname();
	return '8859-1' if $kernel =~ /SunOS|Solaris/i;
	return 'ISO-8859-1';
}

sub _pad {
	my ($mode,$str,$len,$fill) = @_;
	$fill ||= ' ';
	return substr($str,0,$len) if length($str)>=$len;
	if ($mode eq 'left') {
		my $addlen = $len - length($str);
		$fill = $fill x $addlen;
		$fill = substr($fill,0,$addlen);
		$str = "$fill$str";
	}
	else {
		while (length($str) < $len) {
			$str .= $fill;