1#!/usr/bin/perl 2 3package JLdap; 4 5require 5.002; 6 7use Net::LDAP::Entry; 8no warnings qw (uninitialized); 9 10#use Fcntl; 11 12##++ 13## Global Variables. Declare lock constants manually, instead of 14## importing them from Fcntl. 15## 16use vars qw ($VERSION); 17##-- 18 19$JLdap::VERSION = '1.00'; 20 21#my $NUMERICTYPES = '^(NUMBER|FLOAT|DOUBLE|INT|INTEGER|NUM)$'; #20000224 22#my $STRINGTYPES = '^(VARCHAR|CHAR|VARCHAR|DATE|LONG|BLOB|MEMO)$'; 23 24##++ 25## Public Methods and Constructor 26##-- 27 28sub new 29{ 30 my $class = shift; 31 my $self; 32 33 $self = { 34 commands => 'select|update|delete|alter|insert|create|drop|primary_key_info', 35 column => '[A-Za-z0-9\~\x80-\xFF][\w\x80-\xFF]+', 36 _select => '[\w\x80-\xFF\*,\s\~]+', 37 path => '[\w\x80-\xFF\-\/\.\:\~\\\\]+', 38 table => '', 39 timestamp => 0, 40 fields => {}, 41 use_fields => '', 42 key_fields => '', 43 order => [], 44 types => {}, 45 lengths => {}, 46 scales => {}, 47 defaults => {}, 48 records => [], 49 errors => {}, 50 lasterror => 0, #JWT: ADDED FOR ERROR-CONTROL 51 lastmsg => '', 52 CaseTableNames => 0, #JWT: 19990991 TABLE-NAME CASE-SENSITIVITY? 53 LongTruncOk => 0, #JWT: 19991104: ERROR OR NOT IF TRUNCATION. 54 RaiseError => 0, #JWT: 20000114: ADDED DBI RAISEERROR HANDLING. 55 silent => 0, 56 ldap_dbh => 0, 57 ldap_sizelimit => 0, #JWT: LIMIT #RECORDS FETCHED, IF SET. 58 ldap_timelimit => 0, #JWT: LIMIT #RECORDS FETCHED, IF SET. 59 ldap_deref => 0, #JWT: LIMIT #RECORDS FETCHED, IF SET. 60 ldap_typesonly => 0, 61 ldap_callback => 0, 62 ldap_scope => 0, 63 ldap_inseparator => '|', 64 ldap_outseparator => '|', 65 ldap_firstonly => 0, 66 ldap_nullsearchvalue => ' ', #ADDED 20040330 TO FOR BACKWARD COMPATABILITY. 67 ldap_appendbase2ins => 0, #ADDED 20060719 FOR BACKWARD COMPAT. - 0.08+ NO LONGER APPENDS BASE TO ALWAYSINSERT PER REQUEST. 68 dirty => 0, #JWT: 20000229: PREVENT NEEDLESS RECOMMITS. 69 tindx => 0 #REPLACES GLOBAL VARIABLE. 70 }; 71 72 bless $self, $class; 73 74 for (my $i=0;$i<scalar(@_);$i+=2) #ADDED: 20040330 TO ALLOW SETTING ATTRIBUTES IN INITIALIZATION! 75 { 76 $self->{$_[$i]} = $_[$i+1]; 77 } 78 79 $self->initialize; 80 return $self; 81} 82sub initialize 83{ 84 my $self = shift; 85 86 $self->define_errors; 87} 88 89sub sql 90{ 91 my ($self, $csr, $query) = @_; 92 93 my ($command, $status, $base, $fields); 94#print STDERR "-sql1($command,$status,$base,$fields)"; 95 return wantarray ? () : -514 unless ($query); 96 $self->{lasterror} = 0; 97 $self->{lastmsg} = ''; 98 $query =~ s/\n/ /gso; 99 $query =~ s/^\s*(.*?)\s*$/$1/; 100 $query = 'select tables' if ($query =~ /^show\s+tables$/i); 101 $query = 'select tables' if ($query =~ /^select\s+TABLE_NAME\s+from\s+USER_TABLES$/i); #ORACLE-COMPATABILITY. 102 $command = ''; 103 104 if ($query =~ /^($self->{commands})/io) 105 { 106 $command = $1; 107 $command =~ tr/A-Z/a-z/; #ADDED 19991202! 108 $status = $self->$command ($csr, $query); 109 if (!defined($status)) #NEXT 5 ADDED PER PATCH REQUEST 20091101: 110 { 111 $self->display_error(-599); 112 return wantarray ? () : -599; 113 } 114 elsif (ref ($status) eq 'ARRAY') #SELECT RETURNED OK (LIST OF RECORDS). 115 { 116 return wantarray ? @$status : $status; 117 } 118 else 119 { 120 if ($status < 0) 121 { #SQL RETURNED AN ERROR! 122#print STDERR "-sql6 status=$status=\n"; 123 $self->display_error ($status); 124 #return ($status); 125 return wantarray ? () : $status; 126 } 127 else 128 { #SQL RETURNED OK. 129#print STDERR "-sql7 status=$status= at=$@= cash=$_= bang=$!= query=$?=\n"; 130 return wantarray ? ($status) : $status; 131 } 132 } 133 } 134 else 135 { 136 return wantarray ? () : -514; 137 } 138} 139 140sub select 141{ 142 my ($self, $csr, $query) = @_; 143 144 my (@ordercols) = (); 145 $regex = $self->{_select}; 146 $path = $self->{path}; 147 my (@rtnvals) = (); 148 149 my $distinct; 150 $distinct = 1 if ($query =~ s/select\s+distinct(\s+\w|\s*\(|\s+\*)/select $1/i); 151 my ($dbh) = $csr->FETCH('ldap_dbh'); 152 my ($tablehash); 153 154 if ($query =~ /^select tables$/io) 155 { 156 $tablehash = $dbh->FETCH('ldap_tablenames'); 157 $self->{use_fields} = 'TABLE_NAME'; #ADDED 20000224 FOR DBI! 158 $values_or_error = []; 159 for ($i=0;$i<=$#{$tablehash};$i++) 160 { 161 push (@$values_or_error,[$tablehash->[$i]]); 162 } 163 unshift (@$values_or_error, ($#{$tablehash}+1)); 164 return $values_or_error; 165 } 166 elsif ($query =~ /^select\s+ # Keyword 167 ($regex)\s+ # Columns 168 from\s+ # 'from' 169 ($path)(.*)$/iox) 170 { 171 ($attbs, $table, $extra) = ($1, $2, $3); 172 173 $table =~ tr/A-Z/a-z/ unless ($self->{CaseTableNames}); #JWT:TABLE-NAMES ARE NOW CASE-INSENSITIVE! 174 $self->{file} = $table; 175 if ($extra =~ s/([\s|\)]+)order\s+by\s*(.*)/$1/i) 176 { 177 $orderclause = $2; 178 @ordercols = split(/,/,$orderclause); 179 $descorder = ($ordercols[$#ordercols] =~ s/(\w+\W+)desc(?:end|ending)?$/$1/i); #MODIFIED 20000721 TO ALLOW "desc|descend|descending"! 180 for $i (0..$#ordercols) 181 { 182 $ordercols[$i] =~ s/\s//igo; #CASE-INSENSITIVITY ADDED NEXT 2: 20050416 PER PATCH BY jmorano 183 $ordercols[$i] =~ s/[\(\)]+//igo; 184 } 185 } 186 $tablehash = $dbh->FETCH('ldap_tables'); 187 return (-524) unless ($tablehash->{$table}); 188 189 my ($base, $objfilter, $dnattbs, $allattbs, $alwaysinsert) = split(/\:/o ,$tablehash->{$table}); 190 $attbs = $allattbs if ($allattbs && $attbs =~ s/\*//o); 191 $attbs =~ s/\s//go; 192 $attbs =~ tr/A-Z/a-z/; 193 @{$self->{order}} = split(/,/o, $attbs) unless ($attbs eq '*'); 194 my $fieldnamehash = (); 195 my $attbcnt = 0; 196 foreach my $i (@{$self->{order}}) 197 { 198 $fieldnamehash{$i} = $attbcnt++; 199 } 200 my ($ldap) = $csr->FETCH('ldap_ldap'); 201 $objfilter ||= 'objectclass=*'; 202 $objfilter = "($objfilter)" unless ($objfilter =~ /^\(/o); 203#print "<BR>-where=$extra=\n"; 204 if ($extra =~ /^\s+where\s*(.+)$/io) 205 { 206 $filter = $self->parse_expression($1); 207 $filter = '('.$filter.')' unless ($filter =~ /^\(/o); 208 $filter = "(&$objfilter$filter)"; 209 } 210 else 211 { 212 $filter = $objfilter; 213 } 214#print "<BR>-filter =$filter=\n"; 215 my $data; 216 my (@searchops) = ( 217 'base' => $base, 218 'filter' => $filter, 219 'attrs' => [split(/\,/o, $attbs)] 220 ); 221 foreach my $i (qw(ldap_sizelimit ldap_timelimit deref typesonly 222 callback)) 223 { 224 $j = $i; 225 $j =~ s/^ldap_//o; 226 push (@searchops, ($j, $self->{$i})) if ($self->{$i}); 227 } 228 push (@searchops, ('scope', ($self->{ldap_scope} || 'one'))); 229#print "--- ATTBS =$attbs=\n"; 230#print "--- SEARCH OPS =".join('|',@searchops)."=\n"; 231 $data = $ldap->search(@searchops) 232 or return($self->ldap_error($@,"Search failed to return object: filter=$filter (".$data->error().")")); 233#print "--- data=$data=\n"; 234 my ($j) = 0; 235 my (@varlist) = (); 236 while (my $entry = $data->shift_entry()) 237 { 238 $dn = $entry->dn(); 239 next unless ($dn =~ /$base$/i); #CASE-INSENSITIVITY ADDED NEXT 2: 20050416 PER PATCH BY jmorano 240 @attributes = $entry->attributes; 241 unless ($attbcnt) 242 { 243 $attbs = join(',',@attributes); 244 $attbcnt = 0; 245 @{$self->{order}} = @attributes; 246 foreach my $i (@{$self->{order}}) 247 { 248 $fieldnamehash{$i} = $attbcnt++; 249 } 250 } 251 $varlist[$j] = []; 252 for (my $i=0;$i<$attbcnt;$i++) 253 { 254 $varlist[$j][$i] = ''; 255 } 256 $i = 0; 257 foreach my $attr (@{$self->{order}}) 258 { 259# $valuesref = $entry->get($attr); #CHGD. TO NEXT PER PATCH REQUEST 20091101: 260 $valuesref = $entry->get_value($attr, asref => 1); 261 if ($self->{ldap_firstonly} && $self->{ldap_firstonly} <= scalar (@{$valuesref})) 262 { 263 #$varlist[$j][$fieldnamehash{$attr}] = join($self->{ldap_outseparator}, $valuesref->[0]); #CHGD. 20010829 TO NEXT. 264 $varlist[$j][$fieldnamehash{$attr}] = join($self->{ldap_outseparator}, @{$valuesref}[0..($self->{ldap_firstonly}-1)]); 265 } 266 else 267 { 268 $varlist[$j][$fieldnamehash{$attr}] = join($self->{ldap_outseparator}, @$valuesref) || ''; 269 } 270 unless ($valuesref[0]) 271 { 272 $varlist[$j][$fieldnamehash{dn}] = $dn if ($attr eq 'dn'); 273 } 274 $i++; 275 } 276 ++$j; 277 } 278 $self->{use_fields} = $attbs; 279 if ($distinct) #THIS MAKES "DISTINCT" WORK. 280 { 281 my (%disthash); 282 for (my $i=0;$i<=$#varlist;$i++) 283 { 284 ++$disthash{join("\x02",@{$varlist[$i]})}; 285 } 286 @varlist = (); 287 foreach my $i (keys(%disthash)) 288 { 289 push (@varlist, [split(/\x02/o, $i, -1)]); 290 } 291 } 292 if ($#ordercols >= 0) #SORT 'EM! 293 { 294 my @SV; 295 for (my $i=0;$i<=$#varlist;$i++) 296 { 297 $SV[$i] = ''; 298 foreach my $j (@ordercols) 299 { 300 $SV[$i] .= $varlist[$i][$fieldnamehash{$j}] . "\x01"; 301 } 302 } 303 @sortvector = &sort_elements(\@SV); 304 @sortvector = reverse(@sortvector) if ($descorder); 305 @SV = (); 306 while (@sortvector) 307 { 308 push (@SV, $varlist[shift(@sortvector)]); 309 } 310 @varlist = @SV; 311 @SV = (); 312 } 313 return [($#attributes+1), @varlist]; 314 } 315 else #INVALID SELECT STATEMENT! 316 { 317 return (-503); 318 } 319} 320 321sub sort_elements 322{ 323 my (@elements, $line, @sortlist, @sortedlist, $j, $t, $argcnt, $linedata, 324 $vectorid, @sortvector); 325 326 my ($lo) = 0; 327 my ($hi) = 0; 328 $lo = shift unless (ref($_[0])); 329 $hi = shift unless (ref($_[0])); 330 331 if ($lo || $hi) 332 { 333 for ($j=0;$j<=$#{$_[0]};$j++) 334 { 335 $sortvector[$j] = $j; 336 } 337 } 338 $hi ||= $#{$_[0]}; 339 $argcnt = scalar(@_); 340 for (my $i=$lo;$i<=$hi;$i++) 341 { 342 $line = $_[0][$i]; 343 for ($j=1;$j<$argcnt;$j++) 344 { 345 $line .= "\x02" . $_[$j][$i]; 346 } 347 $line .= "\x04".$i; 348 push (@sortlist, $line); 349 } 350 351 @sortedlist = sort @sortlist; 352 $i = $lo; 353 foreach $line (@sortedlist) 354 { 355 ($linedata,$vectorid) = split(/\x04/o, $line); 356 (@elements) = split(/\x02/o, $linedata); 357 $t = $#elements unless $t; 358 for ($j=$t;$j>=1;$j--) 359 { 360 #push (@{$_[$j]}, $elements[$j]); 361 ${$_[$j]}[$i] = $elements[$j]; 362 } 363 $sortvector[$i] = $vectorid; 364 $elements[0] =~ s/\s+//go; 365 ${$_[0]}[$i] = $elements[$j]; 366 ++$i; 367 } 368 return @sortvector; 369} 370 371sub ldap_error 372{ 373 my ($self,$errcode,$errmsg,$warn) = @_; 374 375 $err = $errcode || -1; 376 $errdetails = $errmsg; 377 $err = -1 * $err if ($err > 0); 378 return ($err) unless (defined($warn) && $warn); 379 380# print "Content-type: text/html\nWindow-target: _parent", "\n\n" 381# if (defined($warn) && $warn == 1); 382 383 return ($self->display_error($errcode)); 384} 385 386sub display_error 387{ 388 my ($self, $error) = @_; 389 390 $other = $@ || $! || 'None'; 391 392 print STDERR <<Error_Message unless ($self->{silent}); 393 394Oops! The following error occurred when processing your request: 395 396 $self->{errors}->{$error} ($errdetails) 397 398Here's some more information to help you: 399 400 file: $self->{file} 401 $other 402 403Error_Message 404 405#JWT: ADDED FOR ERROR-CONTROL. 406 407 $self->{lasterror} = $error; 408 $self->{lastmsg} = "$error:" . $self->{errors}->{$error}; 409 $self->{lastmsg} .= '('.$errdetails.')' if ($errdetails); #20000114 410 411 $errdetails = ''; #20000114 412 die $self->{lastmsg} if ($self->{RaiseError}); #20000114. 413 414 #return (1); 415 return ($error); 416} 417 418sub commit 419{ 420 my ($self) = @_; 421 my ($status) = 1; 422 my ($dbh) = $self->FETCH('ldap_dbh'); 423 my ($autocommit) = $dbh->FETCH('AutoCommit'); 424 425 $status = $dbh->commit() unless ($autocommit); 426 427 $self->{dirty} = 0 if ($status > 0); 428 return undef if ($status <= 0); #ADDED 20000103 429 return $status; 430} 431 432##++ 433## Private Methods 434##-- 435 436sub define_errors 437{ 438 my $self = shift; 439 my $errors; 440 441 $errors = {}; 442 443 $errors->{'-501'} = 'Could not open specified database.'; 444 $errors->{'-502'} = 'Specified column(s) not found.'; 445 $errors->{'-503'} = 'Incorrect format in [select] statement.'; 446 $errors->{'-504'} = 'Incorrect format in [update] statement.'; 447 $errors->{'-505'} = 'Incorrect format in [delete] statement.'; 448 $errors->{'-506'} = 'Incorrect format in [add/drop column] statement.'; 449 $errors->{'-507'} = 'Incorrect format in [alter table] statement.'; 450 $errors->{'-508'} = 'Incorrect format in [insert] command.'; 451 $errors->{'-509'} = 'The no. of columns does not match no. of values.'; 452 $errors->{'-510'} = 'A severe error! Check your query carefully.'; 453 $errors->{'-511'} = 'Cannot write the database to output file.'; 454 $errors->{'-512'} = 'Unmatched quote in expression.'; 455 $errors->{'-513'} = 'Need to open the database first!'; 456 $errors->{'-514'} = 'Please specify a valid query.'; 457# $errors->{'-515'} = 'Cannot get lock on database file.'; 458# $errors->{'-516'} = 'Cannot delete temp. lock file.'; 459 $errors->{'-517'} = "Built-in function failed ($@)."; 460 $errors->{'-518'} = "Unique Key Constraint violated."; #JWT. 461 $errors->{'-519'} = "Field would have to be truncated."; #JWT. 462 $errors->{'-520'} = "Can not create existing table (drop first!)."; #20000225 JWT. 463 $errors->{'-521'} = "Can not change datatype on non-empty table."; #20000323 JWT. 464 $errors->{'-522'} = "Can not decrease field-size on non-empty table."; #20000323 JWT. 465 $errors->{'-523'} = "Update Failed to commit changes."; #20000323 JWT. 466 $errors->{'-524'} = "No such table."; #20000323 JWT. 467 $errors->{'-599'} = 'General error.'; 468 469 $self->{errors} = $errors; 470 471 return (1); 472} 473 474sub parse_expression 475{ 476 my ($self, $s) = @_; 477 478 $s =~ s/\s+$//o; #STRIP OFF LEADING AND TRAILING WHITESPACE. 479 $s =~ s/^\s+//o; 480 return unless ($s); 481 482 483 my $relop = '(?:<|=|>|<=|>=|!=|like|not\s+like|is\s+not|is)'; 484 my %boolopsym = ('and' => '&', 'or' => '|'); 485 486 my $indx = 0; 487 488 my @P = (); 489 my @T3 = (); #PROTECTS MULTI-WAY RELOP EXPRESSIONS, IE. (A AND B AND C) 490 my $t3indx = 0; 491 @T = (); 492 my @QS = (); 493 494 $s=~s|\\\'|\x04|go; #PROTECT "\'" IN QUOTES. 495 $s=~s|\\\"|\x02|go; #PROTECT "\"" IN QUOTES. 496 497 #THIS NEXT LOOP STRIPS OUT AND SAVES ALL QUOTED STRING LITERALS 498 #TO PREVENT THEM FROM INTERFEARING WITH OTHER REGICES, IE. DON'T 499 #WANT OPERATORS IN STRINGS TO BE TREATED AS OPERATORS! 500 501 $indx++ while ($s =~ s/([\'\"])([^\1]*?)\1/ 502 $QS[$indx] = $2; "\$QS\[$indx]"/e); 503 504 for (my $i=0;$i<=$#QS;$i++) #ESCAPE LDAP SPECIAL-CHARACTERS. 505 { 506 $QS[$i] =~ s/\\x([\da-fA-F][\da-fA-F])/\x05$1/g; #PROTECT PERL HEX TO LDAP HEX (\X## => \##). 507 #$QS[$i] =~ s/([\*\(\)\+\\\<\>])/\\$1/g; #CHGD. TO NEXT. 20020409! 508 $QS[$i] =~ s/([\*\(\)\\])/"\\".unpack('H2',$1)/eg; 509 #$QS[$i] =~ s/\\x(\d\d)/\\$1/g; #CONVERT PERL HEX TO LDAP HEX (\X## => \##). 510 $QS[$i] =~ s/\x05([\da-fA-F][\da-fA-F])/\\$1/go; #CONVERT PERL HEX TO LDAP HEX (\X## => \##). 511 } 512#print STDERR "-parse_expression: QS list=".join('|',@QS)."= SSSS=$s=\n"; 513 $indx = 0; 514 515 #I TRIED TO ALLOWING ATTRIBUTES TO BE COMPARED W/OTHER ATTRIBUTES, BUT 516 #(20020409), BUT APPARENTLY LDAP ONLY ALLOWS STRING CONSTANTS ON RHS OF OPERATORS! 517 518# $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! 519 $indx++ while ($s =~ s/(\w+)\s*($relop)\s*(\$QS\[\d*\])/ 520 my ($one, $two, $three) = ($1, $2, $3); 521 my ($regex) = 0; 522 my ($opr) = $two; 523 #CONVERT "NOT LIKE" AND "IS NOT" TO "!( = ). 524 525 if ($two =~ m!(?:not\s+like|is\s+not)!io) 526 { 527 $two = '='; 528 $regex = 2; 529 } 530 elsif ($two =~ m!(?:like|is)!io) #CONVERT "LIKE" AND "IS" TO "=". 531 { 532 $two = '='; 533 $regex = 1; 534 } 535 $P[$indx] = $one.$two.$three; #SAVE EXPRESSION. 536 537 #CONVERT SQL WILDCARDS INTO LDAP WILDCARDS IN OPERAND. 538 539 my ($qsindx); 540 if ($three =~ m!\$QS\[(\d+)\]!) 541 { 542 $qsindx = $1; 543 if ($regex > 0) 544 { 545 if ($opr !~ m!is!io) 546 { 547 $QS[$qsindx] =~ s!\%!\*!go; #FIX WILDCARD. NOTE - NO FIX FOR "_"! 548 } 549 } 550 $QS[$qsindx] = $self->{ldap_nullsearchvalue} unless (length($QS[$qsindx])); 551 } 552 $P[$indx] = "!($P[$indx])" if ($regex == 2 || $opr eq '!=' || ($opr eq '=' && !length($QS[$qsindx]))); #INVERT EXPRESSION IF "NOT"! 553 $P[$indx] =~ s!\!\=!\=!o; #AFTER INVERSION, FIX "!=" (NOT VALID IN LDAP!) 554 "\$P\[$indx]"; 555 /ei); #CASE-INSENSITIVITY ADDED NEXT 2: 20050416 PER PATCH BY jmorano 556 $self->{tindx} = 0; 557 $s = &parseParins($self, $s); 558 559 for (my $i=0;$i<=$#T;$i++) 560 { 561# 1 while ($T[$i] =~ s/(.+?)\s*\band\b\s*(.+)/\&\($1\)\($2\)/i); 562 1 while ($T[$i] =~ s/([^\(\)]+)\s*\band\b\s*([^\(\)]+)(?:and|or)?/\&\($1\)\($2\)/i); 563 1 while ($T[$i] =~ s/([^\(\)]+)\s*\bor\b\s*([^\(\)]+)(?:and|or)?/\|\($1\)\($2\)/i); 564 } 565 $s =~ s/AND/and/igo; 566 $s =~ s/OR/or/igo; 567# 1 while ($s =~ s/(.+?)\s*\band\b\s*(.+)/\(\&\($1\)\($2\)\)/i); #CASE-INSENSITIVITY ADDED NEXT 2: 20050416 PER PATCH BY jmorano 568 1 while ($s =~ s/([^\(\)]+)\s*\band\b\s*([^\(\)]+)(?:and|or)?/\&\($1\)\($2\)/i); #CASE-INSENSITIVITY ADDED NEXT 2: 20050416 PER PATCH BY jmorano 569 1 while ($s =~ s/([^\(\)]+)\s*\bor\b\s*([^\(\)]+)(?:and|or)?/\|\($1\)\($2\)/i); #CASE-INSENSITIVITY ADDED NEXT 2: 20050416 PER PATCH BY jmorano 570 1 while ($s =~ s/\bnot\b\s*([^\s\)]+)?/\!\($1\)/); 571 1 while ($s =~ s/\$T\[(\d+)\]/$T[$1]/g); 572 $s =~ s/(\w+)\s+is\s+not\s+null?/$1\=\*/gi; 573 $s =~ s/(\w+)\s+is\s+null?/\!\($1\=\*\)/gi; 574 575 #CONVERT SQL WILDCARDS TO PERL REGICES. 576 577 1 while ($s =~ s/\$P\[(\d+)\]/$P[$1]/g); 578 $s =~ s/ +//go; 579 1 while ($s =~ s/\$QS\[(\d+)\]/$QS[$1]/g); 580 $s =~ s/\x04/\'/go; #UNPROTECT AND UNESCAPE QUOTES WITHIN QUOTES. 581 $s = '(' . $s . ')' unless ($s =~ /^\(/o); 582 return $s; 583} 584 585sub parseParins 586{ 587 my $self = shift; 588 my $s = shift; 589 590 $self->{tindx}++ while ($s =~ s/\(([^\(\)]+)\)/ 591 $T[$self->{tindx}] = &parseParins($self, $1); "\$T\[$self->{tindx}]" 592 /e); 593 return $s; 594} 595 596sub rollback 597{ 598 my ($self) = @_; 599 600 my ($status) = 1; 601 my ($dbh) = $self->FETCH('ldap_dbh'); 602 my ($autocommit) = $dbh->FETCH('AutoCommit'); 603 604 $status = $dbh->rollback() unless ($autocommit); 605 606 $self->{dirty} = 0 if ($status > 0); 607 return $status; 608} 609 610sub update 611{ 612 my ($self, $csr, $query) = @_; 613 my ($i, $path, $regex, $table, $extra, @attblist, $filter, $all_columns); 614 my $status = 0; 615 my ($psuedocols) = "CURVAL|NEXTVAL|ROWNUM"; 616#print STDERR "-update10 sql=$query=\n"; 617 ##++ 618 ## Hack to allow parenthesis to be escaped! 619 ##-- 620 621 $query =~ s/\\([()])/sprintf ("%%\0%d: ", ord ($1))/ge; 622 $path = $self->{path}; 623 $regex = $self->{column}; 624 625 if ($query =~ /^update\s+($path)\s+set\s+(.+)$/i) 626 { 627 ($table, $extra) = ($1, $2); 628#print STDERR "-update20: table=$table= extra=$extra=\n"; 629 #ADDED IF-STMT 20010418 TO CATCH 630 #PARENTHESIZED SET-CLAUSES (ILLEGAL IN ORACLE & CAUSE WIERD PARSING ERRORS!) 631 632 if ($extra =~ /^\(.+\)\s*where/io) 633 { 634 $errdetails = 'parenthesis around SET clause?'; 635 return (-504); 636 } 637 $table =~ tr/A-Z/a-z/ unless ($self->{CaseTableNames}); #JWT:TABLE-NAMES ARE NOW CASE-INSENSITIVE! 638 $self->{file} = $table; 639 640 my ($dbh) = $csr->FETCH('ldap_dbh'); 641 my ($ldap) = $csr->FETCH('ldap_ldap'); 642 my ($tablehash) = $dbh->FETCH('ldap_tables'); 643 return (-524) unless ($tablehash->{$table}); 644 my ($base, $objfilter, $dnattbs, $allattbs, $alwaysinsert) = split(/\:/,$tablehash->{$table}); 645 646 $all_columns = {}; 647 648 $extra =~ s/\\\\/\x02/go; #PROTECT "\\" 649 #1$extra =~ s/\'\'/\x03\x03/go; #PROTECT '', AND \'. 650 $extra =~ s/\\\'/\x03/go; #PROTECT '', AND \'. 651 652 $extra =~ s/^\s+//o; #STRIP OFF SURROUNDING SPACES. 653 $extra =~ s/\s+$//o; 654 655 #NOW TEMPORARILY PROTECT COMMAS WITHIN (), IE. FN(ARG1,ARG2). 656 657 $column = $self->{column}; 658 $extra =~ s/($column\s*\=\s*)\'(.*?)\'(,|$)/ 659 my ($one,$two,$three) = ($1,$2,$3); 660 $two =~ s|\,|\x05|go; 661 $two =~ s|\(|\x06|go; 662 $two =~ s|\)|\x07|go; 663 $one."'".$two."'".$three; 664 /eg; 665 666 1 while ($extra =~ s/\(([^\(\)]*)\)/ 667 my ($args) = $1; 668 $args =~ s|\,|\x05|go; 669 "\x06$args\x07"; 670 /eg); 671 @expns = split(',',$extra); 672#print STDERR "-update50: extra=$extra= expns=".join('|',@expns)."=\n"; 673 for ($i=0;$i<=$#expns;$i++) #PROTECT "WHERE" IN QUOTED VALUES. 674 { 675 $expns[$i] =~ s/\x05/\,/go; 676 $expns[$i] =~ s/\x06/\(/go; 677 $expns[$i] =~ s/\x07/\)/go; 678 $expns[$i] =~ s/\=\s*'([^']*?)where([^']*?)'/\='$1\x05$2'/gi; 679 $expns[$i] =~ s/\'(.*?)\'/my ($j)=$1; 680 $j=~s|where|\x05|gio; 681 "'$j'" 682 /eg; 683 } 684 $extra = $expns[$#expns]; #EXTRACT WHERE-CLAUSE, IF ANY. 685 $filter = ($extra =~ s/(.*)where(.+)$/where$1/i) ? $2 : ''; 686 $filter =~ s/\s+//o; 687 $expns[$#expns] =~ s/\s*where(.+)$//io; #20000108 REP. PREV. LINE 2FIX BUG IF LAST COLUMN CONTAINS SINGLE QUOTES. 688 $column = $self->{column}; 689 $objfilter ||= 'objectclass=*'; 690 $objfilter = "($objfilter)" unless ($objfilter =~ /^\(/o); 691 if ($filter) 692 { 693#print STDERR "--update: BEF parse_expn: filter=$filter=\n"; 694 $filter = $self->parse_expression ($filter); 695#print STDERR "--update: AFT parse_expn: filter=$filter= objfilter=$objfilter=\n"; 696 $filter = '('.$filter.')' unless ($filter =~ /^\(/o); 697 $filter = "(&$objfilter$filter)"; 698 } 699 else 700 { 701 $filter = "$objfilter"; 702 } 703 $filter =~ s/\x03/\\\'/go; #UNPROTECT '', AND \'. #NEXT 2 ADDED 20091101: 704 $filter =~ s/\x02/\\\\/go; #UNPROTECT "\\". 705# $alwaysinsert .= ',' . $base; #CHGD TO NEXT 200780719 PER REQUEST. 706 $alwaysinsert .= ',' . $base if ($self->{ldap_appendbase2ins}); 707 $alwaysinsert =~ s/\\\\/\x02/go; #PROTECT "\\" 708 $alwaysinsert =~ s/\\\,/\x03/go; #PROTECT "\," 709 $alwaysinsert =~ s/\\\=/\x04/go; #PROTECT "\=" 710 my ($i1, $col, $vals, $j, @l); 711 for ($i=0;$i<=$#expns;$i++) #EXTRACT FIELD NAMES AND 712 #VALUES FROM EACH EXPRESSION. 713 { 714 $expns[$i] =~ s/\x03/\\\'/go; #UNPROTECT '', AND \'. 715 $expns[$i] =~ s/\x02/\\\\/go; #UNPROTECT "\\". 716 $expns[$i] =~ s!\s*($column)\s*=\s*(.+)$! 717 my ($var) = $1; 718 my ($val) = $2; 719 720 $val = &pscolfn($self,$val) if ($val =~ "$column\.$psuedocols"); 721 $var =~ tr/A-Z/a-z/; 722 $val =~ s|%\0(\d+): |pack("C",$1)|ge; 723 $val =~ s/^\'//o; #NEXT 2 ADDED 20010530 TO STRIP EXCESS QUOTES. 724 $val =~ s/([^\\\'])\'$/$1/; 725 $val =~ s/\'$//o; 726 $all_columns->{$var} = $val; 727 @_ = split(/\,\s*/o, $alwaysinsert); 728 while (@_) 729 { 730 ($col, $vals) = split(/\=/o, shift); 731 next unless ($col eq $var); 732 $vals =~ s/\x04/\\\=/go; #UNPROTECT "\=" 733 $vals =~ s/\x03/\\\,/go; #UNPROTECT "\," 734 $vals =~ s/\x02/\\\\/go; #UNPROTECT "\\" 735 @l = split(/\Q$self->{ldap_inseparator}\E/, $vals); 736VALUE: for (my $j=0;$j<=$#l;$j++) 737 { 738 next if ($all_columns->{$var} =~ /\b$l[$j]\b/); 739 $all_columns->{$var} .= $self->{ldap_inseparator} 740 if ($all_columns->{$var}); 741 $all_columns->{$var} .= $l[$j]; 742 } 743 } 744 $all_columns->{$var} =~ s/\x02/\\\\/go; 745# $all_columns->{$var} =~ s/\x03/\'/go; #20091030: REPL. W.NEXT LINE TO KEEP ESCAPE SLASH "\" - RETAIN ORIG. COMMENT: 746 $all_columns->{$var} =~ s/\x03/\\\'/go; #20000108 REPL. PREV. LINE - NO NEED TO DOUBLE QUOTES (WE ESCAPE THEM) - THIS AIN'T ORACLE. 747 !e; 748 } 749 750 delete $all_columns->{dn}; #DO NOT ALLOW DN TO BE CHANGED DIRECTLY! 751#foreach my $xxx (sort keys %{$all_columns}) { print STDERR "---data($xxx)=".$all_columns->{$xxx}."=\n"; }; 752 my ($data); 753 my (@searchops) = ( 754 'base' => $base, 755 'filter' => $filter, 756 ); 757 foreach my $i (qw(ldap_sizelimit ldap_timelimit deref typesonly 758 callback)) 759 { 760 $j = $i; 761 $j =~ s/^ldap_//o; 762 push (@searchops, ($j, $self->{$i})) if ($self->{$i}); 763 } 764 push (@searchops, ('scope', ($self->{ldap_scope} || 'one'))); 765#print STDERR "-update: filter=$filter= searchops=".join('|',@searchops)."=\n"; 766 $data = $ldap->search(@searchops) 767 or return($self->ldap_error($@,"Search failed to return object: filter=$filter (".$data->error().")")); 768#print STDERR "-update: got thru search; data=$data=\n"; 769 my (@varlist) = (); 770 $dbh = $csr->FETCH('ldap_dbh'); 771 my ($autocommit) = $dbh->FETCH('AutoCommit'); 772 my ($commitqueue) = $dbh->FETCH('ldap_commitqueue') unless ($autocommit); 773 my (@dnattbs) = split(/\,/o, $dnattbs); 774 my ($changedn); 775#print STDERR "-update: going into loop!\n"; 776 while (my $entry = $data->shift_entry()) 777 { 778#print STDERR "----update: in loop entry=$entry=\n"; 779 $dn = $entry->dn(); 780 $dn =~ s/\\/\x02/go; #PROTECT "\"; 781 $dn =~ s/\\\,/\x03/go; #PROTECT "\,"; 782 $changedn = 0; 783I: foreach my $i (@dnattbs) 784 { 785 foreach my $j (keys %$all_columns) 786 { 787 if ($i eq $j) 788 { 789 $dn =~ s/(\b$i\=)([^\,]+)/$1$all_columns->{$j}/; 790 $changedn = 1; 791 next I; 792 } 793 } 794 } 795 $dn =~ s/(?:\,\s*)$base$//; 796 $dn =~ s/\x03/\\\,/go; #UNPROTECT "\,"; 797 $dn =~ s/\x02/\\/go; #UNPROTECT "\"; 798 foreach my $i (keys %$all_columns) 799 { 800 $all_columns->{$i} =~ s/(?:\\|\')\'/\'/go; #1UNESCAPE QUOTES IN VALUES. 801 @_ = split(/\Q$self->{ldap_inseparator}\E/, $all_columns->{$i}); 802 if (!@_) 803 { 804 push (@attblist, ($i, '')); 805 } 806 elsif (@_ == 1) 807 { 808 push (@attblist, ($i, shift)); 809 } 810 else 811 { 812 push (@attblist, ($i, [@_])); 813 } 814 } 815 $r1 = $entry->replace(@attblist); 816#print STDERR "-update: r1=$r1= attblist=".join('|',@attblist)."=\n"; 817 if ($r1 > 0) 818 { 819 if ($autocommit) 820 { 821 $r2 = $entry->update($ldap); #COMMIT!!! 822 if ($r2->is_error) 823 { 824 $errdetails = $r2->code . ': ' . $r2->error; 825 return (-523); 826 } 827 if ($changedn) 828 { 829 $r2 = $ldap->moddn($entry, newrdn => $dn); 830 if ($r2->is_error) 831 { 832 $errdetails = "Could not change dn - " 833 . $r2->code . ': ' . $r2->error . '!'; 834 return (-523); 835 } 836 } 837 } 838 else 839 { 840 push (@{$commitqueue}, (\$entry, \$ldap)); 841 push (@{$commitqueue}, "dn=$dn") if ($changedn); 842 } 843 ++$status; 844 } 845 else 846 { 847 #return($self->ldap_error($@,"Search failed to return object: filter=$filter (".$data->error().")")); 848 $errdetails = $data->code . ': ' . $data->error; 849 return (-523); 850 } 851 } 852 return ($status); 853 } 854 else 855 { 856 return (-504); 857 } 858} 859 860sub delete 861{ 862 my ($self, $csr, $query) = @_; 863 my ($path, $table, $filter, $wherepart); 864 my $status = 0; 865 866 $path = $self->{path}; 867 if ($query =~ /^delete\s+from\s+($path)(?:\s+where\s+(.+))?$/io) 868 { 869 $table = $1; 870 $wherepart = $2; 871 $table =~ tr/A-Z/a-z/ unless ($self->{CaseTableNames}); #JWT:TABLE-NAMES ARE NOW CASE-INSENSITIVE! 872 $self->{file} = $table; 873 874 my ($dbh) = $csr->FETCH('ldap_dbh'); 875 my ($ldap) = $csr->FETCH('ldap_ldap'); 876 my ($tablehash) = $dbh->FETCH('ldap_tables'); 877 return (-524) unless ($tablehash->{$table}); 878 my ($base, $objfilter, $dnattbs, $allattbs, $alwaysinsert) = split(/\:/,$tablehash->{$table}); 879 $objfilter ||= 'objectclass=*'; 880 $objfilter = "($objfilter)" unless ($objfilter =~ /^\(/o); 881 if ($wherepart =~ /\S/o) 882 { 883 $filter = $self->parse_expression ($wherepart); 884 $filter = '('.$filter.')' unless ($filter =~ /^\(/o); 885 $filter = "(&$objfilter$filter)"; 886 } 887 else 888 { 889 $filter = "$objfilter"; 890 } 891 $filter = '('.$filter.')' unless ($filter =~ /^\(/o); 892 893 $data = $ldap->search( 894 base => $base, 895 filter => $filter, 896 ) or return ($self->ldap_error($@,"Search failed to return object: filter=$filter (".$data->error().")")); 897 my ($j) = 0; 898 my (@varlist) = (); 899 $dbh = $csr->FETCH('ldap_dbh'); 900 my ($autocommit) = $dbh->FETCH('AutoCommit'); 901 my ($commitqueue) = $dbh->FETCH('ldap_commitqueue') unless ($autocommit); 902 while (my $entry = $data->shift_entry()) 903 { 904 $dn = $entry->dn(); 905 next unless ($dn =~ /$base$/i); #CASE-INSENSITIVITY ADDED NEXT 2: 20050416 PER PATCH BY jmorano 906 $r1 = $entry->delete(); 907 if ($autocommit) 908 { 909 $r2 = $entry->update($ldap); #COMMIT!!! 910 if ($r2->is_error) 911 { 912 $errdetails = $r2->code . ': ' . $r2->error; 913 return (-523); 914 } 915 } 916 else 917 { 918 push (@{$commitqueue}, (\$entry, \$ldap)); 919 } 920 ++$status; 921 } 922 923 return $status; 924 } 925 else 926 { 927 return (-505); 928 } 929} 930 931sub primary_key_info 932{ 933 my ($self, $csr, $query) = @_; 934 my $table = $query; 935 $table =~ s/^.*\s+(\w+)$/$1/; 936 $table =~ tr/A-Z/a-z/ unless ($self->{CaseTableNames}); #JWT:TABLE-NAMES ARE NOW CASE-INSENSITIVE! 937 $self->{file} = $table; 938 my ($dbh) = $csr->FETCH('ldap_dbh'); 939 my $tablehash = $dbh->FETCH('ldap_tables'); 940 return -524 unless ($tablehash->{$table}); 941 942 undef %{ $self->{types} }; 943 undef %{ $self->{lengths} }; 944 $self->{use_fields} = 'CAT,SCHEMA,TABLE_NAME,PRIMARY_KEY'; 945 $self->{order} = [ 'CAT', 'SCHEMA', 'TABLE_NAME', 'PRIMARY_KEY' ]; 946 $self->{fields}->{CAT} = 1; 947 $self->{fields}->{SCHEMA} = 1; 948 $self->{fields}->{TABLE_NAME} = 1; 949 $self->{fields}->{PRIMARY_KEY} = 1; 950 undef @{ $self->{records} }; 951 my (@keyfields) = split(/\,\s*/o, $self->{key_fields}); #JWT: PREVENT DUP. KEYS. 952 ${$self->{types}}{CAT} = 'VARCHAR'; 953 ${$self->{types}}{SCHEMA} = 'VARCHAR'; 954 ${$self->{types}}{TABLE_NAME} = 'VARCHAR'; 955 ${$self->{types}}{PRIMARY_KEY} = 'VARCHAR'; 956 ${$self->{lengths}}{CAT} = 50; 957 ${$self->{lengths}}{SCHEMA} = 50; 958 ${$self->{lengths}}{TABLE_NAME} = 50; 959 ${$self->{lengths}}{PRIMARY_KEY} = 50; 960 ${$self->{defaults}}{CAT} = undef; 961 ${$self->{defaults}}{SCHEMA} = undef; 962 ${$self->{defaults}}{TABLE_NAME} = undef; 963 ${$self->{defaults}}{PRIMARY_KEY} = undef; 964 ${$self->{scales}}{PRIMARY_KEY} = 50; 965 ${$self->{scales}}{PRIMARY_KEY} = 50; 966 ${$self->{scales}}{PRIMARY_KEY} = 50; 967 ${$self->{scales}}{PRIMARY_KEY} = 50; 968 my $results; 969 my $keycnt = scalar(@keyfields); 970 while (@keyfields) 971 { 972 push (@{$results}, [0, 0, $table, shift(@keyfields)]); 973 } 974 unshift (@$results, $keycnt); 975 return $results; 976} 977 978sub alter #SQL COMMAND NOT IMPLEMENTED. 979{ 980 $@ = 'SQL "alter" command is not (yet) implemented!'; 981 return 0; 982} 983 984sub insert 985{ 986 #my ($self, $query) = @_; 987 my ($self, $csr, $query) = @_; 988 my ($i, $path, $table, $columns, $values, $status); 989 990 $path = $self->{path}; 991 if ($query =~ /^insert\s+into\s+ # Keyword 992 ($path)\s* # Table 993 (?:\((.+?)\)\s*)? # Keys 994 values\s* # 'values' 995 \((.+)\)$/ixo) 996 { #JWT: MAKE COLUMN LIST OPTIONAL! 997 998 ($table, $columns, $values) = ($1, $2, $3); 999 my ($dbh) = $csr->FETCH('ldap_dbh'); 1000 my ($tablehash) = $dbh->FETCH('ldap_tables'); 1001 $table =~ tr/A-Z/a-z/ unless ($self->{CaseTableNames}); #JWT:TABLE-NAMES ARE NOW CASE-INSENSITIVE! 1002 $self->{file} = $table; 1003 return (-524) unless ($tablehash->{$table}); 1004 my ($base, $objfilter, $dnattbs, $allattbs, $alwaysinsert) = split(/\:/,$tablehash->{$table}); 1005 $columns =~ s/\s//go; 1006 $columns ||= $allattbs; 1007 $columns = join(',', @{ $self->{order} }) unless ($columns =~ /\S/o); #JWT 1008 1009 unless ($columns =~ /\S/o) 1010 { 1011 return ($self->display_error (-509)); 1012 } 1013 $values =~ s/\\\\/\x02/go; #PROTECT "\\" 1014 $values =~ s/\\\'/\x03/go; #PROTECT '', AND \'. 1015 1016 $values =~ s/\'(.*?)\'/ 1017 my ($j)=$1; 1018 $j=~s|,|\x04|go; #PROTECT "," IN QUOTES. 1019 "'$j'" 1020 /eg; 1021 @values = split(/,/o, $values); 1022 $values = ''; 1023 for $i (0..$#values) 1024 { 1025 $values[$i] =~ s/^\s+//o; #STRIP LEADING & TRAILING SPACES. 1026 $values[$i] =~ s/\s+$//o; 1027 $values[$i] =~ s/\x03/\'/go; #RESTORE PROTECTED SINGLE QUOTES HERE. 1028 $values[$i] =~ s/\x02/\\/go; #RESTORE PROTECTED SLATS HERE. 1029 $values[$i] =~ s/\x04/,/go; #RESTORE PROTECTED COMMAS HERE. 1030 } 1031 chop($values); 1032 1033 $status = $self->insert_data ($csr, $base, $dnattbs, $alwaysinsert, $columns, @values); 1034 1035 return $status; 1036 } 1037 else 1038 { 1039 return (-508); 1040 } 1041} 1042 1043sub insert_data 1044{ 1045 my ($self, $csr, $base, $dnattbs, $alwaysinsert, $column_string, @values) = @_; 1046 my (@columns, @attblist, $loop, $column, $j, $k); 1047 $column_string =~ tr/A-Z/a-z/; 1048 $dnattbs =~ tr/A-Z/a-z/; 1049 @columns = split (/\,/o, $column_string); 1050 1051 if ($#columns = $#values) 1052 { 1053 my $dn = ''; 1054 my @t = split(/,/o, $dnattbs); 1055 while (@t) 1056 { 1057 $j = shift (@t); 1058J1: for (my $i=0;$i<=$#columns;$i++) 1059 { 1060 if ($columns[$i] eq $j) 1061 { 1062 $dn .= $columns[$i] . '='; 1063 if ($values[$i] =~ /\Q$self->{ldap_inseparator}\E/) 1064 { 1065 $dn .= (split(/\Q$self->{ldap_inseparator}\E/,$values[$i]))[0]; 1066 } 1067 else 1068 { 1069 $dn .= $values[$i]; 1070 } 1071 $dn .= ', '; 1072 last J1; 1073 } 1074 } 1075 } 1076 $dn =~ s/\'//go; 1077 $dn .= $base; 1078 for (my $i=0;$i<=$#columns;$i++) 1079 { 1080 @l = split(/\Q$self->{ldap_inseparator}\E/,$values[$i]); 1081 while (@l) 1082 { 1083 $j = shift(@l); 1084 $j =~ s/^\'//o; 1085 $j =~ s/([^\\\'])\'$/$1/; 1086 unless (!length($j) || $j eq "'" || $columns[$i] eq 'dn') 1087 { 1088 $j = "'" if ($j eq "''"); 1089 push (@attblist, $columns[$i]); 1090 push (@attblist, $j); 1091 } 1092 } 1093 } 1094# $alwaysinsert .= ',' . $base; #CHGD TO NEXT 200780719 PER REQUEST. 1095 $alwaysinsert .= ',' . $base if ($self->{ldap_appendbase2ins}); 1096 my ($i1, $found, $col, $vals, $j); 1097 @_ = split(/\,\s*/o, $alwaysinsert); 1098 while (@_) 1099 { 1100 ($col, $vals) = split(/\=/o, shift); 1101 @l = split(/\Q$self->{ldap_inseparator}\E/, $vals); 1102VALUE: for (my $i=0;$i<=$#l;$i++) 1103 { 1104 for ($j=0;$j<=$#attblist;$j+=2) 1105 { 1106 if ($attblist[$j] eq $col) 1107 { 1108 next VALUE if ($attblist[$j+1] eq $l[$i]); 1109 } 1110 } 1111 push (@attblist, $col); 1112 push (@attblist, $l[$i]); 1113 } 1114 } 1115 my ($ldap) = $csr->FETCH('ldap_ldap'); 1116 1117 my $entry = Net::LDAP::Entry->new; 1118 $entry->dn($dn); 1119 1120 my $result = $entry->add(@attblist); 1121 $_ = $entry->dn(); 1122 1123 my ($dbh) = $csr->FETCH('ldap_dbh'); 1124 my ($autocommit) = $dbh->FETCH('AutoCommit'); 1125 if ($autocommit) 1126 { 1127 $r2 = $entry->update($ldap); #COMMIT!!! 1128 if ($r2->is_error) 1129 { 1130 $errdetails = $r2->code . ': ' . $r2->error; 1131 return (-523); 1132 } 1133 } 1134 else 1135 { 1136 my ($commitqueue) = $dbh->FETCH('ldap_commitqueue'); 1137 push (@{$commitqueue}, (\$entry, \$ldap)); 1138 } 1139 1140 return (1); 1141 } 1142 else 1143 { 1144 $errdetails = "$#columns != $#values"; #20000114 1145 return (-509); 1146 } 1147} 1148 1149sub create #SQL COMMAND NOT IMPLEMENTED. 1150{ 1151 $@ = 'SQL "create" command is not (yet) implemented!'; 1152 return 0; 1153} 1154 1155sub drop #SQL COMMAND NOT IMPLEMENTED. 1156{ 1157 $@ = 'SQL "drop" command is not (yet) implemented!'; 1158 return 0; 1159} 1160 1161sub pscolfn 1162{ 1163 my ($self,$id) = @_; 1164 return $id unless ($id =~ /CURVAL|NEXTVAL|ROWNUM/); 1165 my ($value) = ''; 1166 my ($seq_file,$col) = split(/\./o, $id); 1167 $seq_file = $self->get_path_info($seq_file) . '.seq'; 1168 1169 $seq_file =~ tr/A-Z/a-z/ unless ($self->{CaseTableNames}); #JWT:TABLE-NAMES ARE NOW CASE-INSENSITIVE! 1170 open (FILE, "<$seq_file") || return (-511); 1171 $x = <FILE>; 1172 #chomp($x); 1173 $x =~ s/\s+$//o; #20000113 1174 ($incval, $startval) = split(/\,/o, $x); 1175 close (FILE); 1176 if ($id =~ /NEXTVAL/o) 1177 { 1178 open (FILE, ">$seq_file") || return (-511); 1179 $incval += ($startval || 1); 1180 print FILE "$incval,$startval\n"; 1181 close (FILE); 1182 } 1183 $value = $incval; 1184 return $value; 1185} 1186 1187sub SYSTIME 1188{ 1189 return time; 1190} 1191 1192sub NUM 1193{ 1194 return shift; 1195} 1196 1197sub NULL 1198{ 1199 return ''; 1200} 1201 12021; 1203