libdbd-ldap-perl 0.20-1 / usr / share / perl5 / JLdap.pm

#!/usr/bin/perl

package JLdap;

require 5.002;

use Net::LDAP::Entry;
use vars qw($VERSION);
no warnings qw (uninitialized);

#use Fcntl; 

##++
##  Global Variables. Declare lock constants manually, instead of 
##  importing them from Fcntl.
##
use vars qw ($VERSION);
##--

$JLdap::VERSION = '0.20';

#my $NUMERICTYPES = '^(NUMBER|FLOAT|DOUBLE|INT|INTEGER|NUM)$';       #20000224
#my $STRINGTYPES = '^(VARCHAR|CHAR|VARCHAR|DATE|LONG|BLOB|MEMO)$';

##++
##  Public Methods and Constructor
##--

sub new
{
    my $class = shift;
    my $self;

    $self = {
                commands     => 'select|update|delete|alter|insert|create|drop|primary_key_info',
                column       => '[A-Za-z0-9\~\x80-\xFF][\w\x80-\xFF]+',
		_select      => '[\w\x80-\xFF\*,\s\~]+',
		path         => '[\w\x80-\xFF\-\/\.\:\~\\\\]+',
		table        => '',
		timestamp    => 0,
		fields       => {},
		use_fields   => '',
		key_fields   => '',
		order        => [],
		types        => {},
		lengths      => {},
		scales       => {},
		defaults     => {},
		records      => [],
		errors       => {},
		lasterror    => 0,     #JWT:  ADDED FOR ERROR-CONTROL
		lastmsg      => '',
		CaseTableNames  => 0,    #JWT:  19990991 TABLE-NAME CASE-SENSITIVITY?
		LongTruncOk  => 0,     #JWT: 19991104: ERROR OR NOT IF TRUNCATION.
		RaiseError   => 0,     #JWT: 20000114: ADDED DBI RAISEERROR HANDLING.
		silent       => 0,
		ldap_dbh			 => 0,
		ldap_sizelimit => 0,    #JWT: LIMIT #RECORDS FETCHED, IF SET.
		ldap_timelimit => 0,    #JWT: LIMIT #RECORDS FETCHED, IF SET.
		ldap_deref => 0,    #JWT: LIMIT #RECORDS FETCHED, IF SET.
		ldap_typesonly => 0,
		ldap_callback => 0,
		ldap_scope => 0,
		ldap_inseparator => '|',
		ldap_outseparator => '|',
		ldap_firstonly => 0,
		ldap_nullsearchvalue => ' ',  #ADDED 20040330 TO FOR BACKWARD COMPATABILITY.
		ldap_appendbase2ins => 0,     #ADDED 20060719 FOR BACKWARD COMPAT. - 0.08+ NO LONGER APPENDS BASE TO ALWAYSINSERT PER REQUEST.
		dirty			 => 0,     #JWT: 20000229: PREVENT NEEDLESS RECOMMITS.
		tindx => 0                    #REPLACES GLOBAL VARIABLE.
	    };

    bless $self, $class;

	 for (my $i=0;$i<scalar(@_);$i+=2)   #ADDED: 20040330 TO ALLOW SETTING ATTRIBUTES IN INITIALIZATION!
	 {
	 	$self->{$_[$i]} = $_[$i+1];
	 }

    $self->initialize;
    return $self;
}
sub initialize
{
	my $self = shift;

	$self->define_errors;
}

sub sql
{
	my ($self, $csr, $query) = @_;

	my ($command, $status, $base, $fields);
#print STDERR "-sql1($command,$status,$base,$fields)";
	return wantarray ? () : -514  unless ($query);
	$self->{lasterror} = 0;
	$self->{lastmsg} = '';
	$query   =~ s/\n/ /gso;
	$query   =~ s/^\s*(.*?)\s*$/$1/;
	$query = 'select tables'  if ($query =~ /^show\s+tables$/i);
	$query = 'select tables'  if ($query =~ /^select\s+TABLE_NAME\s+from\s+USER_TABLES$/i);  #ORACLE-COMPATABILITY.
	$command = '';

	if ($query =~ /^($self->{commands})/io)
	{
		$command = $1;
		$command =~ tr/A-Z/a-z/;    #ADDED 19991202!
		$status  = $self->$command ($csr, $query);
		if (!defined($status))      #NEXT 5 ADDED PER PATCH REQUEST 20091101:
		{
			$self->display_error(-599);
			return wantarray ? () : -599;
		}
		elsif (ref ($status) eq 'ARRAY')   #SELECT RETURNED OK (LIST OF RECORDS).
		{
			return wantarray ? @$status : $status;
		}
		else
		{
			if ($status < 0)
			{             #SQL RETURNED AN ERROR!
#print STDERR "-sql6 status=$status=\n";
				$self->display_error ($status);
				#return ($status);
				return wantarray ? () : $status;
			}
			else
			{                        #SQL RETURNED OK.
#print STDERR "-sql7 status=$status= at=$@= cash=$_= bang=$!= query=$?=\n";
				return wantarray ? ($status) : $status;
			}
		}
	}
	else
	{
		return wantarray ? () : -514;
	}
}

