File Coverage

lib/DB/Handy.pm

Criterion	Covered	Total	%
statement	2236	2522	88.6
branch	1127	1748	64.4
condition	334	603	55.3
subroutine	148	155	95.4
pod	17	41	41.4
total	3862	5069	76.1

line

stmt

bran

cond

sub

pod

time

code

package DB::Handy;

######################################################################

# DB::Handy - Pure-Perl flat-file relational database with DBI-like interface

# https://metacpan.org/dist/DB-Handy

######################################################################

# Compatible : Perl 5.005_03 and later

# Platform : Windows and UNIX/Linux

# FILE LAYOUT:

# //

# .sch schema (text, key=value lines)

# .dat records (fixed-length binary)

# ..idx sorted index (binary)

19							#
20							# INDEX FILE FORMAT (each entry is fixed-size):
21							# Header : "SDBIDX1\n" (8 bytes)
22							# Entries (sorted ascending by key_bytes):
23							# [key_bytes : keysize bytes][rec_no : 4 bytes big-endian uint32]
24							#
25							# Key encoding (byte order == value order):
26							# INT : sign-bit-flipped big-endian uint32
27							# FLOAT : IEEE 754 order-preserving 8-byte encoding
28							# other : NUL-padded fixed-width string
29							#
30							# SCHEMA FILE format for indexes:
31							# IDX=::
32							######################################################################
33
34	11			11		277667	use strict;
	11					25
	11					753
35	11	50		11		364	BEGIN { if ($] < 5.006) { $INC{'warnings.pm'} = 'stub'; eval 'package warnings; sub import {}' } }
	0					0
	0					0
36	11			11		59	use warnings; local $^W = 1;
	11					22
	11					973
37	11	100		11		365	BEGIN { pop @INC if $INC[-1] eq '.' }
38	11			11		60	use Fcntl qw(:DEFAULT :flock);
	11					16
	11					5138
39	11			11		91	use File::Path ();
	11					23
	11					292
40	11			11		94	use File::Spec;
	11					36
	11					349
41	11			11		6227	use POSIX ();
	11					84758
	11					513
42
43	11			11		83	use vars qw($VERSION $errstr);
	11					35
	11					1179
44							$VERSION = '1.01';
45							$VERSION = $VERSION;
46							$errstr = '';
47
48							###############################################################################
49							# Constants
50							###############################################################################
51	11			11		92	use constant RECORD_ACTIVE => "\x01";
	11					23
	11					1290
52	11			11		67	use constant RECORD_DELETED => "\x00";
	11					20
	11					668
53	11			11		60	use constant MAX_VARCHAR => 255;
	11					19
	11					614
54	11			11		59	use constant IDX_MAGIC => "SDBIDX1\n";
	11					20
	11					475
55	11			11		53	use constant IDX_MAGIC_LEN => 8;
	11					21
	11					484
56	11			11		54	use constant REC_NO_SIZE => 4;
	11					16
	11					557795
