File Coverage

lib/DB/Handy.pm

Criterion	Covered	Total	%
statement	2532	2825	89.6
branch	1267	1928	65.7
condition	407	710	57.3
subroutine	152	159	95.6
pod	17	41	41.4
total	4375	5663	77.2

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