File Coverage

lib/DB/Handy.pm

Criterion	Covered	Total	%
statement	2479	2772	89.4
branch	1242	1892	65.6
condition	403	704	57.2
subroutine	152	159	95.6
pod	17	41	41.4
total	4293	5568	77.1

line

stmt

bran

cond

sub

pod

time

code

package DB::Handy;

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

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

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

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

# Compatible : Perl 5.005_03 and later

# Platform : Windows and UNIX/Linux

# FILE LAYOUT:

# //

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

# .dat records (fixed-length binary)

# ..idx sorted index (binary)

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