57
58							my %TYPE_SIZE = (
59							INT => 4,
60							FLOAT => 8,
61							CHAR => undef,
62							VARCHAR => undef,
63							DATE => 10,
64							);
65
66							###############################################################################
67							# Constructor
68							###############################################################################
69							sub new {
70	31			31	1	1463488	my($class, %args) = @_;
71							my $self = {
72							base_dir => ($args{base_dir} \|\| 'simpledbms_data'),
73	31		50			284	db_name => ($args{db_name} \|\| ''),
			50
74							_tables => {},
75							_locks => {},
76							};
77	31					69	bless $self, $class;
78	31	100				657	unless (-d $self->{base_dir}) {
79	10					26	eval {
80	10					11373	File::Path::mkpath($self->{base_dir});
81							};
82	10	50				82	if ($@) {
83	0					0	$errstr = "Cannot create base_dir: $@";
84	0					0	return undef;
85							}
86							}
87	31					119	return $self;
88							}
89
90							###############################################################################
91							# Database-level
92							###############################################################################
93							sub create_database {
94	11			11	1	111	my($self, $db_name) = @_;
95	11					65	my $path = $self->_db_path($db_name);
96	11	100				382	if (-d $path) {
97	1					5	$errstr = "Database '$db_name' already exists";
98	1					6	return 0;
99							}
100	10					32	eval {
101	10					1824	File::Path::mkpath($path);
102							};
103	10	50				137	if ($@) {
104	0					0	$errstr = "Cannot create database '$db_name': $@";
105	0					0	return 0;
106							}
107	10					82	return 1;
108							}
109
110							sub use_database {
111	33			33	1	155	my($self, $db_name) = @_;
112	33					104	my $path = $self->_db_path($db_name);
113	33	100				1901	unless (-d $path) {
114	3					13	$errstr = "Database '$db_name' does not exist";
115	3					25	return 0;
116							}
117	30					143	$self->{db_name} = $db_name;
118	30					76	$self->{_tables} = {};
119	30					206	return 1;
120							}
121
122							sub drop_database {
123	1			1	1	19	my($self, $db_name) = @_;
124	1					4	my $path = $self->_db_path($db_name);
125	1	50				48	unless (-d $path) {
126	0					0	$errstr = "Database '$db_name' does not exist";
127	0					0	return 0;
128							}
129	1					4	eval {
130	1					432	File::Path::rmtree($path);
131							};
132	1	50				7	if ($@) {
133	0					0	$errstr = "Cannot drop database '$db_name': $@";
134	0					0	return 0;
135							}
136	1	50				7	$self->{db_name} = '' if $self->{db_name} eq $db_name;
137	1					7	return 1;
138							}
139
140							sub list_databases {
141	4			4	1	70	my($self) = @_;
142	4					14	my $base = $self->{base_dir};
143	4					14	local *DH;
144	4	50				237	opendir(DH, $base) or do { $errstr = "Cannot open base_dir: $!"; return (); };
	0					0
	0					0
145	4	100				147	my @dbs = grep { !/^\./ && -d File::Spec->catdir($base, $_) } readdir(DH);
	12					190
146	4					107	closedir DH;
147	4					46	return sort @dbs;
148							}
149
150							###############################################################################
151							# Table-level
152							###############################################################################
153							sub create_table {
154	67			67	1	258	my($self, $table, $columns) = @_;
155	67	100				210	return $self->_err("No database selected") unless $self->{db_name};
156	66					231	my $sch_file = $self->_file($table, 'sch');
157	66	50				3886	return $self->_err("Table '$table' already exists") if -f $sch_file;
158
159	66					183	my @cols;
160	66					180	my $rec_size = 1;
161	66					169	for my $col (@$columns) {
162	165					483	my($name, $type, $size) = @$col;
163	165					298	$type = uc($type);
164	165	50				460	return $self->_err("Unknown type '$type'") unless exists $TYPE_SIZE{$type};
165	165					251	my $store;
166	165	100				453	if ($type eq 'CHAR') {
		100
167	3	50	33			25	return $self->_err("CHAR requires a size") unless $size && ($size > 0);
168	3					7	$store = int($size);
169							}
170							elsif ($type eq 'VARCHAR') {
171	60					109	$store = MAX_VARCHAR;
172							}
173							else {
174	102					222	$store = $TYPE_SIZE{$type};
175							}
176	165					290	$rec_size += $store;
177	165					861	push @cols, { name=>$name, type=>$type, size=>$store };
178							}
179
180	66					262	local *FH;
181	66	50				10266	open(FH, "> $sch_file") or return $self->_err("Cannot write schema: $!");
182	66					1235	print FH "VERSION=1\n";
183	66					249	print FH "RECSIZE=$rec_size\n";
184	66					230	for my $c (@cols) {
185	165					783	print FH "COL=$c->{name}:$c->{type}:$c->{size}\n";
186							}
187	66					4122	close FH;
188
189	66					309	local *FH;
190	66	50				315	open(FH, "> ".$self->_file($table,'dat')) or return $self->_err("Cannot create dat: $!");
191	66					924	close FH;
192	66					752	return 1;
193							}
194
195							sub drop_table {
196	3			3	1	15	my($self, $table) = @_;
197	3	50				16	return $self->_err("No database selected") unless $self->{db_name};
198	3					12	my $sch = $self->_load_schema($table);
199	3	50	33			22	if ($sch && $sch->{indexes}) {
200	3					7	for my $ix (values %{$sch->{indexes}}) {
	3					12
201	1					4	my $f = $self->_idx_file($table, $ix->{name});
202	1	50				128	unlink $f if -f $f;
203							}
204							}
205	3					12	for my $ext (qw(sch dat lck)) {
206	9					61	my $f = $self->_file($table, $ext);
207	9	100				898	unlink $f if -f $f;
208							}
209	3					19	my $dir = $self->_db_path($self->{db_name});
210	3					12	local *DH;
211	3	50				146	if (opendir DH, $dir) {
212	3					88	for my $f (readdir DH) {
213	26	50				198	unlink File::Spec->catfile($dir, $f) if $f =~ /^\Q${table}\E\.[^.]+\.idx$/;
214							}
215	3					42	closedir DH;
216							}
217	3					14	delete $self->{_tables}{$table};
218	3					79	return 1;
219							}
220
221							sub list_tables {
222	6			6	1	75	my($self) = @_;
223	6	50				28	return $self->_err("No database selected") unless $self->{db_name};
224	6					30	my $dir = $self->_db_path($self->{db_name});
225	6					23	local *DH;
226	6	50				359	opendir(DH, $dir) or return ();
227	6	100				226	my @tbls = map { /^(.+)\.sch$/ ? $1 : () } readdir DH;
	59					273
228	6					113	closedir DH;
229	6					78	return sort @tbls;
230							}
231
232							sub describe_table {
233	5			5	1	124	my($self, $table) = @_;
234	5	50				23	my $sch = $self->_load_schema($table) or return undef;
235	5					22	return $sch->{cols};
236							}
237
238							###############################################################################
239							# INDEX DDL
240							###############################################################################
241							sub create_index {
242	15			15	1	50	my($self, $idxname, $table, $colname, $unique) = @_;
243	15	50				57	return $self->_err("No database selected") unless $self->{db_name};
244	15	50				49	my $sch = $self->_load_schema($table) or return undef;
245
246	15					29	my($col_def) = grep { $_->{name} eq $colname } @{$sch->{cols}};
	39					106
	15					43
247	15	50				39	return $self->_err("Column '$colname' not found in '$table'") unless $col_def;
248	15	50				45	return $self->_err("Index '$idxname' already exists on '$table'") if $sch->{indexes}{$idxname};
249
250	15	100				52	$unique = $unique ? 1 : 0;
251
252	15					80	my $sch_file = $self->_file($table, 'sch');
253	15					44	local *FH;
254	15	50				689	open(FH, ">> $sch_file") or return $self->_err("Cannot update schema: $!");
255	15					184	print FH "IDX=$idxname:$colname:$unique\n";
256	15					845	close FH;
257
258							$sch->{indexes}{$idxname} = {
259							name => $idxname,
260							col => $colname,
261							unique => $unique,
262							keysize => $col_def->{size},
263							coltype => $col_def->{type},
264	15					201	};
265
266	15					86	return $self->_rebuild_index($table, $idxname);
267							}
268
269							sub drop_index {
270	1			1	1	5	my($self, $idxname, $table) = @_;
271	1	50				3	return $self->_err("No database selected") unless $self->{db_name};
272	1	50				4	my $sch = $self->_load_schema($table) or return undef;
273	1	50				3	return $self->_err("Index '$idxname' does not exist on '$table'") unless $sch->{indexes}{$idxname};
274
275	1					3	unlink $self->_idx_file($table, $idxname);
276	1					5	delete $sch->{indexes}{$idxname};
277	1					4	return $self->_rewrite_schema($table, $sch);
278							}
279
280							sub list_indexes {
281	1			1	1	4	my($self, $table) = @_;
282	1	50				3	return $self->_err("No database selected") unless $self->{db_name};
283	1	50				4	my $sch = $self->_load_schema($table) or return undef;
284	1					1	return [ values %{$sch->{indexes}} ];
	1					4
285							}
286
287							###############################################################################
288							# DML: INSERT
289							###############################################################################
290							sub insert {
291	694			694	1	1521	my($self, $table, $row) = @_;
292	694	50				1656	return $self->_err("No database selected") unless $self->{db_name};
293	694	100				1724	my $sch = $self->_load_schema($table) or return undef;
294
295							# UNIQUE check
296	693					913	for my $ix (values %{$sch->{indexes}}) {
	693					1855
297	332	100				787	next unless $ix->{unique};
298	14					33	my $val = $row->{$ix->{col}};
299	14	100				43	if ($self->_idx_lookup_exact($table, $ix, $val) >= 0) {
300	5					33	return $self->_err("UNIQUE constraint violated on '$ix->{name}' (col '$ix->{col}', value '$val')");
301							}
302							}
303
304	688					852	for my $col (@{$sch->{cols}}) {
	688					1277
305	1194					1937	my $cn = $col->{name};
306	1194	100	100			5444	if ((!defined($row->{$cn}) \|\| ($row->{$cn} eq '')) && defined $sch->{defaults}{$cn}) {
			100
307	14					48	$row->{$cn} = $sch->{defaults}{$cn};
308							}
309							}
310	688	50				972	for my $cn (keys %{$sch->{notnull} \|\| {}}) {
	688					1783
311	39	100	100			190	return $self->_err("NOT NULL constraint violated on column '$cn'") unless defined($row->{$cn}) && ($row->{$cn} ne '');
312							}
313	681	50				838	for my $cn (keys %{$sch->{checks} \|\| {}}) {
	681					1590
314	10	100				39	return $self->_err("CHECK constraint failed on column '$cn'") unless eval_bool($sch->{checks}{$cn},$row);
315							}
316	678	50				1732	my $packed = $self->_pack_record($sch, $row) or return undef;
317	678					1742	my $dat = $self->_file($table, 'dat');
318	678					1786	local *FH;
319	678	50				29652	open(FH, ">> $dat") or return $self->_err("Cannot open dat for append: $!");
320	678					2086	binmode FH;
321	678					1951	_lock_ex(\*FH);
322	678					4715	my $file_size = (stat FH)[7];
323	678					2282	my $rec_no = int($file_size / $sch->{recsize});
324	678					3728	print FH $packed;
325	678					1644	_unlock(\*FH);
326	678					7015	close FH;
327
328	678					982	for my $ix (values %{$sch->{indexes}}) {
	678					2345
329	324					1325	$self->_idx_insert($table, $ix, $row->{$ix->{col}}, $rec_no);
330							}
331	678					8376	return 1;
332							}
333
334							sub delete_rows {
335	10			10	1	33	my($self, $table, $where_info) = @_;
336	10	50				49	return $self->_err("No database selected") unless $self->{db_name};
337	10	50				32	my $sch = $self->_load_schema($table) or return undef;
338	10					36	my $where_sub = _to_where_sub($where_info);
339	10					36	my $dat = $self->_file($table, 'dat');
340	10					28	my $recsize = $sch->{recsize};
341	10					17	my $count = 0;
342
343	10					28	local *FH;
344	10	50				466	open(FH, "+< $dat") or return $self->_err("Cannot open dat for delete: $!");
345	10					38	binmode FH;
346	10					40	_lock_ex(\*FH);
347
348	10					44	seek(FH, 0, 0);
349	10					26	my($pos, $rec_no) = (0, 0);
350	10					31	while (1) {
351	80					975	seek(FH, $pos, 0);
352	80					132	my $raw = '';
353	80					881	my $n = read(FH, $raw, $recsize);
354	80	100	66			357	last unless defined($n) && ($n == $recsize);
355	70	100				220	if (substr($raw, 0, 1) ne RECORD_DELETED) {
356	65					184	my $row = $self->_unpack_record($sch, $raw);
357	65	100	66			212	if (!$where_sub \|\| $where_sub->($row)) {
358	12					111	seek(FH, $pos, 0);
359	12					38	print FH RECORD_DELETED;
360	12					24	$count++;
361	12					17	for my $ix (values %{$sch->{indexes}}) {
	12					53
362	9					33	$self->_idx_delete($table, $ix, $row->{$ix->{col}}, $rec_no);
363							}
364							}
365							}
366	70					112	$pos += $recsize;
367	70					198	$rec_no++;
368							}
369	10					43	_unlock(\*FH);
370	10					110	close FH;
371	10					57	return $count;
372							}
373
374							###############################################################################
375							# VACUUM
376							###############################################################################
377							sub vacuum {
378	2			2	1	9	my($self, $table) = @_;
379	2	50				10	return $self->_err("No database selected") unless $self->{db_name};
380	2	50				7	my $sch = $self->_load_schema($table) or return undef;
381	2					6	my $dat = $self->_file($table, 'dat');
382	2					6	my $tmp = $dat . '.tmp';
383	2					6	my $recsize = $sch->{recsize};
384
385	2					5	local *IN_FH;
386	2	50				77	open(IN_FH, "< $dat") or return $self->_err("Cannot open dat: $!");
387	2					5	local *OUT_FH;
388	2	50				299	open(OUT_FH, "> $tmp") or do { close IN_FH; return $self->_err("Cannot open tmp: $!"); };
	0					0
	0					0
389	2					9	binmode IN_FH;
390	2					5	binmode OUT_FH;
391	2					9	_lock_ex(\*IN_FH);
392
393	2					4	my $kept = 0;
394	2					5	while (1) {
395	19					25	my $raw = '';
396	19					72	my $n = read(IN_FH, $raw, $recsize);
397	19	100	66			56	last unless defined($n) && ($n == $recsize);
398	17	100				43	if (substr($raw, 0, 1) ne RECORD_DELETED) {
399	13					56	print OUT_FH $raw;
400	13					59	$kept++;
401							}
402							}
403	2					7	_unlock(\*IN_FH);
404	2					19	close IN_FH;
405	2					83	close OUT_FH;
406	2	50				539	rename($tmp, $dat) or return $self->_err("Cannot replace dat: $!");
407
408	2					7	for my $ix (values %{$sch->{indexes}}) {
	2					10
409	3	50				10	$self->_rebuild_index($table, $ix->{name}) or return undef;
410							}
411	2					12	return $kept;
412							}
413
414							###############################################################################
415							# execute()
416							###############################################################################
417							sub execute {
418	1165			1165	1	13530	my($self, $sql) = @_;
419	1165					16239	$sql =~ s/^\s+\|\s+$//g;
420	1165					10444	$sql =~ s/\s+/ /g;
421
422							# Detect subqueries: any SELECT that contains a nested (SELECT ...)
423							# Route through the subquery engine, but guard against infinite recursion
424							# by only routing non-trivial top-level statements (not pure SELECT).
425	1165	100				6412	if ($sql =~ /\(\s*SELECT\b/i) {
426
427							# Only intercept DML/DDL statements and complex SELECTs here;
428							# pure inner SELECTs (called recursively) pass through normally.
429							# Top-level statements that may contain subqueries:
430	28	50				180	if ($sql =~ /^(?:SELECT\|INSERT\|UPDATE\|DELETE)\b/i) {
431	28					134	return $self->execute_with_subquery($sql);
432							}
433							}
434
435	1137	100				3643	if ($sql =~ /^CREATE\s+DATABASE\s+(\w+)$/i) {
436	4	50				37	return $self->create_database($1)
437							? { type=>'ok', message=>"Database '$1' created" }
438							: { type=>'error', message=>$errstr };
439							}
440	1133	100				3287	if ($sql =~ /^USE\s+(\w+)$/i) {
441	26	100				76	return $self->use_database($1)
442							? { type=>'ok', message=>"Using database '$1'" }
443							: { type=>'error', message=>$errstr };
444							}
445	1107	50				2561	if ($sql =~ /^DROP\s+DATABASE\s+(\w+)$/i) {
446	0	0				0	return $self->drop_database($1)
447							? { type=>'ok', message=>"Database '$1' dropped" }
448							: { type=>'error', message=>$errstr };
449							}
450	1107	100				2591	if ($sql =~ /^SHOW\s+DATABASES$/i) {
451	1					4	return { type=>'list', data=>[ $self->list_databases() ] };
452							}
453	1106	100				2460	if ($sql =~ /^SHOW\s+TABLES$/i) {
454	1					7	return { type=>'list', data=>[ $self->list_tables() ] };
455							}
456	1105	100				2661	if ($sql =~ /^SHOW\s+(?:INDEXES\|INDICES\|INDEX)\s+(?:ON\|FROM)\s+(\w+)$/i) {
457	1					4	my $ixs = $self->list_indexes($1);
458	1	50				7	return defined($ixs)
459							? { type=>'indexes', table=>$1, data=>$ixs }
460							: { type=>'error', message=>$errstr };
461							}
462	1104	100				2639	if ($sql =~ /^DESCRIBE\s+(\w+)$/i) {
463	2					9	my $cols = $self->describe_table($1);
464	2	50				18	return $cols
465							? { type=>'describe', data=>$cols }
466							: { type=>'error', message=>$errstr };
467							}
468	1102	100				2857	if ($sql =~ /^CREATE\s+TABLE\s+(\w+)\s*$(.+)$$/si) {
469	67					352	my($tbl, $col_str) = ($1, $2);
470	67					265	my @col_defs = _split_col_defs($col_str);
471	67					218	my(@cols, %nn, %defs, %chks, $pk);
472	67					151	for my $cd (@col_defs) {
473	166					1158	$cd =~ s/^\s+\|\s+$//g;
474	166	50				470	if ($cd =~ /^PRIMARY\s+KEY\s$\s(\w+)\s*$$/si) {
475	0					0	$pk = $1;
476	0					0	next;
477							}
478	166					307	my($cn, $ct, $cs, $rest);
479	166	100				897	if ($cd =~ /^(\w+)\s+(CHAR\|VARCHAR)\s$\s(\d+)\s$(.)/si) {
		50
480	63					363	($cn, $ct, $cs, $rest) = ($1, uc($2), $3, $4);
481							}
482							elsif ($cd =~ /^(\w+)\s+(\w+)(.*)/si) {
483	103					487	($cn, $ct, $rest) = ($1, uc($2), $3);
484	103					177	$cs = undef;
485							}
486							else {
487	0					0	return { type=>'error', message=>"Cannot parse column def: $cd" };
488							}
489	166					606	push @cols, [ $cn, $ct, $cs ];
490	166	50				401	$rest = '' unless defined $rest;
491	166	100				378	$pk = $cn if $rest =~ /\bPRIMARY\s+KEY\b/si;
492	166	100				472	$nn{$cn} = 1 if $rest =~ /\b(?:NOT\s+NULL\|PRIMARY\s+KEY)\b/si;
493	166	100				433	$defs{$cn} = (defined($1) ? $1 : $2) if $rest =~ /\bDEFAULT\s+(?:'([^'])'\|(-?\d+\.?\d))/si;
		100
494	166	100				433	$chks{$cn} = $1 if $rest =~ /\bCHECK\s*$(.+)$/si;
495							}
496	67	100				177	$nn{$pk} = 1 if defined $pk;
497	67	100				358	$self->create_table($tbl,[ @cols ]) or return { type=>'error', message=>$errstr };
498	66	50	100			690	if (%nn \|\| %defs \|\| %chks \|\| defined $pk) {
			66
			66
499	11	50				53	my $sch = $self->_load_schema($tbl) or return { type=>'error', message=>$errstr };
500	11					83	$sch->{notnull} = { %nn };
501	11					44	$sch->{defaults} = { %defs };
502	11					43	$sch->{checks} = { %chks };
503	11	100				67	$sch->{pk} = $pk if defined $pk;
504	11					92	$self->_rewrite_schema($tbl, $sch);
505							}
506	66					823	return { type=>'ok', message=>"Table '$tbl' created" };
507							}
508	1035	100				2674	if ($sql =~ /^DROP\s+TABLE\s+(\w+)$/i) {
509	3	50				18	return $self->drop_table($1)
510							? { type=>'ok', message=>"Table '$1' dropped" }
511							: { type=>'error', message=>$errstr };
512							}
513	1032	100				2970	if ($sql =~ /^CREATE\s+(UNIQUE\s+)?INDEX\s+(\w+)\s+ON\s+(\w+)\s$\s(\w+)\s*$$/i) {
514	15					136	my($uniq, $idxname, $tbl, $col) = ($1, $2, $3, $4);
515	15	100				94	return $self->create_index($idxname, $tbl, $col, $uniq ? 1 : 0)
		50
516							? { type=>'ok', message=>"Index '$idxname' created on '$tbl'('$col')" }
517							: { type=>'error', message=>$errstr };
518							}
519	1017	100				2267	if ($sql =~ /^DROP\s+INDEX\s+(\w+)\s+ON\s+(\w+)$/i) {
520	1	50				6	return $self->drop_index($1,$2)
521							? { type=>'ok', message=>"Index '$1' dropped" }
522							: { type=>'error', message=>$errstr };
523							}
524	1016	100				2227	if ($sql =~ /^VACUUM\s+(\w+)$/i) {
525	2					9	my $n = $self->vacuum($1);
526	2	50				27	return defined($n)
527							? { type=>'ok', message=>"Vacuum done, $n records kept" }
528							: { type=>'error', message=>$errstr };
529							}
530	1014	100				5061	if ($sql =~ /^INSERT\s+INTO\s+(\w+)\s$([^)]+)$\sVALUES\s*$(.+)$$/i) {
531	684					3125	my($tbl, $col_str, $val_str) = ($1, $2, $3);
532	684					2290	my @c = map { my $x = $_; $x =~ s/^\s+\|\s+\$//g; $x } split /,/, $col_str;
	1164					1693
	1164					3408
	1164					2990
533	684					1813	my @v = _parse_values($val_str);
534	684					1007	my %row;
535	684					2118	@row{@c} = @v;
536	684	100				2502	return $self->insert($tbl,\%row)
537							? { type=>'ok', message=>"1 row inserted" }
538							: { type=>'error', message=>$errstr };
539							}
540	330	100				849	if ($sql =~ /^INSERT\s+INTO\s+(\w+)\s*$([^)]+)$\s+(SELECT\b.+)$/si) {
541	4					26	my($tbl, $cs, $sel) = ($1, $2, $3);
542	4					19	my @dst_cols = map { my $x = $_; $x =~ s/^\s+\|\s+$//g; $x } split /,/, $cs;
	8					15
	8					24
	8					26
543
544							# Extract SELECT column list in declaration order.
545							# The engine stores rows as hashes (alphabetical key order), so we
546							# must parse the SELECT list to know the intended positional mapping.
547	4					9	my @src_cols;
548	4	50				29	if ($sel =~ /^SELECT\s+(.*?)\s+FROM\s+/si) {
549	4					14	@src_cols = map { my $c = $_; $c =~ s/^\s+\|\s+$//g; $c =~ s/\s+AS\s+\w+$//si; $c } split /,/, $1;
	8					16
	8					23
	8					42
	8					22
550							}
551	4					43	my $res = $self->execute($sel);
552	4	50				19	return { type=>'error', message=>$res->{message} } if $res->{type} eq 'error';
553	4					10	my $n = 0;
554	4					8	for my $r (@{$res->{data}}) {
	4					12
555
556							# Map SELECT columns to INSERT columns by position:
557							# dst_cols[i] <- r->{ src_cols[i] }
558							# When column names match (same-name case), this is identical
559							# to a name-based lookup. When they differ (e.g. INSERT INTO
560							# dst(a,b) SELECT x,y FROM src), the positional mapping is used.
561							# Fall back to alphabetical order when src_cols could not be
562							# parsed (e.g. SELECT *).
563	10	50				43	my @src_keys = @src_cols ? @src_cols : sort keys %$r;
564	10					21	my %row = ();
565	10					30	for my $i (0 .. $#dst_cols) {
566	20	50				76	$row{$dst_cols[$i]} = defined($src_keys[$i]) ? $r->{$src_keys[$i]} : undef;
567							}
568	10	50				55	$self->insert($tbl, { %row }) and $n++;
569							}
570	4					50	return { type=>'ok', message=>"$n row(s) inserted" };
571							}
572	326	100				1200	if ($sql =~ /^SELECT\b/i) {
573	291					1108	return $self->select($sql);
574							}
575	35	100				372	if ($sql =~ /^UPDATE\s+(\w+)\s+SET\s+(.+?)(\s+WHERE\s+.+)?$/si) {
576	25	100				191	my($tbl, $set_str, $wc) = ($1, $2, (defined($3) ? $3 : ''));
577	25					87	my %se = parse_set_exprs($set_str);
578	25					49	my $ws;
579	25	100				122	if ($wc =~ /\bWHERE\s+(.+)/si) {
580	24					109	(my $e = $1) =~ s/^\s+\|\s+$//g;
581	24					170	$ws = where_sub($e);
582							}
583	25					203	my $n = $self->update($tbl,\%se,$ws);
584	25	100				504	return defined($n)
585							? { type=>'ok', message=>"$n row(s) updated" }
586							: { type=>'error', message=>$errstr };
587							}
588	10	50				97	if ($sql =~ /^DELETE\s+FROM\s+(\w+)(.*)?$/si) {
589	10	50				63	my($tbl, $rest) = ($1, (defined($2) ? $2 : ''));
590	10					20	my $ws;
591	10	50				113	if ($rest =~ /\bWHERE\s+(.+)/si) {
592	10					74	(my $e = $1) =~ s/^\s+\|\s+$//g;
593	10					61	$ws = where_sub($e);
594							}
595	10					67	my $n = $self->delete_rows($tbl,$ws);
596	10	50				182	return defined($n)
597							? { type=>'ok', message=>"$n row(s) deleted" }
598							: { type=>'error', message=>$errstr };
599							}
600	0					0	return { type=>'error', message=>"Unsupported SQL: $sql" };
601							}
602
603							###############################################################################
604							# SUBQUERY ENGINE
605							#
606							# Supported subquery positions:
607							#
608							# 1. WHERE col IN (SELECT single_col FROM ...)
609							# 2. WHERE col NOT IN (SELECT single_col FROM ...)
610							# 3. WHERE col OP (SELECT single_col FROM ...) OP = = != < > <= >=
611							# 4. WHERE EXISTS (SELECT ... FROM ...)
612							# 5. WHERE NOT EXISTS (SELECT ... FROM ...)
613							# 6. FROM (SELECT ...) AS alias -- derived table / inline view
614							# 7. SELECT (SELECT single_col ...) AS alias -- scalar subquery in SELECT list
615							#
616							# Nesting: subqueries may themselves contain subqueries (recursive expansion).
617							# Correlated subqueries: outer row values injected via _subq_context hashref.
618							###############################################################################
619
620							# ---------------------------------------------------------------------------
621							# Public wrapper: expand all subqueries in a SQL string, then execute.
622							# Called by execute() when a subquery token is detected.
623							# ---------------------------------------------------------------------------
624							sub execute_with_subquery {
625	32			32	0	73	my($self, $sql) = @_;
626
627							# Handle derived table in FROM: FROM (SELECT ...) AS alias
628	32	100				213	if ($sql =~ /\bFROM\s*\(/i) {
629	4					20	return $self->_exec_derived_table($sql);
630							}
631
632							# Handle scalar subqueries in SELECT list: SELECT (SELECT ...) AS alias
633	28	50				97	if ($sql =~ /^SELECT\s*\(/i) {
634	0					0	return $self->_exec_scalar_select_subquery($sql);
635							}
636
637							# Expand WHERE-clause subqueries iteratively (innermost first)
638	28					99	my $expanded = $self->_expand_where_subqueries($sql, {});
639	28	50				87	return $expanded if ref($expanded) eq 'HASH'; # error hash
640
641							# If correlated subqueries remain (still contain (SELECT), use row-level evaluator
642	28	100				91	if ($expanded =~ /\(\s*SELECT\b/i) {
643	4					19	return $self->_exec_correlated_select($expanded);
644							}
645
646	24					76	return $self->execute($expanded);
647							}
648
649							# ---------------------------------------------------------------------------
650							# Execute a SELECT with correlated subqueries in the WHERE clause.
651							# Scans each row, evaluates the subquery with the row as outer context.
652							# ---------------------------------------------------------------------------
653							sub _exec_correlated_select {
654	4			4		8	my($self, $sql) = @_;
655
656							# Must be a plain SELECT (no JOIN, no derived table)
657	4	50				91	unless ($sql =~ /^SELECT\s+(.+?)\s+FROM\s+(\w+)(.*)?$/i) {
658	0					0	return { type=>'error', message=>"Cannot execute correlated query: $sql" };
659							}
660	4	50				26	my($col_str, $tbl, $rest) = ($1, $2, (defined($3) ? $3 : ''));
661
662	4	50				13	my $sch = $self->_load_schema($tbl) or return { type=>'error', message=>$errstr };
663
664							# Parse col list
665	4					8	my @sel_cols;
666	4	50				11	unless ($col_str =~ /^\*$/) {
667	4					16	@sel_cols = map { my $x = $_; $x =~ s/^\s+\|\s+\$//g; $x } split /,/, $col_str;
	4					9
	4					15
	4					15
668							}
669
670							# Strip ORDER BY / LIMIT / OFFSET
671	4					6	my %opts;
672	4	50				24	if ($rest =~ s/\bLIMIT\s+(\d+)//i) {
673	0					0	$opts{limit} = $1;
674							}
675	4	50				21	if ($rest =~ s/\bOFFSET\s+(\d+)//i) {
676	0					0	$opts{offset} = $1;
677							}
678	4	100				29	if ($rest =~ s/\bORDER\s+BY\s+(\w+)(?:\s+(ASC\|DESC))?//i) {
679	1					5	$opts{order_by} = $1;
680	1	50				7	$opts{order_dir} = defined($2) ? $2 : 'ASC';
681							}
682
683							# Extract WHERE expression
684	4					8	my $where_expr = '';
685	4	50				14	if ($rest =~ /\bWHERE\s+(.+)/i) {
686	4					8	$where_expr = $1;
687	4					52	$where_expr =~ s/^\s+\|\s+$//g;
688							}
689
690							# Parse conditions (may include subquery conditions)
691	4					16	my $conds = $self->_parse_conditions_with_subq($where_expr);
692	4					18	my $filter = $self->_compile_where_with_subq($conds);
693
694							# Full scan with per-row subquery evaluation
695	4					15	my $dat = $self->_file($tbl, 'dat');
696	4					17	my $recsize = $sch->{recsize};
697	4					9	my @results;
698
699	4					14	local *FH;
700	4	50				190	open(FH, "< $dat") or return { type=>'error', message=>"Cannot open dat: $!" };
701	4					20	binmode FH;
702	4					15	_lock_sh(\*FH);
703	4					8	my $rec_no = 0;
704	4					6	while (1) {
705	32					51	my $raw = '';
706	32					229	my $n = read(FH, $raw, $recsize);
707	32	100	66			136	last unless defined($n) && ($n == $recsize);
708	28	50				66	if (substr($raw, 0, 1) ne RECORD_DELETED) {
709	28					77	my $row = $self->_unpack_record($sch, $raw);
710
711							# Make row available under both bare and table-qualified names
712	28					101	my %qrow = %$row;
713	28					49	for my $c (@{$sch->{cols}}) {
	28					56
714	132					332	$qrow{"$tbl.$c->{name}"} = $row->{$c->{name}};
715							}
716	28	100				152	push @results, { %qrow } if $filter->({ %qrow });
717							}
718	28					132	$rec_no++;
719							}
720	4					17	_unlock(\*FH);
721	4					30	close FH;
722
723							# ORDER BY
724	4	100				20	if (my $ob = $opts{order_by}) {
725	1	50				7	my $dir = lc(defined($opts{order_dir}) ? $opts{order_dir} : 'asc');
726							@results = sort {
727	1					7	my($va, $vb) = ($a->{$ob}, $b->{$ob});
	3					11
728	3	50	33			30	my $cmp = (defined($va) && ($va =~ /^-?\d+\.?\d*$/) &&
		50
		50
729							defined($vb) && ($vb =~ /^-?\d+\.?\d*$/))
730							? ($va <=> $vb)
731							: ((defined($va) ? $va : '') cmp (defined($vb) ? $vb : ''));
732	3	50				11	($dir eq 'desc') ? -$cmp : $cmp;
733							} @results;
734							}
735
736							# OFFSET / LIMIT
737	4	50				142	my $off = defined($opts{offset}) ? $opts{offset} : 0;
738	4	50				13	@results = splice(@results, $off) if $off;
739	4	50				13	if (defined $opts{limit}) {
740	0					0	my $last = $opts{limit} - 1;
741	0	0				0	$last = $#results if $last > $#results;
742	0					0	@results = @results[0..$last];
743							}
744
745							# Column projection (remove table-qualified duplicates)
746	4					6	my @proj;
747	4					9	for my $r (@results) {
748	15					18	my %p;
749	15	50				26	if (@sel_cols) {
750	15					19	for my $c (@sel_cols) {
751	15					42	$p{$c} = $r->{$c};
752							}
753							}
754							else {
755
756							# All bare columns
757	0					0	for my $c (@{$sch->{cols}}) {
	0					0
758	0					0	$p{$c->{name}} = $r->{$c->{name}};
759							}
760							}
761	15					47	push @proj, { %p };
762							}
763
764	4					193	return { type=>'rows', data=>[ @proj ] };
765							}
766
767							# ---------------------------------------------------------------------------
768							# _expand_where_subqueries($sql, \%outer_row)
769							#
770							# Finds the innermost (SELECT ...) in a WHERE clause and replaces it with
771							# its evaluated result (a literal list or scalar). Repeats until no
772							# subqueries remain. Returns the rewritten SQL string, or error hashref.
773							# ---------------------------------------------------------------------------
774							sub _expand_where_subqueries {
775	28			28		66	my($self, $sql, $outer_row) = @_;
776	28		50			60	$outer_row \|\|= {};
777
778	28					51	my $max_depth = 32;
779	28					50	my $iter = 0;
780
781	28		66			188	while (($sql =~ /\(\s*SELECT\b/i) && ($iter++ < $max_depth)) {
782
783							# Find the innermost (SELECT ...) -- i.e. the one with no nested (SELECT
784	26					74	my $pos = _find_innermost_subquery($sql);
785	26	50				89	last unless defined $pos;
786
787	26					57	my($start, $end) = @$pos;
788	26					80	my $inner_sql = substr($sql, $start + 1, $end - $start - 1);
789	26					340	$inner_sql =~ s/^\s+\|\s+$//g;
790
791							# Determine context: what precedes the opening paren
792	26					90	my $prefix = substr($sql, 0, $start);
793
794							# Detect correlated subquery: inner SQL contains tablename.colname
795							# references that are NOT from the inner query's own tables.
796							# Heuristic: if inner_sql has \w+\.\w+ patterns, check if those
797							# table-names appear in the inner FROM clause.
798	26	100				68	if (_subquery_is_correlated($inner_sql)) {
799
800							# Cannot pre-evaluate; will be handled per-row in _compile_where_with_subq.
801							# Mark as a correlated subquery placeholder and stop expanding here.
802	4					12	last;
803							}
804
805							# Inject outer row values for correlated references
806	22					84	my $resolved = $self->_resolve_correlated($inner_sql, $outer_row);
807
808							# Execute the inner query
809	22					136	my $inner_res = $self->execute($resolved);
810	22	50	33			123	if (!$inner_res \|\| ($inner_res->{type} eq 'error')) {
811	0	0				0	my $msg = $inner_res ? $inner_res->{message} : $errstr;
812	0					0	return { type=>'error', message=>"Subquery error: $msg" };
813							}
814
815	22	50				33	my @inner_rows = @{ $inner_res->{data} \|\| [] };
	22					100
816
817							# Determine what kind of subquery this is based on prefix context
818	22					34	my $replacement;
819	22	100	66			294	if (($prefix =~ /\bIN\s$/i) \|\| ($prefix =~ /\bNOT\s+IN\s$/i)) {
		100
820
821							# IN / NOT IN: build a parenthesised list of literal values
822	11					18	my @vals;
823	11					23	for my $r (@inner_rows) {
824	15					38	my @rv = values %$r;
825	15	50				33	my $v = defined($rv[0]) ? $rv[0] : 'NULL';
826	15	50				58	if ($v =~ /^-?\d+\.?\d*$/) {
827	15					37	push @vals, $v;
828							}
829							else {
830	0					0	push @vals, "'$v'";
831							}
832							}
833	11	100				41	if (@vals) {
834	9					34	$replacement = '(' . join(',', @vals) . ')';
835							}
836							else {
837
838							# Empty set: IN (NULL) never matches; NOT IN (NULL) always matches
839	2					4	$replacement = '(NULL)';
840							}
841							}
842							elsif ($prefix =~ /\b(?:EXISTS\|NOT\s+EXISTS)\s*$/i) {
843
844							# EXISTS / NOT EXISTS: replace the paren content with 1 or 0
845							# The EXISTS keyword stays; we replace just the (SELECT ...) with (1) or (0)
846	3	100				9	$replacement = @inner_rows ? '(1)' : '(0)';
847							}
848							else {
849
850							# Scalar subquery (=, !=, <, >, <=, >=, or bare use)
851	8	50				22	if (@inner_rows > 1) {
852	0					0	return { type=>'error', message=>"Subquery returns more than one row" };
853							}
854	8	100				22	if (@inner_rows == 0) {
855	1					4	$replacement = 'NULL';
856							}
857							else {
858	7					14	my @rv = values %{ $inner_rows[0] };
	7					26
859	7	50				34	my $v = defined($rv[0]) ? $rv[0] : 'NULL';
860	7	50				42	$replacement = ($v =~ /^-?\d+\.?\d*$/) ? $v : "'$v'";
861							}
862							}
863
864							# Splice the replacement into the SQL
865	22					196	substr($sql, $start, $end - $start + 1) = $replacement;
866							}
867
868	28					87	return $sql;
869							}
870
871							# ---------------------------------------------------------------------------
872							# Detect whether a subquery SQL string contains correlated outer references.
873							# A subquery is correlated if it contains alias.colname where the alias
874							# is NOT one of the tables listed in its own FROM clause.
875							# ---------------------------------------------------------------------------
876							sub _subquery_is_correlated {
877	26			26		54	my($inner_sql) = @_;
878
879							# Find tables in the inner FROM clause
880	26					65	my %inner_tables;
881
882							# FROM t1 [AS a1] [JOIN t2 AS a2 ON ...]*
883	26	50				217	if ($inner_sql =~ /\bFROM\s+(\w+)(?:\s+(?:AS\s+)?(\w+))?/i) {
884	26	100				167	$inner_tables{ lc(defined($2) ? $2 : $1) } = 1;
885	26					76	$inner_tables{ lc($1) } = 1;
886							}
887	26					146	while ($inner_sql =~ /\bJOIN\s+(\w+)(?:\s+(?:AS\s+)?(\w+))?/gi) {
888	0	0				0	$inner_tables{ lc(defined($2) ? $2 : $1) } = 1;
889	0					0	$inner_tables{ lc($1) } = 1;
890							}
891
892							# Look for alias.col references in WHERE clause
893	26					106	while ($inner_sql =~ /\b(\w+)\.(\w+)\b/g) {
894	5					19	my($tbl, $col) = (lc($1), $2);
895	5	100				36	return 1 unless $inner_tables{$tbl};
896							}
897	22					138	return 0;
898							}
899
900							# ---------------------------------------------------------------------------
901							# Find the innermost (SELECT ...) -- the one whose content has no nested
902							# (SELECT. Returns [$start_pos, $end_pos] of the outer parens, or undef.
903							# ---------------------------------------------------------------------------
904							sub _find_innermost_subquery {
905	26			26		53	my($sql) = @_;
906	26					40	my $len = length($sql);
907	26					38	my $best_start;
908							my $best_end;
909
910	26					41	my $i = 0;
911	26					54	while ($i < $len) {
912
913							# Look for ( followed (possibly with spaces) by SELECT
914	2603	100				3939	if (substr($sql, $i, 1) eq '(' ) {
915
916							# Check if this opens a SELECT
917	29					75	my $peek = substr($sql, $i+1);
918	29					94	$peek =~ s/^\s+//;
919	29	100				90	if ($peek =~ /^SELECT\b/i) {
920
921							# Walk to matching close paren, check for no nested SELECT
922	28					42	my $depth = 1;
923	28					44	my $j = $i + 1;
924	28					30	my $has_nested = 0;
925	28					40	my $in_str = 0;
926	28		100			115	while (($j < $len) && ($depth > 0)) {
927	1458					1757	my $ch = substr($sql, $j, 1);
928	1458	100				2570	if ($ch eq "'") {
		100
929
930							# Toggle string mode
931	16					26	$in_str = !$in_str;
932							}
933							elsif (!$in_str) {
934	1402	100				2407	if ($ch eq '(') {
		100
935	3					6	$depth++;
936
937							# check for nested SELECT
938	3					9	my $p2 = substr($sql, $j+1);
939	3					8	$p2 =~ s/^\s+//;
940	3	100	66			19	$has_nested = 1 if ($depth > 1) && ($p2 =~ /^SELECT\b/i);
941							}
942							elsif ($ch eq ')') {
943	31					44	$depth--;
944							}
945							}
946	1458					3495	$j++;
947							}
948	28	100	66			103	if (($depth == 0) && !$has_nested) {
949
950							# This is an innermost SELECT subquery
951	26					37	$best_start = $i;
952	26					51	$best_end = $j - 1;
953
954							# Don't break -- we want the last (innermost) one found
955							}
956							}
957							}
958	2603					3707	$i++;
959							}
960
961	26	50				128	return defined($best_start) ? [ $best_start, $best_end ] : undef;
962							}
963
964							# ---------------------------------------------------------------------------
965							# _resolve_correlated($inner_sql, \%outer_row)
966							#
967							# Replace references to outer-row columns in a correlated subquery.
968							# Outer references appear as outer.colname or are matched when the column
969							# name exists in %outer_row but NOT in the inner query's table.
970							# Simple heuristic: replace outer.col tokens with the literal value.
971							# ---------------------------------------------------------------------------
972							sub _resolve_correlated {
973	50			50		132	my($self, $sql, $outer_row) = @_;
974	50	100				139	return $sql unless %$outer_row;
975
976							# Build sorted list: longer (qualified) keys first so alias.col
977							# is replaced before bare col to avoid double-substitution.
978	28					160	my @keys = sort { length($b) <=> length($a) } keys %$outer_row;
	617					722
979
980	28					60	for my $qkey (@keys) {
981	264	50				786	my $val = defined($outer_row->{$qkey}) ? $outer_row->{$qkey} : 'NULL';
982	264	100				1121	my $lit = ($val =~ /^-?\d+\.?\d*$/) ? $val : "'$val'";
983
984	264	100				499	if (index($qkey, '.') >= 0) {
985
986							# Qualified key: e.g. "employees.id"
987							# Build regex that matches the full qualified token
988	132					390	(my $pat = $qkey) =~ s/\./\\./g;
989	132					12720	$sql =~ s/(?
990							}
991							else {
992
993							# Bare key: only replace if NOT preceded by a dot
994							# (avoids replacing "id" inside "employees.id" already handled above)
995	132					9300	$sql =~ s/(?
996							}
997							}
998	28					167	return $sql;
999							}
1000
1001							# ---------------------------------------------------------------------------
1002							# EXISTS / NOT EXISTS correlated subquery evaluation at runtime
1003							#
1004							# These must be evaluated per-outer-row, so they cannot be pre-expanded.
1005							# We detect them in _parse_conditions and defer evaluation.
1006							# ---------------------------------------------------------------------------
1007
1008							# Enhanced _parse_conditions that understands subquery conditions.
1009							# Returns arrayref of condition hashrefs; subquery conditions have:
1010							# { type => 'subquery',
1011							# op => 'IN'\|'NOT_IN'\|'EXISTS'\|'NOT_EXISTS'\|'CMP',
1012							# col => colname, # for IN/NOT_IN/CMP
1013							# cmp_op => '='\|..., # for CMP
1014							# subql => 'SELECT ...',
1015							# }
1016							sub _parse_conditions_with_subq {
1017	6			6		15	my($self, $expr) = @_;
1018	6					9	my @conds;
1019
1020							# Split on AND (but not inside parens/strings)
1021	6					19	my @parts = _split_and_clauses($expr);
1022
1023	6					16	for my $part (@parts) {
1024	6					79	$part =~ s/^\s+\|\s+$//g;
1025
1026							# EXISTS (SELECT ...)
1027	6	100				32	if ($part =~ /^(NOT\s+)?EXISTS\s$(.+)$\s$/si) {
1028	3					15	my($neg, $subql) = ($1, $2);
1029	3					46	$subql =~ s/^\s+\|\s+$//g;
1030	3	100				25	push @conds, {
1031							type => 'subquery',
1032							op => ($neg ? 'NOT_EXISTS' : 'EXISTS'),
1033							subql => $subql,
1034							};
1035	3					11	next;
1036							}
1037
1038							# col [NOT] IN (SELECT ...)
1039	3	50				17	if ($part =~ /^([\w.]+)\s+(NOT\s+)?IN\s$(\sSELECT\b.+)$\s*$/si) {
1040	0					0	my($col, $neg, $subql) = ($1, $2, $3);
1041	0					0	$subql =~ s/^\s+\|\s+$//g;
1042	0	0				0	push @conds, {
1043							type => 'subquery',
1044							op => $neg ? 'NOT_IN' : 'IN',
1045							col => $col,
1046							subql => $subql,
1047							};
1048	0					0	next;
1049							}
1050
1051							# col OP (SELECT ...)
1052	3	100				20	if ($part =~ /^([\w.]+)\s(=\|!=\|<>\|<=\|>=\|<\|>)\s$(\sSELECT\b.+)$\s$/si) {
1053	1					9	my($col, $op, $subql) = ($1, uc($2), $3);
1054	1					18	$subql =~ s/^\s+\|\s+$//g;
1055	1					6	push @conds, {
1056							type => 'subquery',
1057							op => 'CMP',
1058							cmp_op => $op,
1059							col => $col,
1060							subql => $subql,
1061							};
1062	1					3	next;
1063							}
1064
1065							# Normal condition
1066	2	50				32	if ($part =~ /^(\w+)\s(=\|!=\|<>\|<=\|>=\|<\|>\|LIKE)\s(?:'([^'])'\|(-?\d+\.?\d))$/i) {
1067	2					14	my($col, $op, $sv, $nv) = ($1, $2, $3, $4);
1068	2	50				17	push @conds, { col=>$col, op=>uc($op), val=>defined($sv) ? $sv : $nv };
1069							}
1070							}
1071	6					23	return [ @conds ];
1072							}
1073
1074							# Split WHERE expression on top-level AND (not inside parens or strings)
1075							sub _split_and_clauses {
1076	6			6		13	my($expr) = @_;
1077	6					8	my @parts;
1078	6					7	my $cur = '';
1079	6					10	my $depth = 0;
1080	6					8	my $in_str = 0;
1081	6					8	my $i = 0;
1082	6					11	my $len = length($expr);
1083
1084	6					14	while ($i < $len) {
1085	334					424	my $ch = substr($expr, $i, 1);
1086	334	50	33			1310	if (($ch eq "'") && !$in_str) {
		50	33
		50	66
		100
		100
		50
1087	0					0	$in_str = 1;
1088	0					0	$cur .= $ch;
1089							}
1090							elsif (($ch eq "'") && $in_str) {
1091	0					0	$in_str = 0;
1092	0					0	$cur .= $ch;
1093							}
1094							elsif ($in_str) {
1095	0					0	$cur .= $ch;
1096							}
1097							elsif ($ch eq '(') {
1098	4					5	$depth++;
1099	4					6	$cur .= $ch;
1100							}
1101							elsif ($ch eq ')') {
1102	4					22	$depth--;
1103	4					9	$cur .= $ch;
1104							}
1105							elsif (($depth == 0) && (substr($expr, $i, 5) =~ /^AND\s/i)) {
1106	0					0	push @parts, $cur;
1107	0					0	$cur = '';
1108	0					0	$i += 4; # skip "AND "
1109	0					0	next;
1110							}
1111							else {
1112	326					416	$cur .= $ch;
1113							}
1114	334					1603	$i++;
1115							}
1116	6	50				39	push @parts, $cur if $cur =~ /\S/;
1117	6					99	return @parts;
1118							}
1119
1120							# ---------------------------------------------------------------------------
1121							# Build a where-filter sub that handles subquery conditions (evaluated
1122							# at filter time with the candidate row as outer context).
1123							# ---------------------------------------------------------------------------
1124							sub _compile_where_with_subq {
1125	6			6		14	my($self, $conds) = @_;
1126	6	50	33	0		28	return sub { 1 } unless $conds && @$conds;
	0					0
1127
1128	6					21	my @plain;
1129							my @subq;
1130	6					12	for my $c (@$conds) {
1131	6	100	100			27	if (($c->{type} \|\| '') eq 'subquery') {
1132	4					24	push @subq, $c;
1133							}
1134							else {
1135	2					3	push @plain, $c;
1136							}
1137							}
1138
1139	6					60	my $plain_sub = _compile_where_from_conds([ @plain ]);
1140
1141							return sub {
1142	36			36		75	my($row) = @_;
1143
1144							# Plain conditions first (fast path)
1145	36	100	100			94	return 0 if $plain_sub && !$plain_sub->($row);
1146
1147							# Subquery conditions (evaluated per row)
1148	34					56	for my $c (@subq) {
1149	28					70	my $op = $c->{op};
1150	28					95	my $subql = $self->_resolve_correlated($c->{subql}, $row);
1151	28					119	my $res = $self->execute($subql);
1152	28	50	33			130	my @rows = ($res && $res->{type} eq 'rows') ? @{$res->{data}} : ();
	28					66
1153
1154	28	100	33			84	if ($op eq 'EXISTS') {
		100
		50
		50
1155	12	100				68	return 0 unless @rows;
1156							}
1157							elsif ($op eq 'NOT_EXISTS') {
1158	8	100				36	return 0 if @rows;
1159							}
1160							elsif (($op eq 'IN') \|\| ($op eq 'NOT_IN')) {
1161	0	0				0	my $col_val = defined($row->{$c->{col}}) ? $row->{$c->{col}} : '';
1162	0					0	my $found = 0;
1163	0					0	for my $r (@rows) {
1164	0					0	my @rv = values %$r;
1165	0	0				0	my $rv = defined($rv[0]) ? $rv[0] : '';
1166	0		0			0	my $num = (($col_val =~ /^-?\d+\.?\d$/) && ($rv =~ /^-?\d+\.?\d$/));
1167	0	0				0	if ($num ? ($col_val == $rv) : ($col_val eq $rv)) {
		0
1168	0					0	$found = 1;
1169	0					0	last;
1170							}
1171							}
1172	0	0	0			0	return 0 if $found && ($op eq 'NOT_IN');
1173	0	0	0			0	return 0 if !$found && ($op eq 'IN');
1174							}
1175							elsif ($op eq 'CMP') {
1176	8	50				17	return 0 if @rows > 1;
1177	8					10	my $rhs;
1178	8	100				16	if (@rows == 0) {
1179	4					7	$rhs = undef;
1180							}
1181							else {
1182	4					6	my @rv = values %{ $rows[0] };
	4					10
1183	4					12	$rhs = $rv[0];
1184							}
1185	8	100				42	return 0 unless defined $rhs;
1186	4	50				14	my $lhs = defined($row->{$c->{col}}) ? $row->{$c->{col}} : '';
1187	4					7	my $cop = $c->{cmp_op};
1188	4		33			29	my $num = (($lhs =~ /^-?\d+\.?\d$/) && ($rhs =~ /^-?\d+\.?\d$/));
1189	4	50	33			26	if ($cop eq '=') {
		50
		50
		50
		0
		0
1190	0	0				0	return 0 unless $num ? ($lhs == $rhs) : ($lhs eq $rhs);
		0
1191							}
1192							elsif (($cop eq '!=') \|\| ($cop eq '<>')) {
1193	0	0				0	return 0 unless $num ? ($lhs != $rhs) : ($lhs ne $rhs);
		0
1194							}
1195							elsif ($cop eq '<') {
1196	0	0				0	return 0 unless $num ? ($lhs < $rhs) : ($lhs lt $rhs);
		0
1197							}
1198							elsif ($cop eq '>') {
1199	4	50				22	return 0 unless $num ? ($lhs > $rhs) : ($lhs gt $rhs);
		50
1200							}
1201							elsif ($cop eq '<=') {
1202	0	0				0	return 0 unless $num ? ($lhs <= $rhs) : ($lhs le $rhs);
		0
1203							}
1204							elsif ($cop eq '>=') {
1205	0	0				0	return 0 unless $num ? ($lhs >= $rhs) : ($lhs ge $rhs);
		0
1206							}
1207							}
1208							}
1209	21					202	return 1;
1210	6					87	};
1211							}
1212
1213							# ---------------------------------------------------------------------------
1214							# Derived table: FROM (SELECT ...) AS alias [WHERE ...] [ORDER BY ...]
1215							#
1216							# Evaluates the inner SELECT, materialises the result as an in-memory
1217							# virtual table, then applies the outer WHERE/ORDER BY/LIMIT/OFFSET.
1218							# ---------------------------------------------------------------------------
1219							sub _exec_derived_table {
1220	4			4		10	my($self, $sql) = @_;
1221
1222							# Parse: SELECT outer_cols FROM (inner_sql) AS alias [WHERE ...] [ORDER BY ...] [LIMIT] [OFFSET]
1223							# Step 1: find the outer SELECT list
1224	4	50				27	unless ($sql =~ /^SELECT\s+(.+?)\s+FROM\s*\(/si) {
1225	0					0	return { type=>'error', message=>"Cannot parse derived table query" };
1226							}
1227	4					12	my $outer_cols_str = $1;
1228
1229							# Step 2: extract the (inner_sql) AS alias part using paren matching
1230	4					14	my $from_pos = index(lc($sql), 'from');
1231	4					8	my $paren_start = index($sql, '(', $from_pos);
1232	4	50				8	unless ($paren_start >= 0) {
1233	0					0	return { type=>'error', message=>"Cannot find subquery in FROM clause" };
1234							}
1235
1236	4					13	my($inner_sql, $close_pos) = _extract_paren_content($sql, $paren_start);
1237	4	50				9	unless (defined $inner_sql) {
1238	0					0	return { type=>'error', message=>"Unmatched parentheses in FROM clause" };
1239							}
1240	4					28	$inner_sql =~ s/^\s+\|\s+$//g;
1241
1242							# Step 3: parse alias and trailing clauses after the closing paren
1243	4					8	my $after = substr($sql, $close_pos + 1);
1244	4					10	$after =~ s/^\s+//;
1245
1246	4					6	my $alias;
1247	4	50				16	if ($after =~ s/^(?:AS\s+)?(\w+)\s*//i) {
1248	4					9	$alias = $1;
1249							}
1250							else {
1251	0					0	$alias = 'subq';
1252							}
1253
1254							# Step 4: parse outer WHERE / ORDER BY / LIMIT / OFFSET
1255	4					4	my %outer_opts;
1256	4	100				15	if ($after =~ s/\bLIMIT\s+(\d+)//i) {
1257	1					2	$outer_opts{limit} = $1;
1258							}
1259	4	50				10	if ($after =~ s/\bOFFSET\s+(\d+)//i) {
1260	0					0	$outer_opts{offset} = $1;
1261							}
1262	4	100				13	if ($after =~ s/\bORDER\s+BY\s+([\w.]+)(?:\s+(ASC\|DESC))?//i) {
1263	1					2	$outer_opts{order_by} = $1;
1264	1		50			6	$outer_opts{order_dir} = ($2 \|\| 'ASC');
1265							}
1266
1267	4					4	my $outer_where_str = '';
1268	4	100				10	if ($after =~ /\bWHERE\s+(.+)/i) {
1269	2					3	$outer_where_str = $1;
1270	2					7	$outer_where_str =~ s/^\s+\|\s+$//g;
1271							}
1272
1273							# Step 5: execute the inner query (recursing through execute_with_subquery)
1274	4					10	my $inner_res = $self->execute_with_subquery($inner_sql);
1275	4	50	33			30	if (!$inner_res \|\| ($inner_res->{type} eq 'error')) {
1276	0	0				0	my $msg = $inner_res ? $inner_res->{message} : $errstr;
1277	0					0	return { type=>'error', message=>"Derived table subquery error: $msg" };
1278							}
1279
1280	4	50				7	my @inner_rows = @{ $inner_res->{data} \|\| [] };
	4					29
1281
1282							# Step 6: qualify column names with alias (for outer WHERE resolution)
1283	4					8	my @qualified_rows;
1284	4					8	for my $r (@inner_rows) {
1285	20					26	my %qr;
1286	20					40	for my $k (keys %$r) {
1287
1288							# Strip existing alias prefix if any, re-prefix with outer alias
1289	40	50				73	my $bare = ($k =~ /\.(\w+)$/) ? $1 : $k;
1290	40					96	$qr{"$alias.$bare"} = $r->{$k};
1291	40					70	$qr{$bare} = $r->{$k}; # also keep bare for convenience
1292							}
1293	20					95	push @qualified_rows, { %qr };
1294							}
1295
1296							# Step 7: apply outer WHERE
1297	4	100				17	if ($outer_where_str =~ /\S/) {
1298	2					24	my $conds = $self->_parse_conditions_with_subq($outer_where_str);
1299	2					6	my $filter = $self->_compile_where_with_subq($conds);
1300	2					4	@qualified_rows = grep { $filter->($_) } @qualified_rows;
	8					11
1301							}
1302
1303							# Step 8: ORDER BY
1304	4	100				21	if (my $ob = $outer_opts{order_by}) {
1305	1		50			5	my $dir = lc($outer_opts{order_dir} \|\| 'asc');
1306							@qualified_rows = sort {
1307	1					6	my $va = defined($a->{$ob})
1308							? $a->{$ob}
1309	17	50				27	: $a->{ ($ob =~ /\.(\w+)$/)[0] };
1310							my $vb = defined($b->{$ob})
1311							? $b->{$ob}
1312	17	50				22	: $b->{ ($ob =~ /\.(\w+)$/)[0] };
1313	17	50	33			91	my $cmp = (defined($va) && ($va =~ /^-?\d+\.?\d*$/) &&
			0
			0
1314							defined($vb) && ($vb =~ /^-?\d+\.?\d*$/))
1315							? ($va <=> $vb)
1316							: (($va \|\| '') cmp ($vb \|\| ''));
1317	17	50				27	($dir eq 'desc') ? -$cmp : $cmp;
1318							} @qualified_rows;
1319							}
1320
1321							# Step 9: OFFSET / LIMIT
1322	4		50			15	my $off = ($outer_opts{offset} \|\| 0);
1323	4	50				8	@qualified_rows = splice(@qualified_rows, $off) if $off;
1324	4	100				22	if (defined $outer_opts{limit}) {
1325	1					3	my $last = $outer_opts{limit} - 1;
1326	1	50				3	$last = $#qualified_rows if $last > $#qualified_rows;
1327	1					7	@qualified_rows = @qualified_rows[0..$last];
1328							}
1329
1330							# Step 10: outer column projection
1331	4					6	my @proj_rows;
1332	4	50				15	if ($outer_cols_str =~ /^\s\\s*$/) {
1333	0					0	@proj_rows = @qualified_rows;
1334							}
1335							else {
1336	4					15	my @want = map { my $x = $_; $x =~ s/^\s+\|\s+\$//g; $x } split /,/, $outer_cols_str;
	4					7
	4					18
	4					12
1337	4					10	for my $r (@qualified_rows) {
1338	13					15	my %p;
1339	13					15	for my $w (@want) {
1340	13	50	0			41	if (exists $r->{$w}) {
		0
1341	13					24	$p{$w} = $r->{$w};
1342							}
1343							elsif ($w =~ /^$alias\.(\w+)$/ && exists $r->{$1}) {
1344	0					0	$p{$w} = $r->{$1};
1345							}
1346							else {
1347
1348							# bare name search
1349	0					0	for my $k (keys %$r) {
1350	0	0	0			0	if (($k =~ /\.\Q$w\E$/) \|\| ($k eq $w)) {
1351	0					0	$p{$w} = $r->{$k};
1352	0					0	last;
1353							}
1354							}
1355							}
1356							}
1357	13					49	push @proj_rows, { %p };
1358							}
1359							}
1360
1361	4					77	return { type=>'rows', data=>[ @proj_rows ] };
1362							}
1363
1364							# ---------------------------------------------------------------------------
1365							# Scalar subquery in SELECT list
1366							# SELECT (SELECT agg_col FROM t WHERE ...) AS label, other_col FROM main_tbl ...
1367							# ---------------------------------------------------------------------------
1368							sub _exec_scalar_select_subquery {
1369	0			0		0	my($self, $sql) = @_;
1370
1371							# Strategy: collect all scalar subqueries in the SELECT list,
1372							# evaluate each, replace with the literal value, then execute the rest.
1373
1374							# Find all top-level (SELECT ...) AS alias in the SELECT list
1375							# For simplicity: expand iteratively like WHERE subqueries
1376	0					0	my $expanded = $self->_expand_where_subqueries($sql, {});
1377	0	0				0	return $expanded if ref($expanded) eq 'HASH';
1378	0					0	return $self->execute($expanded);
1379							}
1380
1381							# ---------------------------------------------------------------------------
1382							# Extract content between matching parens starting at $start_pos.
1383							# Returns ($content_without_outer_parens, $close_paren_pos).
1384							# ---------------------------------------------------------------------------
1385							sub _extract_paren_content {
1386	4			4		20	my($sql, $start_pos) = @_;
1387	4					5	my $len = length($sql);
1388	4					6	my $depth = 0;
1389	4					5	my $in_str = 0;
1390	4					12	for my $i ($start_pos .. $len-1) {
1391	204					184	my $ch = substr($sql, $i, 1);
1392	204	50	33			389	if (($ch eq "'") && !$in_str) {
		50	33
		50
1393	0					0	$in_str = 1;
1394							}
1395							elsif (($ch eq "'") && $in_str) {
1396	0					0	$in_str = 0;
1397							}
1398							elsif (!$in_str) {
1399	204	100				280	if ($ch eq '(') {
		100
1400	4					5	$depth++;
1401							}
1402							elsif ($ch eq ')') {
1403	4					5	$depth--;
1404	4	50				9	if ($depth == 0) {
1405	4					24	return (substr($sql, $start_pos+1, $i-$start_pos-1), $i);
1406							}
1407							}
1408							}
1409							}
1410	4					0	return (undef, undef);
1411							}
1412
1413							###############################################################################
1414							# Index internals
1415							###############################################################################
1416
1417							sub _idx_file {
1418	751			751		1375	my($self, $table, $idxname) = @_;
1419	751					10805	File::Spec->catfile($self->{base_dir}, $self->{db_name}, "$table.$idxname.idx");
1420							}
1421
1422							sub _encode_key {
1423	477			477		818	my($type, $keysize, $val) = @_;
1424	477	50				978	$val = '' unless defined $val;
1425	477	100				1026	if ($type eq 'INT') {
		100
1426	353		100			753	my $iv = int($val \|\| 0);
1427	353	50				697	$iv = 2147483647 if $iv > 2147483647;
1428	353	50				620	$iv = -2147483648 if $iv < -2147483648;
1429	353					1724	return pack('N', ($iv & 0xFFFFFFFF) ^ 0x80000000);
1430							}
1431							elsif ($type eq 'FLOAT') {
1432
1433							# my $packed = pack('d>', $val+0);
1434	89					401	my $packed = pack('d', $val+0);
1435	89	50				311	$packed = reverse($packed) if unpack("C", pack("S", 1));
1436
1437	89					215	my @b = unpack('C8', $packed);
1438	89	100				187	if ($b[0] & 0x80) {
1439	2					4	@b = map { $_ ^ 0xFF } @b;
	16					19
1440							}
1441							else {
1442	87					137	$b[0] ^= 0x80;
1443							}
1444	89					405	return pack('C8', @b);
1445							}
1446							else {
1447	35					53	my $sv = substr($val, 0, $keysize);
1448	35					82	$sv .= "\x00" x ($keysize - length($sv));
1449	35					75	return $sv;
1450							}
1451							}
1452
1453
1454							sub _idx_entry_size {
1455	388			388		793	$_[0]->{keysize} + REC_NO_SIZE;
1456							}
1457
1458							sub _idx_read_all {
1459	388			388		608	my($self, $table, $ix) = @_;
1460	388					864	my $idx_file = $self->_idx_file($table, $ix->{name});
1461	388					883	my $entry_size = _idx_entry_size($ix);
1462	388					473	my @entries;
1463	388	50				7360	return [ @entries ] unless -f $idx_file;
1464	388					1229	local *FH;
1465	388	50				11298	open(FH, "< $idx_file") or return [ @entries ];
1466	388					1101	binmode FH;
1467	388					612	my $magic = '';
1468	388					5924	read(FH, $magic, IDX_MAGIC_LEN);
1469	388	50				982	unless ($magic eq IDX_MAGIC) {
1470	0					0	close FH;
1471	0					0	return [ @entries ];
1472							}
1473	388					482	while (1) {
1474	23817					23252	my $entry = '';
1475	23817					29288	my $n = read(FH, $entry, $entry_size);
1476	23817	100	66			45872	last unless defined($n) && ($n == $entry_size);
1477	23429					45937	push @entries, [ substr($entry, 0, $ix->{keysize}), unpack('N', substr($entry, $ix->{keysize}, REC_NO_SIZE)) ];
1478							}
1479	388					3920	close FH;
1480	388					3413	return [ @entries ];
1481							}
1482
1483							sub _idx_write_all {
1484	357			357		770	my($self, $table, $ix, $entries) = @_;
1485	357					909	my $idx_file = $self->_idx_file($table, $ix->{name});
1486	357					951	local *FH;
1487	357	50				32539	open(FH, "> $idx_file") or return $self->_err("Cannot write index: $!");
1488	357					1414	binmode FH;
1489	357					1277	_lock_ex(\*FH);
1490	357					2768	print FH IDX_MAGIC;
1491	357					1082	for my $e (@$entries) {
1492	22973					32742	print FH $e->[0] . pack('N', $e->[1]);
1493							}
1494	357					1027	_unlock(\*FH);
1495	357					16310	close FH;
1496	357					5873	return 1;
1497							}
1498
1499							sub _idx_bisect {
1500	398			398		759	my($entries, $key_bytes) = @_;
1501	398					726	my($lo, $hi) = (0, scalar @$entries);
1502	398					819	while ($lo < $hi) {
1503	1837					2478	my $mid = int(($lo + $hi) / 2);
1504	1837	100				2816	if ($entries->[$mid][0] lt $key_bytes) {
1505	1670					2572	$lo = $mid + 1;
1506							}
1507							else {
1508	167					274	$hi = $mid;
1509							}
1510							}
1511	398					622	return $lo;
1512							}
1513
1514							sub _idx_lookup_exact {
1515	18			18		42	my($self, $table, $ix, $val) = @_;
1516	18					54	my $key_bytes = _encode_key($ix->{coltype}, $ix->{keysize}, $val);
1517	18					53	my $entries = $self->_idx_read_all($table, $ix);
1518	18					47	my $pos = _idx_bisect($entries, $key_bytes);
1519	18		66			106	while (($pos < @$entries) && ($entries->[$pos][0] eq $key_bytes)) {
1520	9					58	return $pos;
1521							}
1522	9					41	return -1;
1523							}
1524
1525							sub _idx_insert {
1526	327			327		819	my($self, $table, $ix, $val, $rec_no) = @_;
1527	327					722	my $key_bytes = _encode_key($ix->{coltype}, $ix->{keysize}, $val);
1528	327					845	my $entries = $self->_idx_read_all($table, $ix);
1529	327					746	my $pos = _idx_bisect($entries, $key_bytes);
1530	327					1365	splice(@$entries, $pos, 0, [$key_bytes, $rec_no]);
1531	327					795	return $self->_idx_write_all($table, $ix, $entries);
1532							}
1533
1534							sub _idx_delete {
1535	12			12		28	my($self, $table, $ix, $val, $rec_no) = @_;
1536	12					29	my $key_bytes = _encode_key($ix->{coltype}, $ix->{keysize}, $val);
1537	12					31	my $entries = $self->_idx_read_all($table, $ix);
1538	12					23	my $pos = _idx_bisect($entries, $key_bytes);
1539	12					16	my $deleted = 0;
1540	12		33			41	while (($pos < @$entries) && ($entries->[$pos][0] eq $key_bytes)) {
1541	17	100				27	if ($entries->[$pos][1] == $rec_no) {
1542	12					20	splice(@$entries, $pos, 1);
1543	12					19	$deleted++;
1544	12					17	last;
1545							}
1546	5					10	$pos++;
1547							}
1548	12	50				31	return $self->_idx_write_all($table, $ix, $entries) if $deleted;
1549	0					0	return 1;
1550							}
1551
1552							sub _idx_range {
1553	19			19		44	my($self, $table, $ix, $lo_val, $lo_inc, $hi_val, $hi_inc) = @_;
1554	19					37	my $entries = $self->_idx_read_all($table, $ix);
1555	19	50				43	return [] unless @$entries;
1556
1557	19					23	my $lo_pos = 0;
1558	19	100				39	if (defined $lo_val) {
1559	17					44	my $lo_key = _encode_key($ix->{coltype}, $ix->{keysize}, $lo_val);
1560	17					36	$lo_pos = _idx_bisect($entries, $lo_key);
1561	17		66			80	$lo_pos++ while !$lo_inc && ($lo_pos < @$entries) && ($entries->[$lo_pos][0] eq $lo_key);
			100
1562							}
1563	19					26	my $hi_pos = scalar @$entries;
1564	19	100				33	if (defined $hi_val) {
1565	12					71	my $hi_key = _encode_key($ix->{coltype}, $ix->{keysize}, $hi_val);
1566	12					28	my $p = _idx_bisect($entries, $hi_key);
1567	12		100			73	$p++ while $hi_inc && ($p < @$entries) && ($entries->[$p][0] eq $hi_key);
			100
1568	12					17	$hi_pos = $p;
1569							}
1570	19					54	return [ map { $entries->[$_][1] } $lo_pos .. $hi_pos-1 ];
	109					313
1571							}
1572
1573							sub _rebuild_index {
1574	18			18		53	my($self, $table, $idxname) = @_;
1575	18	50				58	my $sch = $self->_load_schema($table) or return undef;
1576	18					45	my $ix = $sch->{indexes}{$idxname};
1577	18	50				126	return $self->_err("Index '$idxname' not found") unless $ix;
1578	18					56	my $dat = $self->_file($table, 'dat');
1579	18					44	my $recsize = $sch->{recsize};
1580	18					33	my @entries;
1581	18	50				360	if (-f $dat) {
1582	18					57	local *FH;
1583	18	50				563	open(FH, "< $dat") or return $self->_err("Cannot read dat: $!");
1584	18					47	binmode FH;
1585	18					34	my $rec_no = 0;
1586	18					28	while (1) {
1587	97					104	my $raw = '';
1588	97					494	my $n = read(FH, $raw, $recsize);
1589	97	100	66			323	last unless defined($n) && ($n == $recsize);
1590	79	50				161	if (substr($raw, 0, 1) ne RECORD_DELETED) {
1591	79					126	my $row = $self->_unpack_record($sch, $raw);
1592	79					178	push @entries, [ _encode_key($ix->{coltype}, $ix->{keysize}, $row->{$ix->{col}}), $rec_no ];
1593							}
1594	79					97	$rec_no++;
1595							}
1596	18					214	close FH;
1597							}
1598	18					72	@entries = sort { $a->[0] cmp $b->[0] } @entries;
	162					200
1599	18					96	return $self->_idx_write_all($table, $ix, \@entries);
1600							}
1601
1602							sub _find_index_for_conds {
1603	131			131		310	my($self, $table, $sch, $conds) = @_;
1604	131	50	33			545	return undef unless $conds && @$conds;
1605	131	100				193	return undef unless %{$sch->{indexes}};
	131					581
1606	21					185	my %col2ix;
1607	21					49	for my $ix (values %{$sch->{indexes}}) {
	21					71
1608	47					82	$col2ix{$ix->{col}} = $ix;
1609							}
1610	21					36	for my $c (@$conds) {
1611	21	50				46	my $ix = $col2ix{$c->{col}} or next;
1612	21					35	my $op = $c->{op};
1613	21	100				60	if ($op eq '=') {
		100
		100
		100
		50
1614	12					32	my $key_bytes = _encode_key($ix->{coltype}, $ix->{keysize}, $c->{val});
1615	12					35	my $entries = $self->_idx_read_all($table, $ix);
1616	12					35	my $pos = _idx_bisect($entries, $key_bytes);
1617	12					25	my @rec_nos;
1618	12		100			58	while (($pos < @$entries) && ($entries->[$pos][0] eq $key_bytes)) {
1619	15					26	push @rec_nos, $entries->[$pos][1];
1620	15					39	$pos++;
1621							}
1622	12					100	return [ @rec_nos ];
1623							}
1624							elsif ($op eq '<') {
1625	1					4	return $self->_idx_range($table, $ix, undef, 0, $c->{val}, 0);
1626							}
1627							elsif ($op eq '<=') {
1628	1					4	return $self->_idx_range($table, $ix, undef, 0, $c->{val}, 1);
1629							}
1630							elsif ($op eq '>') {
1631	2					8	return $self->_idx_range($table, $ix, $c->{val}, 0, undef, 0);
1632							}
1633							elsif ($op eq '>=') {
1634	5					14	return $self->_idx_range($table, $ix, $c->{val}, 1, undef, 0);
1635							}
1636							}
1637	0					0	return undef;
1638							}
1639
1640							# _try_index_and_range($table, $sch, $where_expr)
1641							#
1642							# Attempt to satisfy a two-sided range or BETWEEN predicate using an index.
1643							# Recognises these WHERE patterns (same column, values numeric or quoted):
1644							# col OP1 val1 AND col OP2 val2 (e.g. id > 5 AND id < 10)
1645							# col BETWEEN val1 AND val2
1646							# Returns an arrayref of matching record numbers, or undef if no index
1647							# can be applied (caller falls through to a full table scan).
1648							#
1649							sub _try_index_and_range {
1650	168			168		426	my($self, $table, $sch, $where_expr) = @_;
1651	168	100				258	return undef unless %{$sch->{indexes}};
	168					579
1652	10					17	my %col2ix;
1653	10					14	for my $ix (values %{$sch->{indexes}}) {
	10					24
1654	20					39	$col2ix{$ix->{col}} = $ix;
1655							}
1656	10					49	my $VAL = qr/(?:'([^'])'\|(-?\d+\.?\d))/;
1657	10					22	my $OP = qr/(<=\|>=\|<\|>)/;
1658							# BETWEEN col BETWEEN val1 AND val2
1659	10	100				464	if ($where_expr =~ /^(\w+)\s+BETWEEN\s+$VAL\s+AND\s+$VAL\s*$/i) {
1660	3					14	my($col, $lo_s, $lo_n, $hi_s, $hi_n) = ($1,$2,$3,$4,$5);
1661	3	50				7	my $lo = defined($lo_s) ? $lo_s : $lo_n;
1662	3	50				5	my $hi = defined($hi_s) ? $hi_s : $hi_n;
1663	3	50				7	my $ix = $col2ix{$col} or return undef;
1664	3					9	return $self->_idx_range($table, $ix, $lo, 1, $hi, 1);
1665							}
1666							# AND: col OP val AND col OP val (same column)
1667	7	50				427	if ($where_expr =~ /^(\w+)\s+$OP\s+$VAL\s+AND\s+\1\s+$OP\s+$VAL\s*$/i) {
1668	7					53	my($col, $op1, $v1s, $v1n, $op2, $v2s, $v2n) = ($1,$2,$3,$4,$5,$6,$7);
1669	7	50				18	my $v1 = defined($v1s) ? $v1s : $v1n;
1670	7	50				12	my $v2 = defined($v2s) ? $v2s : $v2n;
1671	7	50				34	my $ix = $col2ix{$col} or return undef;
1672							# Determine lo (lower bound) and hi (upper bound)
1673	7					12	my($lo, $lo_inc, $hi, $hi_inc);
1674	7	100	100			31	if ($op1 eq '>' \|\| $op1 eq '>=') {
1675	6					13	($lo, $lo_inc) = ($v1, $op1 eq '>=');
1676	6					14	($hi, $hi_inc) = ($v2, $op2 eq '<=');
1677							}
1678							else {
1679	1					2	($lo, $lo_inc) = ($v2, $op2 eq '>=');
1680	1					2	($hi, $hi_inc) = ($v1, $op1 eq '<=');
1681							}
1682	7					22	return $self->_idx_range($table, $ix, $lo, $lo_inc, $hi, $hi_inc);
1683							}
1684	0					0	return undef;
1685							}
1686
1687							###############################################################################
1688							# JOIN -- Public entry point
1689							###############################################################################
1690							# join_select(\@join_specs, \@col_specs, \@where_conds, \%opts)
1691							#
1692							# join_specs : arrayref of hashrefs, in left-to-right order
1693							# { table => 'employees', # physical table name
1694							# alias => 'e', # alias (or same as table)
1695							# type => 'INNER'\|'LEFT'\|'RIGHT'\|'CROSS',
1696							# on_left => 'e.dept_id', # undef for first/CROSS
1697							# on_right => 'd.id', # undef for first/CROSS
1698							# }
1699							#
1700							# col_specs : arrayref of 'alias.col' or 'alias.' or ''
1701							# undef = all columns (alias-qualified)
1702							#
1703							# where_conds : arrayref of condition hashrefs (from _parse_join_conditions)
1704							# { lhs_alias, lhs_col, op, rhs_alias, rhs_col, val }
1705							#
1706							# opts : { order_by=>'alias.col'\|'col', order_dir=>'ASC', limit=>N, offset=>M }
1707							#
1708							sub join_select {
1709	27			27	0	65	my($self, $join_specs, $col_specs, $where_conds, $opts) = @_;
1710	27	50				89	return $self->_err("No database selected") unless $self->{db_name};
1711	27		50			66	$opts \|\|= {};
1712	27		50			59	$where_conds \|\|= [];
1713
1714							# ------------------------------------------------------------------
1715							# Step 1: load schemas; build alias -> { table, schema } map
1716							# ------------------------------------------------------------------
1717	27					47	my %alias_info; # alias => { table, sch, rows(lazy) }
1718	27					60	for my $js (@$join_specs) {
1719	56	50				177	my $sch = $self->_load_schema($js->{table}) or return undef;
1720							$alias_info{ $js->{alias} } = {
1721							table => $js->{table},
1722	56					248	sch => $sch,
1723							};
1724							}
1725
1726							# ------------------------------------------------------------------
1727							# Step 2: load the leftmost (driving) table fully into memory
1728							# ------------------------------------------------------------------
1729	27					87	my $first = $join_specs->[0];
1730	27					46	my @cur_rows = @{ $self->_scan_table_all($first->{table}, $first->{alias}) };
	27					92
1731	27	50	33			113	return undef unless defined($cur_rows[0]) \|\| !$self->{_last_err};
1732
1733							# ------------------------------------------------------------------
1734							# Step 3: for each subsequent table, apply the JOIN
1735							# ------------------------------------------------------------------
1736	27					105	for my $i (1 .. $#$join_specs) {
1737	29					61	my $js = $join_specs->[$i];
1738	29		50			105	my $join_type = uc($js->{type} \|\| 'INNER');
1739
1740							# Parse ON alias1.col1 = alias2.col2
1741	29					60	my($on_l_alias, $on_l_col, $on_r_alias, $on_r_col);
1742	29	50	33			165	if ($js->{on_left} && $js->{on_right}) {
1743	29					80	($on_l_alias, $on_l_col) = _split_qualified($js->{on_left});
1744	29					116	($on_r_alias, $on_r_col) = _split_qualified($js->{on_right});
1745							}
1746
1747							# Load the right-side table
1748	29					50	my @right_rows = @{ $self->_scan_table_all($js->{table}, $js->{alias}) };
	29					95
1749
1750							# Build hash on right side if possible (index-nested-loop join)
1751	29					66	my %right_hash;
1752	29					49	my $use_hash = 0;
1753	29	50	33			148	if (defined($on_r_alias) && defined($on_r_col)) {
1754	29					91	for my $rr (@right_rows) {
1755							my $rkey = defined($rr->{"$on_r_alias.$on_r_col"})
1756	138	100				384	? $rr->{"$on_r_alias.$on_r_col"}
1757							: '';
1758	138					194	push @{ $right_hash{$rkey} }, $rr;
	138					406
1759							}
1760	29					50	$use_hash = 1;
1761							}
1762
1763	29					45	my @next_rows;
1764
1765	29	100	66			180	if (($join_type eq 'CROSS') \|\| (!defined $on_l_alias)) {
		100
		100
		50
1766
1767							# Cartesian product
1768	1					3	for my $lr (@cur_rows) {
1769	2					4	for my $rr (@right_rows) {
1770	6					24	push @next_rows, { %$lr, %$rr };
1771							}
1772							}
1773							}
1774							elsif ($join_type eq 'INNER') {
1775	22					44	for my $lr (@cur_rows) {
1776							my $lkey = defined($lr->{"$on_l_alias.$on_l_col"})
1777	145	50				381	? $lr->{"$on_l_alias.$on_l_col"}
1778							: '';
1779	145	50	100			444	my $matches = $use_hash ? ($right_hash{$lkey} \|\| []) : [ @right_rows ];
1780	145					272	for my $rr (@$matches) {
1781	127	50	33			309	next if ($use_hash == 0) && !_join_row_matches($lr, $rr, $on_l_alias, $on_l_col, $on_r_alias, $on_r_col);
1782	127					958	push @next_rows, { %$lr, %$rr };
1783							}
1784							}
1785							}
1786							elsif ($join_type eq 'LEFT') {
1787	5					13	for my $lr (@cur_rows) {
1788							my $lkey = defined($lr->{"$on_l_alias.$on_l_col"})
1789	32	50				88	? $lr->{"$on_l_alias.$on_l_col"}
1790							: '';
1791							my $matches = $use_hash ? ($right_hash{$lkey} \|\| [])
1792	32	50	100			103	: [ grep { _join_row_matches($lr, $_, $on_l_alias, $on_l_col, $on_r_alias, $on_r_col) }
	0					0
1793							@right_rows
1794							];
1795	32	100				62	if (@$matches) {
1796	27					45	for my $rr (@$matches) {
1797	30					216	push @next_rows, { %$lr, %$rr };
1798							}
1799							}
1800							else {
1801
1802							# NULL-fill right side
1803	5					26	my %null_right = _make_null_row($js->{alias}, $alias_info{$js->{alias}}{sch});
1804	5					42	push @next_rows, { %$lr, %null_right };
1805							}
1806							}
1807							}
1808							elsif ($join_type eq 'RIGHT') {
1809
1810							# RIGHT JOIN: swap sides, do LEFT, then results are correct
1811	1					4	for my $rr (@right_rows) {
1812	5	50				20	my $rkey = defined($rr->{"$on_r_alias.$on_r_col"}) ? $rr->{"$on_r_alias.$on_r_col"} : '';
1813	5					27	my $l_alias_key = "$on_l_alias.$on_l_col";
1814	5					11	my @matched_lefts;
1815	5					8	for my $lr (@cur_rows) {
1816	35	50				71	my $lkey = defined($lr->{$l_alias_key}) ? $lr->{$l_alias_key} : '';
1817	35	100				83	push @matched_lefts, $lr if $lkey eq $rkey;
1818							}
1819	5	100				13	if (@matched_lefts) {
1820	3					7	for my $lr (@matched_lefts) {
1821	6					40	push @next_rows, { %$lr, %$rr };
1822							}
1823							}
1824							else {
1825
1826							# NULL-fill all left-side aliases seen so far
1827	2					3	my %null_left;
1828	2					6	for my $prev_js (@{$join_specs}[0..$i-1]) {
	2					7
1829	2					9	my %nr = _make_null_row($prev_js->{alias}, $alias_info{$prev_js->{alias}}{sch});
1830	2					11	%null_left = (%null_left, %nr);
1831							}
1832	2					17	push @next_rows, { %null_left, %$rr };
1833							}
1834							}
1835							}
1836
1837	29					373	@cur_rows = @next_rows;
1838							}
1839
1840							# ------------------------------------------------------------------
1841							# Step 4: apply WHERE (post-join filter)
1842							# ------------------------------------------------------------------
1843	27	100				79	if (@$where_conds) {
1844	15					45	my $wsub = _compile_join_where($where_conds);
1845	15					39	@cur_rows = grep { $wsub->($_) } @cur_rows;
	91					165
1846							}
1847
1848							# ------------------------------------------------------------------
1849							# Step 5: ORDER BY
1850							# ------------------------------------------------------------------
1851	27	100				100	if (my $ob = $opts->{order_by}) {
1852	5		50			22	my $dir = lc($opts->{order_dir} \|\| 'asc');
1853
1854							# ob may be 'alias.col' or bare 'col'; normalise
1855							@cur_rows = sort {
1856	5					32	my $va = $a->{$ob};
	54					96
1857	54					84	my $vb = $b->{$ob};
1858	54	50	33			492	my $cmp = (defined($va) && ($va =~ /^-?\d+\.?\d*$/) &&
			0
			0
1859							defined($vb) && ($vb =~ /^-?\d+\.?\d*$/))
1860							? ($va <=> $vb)
1861							: (($va \|\| '') cmp ($vb \|\| ''));
1862	54	100				134	($dir eq 'desc') ? -$cmp : $cmp;
1863							} @cur_rows;
1864							}
1865
1866							# ------------------------------------------------------------------
1867							# Step 6: OFFSET / LIMIT
1868							# ------------------------------------------------------------------
1869	27		100			128	my $offset = ($opts->{offset} \|\| 0);
1870	27	100				69	@cur_rows = splice(@cur_rows, $offset) if $offset;
1871	27	100				78	if (defined $opts->{limit}) {
1872	2					7	my $last = $opts->{limit} - 1;
1873	2	50				9	$last = $#cur_rows if $last > $#cur_rows;
1874	2					17	@cur_rows = @cur_rows[0..$last];
1875							}
1876
1877							# ------------------------------------------------------------------
1878							# Step 7: column projection
1879							# ------------------------------------------------------------------
1880	27	100	66			121	if ($col_specs && @$col_specs) {
1881
1882							# Expand wildcards: 'alias.' or ''
1883	25					50	my @expanded;
1884	25					53	for my $cs (@$col_specs) {
1885	52	50				220	if ($cs eq '*') {
		100
1886
1887							# all columns from all aliases
1888	0					0	for my $js (@$join_specs) {
1889	0					0	my $a = $js->{alias};
1890	0					0	my $sch = $alias_info{$a}{sch};
1891	0					0	for my $c (@{$sch->{cols}}) {
	0					0
1892	0					0	push @expanded, "$a.$c->{name}";
1893							}
1894							}
1895							}
1896							elsif ($cs =~ /^(\w+)\.\*$/) {
1897	1					6	my $a = $1;
1898	1	50				6	my $sch = $alias_info{$a} ? $alias_info{$a}{sch} : undef;
1899	1	50				4	if ($sch) {
1900	1					2	for my $c (@{$sch->{cols}}) {
	1					3
1901	4					14	push @expanded, "$a.$c->{name}";
1902							}
1903							}
1904							}
1905							else {
1906	51					166	push @expanded, $cs;
1907							}
1908							}
1909	25					40	my @proj_rows;
1910	25					43	for my $r (@cur_rows) {
1911	82					146	my %p;
1912	82					169	for my $ck (@expanded) {
1913
1914							# Try qualified name first, then bare name
1915	175	50				356	if (exists $r->{$ck}) {
1916	175					409	$p{$ck} = $r->{$ck};
1917							}
1918							else {
1919
1920							# bare name: find first matching qualified key
1921	0					0	for my $k (keys %$r) {
1922	0	0	0			0	if (($k =~ /\.\Q$ck\E$/) \|\| ($k eq $ck)) {
1923	0					0	$p{$ck} = $r->{$k};
1924	0					0	last;
1925							}
1926							}
1927							}
1928							}
1929	82					382	push @proj_rows, { %p };
1930							}
1931	25					271	return [ @proj_rows ];
1932							}
1933
1934	2					16	return [ @cur_rows ];
1935							}
1936
1937							# Load all active rows from a table, qualifying each column as "alias.col"
1938							sub _scan_table_all {
1939	56			56		137	my($self, $table, $alias) = @_;
1940	56	50				152	my $sch = $self->_load_schema($table) or return [];
1941	56					151	my $dat = $self->_file($table, 'dat');
1942	56					198	my $recsize = $sch->{recsize};
1943	56					118	my @rows;
1944
1945	56					191	local *FH;
1946	56	50				2759	open(FH, "< $dat") or do { $errstr = "Cannot open dat '$dat': $!"; return []; };
	0					0
	0					0
1947	56					219	binmode FH;
1948	56					240	_lock_sh(\*FH);
1949	56					109	while (1) {
1950	367					650	my $raw = '';
1951	367					2925	my $n = read(FH, $raw, $recsize);
1952	367	100	66			1996	last unless defined($n) && ($n == $recsize);
1953	311	50				836	next if substr($raw, 0, 1) eq RECORD_DELETED;
1954	311					860	my $raw_row = $self->_unpack_record($sch, $raw);
1955
1956							# Qualify column names with alias
1957	311					525	my %qrow;
1958	311					516	for my $col (@{$sch->{cols}}) {
	311					691
1959	1115					3016	$qrow{"$alias.$col->{name}"} = $raw_row->{$col->{name}};
1960							}
1961	311					2220	push @rows, { %qrow };
1962							}
1963	56					208	_unlock(\*FH);
1964	56					734	close FH;
1965	56					478	return [ @rows ];
1966							}
1967
1968							# Build a row of NULLs for the given alias (for outer joins)
1969							sub _make_null_row {
1970	7			7		24	my($alias, $sch) = @_;
1971	7					12	my %row;
1972	7					29	for my $col (@{$sch->{cols}}) {
	7					20
1973	24					62	$row{"$alias.$col->{name}"} = undef;
1974							}
1975	7					37	return %row;
1976							}
1977
1978							# Split "alias.col" into (alias, col); if no dot, return (undef, col)
1979							sub _split_qualified {
1980	75			75		158	my($qname) = @_;
1981	75	50				524	if ($qname =~ /^(\w+)\.(\w+)$/) {
1982	75					379	return ($1, $2);
1983							}
1984	0					0	return (undef, $qname);
1985							}
1986
1987							# Check if a pair of rows satisfies the ON equality condition
1988							sub _join_row_matches {
1989	0			0		0	my($lr, $rr, $la, $lc, $ra, $rc) = @_;
1990	0	0				0	my $lv = defined($la) ? $lr->{"$la.$lc"} : $lr->{$lc};
1991	0	0				0	my $rv = defined($ra) ? $rr->{"$ra.$rc"} : $rr->{$rc};
1992	0	0	0			0	return 0 unless defined($lv) && defined($rv);
1993
1994							# numeric compare if both look numeric
1995	0	0	0			0	if (($lv =~ /^-?\d+\.?\d$/) && ($rv =~ /^-?\d+\.?\d$/)) {
1996	0	0				0	return (($lv == $rv) ? 1 : 0);
1997							}
1998	0	0				0	return (($lv eq $rv) ? 1 : 0);
1999							}
2000
2001							###############################################################################
2002							# JOIN WHERE compiler
2003							# Conditions from the WHERE clause after a JOIN may reference qualified
2004							# columns (alias.col) or bare column names.
2005							# Condition hashref keys:
2006							# lhs_alias, lhs_col -- left-hand side
2007							# op -- = != <> < > <= >= LIKE
2008							# rhs_alias, rhs_col -- right-hand side (column comparison) OR
2009							# val -- literal value
2010							###############################################################################
2011							sub _compile_join_where {
2012	15			15		34	my($conds) = @_;
2013	15	50	33	0		73	return sub { 1 } unless $conds && @$conds;
	0					0
2014							return sub {
2015	91			91		152	my($row) = @_;
2016	91					147	for my $c (@$conds) {
2017
2018							# Resolve left-hand value
2019	97					125	my $lv;
2020	97	50				187	if (defined $c->{lhs_alias}) {
2021	97					229	$lv = $row->{"$c->{lhs_alias}.$c->{lhs_col}"};
2022							}
2023							else {
2024
2025							# bare name: search qualified keys
2026	0					0	for my $k (keys %$row) {
2027	0	0	0			0	if (($k =~ /\.\Q$c->{lhs_col}\E$/) \|\| ($k eq $c->{lhs_col})) {
2028	0					0	$lv = $row->{$k};
2029	0					0	last;
2030							}
2031							}
2032							}
2033	97	100				185	$lv = '' unless defined $lv;
2034
2035							# Resolve right-hand value (literal or column)
2036	97					174	my $rv;
2037	97	50				159	if (defined $c->{rhs_col}) {
2038	0	0				0	if (defined $c->{rhs_alias}) {
2039	0					0	$rv = $row->{"$c->{rhs_alias}.$c->{rhs_col}"};
2040							}
2041							else {
2042	0					0	for my $k (keys %$row) {
2043	0	0	0			0	if (($k =~ /\.\Q$c->{rhs_col}\E$/) \|\| ($k eq $c->{rhs_col})) {
2044	0					0	$rv = $row->{$k};
2045	0					0	last;
2046							}
2047							}
2048							}
2049							}
2050							else {
2051	97					178	$rv = $c->{val};
2052							}
2053	97	100				202	$rv = '' unless defined $rv;
2054
2055	97					210	my $op = $c->{op};
2056
2057							# IN / NOT IN
2058	97	100	66			332	if (($op eq 'IN') \|\| ($op eq 'NOT_IN')) {
2059	8					7	my $lhs_val = $lv;
2060	8					6	my $found = 0;
2061	8					7	for my $cv (@{$c->{vals}}) {
	8					9
2062	8	50				9	next unless defined $cv;
2063	8		33			27	my $num2 = (($lhs_val =~ /^-?\d+\.?\d$/) && ($cv =~ /^-?\d+\.?\d$/));
2064	8	50				13	if ($num2 ? ($lhs_val == $cv) : ($lhs_val eq $cv)) {
		100
2065	4					4	$found = 1;
2066	4					6	last;
2067							}
2068							}
2069	8	50	66			14	return 0 if $found && ($op eq 'NOT_IN');
2070	8	100	66			18	return 0 if !$found && ($op eq 'IN');
2071	4					4	next;
2072							}
2073
2074	89		66			526	my $num = (($lv =~ /^-?\d+\.?\d$/) && ($rv =~ /^-?\d+\.?\d$/));
2075
2076	89	100	33			241	if ($op eq '=') {
		50
		50
		100
		50
		50
		0
2077	77	100				616	return 0 unless $num ? ($lv == $rv) : ($lv eq $rv);
		100
2078							}
2079							elsif (($op eq '!=') \|\| ($op eq '<>')) {
2080	0	0				0	return 0 unless $num ? ($lv != $rv) : ($lv ne $rv);
		0
2081							}
2082							elsif ($op eq '<') {
2083	0	0				0	return 0 unless $num ? ($lv < $rv) : ($lv lt $rv);
		0
2084							}
2085							elsif ($op eq '>') {
2086	9	50				87	return 0 unless $num ? ($lv > $rv) : ($lv gt $rv);
		100
2087							}
2088							elsif ($op eq '<=') {
2089	0	0				0	return 0 unless $num ? ($lv <= $rv) : ($lv le $rv);
		0
2090							}
2091							elsif ($op eq '>=') {
2092	3	50				15	return 0 unless $num ? ($lv >= $rv) : ($lv ge $rv);
		100
2093							}
2094							elsif ($op eq 'LIKE') {
2095	0					0	(my $p = $rv) =~ s/%/.*/g;
2096	0					0	$p =~ s/_/./g;
2097	0	0				0	return 0 unless $lv =~ /^$p$/i;
2098							}
2099							}
2100	24					138	return 1;
2101	15					116	};
2102							}
2103
2104							###############################################################################
2105							# JOIN SQL parser
2106							# Handles:
2107							# SELECT col_list
2108							# FROM t1 [AS a1]
2109							# [INNER\|LEFT [OUTER]\|RIGHT [OUTER]\|CROSS] JOIN t2 [AS a2] ON a1.c = a2.c
2110							# [ JOIN t3 [AS a3] ON ... ]
2111							# [WHERE ...]
2112							# [ORDER BY alias.col [ASC\|DESC]]
2113							# [LIMIT n] [OFFSET m]
2114							###############################################################################
2115							sub _parse_join_sql {
2116	27			27		64	my($sql) = @_;
2117							# sql has been normalised: single spaces, trimmed
2118
2119							# ---------------------------------------------------------------
2120							# 1. Extract SELECT column list and the FROM...rest portion
2121							# ---------------------------------------------------------------
2122	27	50				381	return undef unless $sql =~ /^SELECT\s+(.+?)\s+FROM\s+(.+)$/si;
2123	27					163	my($sel_str, $from_rest) = ($1, $2);
2124
2125							# ---------------------------------------------------------------
2126							# 2. Strip trailing ORDER BY / LIMIT / OFFSET
2127							# (strip right-to-left to avoid greedy issues)
2128							# ---------------------------------------------------------------
2129	27					43	my %opts;
2130
2131							# Strip suffixes right-to-left: OFFSET, LIMIT, ORDER BY
2132							# (ORDER BY may precede LIMIT/OFFSET, so strip LIMIT+OFFSET first)
2133	27	100				263	if ($from_rest =~ s/\s+OFFSET\s+(\d+)\s*$//i) {
2134	1					6	$opts{offset} = $1;
2135							}
2136	27	100				241	if ($from_rest =~ s/\s+LIMIT\s+(\d+)\s*$//i) {
2137	2					9	$opts{limit} = $1;
2138							}
2139	27	100				239	if ($from_rest =~ s/\s+ORDER\s+BY\s+([\w.]+)(?:\s+(ASC\|DESC))?\s*$//i) {
2140	6					25	$opts{order_by} = $1;
2141	6		100			40	$opts{order_dir} = ($2 \|\| 'ASC');
2142							}
2143
2144							# ---------------------------------------------------------------
2145							# 3. Extract WHERE clause (everything after WHERE keyword,
2146							# which must come after all JOIN...ON clauses)
2147							# ---------------------------------------------------------------
2148	27					51	my $where_str = '';
2149
2150							# WHERE must appear after the last ON clause; we find the last WHERE
2151	27	100				242	if ($from_rest =~ s/\s+WHERE\s+(.+)$//i) {
2152	15					45	$where_str = $1;
2153	15					104	$where_str =~ s/^\s+\|\s+$//g;
2154							}
2155
2156							# ---------------------------------------------------------------
2157							# 4. Parse the FROM clause using iterative regex matching
2158							# Grammar: table [AS alias] { join_type JOIN table [AS alias] ON col=col }*
2159							# ---------------------------------------------------------------
2160	27					50	my @join_specs;
2161
2162							# Parse the driving (first) table
2163	27					56	my $fr = $from_rest;
2164	27					63	$fr =~ s/^\s+//;
2165	27	50				177	unless ($fr =~ s/^(\w+)(?:\s+(?:AS\s+)?(\w+))?//) {
2166	0					0	return undef;
2167							}
2168	27	50				141	my($first_tbl, $first_alias) = ($1, defined($2) ? $2 : $1);
2169	27					167	push @join_specs, { table => $first_tbl, alias => $first_alias, type => 'FIRST' };
2170
2171							# Iteratively match JOIN clauses
2172	27					684	while ($fr =~ s/^\s+(?:(INNER\|LEFT(?:\s+OUTER)?\|RIGHT(?:\s+OUTER)?\|CROSS)\s+)?JOIN\s+(\w+)(?:\s+(?:AS\s+)?(\w+))?(?:\s+ON\s+([\w.]+)\s=\s([\w.]+))?//i) {
2173	29					183	my($type_kw, $tbl, $alias, $on_left, $on_right) = ($1, $2, $3, $4, $5);
2174	29					55	my $type = 'INNER';
2175	29	100	66			353	if (defined($type_kw) && ($type_kw =~ /LEFT/i)) {
		100	66
		100	66
2176	5					12	$type = 'LEFT';
2177							}
2178							elsif (defined($type_kw) && ($type_kw =~ /RIGHT/i)) {
2179	1					4	$type = 'RIGHT';
2180							}
2181							elsif (defined($type_kw) && ($type_kw =~ /CROSS/i)) {
2182	1					4	$type = 'CROSS';
2183							}
2184	29	50				133	$alias = $tbl unless defined $alias;
2185	29					255	push @join_specs, {
2186							table => $tbl,
2187							alias => $alias,
2188							type => $type,
2189							on_left => $on_left,
2190							on_right => $on_right,
2191							};
2192							}
2193
2194							# Must have at least 2 tables to be a JOIN
2195	27	50				92	return undef if @join_specs < 2;
2196
2197							# ---------------------------------------------------------------
2198							# 5. Parse SELECT column list
2199							# ---------------------------------------------------------------
2200	27					41	my @col_specs;
2201	27	100				99	if ($sel_str =~ /^\s\\s*$/) {
2202	1					3	@col_specs = (); # empty = all columns (expanded later)
2203							}
2204							else {
2205	26					193	for my $cs (split /\s,\s/, $sel_str) {
2206	55					232	$cs =~ s/^\s+\|\s+$//g;
2207	55					134	push @col_specs, $cs;
2208							}
2209							}
2210
2211							# ---------------------------------------------------------------
2212							# 6. Parse WHERE conditions
2213							# ---------------------------------------------------------------
2214	27					55	my @where_conds;
2215	27	100				126	@where_conds = _parse_join_conditions($where_str) if $where_str =~ /\S/;
2216
2217	27					224	return [ [ @join_specs ], [ @col_specs ], [ @where_conds ], { %opts } ];
2218							}
2219
2220							# Parse WHERE expression containing possibly qualified column names
2221							# Returns arrayref of condition hashrefs
2222							sub _parse_join_conditions {
2223	15			15		37	my($expr) = @_;
2224	15	50	33			80	return () unless defined($expr) && ($expr =~ /\S/);
2225	15					27	my @conds;
2226	15					70	for my $part (split /\s+AND\s+/i, $expr) {
2227	17					104	$part =~ s/^\s+\|\s+$//g;
2228
2229							# col-vs-col: alias1.col1 OP alias2.col2
2230	17	100	66			221	if (($part =~ /^((?:\w+\.)?\w+)\s(=\|!=\|<>\|<=\|>=\|<\|>)\s((?:\w+\.)?\w+)$/i) && ($part !~ /'/)) {
		100
		50
2231	10					58	my($lhs, $op, $rhs) = ($1, uc($2), $3);
2232
2233							# Heuristic: if rhs looks like a number, treat as literal
2234	10	50				57	if ($rhs =~ /^-?\d+\.?\d*$/) {
2235	10					33	my($la, $lc) = _split_qualified($lhs);
2236	10					75	push @conds, { lhs_alias=>$la, lhs_col=>$lc, op=>$op, val=>$rhs };
2237							}
2238							else {
2239	0					0	my($la,$lc) = _split_qualified($lhs);
2240	0					0	my($ra,$rc) = _split_qualified($rhs);
2241	0					0	push @conds, { lhs_alias=>$la, lhs_col=>$lc, op=>$op, rhs_alias=>$ra, rhs_col=>$rc };
2242							}
2243							# col [NOT] IN (val, val, ...)
2244							}
2245							elsif ($part =~ /^((?:\w+\.)?\w+)\s+(NOT\s+)?IN\s$([^)])$\s*$/i) {
2246	1					7	my($lhs, $neg, $list_str) = ($1, $2, $3);
2247	1					9	my($la, $lc) = _split_qualified($lhs);
2248	1					4	my @vals;
2249	1					2	my $ls = $list_str;
2250	1					8	while ($ls =~ s/^\s(?:'([^'])'\|(-?\d+\.?\d)\|(NULL))\s(?:,\|$)//i) {
2251	1					6	my($sv, $nv, $nl) = ($1, $2, $3);
2252	1	50				6	push @vals, defined($nl) ? undef : (defined($sv) ? $sv : $nv);
		50
2253							}
2254	1	50				11	push @conds, {
2255							lhs_alias => $la,
2256							lhs_col => $lc,
2257							op => ($neg ? 'NOT_IN' : 'IN'),
2258							vals => [ @vals ],
2259							};
2260							# col-vs-literal
2261							}
2262							elsif ($part =~ /^((?:\w+\.)?\w+)\s(=\|!=\|<>\|<=\|>=\|<\|>\|LIKE)\s(?:'([^'])'\|(-?\d+\.?\d))$/i) {
2263	6					38	my($lhs, $op, $sv, $nv) = ($1, uc($2), $3, $4);
2264	6					19	my($la, $lc) = _split_qualified($lhs);
2265	6	50				49	push @conds, { lhs_alias=>$la, lhs_col=>$lc, op=>$op, val=>defined($sv) ? $sv : $nv };
2266							}
2267							}
2268	15					73	return @conds;
2269							}
2270
2271							###############################################################################
2272							# General helpers
2273							###############################################################################
2274							sub _err {
2275	24			24		63	my($self, $msg) = @_;
2276	24					71	$errstr = $msg;
2277	24					277	return undef;
2278							}
2279
2280							sub _db_path {
2281	54			54		124	my($self, $db) = @_;
2282	54					767	File::Spec->catdir($self->{base_dir},$db);
2283							}
2284
2285							sub _file {
2286	1296			1296		2665	my($self, $table, $ext) = @_;
2287	1296					33669	File::Spec->catfile($self->{base_dir},$self->{db_name},"$table.$ext");
2288							}
2289
2290							sub _load_schema {
2291	1163			1163		2204	my($self, $table) = @_;
2292	1163	100				5462	return $self->{_tables}{$table} if $self->{_tables}{$table};
2293	80					213	my $sch_file = $self->_file($table,'sch');
2294	80	100				1976	unless (-f $sch_file) {
2295	8					22	$errstr = "Table '$table' does not exist";
2296	8					81	return undef;
2297							}
2298	72					250	local *FH;
2299	72	50				2394	open(FH,"< $sch_file") or do { $errstr = "Cannot read schema: $!"; return undef; };
	0					0
	0					0
2300	72					278	my(%sch, @cols, %indexes);
2301	72					252	$sch{notnull} = {};
2302	72					171	$sch{defaults} = {};
2303	72					171	$sch{checks} = {};
2304	72					177	$sch{pk} = undef;
2305	72					2377	while () {
2306	326					564	chomp;
2307	326	100				2066	if (/^RECSIZE=(\d+)/) {
		100
		100
		50
		100
		50
		50
2308	72					425	$sch{recsize} = $1;
2309							}
2310							elsif (/^COL=(\w+):(\w+):(\d+)/) {
2311	180					1680	push @cols, { name=>$1, type=>$2, size=>$3 };
2312							}
2313							elsif (/^NOTNULL=(\w+)/) {
2314	1					5	$sch{notnull}{$1} = 1;
2315							}
2316							elsif (/^DEFAULT=(\w+):(.+)/) {
2317	0					0	$sch{defaults}{$1} = $2;
2318							}
2319							elsif (/^CHECK=(\w+):(.+)/) {
2320	1					15	$sch{checks}{$1} = $2;
2321							}
2322							elsif (/^PK=(\w+)/) {
2323	0					0	$sch{pk} = $1;
2324	0					0	$sch{notnull}{$1} = 1;
2325							}
2326							elsif (/^IDX=(\w+):(\w+):([01])/) {
2327	0					0	my($iname, $icol, $iuniq) = ($1, $2, $3);
2328	0					0	my($cdef) = grep { $_->{name} eq $icol } @cols;
	0					0
2329							$indexes{$iname} = {
2330							name => $iname,
2331							col => $icol,
2332							unique => $iuniq+0,
2333							keysize => ($cdef ? $cdef->{size} : 0),
2334	0	0				0	coltype => ($cdef ? $cdef->{type} : 'VARCHAR'),
		0
2335							};
2336							}
2337							}
2338	72					840	close FH;
2339	72					315	$sch{cols} = [ @cols ];
2340	72					249	$sch{indexes} = { %indexes };
2341	72					288	$self->{_tables}{$table} = \%sch; # don't write { %sch }
2342	72					513	return \%sch; # don't write { %sch }
2343							}
2344
2345							sub _rewrite_schema {
2346	12			12		45	my($self, $table, $sch) = @_;
2347	12					38	my $sch_file = $self->_file($table,'sch');
2348	12					55	local *FH;
2349	12	50				1492	open(FH,"> $sch_file") or return $self->_err("Cannot rewrite schema: $!");
2350	12					132	print FH "VERSION=1\n";
2351	12					52	print FH "RECSIZE=$sch->{recsize}\n";
2352	12					24	for my $c (@{$sch->{cols}}) {
	12					63
2353	37					154	print FH "COL=$c->{name}:$c->{type}:$c->{size}\n";
2354							}
2355	12					22	for my $ix (values %{$sch->{indexes}}) {
	12					50
2356	2					5	print FH "IDX=$ix->{name}:$ix->{col}:$ix->{unique}\n";
2357							}
2358	12	50				26	for my $c (sort keys %{$sch->{notnull} \|\| {}}) {
	12					92
2359	15					39	print FH "NOTNULL=$c\n";
2360							}
2361	12	50				27	for my $c (sort keys %{$sch->{defaults} \|\| {}}) {
	12					74
2362	7					24	print FH "DEFAULT=$c:$sch->{defaults}{$c}\n";
2363							}
2364	12	50				31	for my $c (sort keys %{$sch->{checks} \|\| {}}) {
	12					54
2365	6					36	print FH "CHECK=$c:$sch->{checks}{$c}\n";
2366							}
2367	12	100				75	print FH "PK=$sch->{pk}\n" if $sch->{pk};
2368	12					2244	close FH;
2369	12					120	return 1;
2370							}
2371
2372							sub _pack_record {
2373	705			705		1221	my($self, $sch, $row) = @_;
2374	705					1188	my $data = RECORD_ACTIVE;
2375	705					847	for my $col (@{$sch->{cols}}) {
	705					1208
2376	1246	100				3219	my $v = defined($row->{$col->{name}}) ? $row->{$col->{name}} : '';
2377	1246					1929	my $t = $col->{type};
2378	1246					1846	my $s = $col->{size};
2379	1246	100				2353	if ($t eq 'INT') {
		100
2380	869		100			2226	my $iv = int($v \|\| 0);
2381	869	50				1611	$iv = 2147483647 if $iv > 2147483647;
2382	869	50				1495	$iv = -2147483648 if $iv < -2147483648;
2383	869					3155	$data .= pack('N', $iv&0xFFFFFFFF);
2384							}
2385							elsif ($t eq 'FLOAT') {
2386	79					422	$data .= pack('d', $v+0);
2387							}
2388							else {
2389	298					675	my $sv = substr($v, 0, $s);
2390	298					742	$sv .= "\x00" x ($s-length($sv));
2391	298					772	$data .= $sv;
2392							}
2393							}
2394	705					2240	return $data;
2395							}
2396
2397							sub _unpack_record {
2398	1973			1973		4849	my($self, $sch, $raw) = @_;
2399	1973					2900	my %row;
2400	1973					2791	my $offset = 1;
2401	1973					2654	for my $col (@{$sch->{cols}}) {
	1973					4885
2402	6811					10527	my $t = $col->{type};
2403	6811					9833	my $s = $col->{size};
2404	6811					13523	my $chunk = substr($raw, $offset, $s);
2405	6811	100				12101	if ($t eq 'INT') {
		100
2406	4089					7727	my $uv = unpack('N', $chunk);
2407	4089	100				7591	$uv -= 4294967296 if $uv > 2147483647;
2408	4089					8614	$row{$col->{name}} = $uv;
2409							}
2410							elsif ($t eq 'FLOAT') {
2411	287					628	$row{$col->{name}} = unpack('d', $chunk);
2412							}
2413							else {
2414	2435					10267	(my $sv = $chunk) =~ s/\x00+$//;
2415	2435					5917	$row{$col->{name}} = $sv;
2416							}
2417	6811					10950	$offset += $s;
2418							}
2419	1973					11889	return { %row };
2420							}
2421
2422	1072			1072		7239	sub _lock_ex { flock($_[0], LOCK_EX) }
2423	315			315		2392	sub _lock_sh { flock($_[0], LOCK_SH) }
2424	1387			1387		33193	sub _unlock { flock($_[0], LOCK_UN) }
2425
2426							sub _to_where_sub {
2427	10			10		21	my($wi) = @_;
2428	10	50				47	return undef unless defined $wi;
2429	10	50				38	return $wi if ref($wi) eq 'CODE';
2430	0	0				0	return _compile_where_from_conds($wi) if ref($wi) eq 'ARRAY';
2431	0					0	return undef;
2432							}
2433
2434							sub _split_col_defs {
2435	67			67		181	my($str) = @_;
2436	67					122	my @parts;
2437	67					123	my $cur = '';
2438	67					121	my $depth = 0;
2439	67					751	for my $ch (split //, $str) {
2440	2254	100	66			6203	if ($ch eq '(') {
		100
		100
2441	69					109	$depth++;
2442	69					120	$cur .= $ch;
2443							}
2444							elsif ($ch eq ')') {
2445	69					106	$depth--;
2446	69					128	$cur .= $ch;
2447							}
2448							elsif (($ch eq ',') && ($depth == 0)) {
2449	99					266	push @parts, $cur;
2450	99					282	$cur = '';
2451							}
2452							else {
2453	2017					3193	$cur .= $ch;
2454							}
2455							}
2456	67	50				577	push @parts, $cur if $cur =~ /\S/;
2457	67					277	return @parts;
2458							}
2459
2460							sub _parse_values {
2461	684			684		1122	my($str) = @_;
2462	684					903	my @vals;
2463	684					1497	while (length $str) {
2464	1164					2276	$str =~ s/^\s+//;
2465	1164	50				2201	last unless length $str;
2466	1164	100				6935	if ($str =~ s/^'((?:[^']\|''))'(?:\s,\s\|\s$)//) {
		50
		50
2467	270					511	my $s = $1;
2468	270					494	$s =~ s/''/'/g;
2469	270					703	push @vals, $s;
2470							}
2471							elsif ($str =~ s/^(NULL)(?:\s,\s\|\s*$)//i) {
2472	0					0	push @vals, undef;
2473							}
2474							elsif ($str =~ s/^(-?\d+\.?\d)(?:\s,\s\|\s$)//) {
2475	894					2799	push @vals, $1;
2476							}
2477							else {
2478	0					0	last;
2479							}
2480							}
2481	684					1824	return @vals;
2482							}
2483
2484							sub _parse_conditions {
2485	0			0		0	my($expr) = @_;
2486	0					0	my @conds;
2487
2488							# Use paren-aware AND splitter
2489	0					0	my @parts = _split_and_clauses($expr);
2490	0					0	for my $part (@parts) {
2491	0					0	$part =~ s/^\s+\|\s+$//g;
2492
2493							# col [NOT] IN (val, val, ...) -- expanded from subquery or literal list
2494	0	0				0	if ($part =~ /^(\w+)\s+(NOT\s+)?IN\s$([^)])$\s*$/i) {
2495	0					0	my($col, $neg, $list_str) = ($1, $2, $3);
2496	0					0	my @vals;
2497
2498							# parse list: numbers or quoted strings or NULL
2499	0					0	my $ls = $list_str;
2500	0					0	while ($ls =~ s/^\s(?:'([^'])'\|(-?\d+\.?\d)\|(NULL))\s(?:,\|$)//i) {
2501	0					0	my($sv, $nv, $nl) = ($1, $2, $3);
2502	0	0				0	push @vals, defined($nl) ? undef : (defined($sv) ? $sv : $nv);
		0
2503							}
2504	0	0				0	push @conds, {
2505							col => $col,
2506							op => $neg ? 'NOT_IN' : 'IN',
2507							vals => [ @vals ],
2508							};
2509	0					0	next;
2510							}
2511
2512							# EXISTS (1) or EXISTS (0) -- already evaluated by subquery expander
2513	0	0				0	if ($part =~ /^(NOT\s+)?EXISTS\s*$(\d+)$$/i) {
2514	0					0	my($neg, $val) = ($1, $2);
2515	0	0				0	my $truth = $val ? 1 : 0;
2516	0	0				0	$truth = 1 - $truth if $neg;
2517	0					0	push @conds, { op => 'CONST', val => $truth };
2518	0					0	next;
2519							}
2520
2521							# EXISTS (1) or NOT EXISTS (0) without outer parens (legacy)
2522	0	0				0	if ($part =~ /^(NOT\s+)?EXISTS\s+(\d+)$/i) {
2523	0					0	my($neg, $val) = ($1, $2);
2524	0	0				0	my $truth = $val ? 1 : 0;
2525	0	0				0	$truth = 1 - $truth if $neg;
2526	0					0	push @conds, { op => 'CONST', val => $truth };
2527	0					0	next;
2528							}
2529
2530							# col OP NULL -- SQL NULL semantics: comparison with NULL is always false
2531	0	0				0	if ($part =~ /^(\w+)\s(=\|!=\|<>\|<=\|>=\|<\|>)\sNULL$/i) {
2532	0					0	push @conds, { op => 'CONST', val => 0 };
2533	0					0	next;
2534							}
2535
2536							# IS [NOT] NULL
2537	0	0				0	if ($part =~ /^(\w+)\s+IS\s+(NOT\s+)?NULL$/i) {
2538	0					0	my($col, $neg) = ($1, $2);
2539	0	0				0	push @conds, { col=>$col, op=>$neg ? 'IS_NOT_NULL' : 'IS_NULL' };
2540	0					0	next;
2541							}
2542
2543							# Normal col OP literal
2544	0	0				0	if ($part =~ /^(\w+)\s(=\|!=\|<>\|<=\|>=\|<\|>\|LIKE)\s(?:'([^'])'\|(-?\d+\.?\d))$/i) {
2545	0					0	my($col, $op, $sv, $nv) = ($1, $2, $3, $4);
2546	0	0				0	push @conds, { col=>$col, op=>uc($op), val=>(defined($sv) ? $sv : $nv) };
2547							}
2548							}
2549	0					0	return [ @conds ];
2550							}
2551
2552							sub _compile_where_from_conds {
2553	6			6		17	my($conds) = @_;
2554	6	100	66			26	return undef unless $conds && @$conds;
2555							return sub {
2556	8			8		9	my($row) = @_;
2557	8					8	for my $c (@$conds) {
2558	8					10	my $op = $c->{op};
2559
2560							# Constant (pre-evaluated EXISTS/NOT EXISTS)
2561	8	50	33			25	if ($op eq 'CONST') {
		50
		50
		50
2562	0	0				0	return 0 unless $c->{val};
2563							# IN / NOT IN with value list
2564							}
2565							elsif (($op eq 'IN') \|\| ($op eq 'NOT_IN')) {
2566	0	0				0	my $rv = defined($row->{$c->{col}}) ? $row->{$c->{col}} : '';
2567	0					0	my $found = 0;
2568	0					0	for my $cv (@{$c->{vals}}) {
	0					0
2569	0	0				0	next unless defined $cv;
2570	0		0			0	my $num = (($rv =~ /^-?\d+\.?\d$/) && ($cv =~ /^-?\d+\.?\d$/));
2571	0	0				0	if ($num ? ($rv == $cv) : ($rv eq $cv)) {
		0
2572	0					0	$found = 1;
2573	0					0	last;
2574							}
2575							}
2576	0	0	0			0	return 0 if $found && ($op eq 'NOT_IN');
2577	0	0	0			0	return 0 if !$found && ($op eq 'IN');
2578							# IS NULL / IS NOT NULL
2579							}
2580							elsif ($op eq 'IS_NULL') {
2581	0	0	0			0	return 0 unless !defined($row->{$c->{col}}) \|\| ($row->{$c->{col}} eq '');
2582							}
2583							elsif ($op eq 'IS_NOT_NULL') {
2584	0	0	0			0	return 0 unless defined($row->{$c->{col}}) && ($row->{$c->{col}} ne '');
2585							# Standard comparison
2586							}
2587							else {
2588	8	50				15	my $rv = defined($row->{$c->{col}}) ? $row->{$c->{col}} : '';
2589	8					10	my $cv = $c->{val};
2590	8		33			41	my $num = (($rv =~ /^-?\d+\.?\d$/) && defined($cv) && ($cv =~ /^-?\d+\.?\d$/));
2591	8	100	33			17	if ($op eq '=') {
		50
		50
		50
		0
		0
		0
2592	4	50				9	return 0 unless $num ? ($rv == $cv) : ($rv eq $cv);
		50
2593							}
2594							elsif (($op eq '!=') \|\| ($op eq '<>')) {
2595	0	0				0	return 0 unless $num ? ($rv != $cv) : ($rv ne $cv);
		0
2596							}
2597							elsif ($op eq '<') {
2598	0	0				0	return 0 unless $num ? ($rv < $cv) : ($rv lt $cv);
		0
2599							}
2600							elsif ($op eq '>') {
2601	4	50				51	return 0 unless $num ? ($rv > $cv) : ($rv gt $cv);
		100
2602							}
2603							elsif ($op eq '<=') {
2604	0	0				0	return 0 unless $num ? ($rv <= $cv) : ($rv le $cv);
		0
2605							}
2606							elsif ($op eq '>=') {
2607	0	0				0	return 0 unless $num ? ($rv >= $cv) : ($rv ge $cv);
		0
2608							}
2609							elsif ($op eq 'LIKE') {
2610	0					0	(my $p = $cv) =~ s/%/.*/g;
2611	0					0	$p =~ s/_/./g;
2612	0	0				0	return 0 unless $rv =~ /^$p$/i;
2613							}
2614							}
2615							}
2616	6					13	return 1;
2617	2					20	};
2618							}
2619
2620							###############################################################################
2621							# SQL-92 Engine
2622							###############################################################################
2623
2624							# =============================================================================
2625							# Expression evaluator eval_expr($expr, \%row) -> scalar
2626							# =============================================================================
2627							sub eval_expr {
2628	2792			2792	0	5811	my($expr, $row) = @_;
2629	2792	50				5462	return undef unless defined $expr;
2630	2792					11008	$expr =~ s/^\s+\|\s+$//g;
2631	2792	50				5659	return undef unless length($expr);
2632	2792	50				6236	return undef if $expr =~ /^NULL$/i;
2633	2792	100				9262	return $expr + 0 if $expr =~ /^-?\d+\.?\d*$/;
2634	2704	100				5518	if ($expr =~ /^'((?:[^']\|'')*)'$/) {
2635	18					71	(my $s = $1) =~ s/''/'/g;
2636	18					103	return $s;
2637							}
2638	2686	50	33			5947	if (($expr =~ /^$(.+)$$/s) && ($1 !~ /^\s*SELECT\b/i)) {
2639	0					0	return eval_expr($1, $row);
2640							}
2641	2686	100				5207	if ($expr =~ /^CASE\b(.*)\bEND$/si) {
2642	9					30	return eval_case($1, $row);
2643							}
2644	2677	100				4769	if ($expr =~ /^COALESCE\s*$(.+)$$/si) {
2645	4					13	for my $a (args($1)) {
2646	6					17	my $v = eval_expr($a, $row);
2647	6	100	66			53	return $v if defined($v) && ($v ne '');
2648							}
2649	0					0	return undef;
2650							}
2651	2673	100				5054	if ($expr =~ /^NULLIF\s*$(.+)$$/si) {
2652	2					8	my @a = args($1);
2653	2	50				8	return undef unless @a == 2;
2654	2					7	my($va, $vb) = (eval_expr($a[0], $row), eval_expr($a[1], $row));
2655	2	50	33			11	if (defined($va) && defined($vb)) {
2656	2	50	33			24	return undef if ((($va =~ /^-?\d+\.?\d$/) && ($vb =~ /^-?\d+\.?\d$/)) ? ($va == $vb) : ($va eq $vb));
		100
2657							}
2658	1					6	return $va;
2659							}
2660	2671	100				4987	if ($expr =~ /^CAST\s$\s(.+?)\s+AS\s+(\w+(?:\s\(\s\d+\s$)?)\s\)$/si) {
2661	2					13	my($ie, $t) = ($1, uc($2));
2662	2					30	my $v = eval_expr($ie,$row);
2663	2	50				7	return undef unless defined $v;
2664	2	100				13	return int($v) if $t =~ /^INT/i;
2665	1	50				7	return $v + 0 if $t =~ /^(FLOAT\|REAL\|DOUBLE\|NUMERIC\|DECIMAL)/i;
2666	1					8	return "$v";
2667							}
2668	2669	100				5176	if ($expr =~ /^(UPPER\|LOWER\|LENGTH\|ABS\|SIGN\|TRIM\|LTRIM\|RTRIM)\s*$(.+)$$/si) {
2669	9					46	my($fn, $arg) = (uc($1), $2);
2670	9					25	my $v = eval_expr($arg,$row);
2671	9	50				27	return undef unless defined $v;
2672	9	100				38	return uc($v) if $fn eq 'UPPER';
2673	7	100				36	return lc($v) if $fn eq 'LOWER';
2674	4	100				21	return length($v) if $fn eq 'LENGTH';
2675	2	50				5	return abs($v + 0) if $fn eq 'ABS';
2676	2	0				7	return (($v > 0) ? 1 : ($v < 0) ? -1 : 0) if $fn eq 'SIGN';
		0
		50
2677	2	50				5	if ($fn eq 'TRIM') {
2678	2					12	(my $s = $v) =~ s/^\s+\|\s+$//g;
2679	2					11	return $s;
2680							}
2681	0	0				0	if ($fn eq 'LTRIM') {
2682	0					0	(my $s = $v) =~ s/^\s+//;
2683	0					0	return $s;
2684							}
2685	0	0				0	if ($fn eq 'RTRIM') {
2686	0					0	(my $s = $v) =~ s/\s+$//;
2687	0					0	return $s;
2688							}
2689							}
2690	2660	50				4898	if ($expr =~ /^ROUND\s*$(.+)$$/si) {
2691	0					0	my @a = args($1);
2692	0					0	my $v = eval_expr($a[0], $row);
2693	0	0				0	return undef unless defined $v;
2694	0	0	0			0	my $d = (@a > 1) ? int(eval_expr($a[1],$row) \|\| 0) : 0;
2695	0					0	return sprintf("%.${d}f", $v+0) + 0;
2696							}
2697	2660	50				5102	if ($expr =~ /^(FLOOR\|CEIL(?:ING)?)\s*$(.+)$$/si) {
2698	0					0	my($fn, $arg) = (uc($1), $2);
2699	0					0	my $v = eval_expr($arg,$row);
2700	0	0				0	return undef unless defined $v;
2701	0	0				0	return $fn eq 'FLOOR' ? POSIX::floor($v+0) : POSIX::ceil($v+0);
2702							}
2703	2660	50				4711	if ($expr =~ /^MOD\s*$(.+)$$/si) {
2704	0					0	my @a = args($1);
2705	0	0				0	return undef unless @a == 2;
2706	0					0	my($a, $b) = (eval_expr($a[0], $row)+0, eval_expr($a[1], $row)+0);
2707	0	0				0	return undef if $b == 0;
2708	0					0	return $a % $b;
2709							}
2710	2660	100				4655	if ($expr =~ /^(?:SUBSTR\|SUBSTRING)\s*$(.+)$$/si) {
2711	1					5	my $inner = $1;
2712	1					4	my($se, $ste, $le);
2713	1	50				9	if ($inner =~ /^(.+?)\s+FROM\s+(\S+)(?:\s+FOR\s+(.+))?$/si) {
2714	0					0	($se, $ste, $le) = ($1, $2, $3);
2715							}
2716							else {
2717	1					4	($se, $ste, $le) = args($inner);
2718							}
2719	1					4	my $s = eval_expr($se, $row);
2720	1	50				4	return undef unless defined $s;
2721	1		50			5	my $st = int(eval_expr($ste, $row) \|\| 1);
2722	1	50				5	$st = 1 if $st < 1;
2723	1	50	50			6	return defined($le)
2724							? substr($s, $st-1, int(eval_expr($le, $row) \|\| 0))
2725							: substr($s, $st-1);
2726							}
2727	2659	50				4673	if ($expr =~ /^CONCAT\s*$(.+)$$/si) {
2728	0					0	my @args = args($1);
2729	0					0	my $r = '';
2730	0					0	for (@args) {
2731	0					0	my $v = eval_expr($_, $row);
2732	0	0				0	$r .= defined($v) ? $v : '';
2733							}
2734	0					0	return $r;
2735							}
2736
2737							# Binary operator: find rightmost at depth 0 (precedence low->high: \|\| then +/- then */%)
2738	2659					4664	for my $op ('\\\|\\\|', '[+\\-]', '[*/%]') {
2739	7955					13259	my $p = find_binop($expr,$op);
2740	7955	100				16546	if (defined $p) {
2741	28					68	my $opsym = substr($expr, $p->{s}, $p->{l});
2742	28					159	my $lv = eval_expr(substr($expr, 0, $p->{s}), $row);
2743	28					105	my $rv = eval_expr(substr($expr, $p->{s}+$p->{l}), $row);
2744	28	100				74	if ($opsym eq '\|\|') {
2745	6	50				38	return (defined($lv) ? $lv : '').(defined($rv) ? $rv : '');
		50
2746							}
2747	22	50	33			92	return undef unless defined($lv) && defined($rv);
2748	22					49	my($l, $r) = ($lv + 0, $rv + 0);
2749	22	100				103	return $l + $r if $opsym eq '+';
2750	12	50				21	return $l - $r if $opsym eq '-';
2751	12	100				44	return $l * $r if $opsym eq '*';
2752	6	50	33			33	return undef if (($opsym eq '/') \|\| ($opsym eq '%')) && ($r == 0);
			33
2753	6	50				9	return $l / $r if $opsym eq '/';
2754	6	50				17	return $l % $r if $opsym eq '%';
2755							}
2756							}
2757	2631	50				5896	if ($expr =~ /^-([\w('.].*)$/s) {
2758	0					0	my $v = eval_expr($1, $row);
2759	0	0				0	return undef unless defined $v;
2760	0					0	return - ($v + 0);
2761							}
2762	2631	100				5525	if ($expr =~ /^(\w+)\.(\w+)$/) {
2763	39					189	my($a, $c) = ($1, $2);
2764	39	100				276	return exists($row->{"$a.$c"}) ? $row->{"$a.$c"} : $row->{$c};
2765							}
2766	2592	50				14204	return $row->{$expr} if $expr =~ /^\w+$/;
2767	0					0	return undef;
2768							}
2769
2770							sub eval_case {
2771	9			9	0	37	my($body, $row) = @_;
2772	9					170	$body =~ s/^\s+\|\s+$//g;
2773	9					22	my $base;
2774	9	50				42	unless ($body =~ /^\s*WHEN\b/i) {
2775	0	0				0	$body =~ s/^(.+?)\s+(?=WHEN\b)//si and $base = $1;
2776							}
2777	9					16	my $else;
2778	9	50				179	$body =~ s/\s\bELSE\b\s+(.+?)\s$//si and $else = $1;
2779	9					126	while ($body =~ s/^\sWHEN\s+(.+?)\s+THEN\s+(.+?)(?=\s+WHEN\b\|\s$)//si) {
2780	15					57	my($we, $te) = ($1, $2);
2781	15					27	my $m;
2782	15	50				35	if (defined $base) {
2783	0					0	my($bv, $wv) = (eval_expr($base, $row),eval_expr($we, $row));
2784	0		0			0	$m = defined($bv) && defined($wv) && ((($bv =~ /^-?\d+\.?\d$/) && ($wv =~ /^-?\d+\.?\d$/)) ? ($bv == $wv) : ($bv eq $wv));
2785							}
2786							else {
2787	15					39	$m = eval_bool($we, $row);
2788							}
2789	15	100				116	return eval_expr($te, $row) if $m;
2790							}
2791	3	50				15	return defined($else) ? eval_expr($else, $row) : undef;
2792							}
2793
2794							sub eval_bool {
2795	34			34	0	80	my($expr, $row) = @_;
2796	34					335	$expr =~ s/^\s+\|\s+$//g;
2797	34	50				225	if ($expr =~ /^(.+?)\s(=\|!=\|<>\|<=\|>=\|<\|>)\s(.+)$/s) {
2798	34					183	my($l, $op, $r) = ($1, uc($2), $3);
2799	34					99	my($lv, $rv) = (eval_expr($l, $row), eval_expr($r, $row));
2800	34	50	33			161	return 0 unless defined($lv) && defined($rv);
2801	34		33			322	my $n = (($lv =~ /^-?\d+\.?\d$/) && ($rv =~ /^-?\d+\.?\d$/));
2802	34	50				113	return $n ? ($lv == $rv) : ($lv eq $rv) if $op eq '=';
		100
2803	29	0				117	return $n ? ($lv != $rv) : ($lv ne $rv) if $op =~ /^(!\|<>)/;
		50
2804	29	50				90	return $n ? ($lv < $rv) : ($lv lt $rv) if $op eq '<';
		100
2805	19	0				44	return $n ? ($lv > $rv) : ($lv gt $rv) if $op eq '>';
		50
2806	19	50				65	return $n ? ($lv <= $rv) : ($lv le $rv) if $op eq '<=';
		100
2807	15	50				138	return $n ? ($lv >= $rv) : ($lv ge $rv) if $op eq '>=';
		50
2808							}
2809	0	0				0	if ($expr =~ /^(.+)\s+IS\s+(NOT\s+)?NULL$/si) {
2810	0					0	my $v = eval_expr($1,$row);
2811	0	0	0			0	return $2 ? (defined($v) && ($v ne '')) : (!defined($v) \|\| ($v eq ''));
			0
2812							}
2813	0					0	return 0;
2814							}
2815
2816							# Argument splitter (handles parentheses and string literals)
2817							sub args {
2818	251			251	0	482	my($str) = @_;
2819	251					464	my @parts;
2820	251					474	my $cur = '';
2821	251					386	my $d = 0;
2822	251					403	my $in_q = 0;
2823	251					1286	for my $ch (split //, $str) {
2824	2404	100	100			11257	if (($ch eq "'") && !$in_q) {
		100	66
		100	100
		100
		100
		100
2825	17					33	$in_q = 1;
2826	17					32	$cur .= $ch;
2827							}
2828							elsif (($ch eq "'") && $in_q) {
2829	17					86	$in_q = 0;
2830	17					37	$cur .= $ch;
2831							}
2832							elsif ($in_q) {
2833	71					125	$cur .= $ch;
2834							}
2835							elsif ($ch eq '(') {
2836	45					71	$d++;
2837	45					80	$cur .= $ch;
2838							}
2839							elsif ($ch eq ')') {
2840	45					87	$d--;
2841	45					72	$cur .= $ch;
2842							}
2843							elsif (($ch eq ',') && ($d == 0)) {
2844	87					192	push @parts, $cur;
2845	87					199	$cur = '';
2846							}
2847							else {
2848	2122					3407	$cur .= $ch;
2849							}
2850							}
2851	251	50				1421	push @parts, $cur if $cur =~ /\S/;
2852	251					787	return @parts;
2853							}
2854
2855							# Find rightmost binary operator at depth 0
2856							sub find_binop {
2857	7955			7955	0	14568	my($expr, $op_pat) = @_;
2858	7955					10356	my $d = 0;
2859	7955					9984	my $in_q = 0;
2860	7955					10433	my $best = undef;
2861	7955					16137	for my $i (0 .. length($expr)-1) {
2862	28445					43027	my $ch = substr($expr, $i, 1);
2863	28445	100	100			211712	if (($ch eq "'") && !$in_q) {
		100	66
		50	66
		50	66
		100	66
			100
2864	2					5	$in_q = 1;
2865							}
2866							elsif (($ch eq "'") && $in_q) {
2867	2					4	$in_q = 0;
2868							}
2869							elsif (!$in_q && ($ch eq '(')) {
2870	0					0	$d++;
2871							}
2872							elsif (!$in_q && ($ch eq ')')) {
2873	0					0	$d--;
2874							}
2875							elsif (!$in_q && ($d == 0) && ($i > 0)) {
2876	20484	100				193377	if (substr($expr, $i) =~ /^($op_pat)/) {
2877	29					171	$best = { s=>$i, l=>length($1) };
2878							}
2879							}
2880							}
2881	7955					15885	return $best;
2882							}
2883
2884							# =============================================================================
2885							# WHERE engine where_sub($expr) -> coderef
2886							# =============================================================================
2887							sub where_sub {
2888	234			234	0	458	my($expr) = @_;
2889	234	50	33	0		1394	return sub{1} unless defined($expr) && ($expr =~ /\S/);
	0					0
2890	234					544	return compile_tree(parse_bool($expr));
2891							}
2892
2893							sub parse_bool {
2894	295			295	0	531	my($expr) = @_;
2895	295					1547	$expr =~ s/^\s+\|\s+$//g;
2896	295					744	my @or = bool_split($expr,'OR');
2897	295	100				622	return { op=>'OR', kids=>[map{parse_bool($_)}@or] } if @or > 1;
	6					21
2898	292					605	my @and = bool_split($expr,'AND');
2899	292	100				670	return { op=>'AND', kids=>[map{parse_bool($_)}@and] } if @and > 1;
	52					139
2900	266	100				797	return { op=>'NOT', kids=>[parse_bool($1)] } if $expr =~ /^NOT\s+(.+)$/si;
2901	264	100	66			847	if (($expr =~ /^$(.+)$$/s) && ($1 !~ /^\s*SELECT\b/i)) {
2902	1					16	return parse_bool($1);
2903							}
2904	263					692	return { op=>'LEAF', cond=>parse_leaf($expr) };
2905							}
2906
2907							sub bool_split {
2908	587			587	0	1095	my($expr, $kw) = @_;
2909	587					864	my $kl = length($kw);
2910	587					733	my @parts;
2911	587					829	my $cur = '';
2912	587					762	my $d = 0;
2913	587					727	my $in_q = 0;
2914	587					727	my $i = 0;
2915	587					779	my $len = length($expr);
2916	587					1265	while ($i < $len) {
2917	6674					9224	my $ch = substr($expr, $i, 1);
2918	6674	100	100			39102	if (($ch eq "'") && !$in_q) {
		100	66
		100	66
		100	100
		100	100
		100	100
			66
			100
2919	80					99	$in_q = 1;
2920	80					110	$cur .= $ch;
2921							}
2922							elsif (($ch eq "'") && $in_q) {
2923	80					104	$in_q = 0;
2924	80					106	$cur .= $ch;
2925							}
2926							elsif ($in_q) {
2927	319					411	$cur .= $ch;
2928							}
2929							elsif ($ch eq '(') {
2930	34					37	$d++;
2931	34					53	$cur .= $ch;
2932							}
2933							elsif ($ch eq ')') {
2934	34					39	$d--;
2935	34					43	$cur .= $ch;
2936							}
2937							elsif (($d == 0)
2938							&& !$in_q
2939							&& (uc(substr($expr, $i, $kl)) eq $kw)
2940							&& (($i == 0) \|\| (substr($expr, $i-1, 1) =~ /\s/))
2941							&& (($i+$kl) < $len)
2942							&& (substr($expr, $i+$kl, 1) =~ /\s/)
2943							) {
2944
2945							# For AND: do not split the AND inside BETWEEN x AND y
2946	35	100				88	if ($kw eq 'AND') {
2947	32					58	my $before = $cur;
2948	32					200	$before =~ s/^\s+\|\s+$//g;
2949	32	100				138	if ($before =~ /\bBETWEEN\s+\S+\s*$/i) {
2950	6					11	$cur .= $ch;
2951	6					9	$i++;
2952	6					16	next;
2953							}
2954							}
2955	29					77	push @parts, $cur;
2956	29					58	$cur = '';
2957	29					39	$i += $kl;
2958	29					74	next;
2959							}
2960							else {
2961	6092					7747	$cur .= $ch;
2962							}
2963	6639					11154	$i++;
2964							}
2965	587					1259	push @parts, $cur;
2966	587					1066	@parts = grep {/\S/} @parts;
	616					2620
2967	587	100				1817	return @parts > 1 ? @parts : ($expr);
2968							}
2969
2970							sub parse_leaf {
2971	263			263	0	487	my($part) = @_;
2972	263					1304	$part =~ s/^\s+\|\s+$//g;
2973	263	100				740	if ($part =~ /^(NOT\s+)?EXISTS\s*$(\d+)$$/i) {
2974	3					9	my($neg, $v) = ($1, $2);
2975	3	100				8	my $t = $v ? 1 : 0;
2976	3	50				7	$t = 1 - $t if $neg;
2977	3					20	return { op=>'CONST', val=>$t };
2978							}
2979	260	100				639	if ($part =~ /^([\w.]+)\s+(NOT\s+)?IN\s$([^)])$$/si) {
2980	11					52	my($col, $neg, $ls) = ($1, $2, $3);
2981	11					21	my @vals;
2982	11					58	while ($ls =~ s/^\s(?:'((?:[^']\|''))'\|(-?\d+\.?\d)\|(NULL))\s(?:,\|$)//i) {
2983	18					72	my($sv, $nv, $nl) = ($1, $2, $3);
2984	18	100				41	if (defined $nl) {
		50
2985	2					5	push @vals, undef;
2986							}
2987							elsif (defined $sv) {
2988	0					0	(my $x = $sv) =~ s/''/'/g;
2989	0					0	push @vals, $x;
2990							}
2991							else {
2992	16					57	push @vals, $nv;
2993							}
2994							}
2995	11	100				153	return { op=>($neg ? 'NOT_IN' : 'IN'), col=>$col, vals=>[ @vals ] };
2996							}
2997	249	100				12565	return { op=>'CONST', val=>0 } if $part =~ /^[\w.]+\s(?:=\|!=\|<>\|<=\|>=\|<\|>)\sNULL$/si;
2998	248	100				909	if ($part =~ /^([\w.]+)\s+IS\s+(NOT\s+)?NULL$/si) {
2999	3	100				33	return { op=>($2 ? 'IS_NOT_NULL' : 'IS_NULL'), col=>$1 };
3000							}
3001	245	100				671	if ($part =~ /^([\w.]+)\s+(NOT\s+)?BETWEEN\s+(.+?)\s+AND\s+(.+)$/si) {
3002	6					51	my($col, $neg, $lo, $hi) = ($1, $2, $3, $4);
3003	6					12	$lo =~ s/^'(.*)'$/$1/s;
3004	6					11	$hi =~ s/^'(.*)'$/$1/s;
3005	6	100				56	return { op=>($neg ? 'NOT_BETWEEN' : 'BETWEEN'), col=>$col, lo=>$lo, hi=>$hi };
3006							}
3007	239	100				1147	if ($part =~ /^(.+?)\s+(NOT\s+)?LIKE\s+('(?:[^']\|'')*'\|\S+)$/si) {
3008	5					29	my($lhs, $neg, $pat) = ($1, $2, $3);
3009	5					30	$pat =~ s/^'(.*)'$/$1/s;
3010	5					24	(my $re = $pat) =~ s/%/.*/g;
3011	5					13	$re =~ s/_/./g;
3012	5	100				76	return { op=>($neg ? 'NOT_LIKE' : 'LIKE'), lhs=>$lhs, re=>$re };
3013							}
3014	234	50				1318	if ($part =~ /^(.+?)\s(=\|!=\|<>\|<=\|>=\|<\|>)\s(.+)$/s) {
3015	234					1145	my($lhs, $op, $rhs) = ($1, uc($2), $3);
3016	234					709	$lhs =~ s/^\s+\|\s+$//g;
3017	234					610	$rhs =~ s/^\s+\|\s+$//g;
3018	234					344	my $rv;
3019	234	100				664	if ($rhs =~ /^'((?:[^']\|'')*)'$/) {
3020	27					88	($rv = $1) =~ s/''/'/g;
3021							}
3022							else {
3023	207					395	$rv = $rhs;
3024							}
3025	234					2387	return{ op=>$op, lhs=>$lhs, rhs_expr=>$rhs, rhs_val=>$rv };
3026							}
3027	0					0	return{ op=>'CONST', val=>0 };
3028							}
3029
3030							sub compile_tree {
3031	294			294	0	618	my($tree) = @_;
3032	294					587	my $op = $tree->{op};
3033	294	100				713	if ($op eq 'AND') {
3034	26					40	my @s = map {compile_tree($_)} @{$tree->{kids}};
	52					112
	26					65
3035	26	100		356		135	return sub { for my $s(@s) { return 0 unless $s->($_[0]) } 1 };
	356					634
	472					1083
	105					445
3036							}
3037	268	100				545	if ($op eq 'OR') {
3038	3					7	my @s = map { compile_tree($_) } @{$tree->{kids}};
	6					15
	3					8
3039	3	100		18		16	return sub { for my $s(@s) { return 1 if $s->($_[0]) } 0 };
	18					84
	30					60
	6					32
3040							}
3041	265	100				612	if ($op eq 'NOT') {
3042	2					8	my $s = compile_tree($tree->{kids}[0]);
3043	2	100		12		10	return sub{ $s->($_[0]) ? 0 : 1 };
	12					26
3044							}
3045	263					602	return compile_leaf($tree->{cond});
3046							}
3047
3048							sub compile_leaf {
3049	263			263	0	461	my($c) = @_;
3050	263	50				733	my $op = defined($c->{op}) ? $c->{op} : '';
3051	263	100		32		550	return sub { $c->{val} ? 1 : 0 } if $op eq 'CONST';
	32	100				104
3052	259	100				534	if ($op eq 'IS_NULL') {
3053	1					2	my $col = $c->{col};
3054	1	50		3		8	return sub { my $v = $_[0]{$col}; !defined($v) \|\| ($v eq '') };
	3					7
	3					38
3055							}
3056	258	100				502	if ($op eq 'IS_NOT_NULL') {
3057	2					6	my $col = $c->{col};
3058	2	50		6		13	return sub { my $v = $_[0]{$col}; defined($v) && ($v ne '') };
	6					12
	6					34
3059							}
3060	256	100	100			993	if (($op eq 'BETWEEN') \|\| ($op eq 'NOT_BETWEEN')) {
3061	6					23	my($col, $lo, $hi, $neg) = ($c->{col}, $c->{lo}, $c->{hi}, $op eq 'NOT_BETWEEN');
3062							return sub {
3063	30			30		42	my $v = $_[0]{$col};
3064	30	50				49	return 0 unless defined $v;
3065	30		33			211	my $n = (($v =~ /^-?\d+\.?\d$/) && ($lo =~ /^-?\d+\.?\d$/) && ($hi =~ /^-?\d+\.?\d*$/));
3066	30	50	100			82	my $in_q = $n ? (($v>=$lo) && ($v<=$hi)) : (($v ge $lo) && ($v le $hi));
			0
3067	30	100				100	$neg ? !$in_q : $in_q;
3068	6					45	};
3069							}
3070	250	100	100			907	if (($op eq 'IN') \|\| ($op eq 'NOT_IN')) {
3071	11					41	my($col, $vals, $neg) = ($c->{col}, $c->{vals}, $op eq 'NOT_IN');
3072							return sub {
3073	77	50		77		223	my $rv = defined($_[0]{$col}) ? $_[0]{$col} : '';
3074	77					131	my $f = 0;
3075	77					175	for my $cv (@$vals) {
3076	109	100				198	next unless defined $cv;
3077	93		33			479	my $n = (($rv =~ /^-?\d+\.?\d$/) && ($cv =~ /^-?\d+\.?\d$/));
3078	93	50				221	if ($n ? ($rv == $cv) : ($rv eq $cv)) {
		100
3079	32					43	$f = 1;
3080	32					51	last;
3081							}
3082							}
3083	77	100				320	$neg ? !$f : $f;
3084	11					111	};
3085							}
3086	239	100	100			823	if (($op eq 'LIKE') \|\| ($op eq 'NOT_LIKE')) {
3087	5					22	my($lhs, $re, $neg) = ($c->{lhs}, $c->{re}, $op eq 'NOT_LIKE');
3088							return sub {
3089	24			24		64	my $v = eval_expr($lhs,$_[0]);
3090	24	50				100	$v = '' unless defined $v;
3091	24	100				167	my $m = ($v =~ /^$re$/si) ? 1 : 0;
3092	24	100				145	$neg ? !$m : $m;
3093	5					41	};
3094							}
3095	234					469	my($lhs, $op2, $rv_lit, $rhs_expr) = @{$c}{qw(lhs op rhs_val rhs_expr)};
	234					968
3096							return sub {
3097	1221			1221		1751	my $row = $_[0];
3098	1221					2562	my $lv = eval_expr($lhs, $row);
3099	1221	50				2629	return 0 unless defined $lv;
3100	1221	50	66			7123	my $rv = (($rhs_expr =~ /^[\w.]+$/) && ($rhs_expr !~ /^-?\d+\.?\d*$/)) ? eval_expr($rhs_expr, $row) : $rv_lit;
3101	1221	50				2404	$rv = '' unless defined $rv;
3102	1221		66			6395	my $n = (($lv =~ /^-?\d+\.?\d$/) && ($rv =~ /^-?\d+\.?\d$/));
3103	1221	100				5706	return $n ? ($lv == $rv) : ($lv eq $rv) if $op2 eq '=';
		100
3104	578	100				1643	return $n ? ($lv != $rv) : ($lv ne $rv) if $op2 =~ /^(!\|<>)/;
		100
3105	568	50				1365	return $n ? ($lv < $rv) : ($lv lt $rv) if $op2 eq '<';
		100
3106	519	50				2880	return $n ? ($lv > $rv) : ($lv gt $rv) if $op2 eq '>';
		100
3107	195	50				722	return $n ? ($lv <= $rv) : ($lv le $rv) if $op2 eq '<=';
		100
3108	102	50				648	return $n ? ($lv >= $rv) : ($lv ge $rv) if $op2 eq '>=';
		50
3109	0					0	return 0;
3110	234					2130	};
3111							}
3112
3113							# =============================================================================
3114							# SELECT dispatcher
3115							# =============================================================================
3116							sub select {
3117	291			291	0	630	my($self, $sql) = @_;
3118	291					836	my @up = split_union($sql);
3119	291	100				770	return $self->exec_union([ @up ]) if @up > 1;
3120	289	100				1815	if ($sql =~ /\bJOIN\b/i) {
3121
3122							# Parse GROUP BY / HAVING from the SQL before handing off to _parse_join_sql
3123	27					65	my $join_sql = $sql;
3124	27					105	my(@gb_join, $having_join);
3125	27					53	$having_join = '';
3126	27	50				253	if ($join_sql =~ s/\bHAVING\s+(.+?)(?=\s*(?:ORDER\s+BY\|LIMIT\|OFFSET\|$))//si) {
3127	0					0	$having_join = $1;
3128	0					0	$having_join =~ s/^\s+\|\s+$//g;
3129							}
3130	27	100				234	if ($join_sql =~ s/\bGROUP\s+BY\s+(.+?)(?=\s*(?:HAVING\|ORDER\s+BY\|LIMIT\|OFFSET\|$))//si) {
3131	1					5	my $gbs = $1;
3132	1					5	$gbs =~ s/^\s+\|\s+$//g;
3133	1					7	@gb_join = map { my $x = $_; $x =~ s/^\s+\|\s+$//g; $x } split /\s,\s/, $gbs;
	1					2
	1					6
	1					23
3134							}
3135	27					105	my $has_agg = ($sql =~ /\b(?:COUNT\|SUM\|AVG\|MIN\|MAX)\s*\(/si);
3136	27		66			164	my $needs_groupby = (@gb_join \|\| ($having_join ne '') \|\| $has_agg);
3137
3138	27					104	my $parsed = _parse_join_sql($join_sql);
3139	27	50				76	if ($parsed) {
3140	27					76	my($js, $cs, $wc, $opts) = @$parsed;
3141
3142							# If GROUP BY / HAVING / aggregate: fetch raw rows with SELECT *
3143	27					43	my $rows;
3144	27	100				63	if ($needs_groupby) {
3145
3146							# Fetch all columns as raw data for aggregation
3147	1					4	my $raw_opts = {%$opts};
3148	1					4	delete $raw_opts->{order_by};
3149	1					3	delete $raw_opts->{order_dir};
3150	1					3	delete $raw_opts->{limit};
3151	1					2	delete $raw_opts->{offset};
3152	1					5	$rows = $self->join_select($js, [], $wc, $raw_opts);
3153							}
3154							else {
3155	26					117	$rows = $self->join_select($js, $cs, $wc, $opts);
3156							}
3157	27	50				113	return{ type=>'error', message=>$errstr } unless $rows;
3158
3159	27	100				68	if ($needs_groupby) {
3160
3161							# Parse col_specs from the original SQL for aggregate evaluation
3162	1					2	my @col_specs_raw;
3163	1	50				23	if ($sql =~ /^SELECT\s+(.+?)\s+FROM\b/si) {
3164	1					5	my $cs_str = $1;
3165	1					11	for my $c (split /\s,\s/, $cs_str) {
3166	3					20	$c =~ s/^\s+\|\s+$//g;
3167	3	100				21	if ($c =~ /^(.+?)\s+AS\s+(\w+)\s*$/si) {
3168	2					9	push @col_specs_raw, [ $1, $2 ];
3169							}
3170							else {
3171	1	50				8	my $alias = ($c =~ /^(\w+)\.(\w+)$/) ? $2 : $c;
3172	1					5	push @col_specs_raw, [ $c, $alias ];
3173							}
3174							}
3175							}
3176
3177							# Group rows
3178	1					3	my(%gr, @go);
3179	1	50				4	if (@gb_join) {
3180	1					3	for my $row (@$rows) {
3181
3182							# resolve GROUP BY key: try qualified then unqualified
3183							my $k = join("\x00", map {
3184	6					11	my $col = $_;
	6					10
3185							my $v = defined($row->{$col})
3186							? $row->{$col}
3187							: (($col =~ /^(\w+)\.(\w+)$/) && defined $row->{$2})
3188	6	0	0			17	? $row->{$2}
		50
3189							: '';
3190	6	50				21	defined($v) ? $v : '';
3191							} @gb_join);
3192	6	100				17	push @go, $k unless exists $gr{$k};
3193	6					10	push @{$gr{$k}}, $row;
	6					15
3194							}
3195							}
3196							else {
3197	0					0	@go = ('__all__');
3198	0					0	$gr{__all__} = $rows;
3199							}
3200
3201	1					2	my @results;
3202	1					21	for my $gk (@go) {
3203	3					10	my $grp = $gr{$gk};
3204	3					6	my $rep = $grp->[0];
3205	3					6	my %out;
3206	3					6	for my $spec (@col_specs_raw) {
3207	9					25	my($expr, $alias) = @$spec;
3208	9					23	$out{$alias} = eval_agg($expr, $grp, $rep);
3209							}
3210	3	50				10	if ($having_join ne '') {
3211	0					0	my $h = $having_join;
3212	0					0	my $cnt = scalar @$grp;
3213	0					0	$h =~ s/COUNT\s$\s\\s$/$cnt/gsi;
3214	0					0	$h =~ s/\b(SUM\|AVG\|MIN\|MAX\|COUNT)\s*$([^)]+)$/eval_agg("$1($2)", $grp, $rep)/geis;
	0					0
3215	0	0				0	next unless where_sub($h)->({ %out });
3216							}
3217	3					24	push @results, { %out };
3218							}
3219
3220							# ORDER BY from opts
3221	1	50				6	if (defined $opts->{order_by}) {
3222	1					3	my $ob = $opts->{order_by};
3223	1		50			64	my $dir = lc($opts->{order_dir} \|\| 'asc');
3224							@results = sort {
3225	1	50				9	my $va = defined($a->{$ob}) ? $a->{$ob} : '';
	3					11
3226	3	50				8	my $vb = defined($b->{$ob}) ? $b->{$ob} : '';
3227	3	50	33			10	my $c = (($va =~ /^-?\d+\.?\d$/) && ($vb =~ /^-?\d+\.?\d$/))
3228							? ($va <=> $vb)
3229							: ($va cmp $vb);
3230	3	50				13	($dir eq 'desc') ? -$c : $c;
3231							} @results;
3232							}
3233	1	50	33			19	if (defined($opts->{offset}) && ($opts->{offset} > 0)) {
3234	0					0	@results = splice(@results, $opts->{offset});
3235							}
3236	1	50				5	if (defined $opts->{limit}) {
3237	0					0	my $l = $opts->{limit} - 1;
3238	0	0				0	$l = $#results if $l > $#results;
3239	0					0	@results = @results[0 .. $l];
3240							}
3241	1					56	return { type=>'rows', data=>[ @results ] };
3242							}
3243	26					453	return { type=>'rows', data=>$rows };
3244							}
3245							}
3246	262	50				1003	my $p = $self->parse_select($sql) or return { type=>'error', message=>"Cannot parse SELECT: $sql" };
3247	262					865	my($distinct, $col_specs, $tbl, $where_expr, $gb, $having, $ob, $limit, $offset) = @$p;
3248	262		100			2784	my $needs_agg = (@$gb \|\| ($having ne '') \|\| grep { $_->[0] =~ /\b(?:COUNT\|SUM\|AVG\|MIN\|MAX)\s*\(/si } @$col_specs);
3249	262	100				695	return $self->exec_groupby($tbl, $col_specs, $where_expr, $gb, $having, $ob, $limit, $offset) if $needs_agg;
3250	237	100				815	my $sch = $self->_load_schema($tbl) or return { type=>'error', message=>$errstr };
3251	230					648	my $dat = $self->_file($tbl,'dat');
3252	230					415	my $ws;
3253	230	100				592	if ($where_expr ne '') {
3254							# Case 1: single condition col OP val (no AND/OR/NOT/BETWEEN/IN)
3255	189	100	66			1884	if (($where_expr =~ /^(\w+)\s(=\|!=\|<>\|<=\|>=\|<\|>)\s(?:'([^'])'\|(-?\d+\.?\d))$/)
3256							&& ($where_expr !~ /\b(?:OR\|AND\|NOT\|BETWEEN\|IN)\b/i)
3257							) {
3258	131					701	my($col, $op, $sv, $nv) = ($1, $2, $3, $4);
3259	131	100				875	my $cond = [{ col=>$col, op=>uc($op), val=>defined($sv) ? $sv : $nv }];
3260	131					545	my $idx = $self->_find_index_for_conds($tbl, $sch, $cond);
3261	131	100				554	if (defined $idx) {
3262	21					42	my $wsub = where_sub($where_expr);
3263	21					66	my @rows;
3264	21					43	local *FH;
3265	21	50				788	open(FH,"< $dat") or return $self->_err("Cannot open dat: $!");
3266	21					59	binmode FH;
3267	21					63	_lock_sh(\*FH);
3268	21					54	my $rs = $sch->{recsize};
3269	21					76	for my $rn (sort { $a <=> $b } @$idx) {
	65					94
3270	53					385	seek(FH,$rn*$rs,0);
3271	53					103	my $raw = '';
3272	53					519	my $n = read(FH, $raw, $rs);
3273	53	50	33			186	next unless defined($n) && ($n == $rs);
3274	53	50				111	next if substr($raw, 0, 1) eq RECORD_DELETED;
3275	53					131	my $row = $self->_unpack_record($sch,$raw);
3276	53	50	33			144	push @rows, $row if !$wsub \|\| $wsub->($row);
3277							}
3278	21					66	_unlock(\*FH);
3279	21					215	close FH;
3280	21					96	return{ type=>'rows', data=>[$self->project([ @rows ], $col_specs, $distinct, $ob, $limit, $offset)] };
3281							}
3282							}
3283							# Case 2: AND of two range conditions on the same indexed column
3284							# col OP1 val1 AND col OP2 val2 (e.g. id > 5 AND id < 10)
3285							# also: col BETWEEN val1 AND val2
3286	168					675	my $idx_range = $self->_try_index_and_range($tbl, $sch, $where_expr);
3287	168	100				393	if (defined $idx_range) {
3288	10					27	my $wsub = where_sub($where_expr);
3289	10					67	my @rows;
3290	10					23	local *FH;
3291	10	50				404	open(FH,"< $dat") or return $self->_err("Cannot open dat: $!");
3292	10					29	binmode FH;
3293	10					35	_lock_sh(\*FH);
3294	10					25	my $rs = $sch->{recsize};
3295	10					47	for my $rn (sort { $a <=> $b } @$idx_range) {
	113					171
3296	71					629	seek(FH,$rn*$rs,0);
3297	71					115	my $raw = '';
3298	71					664	my $n = read(FH, $raw, $rs);
3299	71	50	33			265	next unless defined($n) && ($n == $rs);
3300	71	50				142	next if substr($raw, 0, 1) eq RECORD_DELETED;
3301	71					176	my $row = $self->_unpack_record($sch,$raw);
3302	71	50	33			182	push @rows, $row if !$wsub \|\| $wsub->($row);
3303							}
3304	10					31	_unlock(\*FH);
3305	10					110	close FH;
3306	10					58	return{ type=>'rows', data=>[$self->project([ @rows ], $col_specs, $distinct, $ob, $limit, $offset)] };
3307							}
3308	158					467	$ws = where_sub($where_expr);
3309							}
3310	199					685	my @raw;
3311	199					557	local *FH;
3312	199	50				9877	open(FH,"< $dat") or return $self->_err("Cannot open dat: $!");
3313	199					719	binmode FH;
3314	199					750	_lock_sh(\*FH);
3315	199					702	my $rs = $sch->{recsize};
3316	199					293	while (1) {
3317	1368					2349	my $raw = '';
3318	1368					13117	my $n = read(FH, $raw, $rs);
3319	1368	100	66			5128	last unless defined($n) && ($n == $rs);
3320	1169	100				2814	next if substr($raw, 0, 1) eq RECORD_DELETED;
3321	1158					3207	my $row = $self->_unpack_record($sch, $raw);
3322	1158	100	100			3521	push @raw, $row if !$ws \|\| $ws->($row);
3323							}
3324	199					758	_unlock(\*FH);
3325	199					2509	close FH;
3326	199					1103	return{ type=>'rows', data=>[ $self->project([ @raw ], $col_specs, $distinct, $ob, $limit, $offset) ] };
3327							}
3328
3329							sub parse_select {
3330	262			262	0	596	my($self, $sql) = @_;
3331	262					3045	$sql =~ s/^\s+\|\s+$//g;
3332	262	50				1283	$sql =~ s/^SELECT\s+//si or return undef;
3333	262					483	my $distinct = 0;
3334	262	100				726	$distinct = 1 if $sql =~ s/^DISTINCT\s+//si;
3335	262					692	my($col_str, $rest) = split_at_from($sql);
3336	262	50	33			1093	return undef unless defined($col_str) && defined($rest);
3337	262					1354	$rest =~ s/^\s*FROM\s+//si;
3338	262					429	my $tbl;
3339	262	50				1472	($rest =~ s/^(\w+)//) and ($tbl = $1);
3340
3341							# Optional alias (consumed only when token is not a SQL keyword)
3342	262	50	66			2037	if (($rest =~ /^\s+(\w+)/) && ($1 !~ /^(?:WHERE\|GROUP\|ORDER\|HAVING\|LIMIT\|OFFSET\|INNER\|LEFT\|RIGHT\|JOIN\|ON\|UNION)$/i)) {
3343	0					0	$rest =~ s/^\s+(?:AS\s+)?\w+//si;
3344							}
3345	262					732	$rest =~ s/^\s+//;
3346	262	50				573	return undef unless $tbl;
3347	262					612	my($limit, $offset) = (undef, undef);
3348	262	100				1059	$rest =~ s/\s+OFFSET\s+(\d+)\s*$//si and $offset = $1;
3349	262	100				955	$rest =~ s/\s+LIMIT\s+(\d+)\s*$//si and $limit = $1;
3350	262					392	my @ob;
3351	262	100				1764	if ($rest =~ s/(?:^\|\s+)ORDER\s+BY\s+(.+?)(?=\s*(?:LIMIT\|OFFSET\|$))//si) {
3352	44					104	my $s = $1;
3353	44					157	$s =~ s/^\s+\|\s+$//g;
3354	44					159	for my $item (split /\s,\s/, $s) {
3355	46					141	$item =~ s/^\s+\|\s+$//g;
3356	46					78	my $dir = 'ASC';
3357	46	100				197	$item =~ s/\s+(ASC\|DESC)\s*$//si and $dir = uc($1);
3358	46					194	push @ob, [ $item, $dir ];
3359							}
3360							}
3361	262					439	my $having = '';
3362	262	100				1480	$rest =~ s/(?:^\|\s+)HAVING\s+(.+?)(?=\s*(?:ORDER\|LIMIT\|OFFSET\|$))//si and $having = $1;
3363	262					407	$having =~ s/^\s+\|\s+$//g;
3364	262					343	my @gb;
3365	262	100				1247	if ($rest =~ s/(?:^\|\s+)GROUP\s+BY\s+(.+?)(?=\s*(?:HAVING\|ORDER\|LIMIT\|OFFSET\|$))//si) {
3366	11					47	@gb = map { my $x = $_; $x =~ s/^\s+\|\s+\$//g; $x } split /\s,\s/, $1;
	11					19
	11					41
	11					44
3367							}
3368	262					468	my $where = '';
3369	262	100				1660	$rest =~ /(?:^\|\s*)WHERE\s+(.+)/si and ($where = $1) =~ s/^\s+\|\s+$//g;
3370	262					724	my @cs = parse_col_list($col_str);
3371	262					1960	return [ $distinct, [ @cs ], $tbl, $where, [ @gb ], $having, [ @ob ], $limit, $offset ];
3372							}
3373
3374							sub split_at_from {
3375	262			262	0	494	my($str) = @_;
3376	262					409	my $d = 0;
3377	262					369	my $in_q = 0;
3378	262					486	my $len = length($str);
3379	262					953	for my $i (0 .. $len-1) {
3380	2668					4296	my $ch = substr($str, $i, 1);
3381	2668	100	100			26952	if (($ch eq "'") && !$in_q) {
		100	66
		100	100
		100	100
		100	100
			100
			33
			66
			33
			33
3382	8					15	$in_q = 1;
3383							}
3384							elsif (($ch eq "'") && $in_q) {
3385	8					15	$in_q = 0;
3386							}
3387							elsif (!$in_q && ($ch eq '(')) {
3388	45					78	$d++;
3389							}
3390							elsif (!$in_q && ($ch eq ')')) {
3391	45					83	$d--;
3392							}
3393							elsif (!$in_q
3394							&& ($d == 0)
3395							&& (uc(substr($str, $i, 4)) eq 'FROM')
3396							&& (($i == 0) \|\| (substr($str, $i-1, 1) =~ /\s/))
3397							&& (($i+4 >= $len) \|\| (substr($str, $i+4, 1) =~ /\s/))
3398							) {
3399	262					1451	return (substr($str, 0, $i), substr($str, $i));
3400							}
3401							}
3402	0					0	return (undef, undef);
3403							}
3404
3405							sub parse_col_list {
3406	262			262	0	537	my($cs) = @_;
3407	262					1268	$cs =~ s/^\s+\|\s+$//g;
3408	262	100				750	return(['','']) if $cs eq '*';
3409	219					323	my @specs;
3410	219					595	for my $c (args($cs)) {
3411	297					1309	$c =~ s/^\s+\|\s+$//g;
3412	297					509	my($expr, $alias);
3413	297	100				1238	if ($c =~ /^(.+?)\s+AS\s+(\w+)\s*$/si) {
3414	57					208	($expr, $alias) = ($1, $2);
3415	57					300	$expr =~ s/^\s+\|\s+$//g;
3416							}
3417							else {
3418	240					444	$expr = $c;
3419	240	50				652	$alias = ($expr =~ /^(\w+)\.(\w+)$/?$2:$expr);
3420							}
3421	297					938	push @specs, [$expr, $alias];
3422							}
3423	219					590	return @specs;
3424							}
3425
3426							sub project {
3427	230			230	0	613	my($self, $rows, $col_specs, $distinct, $ob, $limit, $offset) = @_;
3428	230		100			944	my $star = ((@$col_specs == 1) && ($col_specs->[0][0] eq '*'));
3429
3430							# ORDER BY must be evaluated against the original (unprojected) rows so that
3431							# columns not listed in SELECT (e.g. "SELECT name ... ORDER BY score") are
3432							# still accessible for sorting.
3433	230					576	my @sorted = @$rows;
3434	230	100				579	if (@$ob) {
3435							@sorted = sort {
3436	35					211	my($ra, $rb) = ($a, $b);
	244					496
3437	244					420	for my $o (@$ob) {
3438	257					463	my($e, $dir) = @$o;
3439	257	0				309	my $va = do { my $vv = eval_expr($e, $ra); defined($vv) ? $vv : (defined($ra->{$e}) ? $ra->{$e} : '') };
	257	50				462
	257					566
3440	257	0				340	my $vb = do { my $vv = eval_expr($e, $rb); defined($vv) ? $vv : (defined($rb->{$e}) ? $rb->{$e} : '') };
	257	50				447
	257					619
3441	257	100	66			1554	my $c = (($va =~ /^-?\d+\.?\d$/) && ($vb =~ /^-?\d+\.?\d$/)) ? ($va <=> $vb) : ($va cmp $vb);
3442	257	100				690	$c = -$c if lc($dir) eq 'desc';
3443	257	100				860	return $c if $c;
3444							}
3445							0
3446							} @sorted;
3447							}
3448
3449							# Apply OFFSET / LIMIT on sorted raw rows before projection
3450	230	100				506	$offset = 0 unless defined $offset;
3451	230	100				479	@sorted = splice(@sorted, $offset) if $offset;
3452	230	100				502	if (defined $limit) {
3453	8					20	my $l = $limit-1;
3454	8	50				30	$l = $#sorted if $l>$#sorted;
3455	8					39	@sorted = @sorted[0 .. $l];
3456							}
3457
3458							# Project to requested columns
3459	230					337	my @out;
3460	230					466	for my $row (@sorted) {
3461	547	100				975	if ($star) {
3462	98					482	push @out, { %$row };
3463							}
3464							else {
3465	449					638	my %p;
3466	449					1286	$p{$_->[1]} = eval_expr($_->[0], $row) for @$col_specs;
3467	449					1242	push @out, \%p;
3468							}
3469							}
3470
3471							# DISTINCT (applied after projection so aliases are visible)
3472	230	100				608	if ($distinct) {
3473	3					10	my %s;
3474							my @d;
3475	3					16	for my $r (@out) {
3476	19	50				51	my $k = join("\x00", map{ defined($r->{$_}) ? $r->{$_} : "\x01" } sort keys %$r);
	19					59
3477	19	100				61	push @d, $r unless $s{$k}++;
3478							}
3479	3					18	@out = @d;
3480							}
3481	230					6895	return @out;
3482							}
3483
3484							# =============================================================================
3485							# GROUP BY / HAVING / aggregate functions
3486							# =============================================================================
3487							sub exec_groupby {
3488	25			25	0	112	my($self, $tbl, $col_specs, $where_expr, $gb, $having, $ob, $limit, $offset) = @_;
3489	25	50				102	my $sch = $self->_load_schema($tbl) or return{ type=>'error', message=>$errstr };
3490	25					76	my $dat = $self->_file($tbl,'dat');
3491	25	100				93	my $ws = ($where_expr ne '') ? where_sub($where_expr) : undef;
3492	25					53	my @raw;
3493	25					77	local *FH;
3494	25	50				1273	open(FH,"< $dat") or return $self->_err("Cannot open dat: $!");
3495	25					146	binmode FH;
3496	25					137	_lock_sh(\*FH);
3497	25					91	my $rs = $sch->{recsize};
3498	25					39	while (1) {
3499	166					347	my $raw = '';
3500	166					1330	my $n = read(FH, $raw, $rs);
3501	166	100	66			672	last unless defined($n) && ($n == $rs);
3502	141	100				335	next if substr($raw, 0, 1) eq RECORD_DELETED;
3503	132					320	my $row = $self->_unpack_record($sch, $raw);
3504	132	100	100			400	push @raw, $row if !$ws \|\| $ws->($row);
3505							}
3506	25					96	_unlock(\*FH);
3507	25					338	close FH;
3508	25					63	my %gr;
3509							my @go;
3510	25	100				73	if (@$gb) {
3511	11					25	for my $row (@raw) {
3512	71	50				149	my $k = join("\x00", map { my $v = eval_expr($_, $row); defined($v) ? $v : '' } @$gb);
	71					151
	71					299
3513	71	100				251	push @go, $k unless exists $gr{$k};
3514	71					95	push @{$gr{$k}}, $row;
	71					325
3515							}
3516							}
3517							else {
3518	14					42	@go = ('__all__');
3519	14					72	$gr{__all__} = [ @raw ];
3520							}
3521	25					50	my @results;
3522	25					73	for my $gk (@go) {
3523	43					128	my $grp = $gr{$gk};
3524	43	100				109	my $rep = defined($grp->[0]) ? $grp->[0] : {};
3525	43					85	my %out;
3526	43					164	$out{$_->[1]} = eval_agg($_->[0], $grp, $rep) for @$col_specs;
3527	43	100				125	if ($having ne '') {
3528	7					16	my $h = $having;
3529	7					17	my $cnt = scalar @$grp;
3530	7					27	$h =~ s/COUNT\s$\s\\s$/$cnt/gsi;
3531	7					56	$h =~ s/\b(SUM\|AVG\|MIN\|MAX\|COUNT)\s*$([^)]+)$/eval_agg("$1($2)", $grp, $rep)/geis;
	5					38
3532	7	100				50	next unless where_sub($h)->({ %out });
3533							}
3534	41					354	push @results, { %out };
3535							}
3536	25	100				71	if (@$ob) {
3537							@results = sort {
3538	9					48	my($ra, $rb) = ($a, $b);
	22					49
3539	22					42	for my $o (@$ob) {
3540	22					49	my($e, $dir) = @$o;
3541	22	0				45	my $va = do { my $vv = eval_expr($e, $ra); defined($vv) ? $vv : (defined($ra->{$e}) ? $ra->{$e} : '') };
	22	50				50
	22					64
3542	22	0				92	my $vb = do { my $vv = eval_expr($e, $rb); defined($vv) ? $vv : (defined($rb->{$e}) ? $rb->{$e} : '') };
	22	50				64
	22					75
3543	22	100	66			188	my $c = (($va =~ /^-?\d+\.?\d$/) && ($vb =~ /^-?\d+\.?\d$/)) ? ($va <=> $vb) : ($va cmp $vb);
3544	22	50				89	$c = -$c if lc($dir) eq 'desc';
3545	22	50				100	return $c if $c;
3546							}
3547							0
3548							} @results
3549							}
3550	25	50				78	$offset = 0 unless defined $offset;
3551	25	50				77	@results = splice(@results, $offset) if $offset;
3552	25	50				65	if (defined $limit) {
3553	0					0	my $l = $limit - 1;
3554	0	0				0	$l = $#results if $l>$#results;
3555	0					0	@results = @results[0..$l];
3556							}
3557	25					580	return{ type=>'rows', data=>[ @results ] };
3558							}
3559
3560							sub eval_agg {
3561	95			95	0	223	my($expr, $grp, $rep) = @_;
3562	95	100				549	return scalar @$grp if $expr =~ /^COUNT\s$\s\\s$$/si;
3563	63	100				173	if ($expr =~ /^COUNT\s$\sDISTINCT\s+(.+)\s*$$/si) {
3564	1					5	my $e = $1;
3565	1					2	my %s;
3566	1	50				3	$s{ do { my $vv = eval_expr($e, $_); defined($vv) ? $vv : '' } }++ for @$grp;
	5					14
	5					41
3567	1					8	return scalar keys %s;
3568							}
3569	62	100				256	if ($expr =~ /^(COUNT\|SUM\|AVG\|MIN\|MAX)\s*$(.+)$$/si) {
3570	30					144	my($fn, $inner) = (uc($1), $2);
3571	30					130	$inner =~ s/^\s+\|\s+$//g;
3572	30					68	my @vals = grep { defined $_ } map { eval_expr($inner, $_) } @$grp;
	83					211
	83					184
3573	30	50				81	return 0 unless @vals;
3574	30	50				74	return scalar @vals if $fn eq 'COUNT';
3575	30	100				104	if ($fn eq 'SUM') {
3576	13					24	my $s = 0;
3577	13					63	$s += $_ for @vals;
3578	13					67	return $s;
3579							}
3580	17	100				41	if ($fn eq 'AVG') {
3581	9					18	my $s = 0;
3582	9					31	$s += $_ for @vals;
3583	9					78	return $s / @vals;
3584							}
3585	8	100				19	if ($fn eq 'MIN') {
3586	2	50	33			10	return (sort { (($a =~ /^-?\d+\.?\d$/) && ($b =~ /^-?\d+\.?\d$/)) ? ($a<=>$b) : ($a cmp $b) } @vals)[0];
	4					48
3587							}
3588	6	50				14	if ($fn eq 'MAX') {
3589	6	50	33			27	return (sort { (($a =~ /^-?\d+\.?\d$/) && ($b =~ /^-?\d+\.?\d$/)) ? ($b<=>$a) : ($b cmp $a) } @vals)[0];
	13					97
3590							}
3591							}
3592	32					74	return eval_expr($expr, $rep);
3593							}
3594
3595							# =============================================================================
3596							# UNION / UNION ALL
3597							# =============================================================================
3598							sub split_union {
3599	291			291	0	582	my($sql) = @_;
3600	291					479	my @parts;
3601	291					525	my $cur = '';
3602	291					446	my $d = 0;
3603	291					428	my $in_q = 0;
3604	291					400	my $i = 0;
3605	291					520	my $len = length($sql);
3606	291					672	while ($i < $len) {
3607	14829					21435	my $ch = substr($sql, $i, 1);
3608	14829	100	100			96138	if (($ch eq "'") && !$in_q) {
		100	66
		100	66
		100	100
		100	33
		100	66
			33
			33
3609	43					69	$in_q = 1;
3610	43					108	$cur .= $ch;
3611							}
3612							elsif (($ch eq "'") && $in_q) {
3613	43					79	$in_q = 0;
3614	43					74	$cur .= $ch;
3615							}
3616							elsif ($in_q) {
3617	186					277	$cur .= $ch;
3618							}
3619							elsif ($ch eq '(') {
3620	66					102	$d++;
3621	66					103	$cur .= $ch;
3622							}
3623							elsif ($ch eq ')') {
3624	66					98	$d--;
3625	66					145	$cur .= $ch;
3626							}
3627							elsif (($d == 0)
3628							&& !$in_q
3629							&& (uc(substr($sql, $i, 5)) eq 'UNION')
3630							&& (($i == 0) \|\| (substr($sql, $i-1, 1) =~ /\s/))
3631							&& ($i+5 < $len) && (substr($sql, $i+5, 1) =~ /[\s(]/)) {
3632	2					7	push @parts, $cur;
3633	2					4	$cur = '';
3634	2					5	$i += 5;
3635	2		66			32	while (($i < $len) && (substr($sql, $i, 1) =~ /\s/)) {
3636	2					13	$i++;
3637							}
3638	2	100	66			23	if (($i+3 <= $len) && (uc(substr($sql, $i, 3)) eq 'ALL')
			33
			66
3639							&& (($i+3 >= $len) \|\| (substr($sql, $i+3, 1) =~ /\s/))) {
3640	1					4	push @parts, 'ALL';
3641	1					3	$i += 3;
3642	1		66			8	while (($i < $len) && (substr($sql, $i, 1) =~ /\s/)) {
3643	1					22	$i++;
3644							}
3645							}
3646							else {
3647	1					4	push @parts, '';
3648							}
3649	2					7	next;
3650							}
3651							else {
3652	14423					20748	$cur .= $ch;
3653							}
3654	14827					25679	$i++;
3655							}
3656	291	50				1669	push @parts, $cur if $cur =~ /\S/;
3657	291					1179	return @parts;
3658							}
3659
3660							sub exec_union {
3661	2			2	0	5	my($self, $parts) = @_;
3662	2					7	my @p = @$parts;
3663	2					5	my $first = shift @p;
3664	2					16	my $r0 = $self->execute($first);
3665	2	50				10	return $r0 if $r0->{type} eq 'error';
3666	2					5	my @rows = @{$r0->{data}};
	2					6
3667	2					5	my $dedup = 0;
3668	2					8	while (@p >= 2) {
3669	2					5	my $sep = shift @p;
3670	2					4	my $q = shift @p;
3671	2	100				7	$dedup = 1 if $sep ne 'ALL';
3672	2					7	my $r = $self->execute($q);
3673	2	50				12	return $r if $r->{type} eq 'error';
3674	2					5	push @rows, @{$r->{data}};
	2					12
3675							}
3676	2	100				7	if ($dedup) {
3677	1					4	my %s;
3678							my @d;
3679	1					3	for my $r (@rows) {
3680	4	50				13	my $k = join("\x00", map { defined($r->{$_}) ? $r->{$_} : "\x01" } sort keys %$r);
	4					17
3681	4	100				18	push @d, $r unless $s{$k}++;
3682							}
3683	1					5	@rows = @d;
3684							}
3685	2					33	return { type=>'rows', data=>[ @rows ] };
3686							}
3687
3688							# =============================================================================
3689							# UPDATE with expression SET
3690							# =============================================================================
3691							sub parse_set_exprs {
3692	25			25	0	61	my($str) = @_;
3693	25					45	my %set;
3694	25					126	for my $part (args($str)) {
3695	26					157	$part =~ s/^\s+\|\s+$//g;
3696	26	50				306	$set{$1} = $2 if $part =~ /^(\w+)\s=\s(.+)$/;
3697							}
3698	25					167	return %set;
3699							}
3700
3701							sub update {
3702	25			25	0	73	my($self, $table, $set_exprs, $ws) = @_;
3703	25	50				87	return $self->_err("No database selected") unless $self->{db_name};
3704	25	50				84	my $sch = $self->_load_schema($table) or return undef;
3705	25					82	my $dat = $self->_file($table, 'dat');
3706	25					84	my $rs = $sch->{recsize};
3707	25					43	my $n = 0;
3708	25					70	local *FH;
3709	25	50				1297	open(FH,"+< $dat") or return $self->_err("Cannot open dat: $!");
3710	25					106	binmode FH;
3711	25					104	_lock_ex(\*FH);
3712	25					125	seek(FH, 0, 0);
3713	25					86	my $pos = 0;
3714	25					55	my $rno = 0;
3715	25					39	while (1) {
3716	94					1510	seek(FH, $pos, 0);
3717	94					196	my $raw = '';
3718	94					1391	my $x = read(FH, $raw, $rs);
3719	94	100	66			1105	last unless defined($x) && ($x == $rs);
3720	77	100				260	if (substr($raw, 0, 1) ne RECORD_DELETED) {
3721	76					241	my $row = $self->_unpack_record($sch, $raw);
3722	76	100	100			298	if (!$ws \|\| $ws->($row)) {
3723	35					89	my %old;
3724	35					91	for my $ix (values %{$sch->{indexes}}) {
	35					136
3725							$old{$ix->{name}} = $row->{$ix->{col}}
3726	11					38	}
3727	35					193	my %orig = %$row;
3728	35					301	$row->{$_} = eval_expr($set_exprs->{$_}, { %orig }) for keys %$set_exprs;
3729	35					72	for my $ix (values %{$sch->{indexes}}) {
	35					126
3730	10	100	100			41	next unless $ix->{unique} && exists $set_exprs->{$ix->{col}};
3731	4					10	my $nv = $row->{$ix->{col}};
3732	4					43	my $ep = $self->_idx_lookup_exact($table, $ix, $nv);
3733	4	50				13	if ($ep >= 0) {
3734	4					16	my $ef = $self->_idx_file($table, $ix->{name});
3735	4					9	my $es = $ix->{keysize} + REC_NO_SIZE;
3736	4					11	local *IF_FH;
3737	4	50				139	open(IF_FH,"< $ef") or next;
3738	4					10	binmode IF_FH;
3739	4					26	seek(IF_FH, IDX_MAGIC_LEN + $ep * $es + $ix->{keysize}, 0);
3740	4					8	my $rn = '';
3741	4					52	read(IF_FH, $rn, REC_NO_SIZE);
3742	4					81	close IF_FH;
3743	4	100				34	if (unpack('N', $rn) != $rno) {
3744	2					10	_unlock(\*FH);
3745	2					13	close FH;
3746	2					12	return $self->_err("UNIQUE constraint violated on '$ix->{name}'");
3747							}
3748							}
3749							}
3750
3751							# NOT NULL constraint check on UPDATE
3752	33	50				74	for my $cn (keys %{$sch->{notnull} \|\| {}}) {
	33					192
3753	12	100				40	next unless exists $set_exprs->{$cn};
3754	1	50	33			18	unless (defined($row->{$cn}) && ($row->{$cn} ne '')) {
3755	1					5	_unlock(\*FH);
3756	1					16	close FH;
3757	1					7	return $self->_err("NOT NULL constraint violated on column '$cn'");
3758							}
3759							}
3760							# CHECK constraint check on UPDATE
3761	32	50				57	for my $cn (keys %{$sch->{checks} \|\| {}}) {
	32					122
3762	15	100				43	next unless exists $set_exprs->{$cn};
3763	9	100				32	unless (eval_bool($sch->{checks}{$cn}, $row)) {
3764	5					25	_unlock(\*FH);
3765	5					81	close FH;
3766	5					38	return $self->_err("CHECK constraint failed on column '$cn'");
3767							}
3768							}
3769	27					129	my $p = $self->_pack_record($sch, $row);
3770	27					319	seek(FH, $pos, 0);
3771	27					104	print FH $p;
3772	27					180	$n++;
3773	27					73	for my $ix (values %{$sch->{indexes}}) {
	27					148
3774	7	100				29	next unless exists $set_exprs->{$ix->{col}};
3775	3					33	$self->_idx_delete($table, $ix, $old{$ix->{name}}, $rno);
3776	3					18	$self->_idx_insert($table, $ix, $row->{$ix->{col}}, $rno);
3777							}
3778							}
3779							}
3780	69					125	$pos += $rs;
3781	69					108	$rno++;
3782							}
3783	17					79	_unlock(\*FH);
3784	17					224	close FH;
3785	17					126	return $n;
3786							}
3787
3788							###############################################################################
3789							# DBI-like API -- DB::Handy::Connection / DB::Handy::Statement
3790							#
3791							# A standalone implementation with a DBI-inspired interface.
3792							#
3793							# Usage:
3794							# my $dbh = DB::Handy->connect("./data", "mydb");
3795							# my $sth = $dbh->prepare("SELECT * FROM emp WHERE id = ?");
3796							# $sth->execute(1);
3797							# while (my $row = $sth->fetchrow_hashref) { ... }
3798							# $sth->finish;
3799							# $dbh->disconnect;
3800							###############################################################################
3801
3802							###############################################################################
3803							# DB::Handy::Connection -- database connection handle (like $dbh)
3804							###############################################################################
3805							package DB::Handy::Connection;
3806	11			11		172	use vars qw($VERSION);
	11					81
	11					913
3807							$VERSION = $DB::Handy::VERSION;
3808							$VERSION = $VERSION;
3809
3810	11			11		136	use vars qw($errstr);
	11					24
	11					17085
3811							$errstr = '';
3812
3813							# new($base_dir, $database, \%opts)
3814							sub new {
3815	23			23		59	my($class, $base_dir, $database, $opts) = @_;
3816	23	50				53	$opts = {} unless ref($opts) eq 'HASH';
3817	23					66	my $engine = DB::Handy->new(base_dir => $base_dir);
3818	23	50				52	unless (defined $engine) {
3819	0					0	$errstr = $DB::Handy::errstr;
3820	0	0				0	if ($opts->{RaiseError}) {
3821	0					0	die "DB::Handy connect failed: $errstr\n";
3822							}
3823	0					0	return undef;
3824							}
3825							my $self = {
3826							_engine => $engine,
3827							_database => $database \|\| '',
3828							RaiseError => $opts->{RaiseError} \|\| 0,
3829	23	100	50			192	PrintError => (defined($opts->{PrintError}) ? $opts->{PrintError} : 0),
			100
3830							errstr => '',
3831							err => 0,
3832							};
3833	23					68	bless $self, $class;
3834	23	100	66			103	if ($database && (!defined($opts->{AutoUse}) \|\| $opts->{AutoUse})) {
			33
3835	22					74	my $res = $engine->execute("USE $database");
3836	22	100				64	if ($res->{type} eq 'error') {
3837	2					9	$engine->execute("CREATE DATABASE $database");
3838	2					10	$res = $engine->execute("USE $database");
3839							}
3840	22	50				67	if ($res->{type} eq 'error') {
3841	0		0			0	$self->_set_err($DB::Handy::errstr \|\| $res->{message});
3842	0					0	return undef;
3843							}
3844							}
3845	23					113	return $self;
3846							}
3847
3848							# connect($dsn_or_dir, $database, \%opts)
3849							# Also accepts DSN string: "base_dir=./data;database=mydb"
3850							sub connect {
3851	23			23		50	my($class, $dsn, $database, $opts) = @_;
3852	23					29	my $base_dir;
3853	23	100	66			127	if (defined($dsn) && ($dsn =~ /[=;]/)) {
3854	2					10	my %p = map { split /=/, $_, 2 } split /;/, $dsn;
	4					16
3855	2		50			12	$base_dir = $p{base_dir} \|\| $p{dir} \|\| '.';
3856	2		33			12	$database = $p{database} \|\| $p{db} \|\| $database;
3857							}
3858							else {
3859	21	50				45	$base_dir = defined($dsn) ? $dsn : '.';
3860							}
3861	23	100				62	$opts = {} unless ref($opts) eq 'HASH';
3862	23					60	return DB::Handy::Connection->new($base_dir, $database, $opts);
3863							}
3864
3865							# do($sql, @bind) -- shortcut for prepare+execute (useful for DDL/DML)
3866							sub do {
3867	74			74		583	my($self, $sql, @bind) = @_;
3868	74	50				156	my $sth = $self->prepare($sql) or return undef;
3869	74					158	return $sth->execute(@bind);
3870							}
3871
3872							# prepare($sql) -- returns a statement handle
3873							sub prepare {
3874	132			132		616	my($self, $sql) = @_;
3875	132	50	33			799	unless (defined($sql) && ($sql =~ /\S/)) {
3876	0					0	$self->_set_err("prepare: empty SQL");
3877	0					0	return undef;
3878							}
3879	132					771	return DB::Handy::Statement->new($self, $sql);
3880							}
3881
3882							# selectall_arrayref($sql, \%attr, @bind)
3883							# attr: Slice=>{} for array of hashrefs, Slice=>[] (default) for array of arrayrefs
3884							sub selectall_arrayref {
3885	11			11		182	my($self, $sql, $attr, @bind) = @_;
3886	11	50				27	$attr = {} unless ref($attr) eq 'HASH';
3887	11	50				26	my $sth = $self->prepare($sql) or return undef;
3888	11	50				24	$sth->execute(@bind) or return undef;
3889	11					36	return $sth->fetchall_arrayref($attr->{Slice});
3890							}
3891
3892							# selectall_hashref($sql, $key_col, \%attr, @bind)
3893							sub selectall_hashref {
3894	2			2		26	my($self, $sql, $key_col, $attr, @bind) = @_;
3895	2	50				9	my $rows = $self->selectall_arrayref($sql, {Slice=>{}}, @bind) or return undef;
3896	2					6	my %h;
3897	2					4	for my $row (@$rows) {
3898	7					20	$h{$row->{$key_col}} = $row;
3899							}
3900	2					14	return { %h };
3901							}
3902
3903							# selectrow_hashref($sql, \%attr, @bind)
3904							sub selectrow_hashref {
3905	15			15		187	my($self, $sql, $attr, @bind) = @_;
3906	15	50				47	my $sth = $self->prepare($sql) or return undef;
3907	15	50				38	$sth->execute(@bind) or return undef;
3908	15					42	my $row = $sth->fetchrow_hashref;
3909	15					74	$sth->finish;
3910	15					127	return $row;
3911							}
3912
3913							# selectrow_arrayref($sql, \%attr, @bind)
3914							sub selectrow_arrayref {
3915	2			2		40	my($self, $sql, $attr, @bind) = @_;
3916	2	50				10	my $sth = $self->prepare($sql) or return undef;
3917	2	50				9	$sth->execute(@bind) or return undef;
3918	2					10	my $row = $sth->fetchrow_arrayref;
3919	2					10	$sth->finish;
3920	2					17	return $row;
3921							}
3922
3923							# quote($val) -- escape a value as a SQL single-quoted literal
3924							sub quote {
3925	9			9		41	my($self, $val) = @_;
3926	9	100				38	return 'NULL' unless defined $val;
3927	7					19	$val =~ s/'/''/g;
3928	7					24	return "'$val'";
3929							}
3930
3931							# last_insert_id() -- row count recorded by the most recent INSERT
3932	2			2		13	sub last_insert_id { return $_[0]->{_last_insert_id} }
3933
3934							# table_info() -- list of tables [{TABLE_NAME=>...}, ...]
3935							sub table_info {
3936	1			1		10	my($self) = @_;
3937	1					6	my @tables = $self->{_engine}->list_tables();
3938	1					3	return [ map { {TABLE_NAME=>$_, TABLE_TYPE=>'TABLE'} } @tables ];
	2					13
3939							}
3940
3941							# column_info($table) -- column metadata [{COLUMN_NAME=>..., DATA_TYPE=>...}, ...]
3942							sub column_info {
3943	1			1		50	my($self, $table) = @_;
3944	1	50				6	my $cols = $self->{_engine}->describe_table($table) or return undef;
3945	1					3	my $i = 0;
3946	1					3	return [ map { {
3947							COLUMN_NAME => $_->{name},
3948							DATA_TYPE => $_->{type},
3949							ORDINAL_POSITION => ++$i,
3950							IS_NULLABLE => ($_->{not_null} ? 'NO' : 'YES'),
3951							COLUMN_DEF => $_->{default},
3952	4	50				34	} } @$cols ];
3953							}
3954
3955							# disconnect()
3956							sub disconnect {
3957	23			23		334	my($self) = @_;
3958	23					54	$self->{_disconnected} = 1;
3959	23					243	return 1;
3960							}
3961
3962							# ping() -- returns 1 if connection is active
3963	3	100		3		57	sub ping { return $_[0]->{_disconnected} ? 0 : 1 }
3964
3965							# errstr / err accessors
3966	1			1		3	sub errstr { return $_[0]->{errstr} }
3967	4			4		26	sub err { return $_[0]->{err} }
3968
3969							sub _set_err {
3970	8			8		17	my($self, $msg, $code) = @_;
3971	8	50				13	$code = 1 unless defined $code;
3972	8					13	$self->{errstr} = $msg;
3973	8					11	$self->{err} = $code;
3974	8					45	$errstr = $msg;
3975	8	100				18	if ($self->{PrintError}) {
3976	1					10	warn "DB::Handy: $msg\n";
3977							}
3978	8	100				28	if ($self->{RaiseError}) {
3979	2					14	die "DB::Handy: $msg\n";
3980							}
3981							}
3982
3983							###############################################################################
3984							# DB::Handy::Statement -- statement handle (like $sth)
3985							###############################################################################
3986							package DB::Handy::Statement;
3987	11			11		90	use vars qw($VERSION);
	11					17
	11					685
3988							$VERSION = $DB::Handy::VERSION;
3989							$VERSION = $VERSION;
3990
3991	11			11		64	use vars qw($errstr);
	11					17
	11					25283
3992							$errstr = '';
3993
3994							sub new {
3995	132			132		262	my($class, $dbh, $sql) = @_;
3996	132					892	my $self = {
3997							_dbh => $dbh,
3998							_sql => $sql,
3999							_rows => undef,
4000							_cursor => 0,
4001							_executed => 0,
4002							_bind_params => [],
4003							rows => 0,
4004							errstr => '',
4005							err => 0,
4006							NAME => [],
4007							NUM_OF_FIELDS => 0,
4008							};
4009	132					302	bless $self, $class;
4010	132					569	return $self;
4011							}
4012
4013							# execute(@bind_values) -- substitute ? placeholders and run the statement
4014							sub execute {
4015	136			136		392	my($self, @bind) = @_;
4016
4017							# merge values pre-set via bind_param()
4018	136	100	100			324	if (!@bind && @{$self->{_bind_params}}) {
	122					337
4019	2					3	@bind = @{$self->{_bind_params}};
	2					6
4020							}
4021
4022	136					257	my $sql = $self->{_sql};
4023
4024							# substitute ? placeholders with actual values
4025	136	100				269	if (@bind) {
4026	16					36	my @params = @bind;
4027	16					80	$sql =~ s/\?/_dbi_quote(shift @params)/ge;
	18					49
4028							}
4029
4030	136					269	my $engine = $self->{_dbh}{_engine};
4031	136					367	my $res = $engine->execute($sql);
4032
4033	136					547	$self->{_result} = $res;
4034	136					231	$self->{_executed} = 1;
4035
4036	136	100				387	if ($res->{type} eq 'error') {
4037	8					28	$self->_set_err($res->{message});
4038	6					29	return undef;
4039							}
4040
4041	128	100				273	if ($res->{type} eq 'rows') {
4042	55					100	my $data = $res->{data};
4043	55					98	$self->{_rows} = $data;
4044	55					102	$self->{_cursor} = 0;
4045	55					89	my $n = scalar @$data;
4046	55					94	$self->{rows} = $n;
4047							# Determine column order: prefer SELECT list order, fall back to
4048							# sorted keys (used for SELECT *, JOIN results, and empty result sets).
4049	55					211	my @name_order = $self->_col_order_from_sql($sql, $data);
4050	55					163	$self->{NAME} = \@name_order;
4051	55					112	$self->{NUM_OF_FIELDS} = scalar @name_order;
4052	55		100			311	return $n \|\| '0E0';
4053							}
4054
4055							# INSERT / UPDATE / DELETE / DDL
4056	73	50				160	if ($res->{type} eq 'ok') {
4057	73					107	my $affected = 0;
4058	73	100	66			617	if (defined($res->{message}) && ($res->{message} =~ /(\d+)\s+row/)) {
4059	56					168	$affected = $1 + 0;
4060							}
4061	73					106	$self->{rows} = $affected;
4062	73					128	$self->{_rows} = undef;
4063	73	100				308	if ($sql =~ /^\s*INSERT\b/i) {
4064	51					108	$self->{_dbh}{_last_insert_id} = $affected;
4065							}
4066	73		100			525	return $affected \|\| '0E0';
4067							}
4068
4069							# SHOW / DESCRIBE and other statement types
4070	0	0				0	if (ref($res->{data}) eq 'ARRAY') {
4071	0					0	$self->{_rows} = $res->{data};
4072	0					0	$self->{_cursor} = 0;
4073	0					0	$self->{rows} = scalar @{$res->{data}};
	0					0
4074							}
4075	0					0	return '0E0';
4076							}
4077
4078							# _col_order_from_sql($sql, $data)
4079							#
4080							# Parse the SELECT column list from $sql and return column names in
4081							# declaration order. Falls back to sorted keys of the first data row
4082							# when the SELECT list contains '', 'alias.', aggregate expressions,
4083							# or cannot be parsed (e.g. JOINs with qualified names).
4084							#
4085							sub _col_order_from_sql {
4086	55			55		146	my($self, $sql, $data) = @_;
4087							# Fallback: alphabetical from first row (or empty)
4088	55	100	66			227	my @fallback = ($data && @$data) ? sort keys %{$data->[0]} : ();
	54					292
4089	55	50				148	return @fallback unless defined $sql;
4090							# Strip leading SELECT keyword
4091	55					83	my $col_str;
4092	55	50				525	if ($sql =~ /^SELECT\s+(.*?)\s+FROM\b/si) {
4093	55					164	$col_str = $1;
4094							}
4095							else {
4096	0					0	return @fallback;
4097							}
4098	55					124	$col_str =~ s/^DISTINCT\s+//si;
4099							# If SELECT * or alias.* -> fall back
4100	55	100				183	return @fallback if $col_str =~ /(?:^\|\s)\*(?:\s\|$)/;
4101							# Split on commas (not inside parentheses)
4102	54					78	my @parts;
4103	54					131	my($cur, $depth) = ('', 0);
4104	54					236	for my $ch (split //, $col_str) {
4105	653	100	100			1785	if ($ch eq '(') { $depth++; $cur .= $ch }
	16	100				22
	16	100				28
4106	16					22	elsif ($ch eq ')') { $depth--; $cur .= $ch }
	16					24
4107	35					73	elsif ($ch eq ',' && $depth == 0) { push @parts, $cur; $cur = '' }
	35					59
4108	586					889	else { $cur .= $ch }
4109							}
4110	54	50				223	push @parts, $cur if length $cur;
4111	54					88	my @names;
4112	54					101	for my $part (@parts) {
4113	89					455	$part =~ s/^\s+\|\s+$//g;
4114							# explicit alias: expr AS alias
4115	89	100				556	if ($part =~ /\bAS\s+(\w+)\s*$/si) {
		50
		50
4116	21					68	push @names, $1;
4117							}
4118							# qualified alias.col -> use bare col as key
4119							elsif ($part =~ /^(\w+)\.(\w+)$/) {
4120	0					0	push @names, $2;
4121							}
4122							# bare column name
4123							elsif ($part =~ /^(\w+)$/) {
4124	68					190	push @names, $1;
4125							}
4126							# complex expression without alias -> fall back entirely
4127							else {
4128	0					0	return @fallback;
4129							}
4130							}
4131							# Verify that every parsed name exists as a key in the result
4132							# (guards against mis-parses; also handles 0-row results)
4133	54	100				140	if (@$data) {
4134	53					79	my %keys = map { $_ => 1 } keys %{$data->[0]};
	87					269
	53					174
4135	53					120	for my $nm (@names) {
4136	87	50				282	return @fallback unless $keys{$nm};
4137							}
4138							}
4139	54					274	return @names;
4140							}
4141
4142							# fetchrow_hashref -- return next row as hashref (undef at EOF)
4143							sub fetchrow_hashref {
4144	113			113		326	my($self) = @_;
4145	113	100				261	return undef unless defined $self->{_rows};
4146	112	100				176	return undef if $self->{_cursor} >= scalar @{$self->{_rows}};
	112					314
4147	91					210	my $row = $self->{_rows}[ $self->{_cursor}++ ];
4148	91					394	return { %$row };
4149							}
4150
4151							# fetchrow_arrayref -- return next row as arrayref (columns in NAME order)
4152							sub fetchrow_arrayref {
4153	26			26		234	my($self) = @_;
4154	26	100				74	my $href = $self->fetchrow_hashref or return undef;
4155	22	50				38	my @cols = @{$self->{NAME}} ? @{$self->{NAME}} : sort keys %$href;
	22					54
	22					59
4156	22					51	return [ map { $href->{$_} } @cols ];
	49					199
4157							}
4158
4159							# fetchrow_array -- return next row as a list
4160							sub fetchrow_array {
4161	2			2		38	my($self) = @_;
4162	2	50				9	my $aref = $self->fetchrow_arrayref or return ();
4163	2					9	return @$aref;
4164							}
4165
4166							# fetch -- alias for fetchrow_arrayref
4167	0			0		0	sub fetch { return $_[0]->fetchrow_arrayref }
4168
4169							# fetchall_arrayref([$slice])
4170							# $slice = {} -> [{col=>val,...}, ...]
4171							# $slice = [] -> [[val,...], ...] (default)
4172							sub fetchall_arrayref {
4173	14			14		45	my($self, $slice) = @_;
4174	14	50				35	return undef unless defined $self->{_rows};
4175	14					21	my @all;
4176	14	100				38	if (ref($slice) eq 'HASH') {
4177	12					26	while (my $row = $self->fetchrow_hashref) {
4178	30					59	push @all, $row;
4179							}
4180							}
4181							else {
4182	2					11	while (my $row = $self->fetchrow_arrayref) {
4183	8					23	push @all, $row;
4184							}
4185							}
4186	14					158	return [ @all ];
4187							}
4188
4189							# fetchall_hashref($key_col) -- return rows as a hashref keyed by $key_col
4190							sub fetchall_hashref {
4191	2			2		17	my($self, $key_col) = @_;
4192	2					6	my %h;
4193	2					8	while (my $row = $self->fetchrow_hashref) {
4194	7					28	$h{$row->{$key_col}} = $row;
4195							}
4196	2					13	return { %h };
4197							}
4198
4199							# bind_param($pos, $val [, $attr]) -- pre-bind a placeholder by position
4200							sub bind_param {
4201	2			2		11	my($self, $pos, $val, $attr) = @_;
4202	2					7	$self->{_bind_params}[$pos - 1] = $val;
4203	2					5	return 1;
4204							}
4205
4206							# finish -- reset cursor and release resources
4207							sub finish {
4208	40			40		509	my($self) = @_;
4209	40					81	$self->{_rows} = undef;
4210	40					65	$self->{_cursor} = 0;
4211	40					91	$self->{_bind_params} = [];
4212	40					99	return 1;
4213							}
4214
4215							# rows -- number of rows affected or fetched by the last execute
4216	5			5		87	sub rows { return $_[0]->{rows} }
4217
4218							# errstr / err accessors
4219	2			2		8	sub errstr { return $_[0]->{errstr} }
4220	2			2		37	sub err { return $_[0]->{err} }
4221
4222							sub _set_err {
4223	8			8		17	my($self, $msg, $code) = @_;
4224	8	50				19	$code = 1 unless defined $code;
4225	8					12	$self->{errstr} = $msg;
4226	8					14	$self->{err} = $code;
4227	8					12	$errstr = $msg;
4228	8					12	my $dbh = $self->{_dbh};
4229	8	50				26	$dbh->_set_err($msg, $code) if ref($dbh);
4230							}
4231
4232							# _dbi_quote($val) -- internal helper for ? placeholder substitution
4233							sub _dbi_quote {
4234	18			18		37	my($val) = @_;
4235	18	50				45	return 'NULL' unless defined $val;
4236	18	100				142	return $val if $val =~ /^-?\d+\.?\d*$/; # numeric: pass through as-is
4237	5					14	$val =~ s/'/''/g;
4238	5					44	return "'$val'";
4239							}
4240
4241							###############################################################################
4242							# Add connect() class method to DB::Handy
4243							###############################################################################
4244							package DB::Handy;
4245
4246							sub connect {
4247	23			23	1	357694	my($class, $dsn, $database, $opts) = @_;
4248	23					108	return DB::Handy::Connection->connect($dsn, $database, $opts);
4249							}
4250
4251							1;
4252
4253							__END__