sub select
{
	my ($self, $csr, $query) = @_;

	my (@ordercols) = ();
	$regex = $self->{_select};
	$path  = $self->{path};
	my (@rtnvals) = ();

	my $distinct;
	$distinct = 1  if ($query =~ s/select\s+distinct(\s+\w|\s*\(|\s+\*)/select $1/i);
	my ($dbh) = $csr->FETCH('ldap_dbh');
	my ($tablehash);

	if ($query =~ /^select tables$/io)
	{
		$tablehash = $dbh->FETCH('ldap_tablenames');
		$self->{use_fields} = 'TABLE_NAME';  #ADDED 20000224 FOR DBI!
		$values_or_error = [];
		for ($i=0;$i<=$#{$tablehash};$i++)
		{
			push (@$values_or_error,[$tablehash->[$i]]);
		}
		unshift (@$values_or_error, ($#{$tablehash}+1));
		return $values_or_error;
	}
	elsif ($query =~ /^select\s+                         # Keyword
			($regex)\s+                       # Columns
			from\s+                           # 'from'
			($path)(.*)$/iox)
	{           
		($attbs, $table, $extra) = ($1, $2, $3);

		$table =~ tr/A-Z/a-z/  unless ($self->{CaseTableNames});  #JWT:TABLE-NAMES ARE NOW CASE-INSENSITIVE!
		$self->{file} = $table;
		if ($extra =~ s/([\s|\)]+)order\s+by\s*(.*)/$1/i)
		{
			$orderclause = $2;
			@ordercols = split(/,/,$orderclause);
			$descorder = ($ordercols[$#ordercols] =~ s/(\w+\W+)desc(?:end|ending)?$/$1/i);  #MODIFIED 20000721 TO ALLOW "desc|descend|descending"!
			for $i (0..$#ordercols)
			{
				$ordercols[$i] =~ s/\s//igo;   #CASE-INSENSITIVITY ADDED NEXT 2: 20050416 PER PATCH BY jmorano
				$ordercols[$i] =~ s/[\(\)]+//igo;
			}
		}
		$tablehash = $dbh->FETCH('ldap_tables');
		return (-524)  unless ($tablehash->{$table});

		my ($base, $objfilter, $dnattbs, $allattbs, $alwaysinsert) = split(/\:/o ,$tablehash->{$table});
		$attbs = $allattbs  if ($allattbs && $attbs =~ s/\*//o);
		$attbs =~ s/\s//go;
		$attbs =~ tr/A-Z/a-z/;
		@{$self->{order}} = split(/,/o, $attbs)  unless ($attbs eq '*');
		my $fieldnamehash = ();
		my $attbcnt = 0;
		foreach my $i (@{$self->{order}})
		{
			$fieldnamehash{$i} = $attbcnt++;
		}
		my ($ldap) = $csr->FETCH('ldap_ldap');
		$objfilter ||= 'objectclass=*';
		$objfilter = "($objfilter)"  unless ($objfilter =~ /^\(/o);
#print "<BR>-where=$extra=\n";
		if ($extra =~ /^\s+where\s*(.+)$/io)
		{
			$filter = $self->parse_expression($1);
			$filter = '('.$filter.')'  unless ($filter =~ /^\(/o);
			$filter = "(&$objfilter$filter)";
		}
		else
		{
			$filter = $objfilter;
		}
#print "<BR>-filter =$filter=\n";
		my $data;
		my (@searchops) = (
				'base' => $base,
				'filter' => $filter,
				'attrs' => [split(/\,/o, $attbs)]
		);
		foreach my $i (qw(ldap_sizelimit ldap_timelimit deref typesonly 
		callback))
		{
			$j = $i;
			$j =~ s/^ldap_//o;
			push (@searchops, ($j, $self->{$i}))  if ($self->{$i});
		}
		push (@searchops, ('scope', ($self->{ldap_scope} || 'one')));
#print "--- ATTBS =$attbs=\n";
#print "--- SEARCH OPS =".join('|',@searchops)."=\n";
		$data = $ldap->search(@searchops) 
				or return($self->ldap_error($@,"Search failed to return object: filter=$filter (".$data->error().")"));
#print "--- data=$data=\n";
		my ($j) = 0;
		my (@varlist) = ();
		while (my $entry = $data->shift_entry())
		{
			$dn = $entry->dn();
			next  unless ($dn =~ /$base$/i);   #CASE-INSENSITIVITY ADDED NEXT 2: 20050416 PER PATCH BY jmorano
			@attributes = $entry->attributes;
			unless ($attbcnt)
			{
				$attbs = join(',',@attributes);
				$attbcnt = 0;
				@{$self->{order}} = @attributes;
				foreach my $i (@{$self->{order}})
				{
					$fieldnamehash{$i} = $attbcnt++;
				}
			}
			$varlist[$j] = [];
			for (my $i=0;$i<$attbcnt;$i++)
			{
				$varlist[$j][$i] = '';
			}
			$i = 0;
			foreach my $attr (@{$self->{order}})
			{
#				$valuesref = $entry->get($attr);   #CHGD. TO NEXT PER PATCH REQUEST 20091101:
				$valuesref = $entry->get_value($attr, asref => 1);
				if ($self->{ldap_firstonly} && $self->{ldap_firstonly} <= scalar (@{$valuesref}))
				{
					#$varlist[$j][$fieldnamehash{$attr}] = join($self->{ldap_outseparator}, $valuesref->[0]); #CHGD. 20010829 TO NEXT.
					$varlist[$j][$fieldnamehash{$attr}] = join($self->{ldap_outseparator}, @{$valuesref}[0..($self->{ldap_firstonly}-1)]);
				}
				else
				{
					$varlist[$j][$fieldnamehash{$attr}] = join($self->{ldap_outseparator}, @$valuesref) || '';
				}
				unless ($valuesref[0])
				{
					$varlist[$j][$fieldnamehash{dn}] = $dn  if ($attr eq 'dn');
				}
				$i++;
			}
			++$j;
		}
		$self->{use_fields} = $attbs;
		if ($distinct)   #THIS MAKES "DISTINCT" WORK.
		{
			my (%disthash);
			for (my $i=0;$i<=$#varlist;$i++)
			{
				++$disthash{join("\x02",@{$varlist[$i]})};
			}
			@varlist = ();
			foreach my $i (keys(%disthash))
			{
				push (@varlist, [split(/\x02/o, $i, -1)]);
			}
		}
		if ($#ordercols >= 0)   #SORT 'EM!
		{
			my @SV;
			for (my $i=0;$i<=$#varlist;$i++)
			{
				$SV[$i] = '';
				foreach my $j (@ordercols)
				{
					$SV[$i] .= $varlist[$i][$fieldnamehash{$j}] . "\x01";
				}
			}
			@sortvector = &sort_elements(\@SV);
			@sortvector = reverse(@sortvector)  if ($descorder);
			@SV = ();
			while (@sortvector)
			{
				push (@SV, $varlist[shift(@sortvector)]);
			}
			@varlist = @SV;
			@SV = ();
		}
		return [($#attributes+1), @varlist];
	}
	else     #INVALID SELECT STATEMENT!
	{
		return (-503);
	}
}

sub sort_elements
{
	my (@elements, $line, @sortlist, @sortedlist, $j, $t, $argcnt, $linedata, 
			$vectorid, @sortvector);

	my ($lo) = 0;
	my ($hi) = 0;
	$lo = shift  unless (ref($_[0]));
	$hi = shift  unless (ref($_[0]));

	if ($lo || $hi)
	{
		for ($j=0;$j<=$#{$_[0]};$j++)
		{
			$sortvector[$j] = $j;
		}
	}
	$hi ||= $#{$_[0]};
	$argcnt = scalar(@_);
	for (my $i=$lo;$i<=$hi;$i++)
	{
		$line = $_[0][$i];
		for ($j=1;$j<$argcnt;$j++)
		{
			$line .= "\x02" . $_[$j][$i];
		}
		$line .= "\x04".$i;
		push (@sortlist, $line);
	}

	@sortedlist = sort @sortlist;
	$i = $lo;
	foreach $line (@sortedlist)
	{
		($linedata,$vectorid) = split(/\x04/o, $line);
		(@elements) = split(/\x02/o, $linedata);
		$t = $#elements  unless $t;
		for ($j=$t;$j>=1;$j--)
		{
			#push (@{$_[$j]}, $elements[$j]);
			${$_[$j]}[$i] = $elements[$j];
		}
		$sortvector[$i] = $vectorid;
		$elements[0] =~ s/\s+//go;
		${$_[0]}[$i] = $elements[$j];
		++$i;
	}
	return @sortvector;
}

sub ldap_error
{
	my ($self,$errcode,$errmsg,$warn) = @_;

	$err = $errcode || -1;
	$errdetails = $errmsg;
	$err = -1 * $err  if ($err > 0);
	return ($err)  unless (defined($warn) && $warn);

#	print "Content-type: text/html\nWindow-target: _parent", "\n\n"  
#			if (defined($warn) && $warn == 1);

	return ($self->display_error($errcode));
}

sub display_error
{	
	my ($self, $error) = @_;

	$other = $@ || $! || 'None';

	print STDERR <<Error_Message  unless ($self->{silent});

Oops! The following error occurred when processing your request:

    $self->{errors}->{$error} ($errdetails)

Here's some more information to help you:

	file:  $self->{file}
    $other

Error_Message

#JWT:  ADDED FOR ERROR-CONTROL.

	$self->{lasterror} = $error;
	$self->{lastmsg} = "$error:" . $self->{errors}->{$error};
	$self->{lastmsg} .= '('.$errdetails.')'  if ($errdetails);  #20000114

	$errdetails = '';   #20000114
	die $self->{lastmsg}  if ($self->{RaiseError});  #20000114.

    #return (1);
	return ($error);
}

sub commit
{
	my ($self) = @_;
	my ($status) = 1;
	my ($dbh) = $self->FETCH('ldap_dbh');
	my ($autocommit) = $dbh->FETCH('AutoCommit');

	$status = $dbh->commit()  unless ($autocommit);

	$self->{dirty} = 0  if ($status > 0);
	return undef  if ($status <= 0);   #ADDED 20000103
	return $status;
}

##++
##  Private Methods
##--

sub define_errors
{
	my $self = shift;
	my $errors;

	$errors = {};

	$errors->{'-501'} = 'Could not open specified database.';
	$errors->{'-502'} = 'Specified column(s) not found.';
	$errors->{'-503'} = 'Incorrect format in [select] statement.';
	$errors->{'-504'} = 'Incorrect format in [update] statement.';
	$errors->{'-505'} = 'Incorrect format in [delete] statement.';
	$errors->{'-506'} = 'Incorrect format in [add/drop column] statement.';
	$errors->{'-507'} = 'Incorrect format in [alter table] statement.';
	$errors->{'-508'} = 'Incorrect format in [insert] command.';
	$errors->{'-509'} = 'The no. of columns does not match no. of values.';
	$errors->{'-510'} = 'A severe error! Check your query carefully.';
	$errors->{'-511'} = 'Cannot write the database to output file.';
	$errors->{'-512'} = 'Unmatched quote in expression.';
	$errors->{'-513'} = 'Need to open the database first!';
	$errors->{'-514'} = 'Please specify a valid query.';
#    $errors->{'-515'} = 'Cannot get lock on database file.';
#    $errors->{'-516'} = 'Cannot delete temp. lock file.';
	$errors->{'-517'} = "Built-in function failed ($@).";
	$errors->{'-518'} = "Unique Key Constraint violated.";  #JWT.
	$errors->{'-519'} = "Field would have to be truncated.";  #JWT.
	$errors->{'-520'} = "Can not create existing table (drop first!).";  #20000225 JWT.
	$errors->{'-521'} = "Can not change datatype on non-empty table.";  #20000323 JWT.
	$errors->{'-522'} = "Can not decrease field-size on non-empty table.";  #20000323 JWT.
	$errors->{'-523'} = "Update Failed to commit changes.";  #20000323 JWT.
	$errors->{'-524'} = "No such table.";  #20000323 JWT.
	$errors->{'-599'} = 'General error.';

	$self->{errors} = $errors;

	return (1);
}

sub parse_expression
{
	my ($self, $s) = @_;

	$s =~ s/\s+$//o;     #STRIP OFF LEADING AND TRAILING WHITESPACE.
	$s =~ s/^\s+//o;
	return unless ($s);


	my $relop = '(?:<|=|>|<=|>=|!=|like|not\s+like|is\s+not|is)';
	my %boolopsym = ('and' => '&', 'or' => '|');

	my $indx = 0;

	my @P = ();
	my @T3 = ();            #PROTECTS MULTI-WAY RELOP EXPRESSIONS, IE. (A AND B AND C)
	my $t3indx = 0;
	@T = ();
	my @QS = ();

	$s=~s|\\\'|\x04|go;      #PROTECT "\'" IN QUOTES.
	$s=~s|\\\"|\x02|go;      #PROTECT "\"" IN QUOTES.

	#THIS NEXT LOOP STRIPS OUT AND SAVES ALL QUOTED STRING LITERALS 
	#TO PREVENT THEM FROM INTERFEARING WITH OTHER REGICES, IE. DON'T 
	#WANT OPERATORS IN STRINGS TO BE TREATED AS OPERATORS!

	$indx++ while ($s =~ s/([\'\"])([^\1]*?)\1/
			$QS[$indx] = $2; "\$QS\[$indx]"/e);

	for (my $i=0;$i<=$#QS;$i++)   #ESCAPE LDAP SPECIAL-CHARACTERS.
	{
		$QS[$i] =~ s/\\x([\da-fA-F][\da-fA-F])/\x05$1/g;   #PROTECT PERL HEX TO LDAP HEX (\X## => \##).
		#$QS[$i] =~ s/([\*\(\)\+\\\<\>])/\\$1/g;  #CHGD. TO NEXT. 20020409!
		$QS[$i] =~ s/([\*\(\)\\])/"\\".unpack('H2',$1)/eg;
		#$QS[$i] =~ s/\\x(\d\d)/\\$1/g;   #CONVERT PERL HEX TO LDAP HEX (\X## => \##).
		$QS[$i] =~ s/\x05([\da-fA-F][\da-fA-F])/\\$1/go;   #CONVERT PERL HEX TO LDAP HEX (\X## => \##).
	}
#print STDERR "-parse_expression: QS list=".join('|',@QS)."=   SSSS=$s=\n";
	$indx = 0;	

	#I TRIED TO ALLOWING ATTRIBUTES TO BE COMPARED W/OTHER ATTRIBUTES, BUT 
	#(20020409), BUT APPARENTLY LDAP ONLY ALLOWS STRING CONSTANTS ON RHS OF OPERATORS!

#	$indx++ while ($s =~ s/(\w+)\s*($relop)\s*(\$QS\[\d*\]|\w+)/  #THIS WAS TRIED TO COMPARE ATTRIBUTES WITH ATTRIBUTES, BUT APPARENTLY DOESN'T WORK IN LDAP!
	$indx++ while ($s =~ s/(\w+)\s*($relop)\s*(\$QS\[\d*\])/
			my ($one, $two, $three) = ($1, $2, $3);
			my ($regex) = 0;
			my ($opr) = $two;
			#CONVERT "NOT LIKE" AND "IS NOT" TO "!( = ).

			if ($two =~ m!(?:not\s+like|is\s+not)!io)
			{
				$two = '=';
				$regex = 2;
			}
			elsif ($two =~ m!(?:like|is)!io)  #CONVERT "LIKE" AND "IS" TO "=".
			{
				$two = '=';
				$regex = 1;
			}
			$P[$indx] = $one.$two.$three;   #SAVE EXPRESSION.
		
			#CONVERT SQL WILDCARDS INTO LDAP WILDCARDS IN OPERAND.
		
			my ($qsindx);
			if ($three =~ m!\$QS\[(\d+)\]!)
			{
				$qsindx = $1;
				if ($regex > 0)
				{
					if ($opr !~ m!is!io)
					{
						$QS[$qsindx] =~ s!\%!\*!go;     #FIX WILDCARD.  NOTE - NO FIX FOR "_"!
					}
				}
				$QS[$qsindx] = $self->{ldap_nullsearchvalue}  unless (length($QS[$qsindx]));
			}
			$P[$indx] = "!($P[$indx])"  if ($regex == 2 || $opr eq '!=' || ($opr eq '=' && !length($QS[$qsindx])));  #INVERT EXPRESSION IF "NOT"!
			$P[$indx] =~ s!\!\=!\=!o;   #AFTER INVERSION, FIX "!=" (NOT VALID IN LDAP!)
			"\$P\[$indx]";
	/ei);    #CASE-INSENSITIVITY ADDED NEXT 2: 20050416 PER PATCH BY jmorano
	$self->{tindx} = 0;
	$s = &parseParins($self, $s);

	for (my $i=0;$i<=$#T;$i++)
	{
#		1 while ($T[$i] =~ s/(.+?)\s*\band\b\s*(.+)/\&\($1\)\($2\)/i);
		1 while ($T[$i] =~ s/([^\(\)]+)\s*\band\b\s*([^\(\)]+)(?:and|or)?/\&\($1\)\($2\)/i);
		1 while ($T[$i] =~ s/([^\(\)]+)\s*\bor\b\s*([^\(\)]+)(?:and|or)?/\|\($1\)\($2\)/i);
	}
	$s =~ s/AND/and/igo;
	$s =~ s/OR/or/igo;
#	1 while ($s =~ s/(.+?)\s*\band\b\s*(.+)/\(\&\($1\)\($2\)\)/i);   #CASE-INSENSITIVITY ADDED NEXT 2: 20050416 PER PATCH BY jmorano
	1 while ($s =~ s/([^\(\)]+)\s*\band\b\s*([^\(\)]+)(?:and|or)?/\&\($1\)\($2\)/i);   #CASE-INSENSITIVITY ADDED NEXT 2: 20050416 PER PATCH BY jmorano
	1 while ($s =~ s/([^\(\)]+)\s*\bor\b\s*([^\(\)]+)(?:and|or)?/\|\($1\)\($2\)/i);   #CASE-INSENSITIVITY ADDED NEXT 2: 20050416 PER PATCH BY jmorano
	1 while ($s =~ s/\bnot\b\s*([^\s\)]+)?/\!\($1\)/);
	1 while ($s =~ s/\$T\[(\d+)\]/$T[$1]/g);
	$s =~ s/(\w+)\s+is\s+not\s+null?/$1\=\*/gi;
	$s =~ s/(\w+)\s+is\s+null?/\!\($1\=\*\)/gi;

	#CONVERT SQL WILDCARDS TO PERL REGICES.

	1 while ($s =~ s/\$P\[(\d+)\]/$P[$1]/g);
	$s =~ s/ +//go;
	1 while ($s =~ s/\$QS\[(\d+)\]/$QS[$1]/g);
	$s =~ s/\x04/\'/go;    #UNPROTECT AND UNESCAPE QUOTES WITHIN QUOTES.
	$s = '(' . $s . ')'  unless ($s =~ /^\(/o);
	return $s;
}

sub parseParins
{
	my $self = shift;
	my $s = shift;

	$self->{tindx}++ while ($s =~ s/\(([^\(\)]+)\)/
			$T[$self->{tindx}] = &parseParins($self, $1); "\$T\[$self->{tindx}]"
	/e);
	return $s;
}

sub rollback
{
	my ($self) = @_;

	my ($status) = 1;
	my ($dbh) = $self->FETCH('ldap_dbh');
	my ($autocommit) = $dbh->FETCH('AutoCommit');

	$status = $dbh->rollback()  unless ($autocommit);

	$self->{dirty} = 0  if ($status > 0);
	return $status;
}

sub update
{
	my ($self, $csr, $query) = @_;
	my ($i, $path, $regex, $table, $extra, @attblist, $filter, $all_columns);
	my $status = 0;
	my ($psuedocols) = "CURVAL|NEXTVAL|ROWNUM";
#print STDERR "-update10 sql=$query=\n";
    ##++
    ##  Hack to allow parenthesis to be escaped!
    ##--

	$query =~ s/\\([()])/sprintf ("%%\0%d: ", ord ($1))/ge;
	$path  =  $self->{path};
	$regex =  $self->{column};

	if ($query =~ /^update\s+($path)\s+set\s+(.+)$/i)
	{
		($table, $extra) = ($1, $2);
#print STDERR "-update20: table=$table= extra=$extra=\n";
		#ADDED IF-STMT 20010418 TO CATCH 
		#PARENTHESIZED SET-CLAUSES (ILLEGAL IN ORACLE & CAUSE WIERD PARSING ERRORS!)

		if ($extra =~ /^\(.+\)\s*where/io)
		{
			$errdetails = 'parenthesis around SET clause?';
			return (-504);
		}
		$table =~ tr/A-Z/a-z/  unless ($self->{CaseTableNames});  #JWT:TABLE-NAMES ARE NOW CASE-INSENSITIVE!
		$self->{file} = $table;

		my ($dbh) = $csr->FETCH('ldap_dbh');
		my ($ldap) = $csr->FETCH('ldap_ldap');
		my ($tablehash) = $dbh->FETCH('ldap_tables');
		return (-524)  unless ($tablehash->{$table});
		my ($base, $objfilter, $dnattbs, $allattbs, $alwaysinsert) = split(/\:/,$tablehash->{$table});

		$all_columns = {};

		$extra =~ s/\\\\/\x02/go;         #PROTECT "\\"
		#1$extra =~ s/\'\'/\x03\x03/go;    #PROTECT '', AND \'.
		$extra =~ s/\\\'/\x03/go;    #PROTECT '', AND \'.

		$extra =~ s/^\s+//o;  #STRIP OFF SURROUNDING SPACES.
		$extra =~ s/\s+$//o;

		#NOW TEMPORARILY PROTECT COMMAS WITHIN (), IE. FN(ARG1,ARG2).

		$column = $self->{column};
		$extra =~ s/($column\s*\=\s*)\'(.*?)\'(,|$)/
				my ($one,$two,$three) = ($1,$2,$3);
				$two =~ s|\,|\x05|go;
				$two =~ s|\(|\x06|go;
				$two =~ s|\)|\x07|go;
				$one."'".$two."'".$three;
		/eg;

		1 while ($extra =~ s/\(([^\(\)]*)\)/
				my ($args) = $1;
				$args =~ s|\,|\x05|go;
				"\x06$args\x07";
		/eg);
		@expns = split(',',$extra);
#print STDERR "-update50: extra=$extra= expns=".join('|',@expns)."=\n";
		for ($i=0;$i<=$#expns;$i++)  #PROTECT "WHERE" IN QUOTED VALUES.
		{
			$expns[$i] =~ s/\x05/\,/go;
			$expns[$i] =~ s/\x06/\(/go;
			$expns[$i] =~ s/\x07/\)/go;
			$expns[$i] =~ s/\=\s*'([^']*?)where([^']*?)'/\='$1\x05$2'/gi;
			$expns[$i] =~ s/\'(.*?)\'/my ($j)=$1; 
					$j=~s|where|\x05|gio; 
					"'$j'"
			/eg;
		}
		$extra = $expns[$#expns];    #EXTRACT WHERE-CLAUSE, IF ANY.
		$filter = ($extra =~ s/(.*)where(.+)$/where$1/i) ? $2 : '';
		$filter =~ s/\s+//o;
		$expns[$#expns] =~ s/\s*where(.+)$//io;   #20000108 REP. PREV. LINE 2FIX BUG IF LAST COLUMN CONTAINS SINGLE QUOTES.
		$column = $self->{column};
		$objfilter ||= 'objectclass=*';
		$objfilter = "($objfilter)"  unless ($objfilter =~ /^\(/o);
		if ($filter)
		{
#print STDERR "--update: BEF parse_expn: filter=$filter=\n";
			$filter = $self->parse_expression ($filter);
#print STDERR "--update: AFT parse_expn: filter=$filter= objfilter=$objfilter=\n";
			$filter = '('.$filter.')'  unless ($filter =~ /^\(/o);
			$filter = "(&$objfilter$filter)";
		}
		else
		{
			$filter = "$objfilter";
		}
	$filter =~ s/\x03/\\\'/go;    #UNPROTECT '', AND \'.  #NEXT 2 ADDED 20091101:
	$filter =~ s/\x02/\\\\/go;    #UNPROTECT "\\".
#		$alwaysinsert .= ',' . $base;   #CHGD TO NEXT 200780719 PER REQUEST.
		$alwaysinsert .= ',' . $base  if ($self->{ldap_appendbase2ins});
		$alwaysinsert =~ s/\\\\/\x02/go;   #PROTECT "\\"
		$alwaysinsert =~ s/\\\,/\x03/go;   #PROTECT "\,"
		$alwaysinsert =~ s/\\\=/\x04/go;   #PROTECT "\="
		my ($i1, $col, $vals, $j, @l);
		for ($i=0;$i<=$#expns;$i++)  #EXTRACT FIELD NAMES AND 
	                             #VALUES FROM EACH EXPRESSION.
		{
			$expns[$i] =~ s/\x03/\\\'/go;    #UNPROTECT '', AND \'.
			$expns[$i] =~ s/\x02/\\\\/go;    #UNPROTECT "\\".
			$expns[$i] =~ s!\s*($column)\s*=\s*(.+)$!
					my ($var) = $1;
					my ($val) = $2;
		
					$val = &pscolfn($self,$val)  if ($val =~ "$column\.$psuedocols");
					$var =~ tr/A-Z/a-z/;
					$val =~ s|%\0(\d+): |pack("C",$1)|ge;
					$val =~ s/^\'//o;             #NEXT 2 ADDED 20010530 TO STRIP EXCESS QUOTES.
					$val =~ s/([^\\\'])\'$/$1/;
					$val =~ s/\'$//o;
					$all_columns->{$var} = $val;
					@_ = split(/\,\s*/o, $alwaysinsert);
					while (@_)
					{
						($col, $vals) = split(/\=/o, shift);
						next  unless ($col eq $var);
						$vals =~ s/\x04/\\\=/go;       #UNPROTECT "\="
						$vals =~ s/\x03/\\\,/go;       #UNPROTECT "\,"
						$vals =~ s/\x02/\\\\/go;       #UNPROTECT "\\"
						@l = split(/\Q$self->{ldap_inseparator}\E/, $vals);
VALUE:							for (my $j=0;$j<=$#l;$j++)
						{
							next  if ($all_columns->{$var} =~ /\b$l[$j]\b/);
							$all_columns->{$var} .= $self->{ldap_inseparator} 
									if ($all_columns->{$var});
							$all_columns->{$var} .= $l[$j];
						}
					}
					$all_columns->{$var} =~ s/\x02/\\\\/go;
#					$all_columns->{$var} =~ s/\x03/\'/go;   #20091030: REPL. W.NEXT LINE TO KEEP ESCAPE SLASH "\" - RETAIN ORIG. COMMENT:
					$all_columns->{$var} =~ s/\x03/\\\'/go;   #20000108 REPL. PREV. LINE - NO NEED TO DOUBLE QUOTES (WE ESCAPE THEM) - THIS AIN'T ORACLE.
			!e;
		}

		delete $all_columns->{dn};   #DO NOT ALLOW DN TO BE CHANGED DIRECTLY!
#foreach my $xxx (sort keys %{$all_columns}) { print STDERR "---data($xxx)=".$all_columns->{$xxx}."=\n"; };
		my ($data);
		my (@searchops) = (
				'base' => $base,
				'filter' => $filter,
				);
		foreach my $i (qw(ldap_sizelimit ldap_timelimit deref typesonly 
		callback))
		{
			$j = $i;
			$j =~ s/^ldap_//o;
			push (@searchops, ($j, $self->{$i}))  if ($self->{$i});
		}
		push (@searchops, ('scope', ($self->{ldap_scope} || 'one')));
#print STDERR "-update: filter=$filter= searchops=".join('|',@searchops)."=\n";
		$data = $ldap->search(@searchops) 
				or return($self->ldap_error($@,"Search failed to return object: filter=$filter (".$data->error().")"));
#print STDERR "-update:  got thru search; data=$data=\n";
		my (@varlist) = ();
		$dbh = $csr->FETCH('ldap_dbh');
		my ($autocommit) = $dbh->FETCH('AutoCommit');
		my ($commitqueue) = $dbh->FETCH('ldap_commitqueue')  unless ($autocommit);
		my (@dnattbs) = split(/\,/o, $dnattbs);
		my ($changedn);
#print STDERR "-update:  going into loop!\n";
		while (my $entry = $data->shift_entry())
		{
#print STDERR "----update: in loop entry=$entry=\n";
			$dn = $entry->dn();
			$dn =~ s/\\/\x02/go;     #PROTECT "\";
			$dn =~ s/\\\,/\x03/go;   #PROTECT "\,";
			$changedn = 0;
I:			foreach my $i (@dnattbs)
			{
				foreach my $j (keys %$all_columns)
				{
					if ($i eq $j)
					{
						$dn =~ s/(\b$i\=)([^\,]+)/$1$all_columns->{$j}/;
						$changedn = 1;
						next I;
					}
				}
			}
			$dn =~ s/(?:\,\s*)$base$//;
			$dn =~ s/\x03/\\\,/go;     #UNPROTECT "\,";
			$dn =~ s/\x02/\\/go;     #UNPROTECT "\";
			foreach my $i (keys %$all_columns)
			{
				$all_columns->{$i} =~ s/(?:\\|\')\'/\'/go;   #1UNESCAPE QUOTES IN VALUES.
				@_ = split(/\Q$self->{ldap_inseparator}\E/, $all_columns->{$i});
				if (!@_)
				{
					push (@attblist, ($i, ''));
				}
				elsif (@_ == 1)
				{
					push (@attblist, ($i, shift));
				}
				else
				{
					push (@attblist, ($i, [@_]));
				}
			}
			$r1 = $entry->replace(@attblist);
#print STDERR "-update: r1=$r1= attblist=".join('|',@attblist)."=\n";
			if ($r1 > 0)
			{
				if ($autocommit)
				{
					$r2 = $entry->update($ldap);   #COMMIT!!!
					if ($r2->is_error)
					{
						$errdetails = $r2->code . ': ' . $r2->error;
						return (-523);
					}
					if ($changedn)
					{
						$r2 = $ldap->moddn($entry, newrdn => $dn);
						if ($r2->is_error)
						{
							$errdetails = "Could not change dn - " 
									. $r2->code . ': ' . $r2->error . '!';
							return (-523);
						}
					}
				}
				else
				{
					push (@{$commitqueue}, (\$entry, \$ldap));
					push (@{$commitqueue}, "dn=$dn")  if ($changedn);
				}
				++$status;
			}
			else
			{
			#return($self->ldap_error($@,"Search failed to return object: filter=$filter (".$data->error().")"));
				$errdetails = $data->code . ': ' . $data->error;
				return (-523);
			}
		}
		return ($status);
	}
	else
	{
		return (-504);
	}
}

sub delete 
{
	my ($self, $csr, $query) = @_;
	my ($path, $table, $filter, $wherepart);
	my $status = 0;

	$path = $self->{path};
	if ($query =~ /^delete\s+from\s+($path)(?:\s+where\s+(.+))?$/io)
	{
		$table     = $1;
		$wherepart = $2;
		$table =~ tr/A-Z/a-z/  unless ($self->{CaseTableNames});  #JWT:TABLE-NAMES ARE NOW CASE-INSENSITIVE!
		$self->{file} = $table;

		my ($dbh) = $csr->FETCH('ldap_dbh');
		my ($ldap) = $csr->FETCH('ldap_ldap');
		my ($tablehash) = $dbh->FETCH('ldap_tables');
		return (-524)  unless ($tablehash->{$table});
		my ($base, $objfilter, $dnattbs, $allattbs, $alwaysinsert) = split(/\:/,$tablehash->{$table});
		$objfilter ||= 'objectclass=*';
		$objfilter = "($objfilter)"  unless ($objfilter =~ /^\(/o);
		if ($wherepart =~ /\S/o)
		{
			$filter = $self->parse_expression ($wherepart);
			$filter = '('.$filter.')'  unless ($filter =~ /^\(/o);
			$filter = "(&$objfilter$filter)";
		}
		else
		{
			$filter = "$objfilter";
		}
		$filter = '('.$filter.')'  unless ($filter =~ /^\(/o);

		$data = $ldap->search(
				base   => $base,
				filter => $filter,
		) or return ($self->ldap_error($@,"Search failed to return object: filter=$filter (".$data->error().")"));
		my ($j) = 0;
		my (@varlist) = ();
		$dbh = $csr->FETCH('ldap_dbh');
		my ($autocommit) = $dbh->FETCH('AutoCommit');
		my ($commitqueue) = $dbh->FETCH('ldap_commitqueue')  unless ($autocommit);
		while (my $entry = $data->shift_entry())
		{
			$dn = $entry->dn();
			next  unless ($dn =~ /$base$/i);   #CASE-INSENSITIVITY ADDED NEXT 2: 20050416 PER PATCH BY jmorano
			$r1 = $entry->delete();
			if ($autocommit)
			{
				$r2 = $entry->update($ldap);   #COMMIT!!!
				if ($r2->is_error)
				{
					$errdetails = $r2->code . ': ' . $r2->error;
					return (-523);
				}
			}
			else
			{
				push (@{$commitqueue}, (\$entry, \$ldap));
			}
			++$status;
		}

		return $status;
	}
	else
	{
		return (-505);
	}
}

sub primary_key_info
{
	my ($self, $csr, $query) = @_;
	my $table = $query;
	$table =~ s/^.*\s+(\w+)$/$1/;
	$table =~ tr/A-Z/a-z/  unless ($self->{CaseTableNames});  #JWT:TABLE-NAMES ARE NOW CASE-INSENSITIVE!
	$self->{file} = $table;
	my ($dbh) = $csr->FETCH('ldap_dbh');
	my $tablehash = $dbh->FETCH('ldap_tables');
	return -524  unless ($tablehash->{$table});

	undef %{ $self->{types} };
	undef %{ $self->{lengths} };
	$self->{use_fields} = 'CAT,SCHEMA,TABLE_NAME,PRIMARY_KEY';
	$self->{order} = [ 'CAT', 'SCHEMA', 'TABLE_NAME', 'PRIMARY_KEY' ];
	$self->{fields}->{CAT} = 1;
	$self->{fields}->{SCHEMA} = 1;
	$self->{fields}->{TABLE_NAME} = 1;
	$self->{fields}->{PRIMARY_KEY} = 1;
	undef @{ $self->{records} };
	my (@keyfields) = split(/\,\s*/o, $self->{key_fields});  #JWT: PREVENT DUP. KEYS.
	${$self->{types}}{CAT} = 'VARCHAR';
	${$self->{types}}{SCHEMA} = 'VARCHAR';
	${$self->{types}}{TABLE_NAME} = 'VARCHAR';
	${$self->{types}}{PRIMARY_KEY} = 'VARCHAR';
	${$self->{lengths}}{CAT} = 50;
	${$self->{lengths}}{SCHEMA} = 50;
	${$self->{lengths}}{TABLE_NAME} = 50;
	${$self->{lengths}}{PRIMARY_KEY} = 50;
	${$self->{defaults}}{CAT} = undef;
	${$self->{defaults}}{SCHEMA} = undef;
	${$self->{defaults}}{TABLE_NAME} = undef;
	${$self->{defaults}}{PRIMARY_KEY} = undef;
	${$self->{scales}}{PRIMARY_KEY} = 50;
	${$self->{scales}}{PRIMARY_KEY} = 50;
	${$self->{scales}}{PRIMARY_KEY} = 50;
	${$self->{scales}}{PRIMARY_KEY} = 50;
	my $results;
	my $keycnt = scalar(@keyfields);
	while (@keyfields)
	{
		push (@{$results}, [0, 0, $table, shift(@keyfields)]);
	}
	unshift (@$results, $keycnt);
	return $results;
}

sub alter    #SQL COMMAND NOT IMPLEMENTED.
{
	$@ = 'SQL "alter" command is not (yet) implemented!';
	return 0;
}

sub insert
{
	#my ($self, $query) = @_;
	my ($self, $csr, $query) = @_;
	my ($i, $path, $table, $columns, $values, $status);

	$path = $self->{path};
	if ($query =~ /^insert\s+into\s+    # Keyword
			($path)\s*                  # Table
			(?:\((.+?)\)\s*)?           # Keys
	values\s*                           # 'values'
			\((.+)\)$/ixo)
	{   #JWT: MAKE COLUMN LIST OPTIONAL!

		($table, $columns, $values) = ($1, $2, $3);
		my ($dbh) = $csr->FETCH('ldap_dbh');
		my ($tablehash) = $dbh->FETCH('ldap_tables');
		$table =~ tr/A-Z/a-z/  unless ($self->{CaseTableNames});  #JWT:TABLE-NAMES ARE NOW CASE-INSENSITIVE!
		$self->{file} = $table;
		return (-524)  unless ($tablehash->{$table});
		my ($base, $objfilter, $dnattbs, $allattbs, $alwaysinsert) = split(/\:/,$tablehash->{$table});
		$columns =~ s/\s//go;
		$columns ||= $allattbs;
		$columns = join(',', @{ $self->{order} })  unless ($columns =~ /\S/o);  #JWT

		unless ($columns =~ /\S/o)
		{
			return ($self->display_error (-509));
		}
		$values =~ s/\\\\/\x02/go;         #PROTECT "\\"
		$values =~ s/\\\'/\x03/go;    #PROTECT '', AND \'.

		$values =~ s/\'(.*?)\'/
				my ($j)=$1; 
				$j=~s|,|\x04|go;         #PROTECT "," IN QUOTES.
				"'$j'"
		/eg;
		@values = split(/,/o, $values);
		$values = '';
		for $i (0..$#values)
		{
			$values[$i] =~ s/^\s+//o;      #STRIP LEADING & TRAILING SPACES.
			$values[$i] =~ s/\s+$//o;
			$values[$i] =~ s/\x03/\'/go;   #RESTORE PROTECTED SINGLE QUOTES HERE.
			$values[$i] =~ s/\x02/\\/go;   #RESTORE PROTECTED SLATS HERE.
			$values[$i] =~ s/\x04/,/go;    #RESTORE PROTECTED COMMAS HERE.
		}
		chop($values);

		$status = $self->insert_data ($csr, $base, $dnattbs, $alwaysinsert, $columns, @values);

		return $status;
	}
	else
	{
		return (-508);
	}
}

sub insert_data
{
	my ($self, $csr, $base, $dnattbs, $alwaysinsert, $column_string, @values) = @_;
	my (@columns, @attblist, $loop, $column, $j, $k);
	$column_string =~ tr/A-Z/a-z/;
	$dnattbs =~ tr/A-Z/a-z/;
	@columns = split (/\,/o, $column_string);

	if ($#columns = $#values)
	{
		my $dn = '';
		my @t = split(/,/o, $dnattbs);
		while (@t)
		{
			$j = shift (@t);
J1:			for (my $i=0;$i<=$#columns;$i++)
			{
				if ($columns[$i] eq $j)
				{
					$dn .= $columns[$i] . '=';
					if ($values[$i] =~ /\Q$self->{ldap_inseparator}\E/)
					{
						$dn .= (split(/\Q$self->{ldap_inseparator}\E/,$values[$i]))[0];
					}
					else
					{
						$dn .= $values[$i];
					}
					$dn .= ', ';
					last J1;
				}
			}
		}
		$dn =~ s/\'//go;
		$dn .= $base;
		for (my $i=0;$i<=$#columns;$i++)
		{
			@l = split(/\Q$self->{ldap_inseparator}\E/,$values[$i]);
			while (@l)
			{
				$j = shift(@l);
				$j =~ s/^\'//o;
				$j =~ s/([^\\\'])\'$/$1/;
				unless (!length($j) || $j eq "'" || $columns[$i] eq 'dn')
				{
					$j = "'"  if ($j eq "''");
					push (@attblist, $columns[$i]);
					push (@attblist, $j);
				}
			}
		}
#		$alwaysinsert .= ',' . $base;   #CHGD TO NEXT 200780719 PER REQUEST.
		$alwaysinsert .= ',' . $base  if ($self->{ldap_appendbase2ins});
		my ($i1, $found, $col, $vals, $j);
		@_ = split(/\,\s*/o, $alwaysinsert);
		while (@_)
		{
			($col, $vals) = split(/\=/o, shift);
			@l = split(/\Q$self->{ldap_inseparator}\E/, $vals);
VALUE:				for (my $i=0;$i<=$#l;$i++)
			{
				for ($j=0;$j<=$#attblist;$j+=2)
				{
					if ($attblist[$j] eq $col)
					{
						next VALUE  if ($attblist[$j+1] eq $l[$i]);
					}
				}
				push (@attblist, $col);
				push (@attblist, $l[$i]);
			}
		}
		my ($ldap) = $csr->FETCH('ldap_ldap');

		my $entry = Net::LDAP::Entry->new;
		$entry->dn($dn);

		my $result = $entry->add(@attblist);
		$_ = $entry->dn();

		my ($dbh) = $csr->FETCH('ldap_dbh');
		my ($autocommit) = $dbh->FETCH('AutoCommit');
		if ($autocommit)
		{
			$r2 = $entry->update($ldap);   #COMMIT!!!
			if ($r2->is_error)
			{
				$errdetails = $r2->code . ': ' . $r2->error;
				return (-523);
			}
		}
		else
		{
			my ($commitqueue) = $dbh->FETCH('ldap_commitqueue');
			push (@{$commitqueue}, (\$entry, \$ldap));
		}

		return (1);
	}
	else
	{
		$errdetails = "$#columns != $#values";   #20000114
		return (-509);
	}
}						    

sub create    #SQL COMMAND NOT IMPLEMENTED.
{
	$@ = 'SQL "create" command is not (yet) implemented!';
	return 0;
}

sub drop    #SQL COMMAND NOT IMPLEMENTED.
{
	$@ = 'SQL "drop" command is not (yet) implemented!';
	return 0;
}

sub pscolfn
{
	my ($self,$id) = @_;
	return $id  unless ($id =~ /CURVAL|NEXTVAL|ROWNUM/);
	my ($value) = '';
	my ($seq_file,$col) = split(/\./o, $id);
	$seq_file = $self->get_path_info($seq_file) . '.seq';

	$seq_file =~ tr/A-Z/a-z/  unless ($self->{CaseTableNames});  #JWT:TABLE-NAMES ARE NOW CASE-INSENSITIVE!
	open (FILE, "<$seq_file") || return (-511);
	$x = <FILE>;
	#chomp($x);
	$x =~ s/\s+$//o;   #20000113
	($incval, $startval) = split(/\,/o, $x);
	close (FILE);
	if ($id =~ /NEXTVAL/o)
	{
		open (FILE, ">$seq_file") || return (-511);
		$incval += ($startval || 1);
		print FILE "$incval,$startval\n";
		close (FILE);
	}
	$value = $incval;
	return $value;
}

sub SYSTIME
{
	return time;
}

sub NUM
{
	return shift;
}

sub NULL
{
	return '';
}

1;