File Coverage

File:	blib/lib/Database/BI/Controller/Dashboard.pm
Coverage:	77.7%

line	stmt	bran	cond	sub	time	code
1						package Database::BI::Controller::Dashboard;
2
3	12 12 12			12	10866 20 137	use strict;
4	12 12 12			12	21 11 459	use warnings;
5
6						our $VERSION = '0.012.0';
7
8	12 12 12			12	26 12 52	use Mojo::Base 'Mojolicious::Controller', -strict, -signatures;
9
10	12 12 12			12	6725 15 298	use Carp qw(croak carp);
11	12 12 12			12	19 13 333	use List::Util qw(min max sum);
12	12 12 12			12	3025 880097 219	use CGI::Info;
13	12 12 12			12	4732 147575 258	use CGI::Lingua;
14	12 12 12			12	44 13 309	use Mojo::File;
15	12 12 12			12	26 12 296	use Mojo::JSON qw(encode_json decode_json);
16	12 12 12			12	21 13 218	use Mojo::Util qw(url_escape encode);
17	12 12 12			12	29 12 208	use File::Path qw(remove_tree);
18	12 12 12			12	22 11 196	use File::Temp qw(tempfile tempdir);
19	12 12 12			12	17 12 165	use Readonly;
20	12 12 12			12	21 11 196	use Socket qw(inet_aton);
21	12 12 12			12	19 15 59	use Sub::Protected;
22
23						# ---------------------------------------------------------------------------
24						# Constants
25						# ---------------------------------------------------------------------------
26
27						# File extensions that Database::Abstraction can probe, in probe order.
28						# .sql, .sqlite, and .sqlite3 are all SQLite databases; .db is Berkeley DB.
29						Readonly my @SUPPORTED_EXT => qw( csv db sql sqlite sqlite3 xml tsv psv xlsx );
30						# Use \z (absolute end-of-string) not $ (which permits a trailing \n before \z).
31						# A query param decoded from "file.csv%0A" has basename "sales.csv\n"; without \z
32						# that passes the extension guard and reaches realpath with an embedded newline.
33						Readonly my $EXT_RE => do { my $p = join '\|', @SUPPORTED_EXT; qr/\.(?:$p)\z/i };
34
35						# Table name safe-identifier pattern -- must match DataSource's TABLE_NAME_RE
36						# exactly: first character must be a letter or underscore (not a digit), so
37						# that every table name the controller accepts can also be opened by DataSource
38						# without an unhandled croak.
39						Readonly my $TABLE_NAME_RE => qr/\A[A-Za-z_][A-Za-z0-9_]*\z/;
40
41						# URL spec pattern shared by _open_spec and _spec_to_url.
42						# qr{} delimiter avoids the \/ escaping noise required by the // form.
43						# /s: makes . match \n so a percent-decoded newline inside a URL does not
44						# silently truncate the captured URL before the \z end-of-string anchor.
45						Readonly my $URL_SPEC_RE => qr{\Aurl:(https?://.+)\z}si;
46
47						# Redis spec pattern: redis:tablename\|redis://[password@]host[:port][/db_index]
48						# The pipe separates the table name from the connection URL so the URL's own
49						# colons and slashes do not require extra quoting.
50						Readonly my $REDIS_SPEC_RE => qr{\Aredis:([^\|]+)\\|(redis://.+)\z}si;
51
52						# Bare Redis URL -- no table name -- used to list available keys.
53						# Excludes '\|' so it cannot match the redis:table\|redis://... full spec.
54						Readonly my $REDIS_URL_RE => qr{\Aredis://[^\s\|]+\z}si;
55
56						# Hostname pattern accepted in /../hostname/... remote paths.
57						# Mirrors Database::Abstraction's own host validation regex.
58						# Accepts 'hostname', 'user@hostname', and IPv4 addresses (IPv6 is excluded
59						# because the [...] notation would be ambiguous in the path syntax).
60						Readonly my $REMOTE_HOST_RE => qr/\A(?:[a-zA-Z0-9][a-zA-Z0-9._-]\@)?[a-zA-Z0-9][a-zA-Z0-9._-]\z/;
61
62						# ---------------------------------------------------------------------------
63						# I18N message dictionary for all user-visible strings in this controller.
64						# To plug in a Locale::Maketext backend, extend _i18n() below.
65						# ---------------------------------------------------------------------------
66
67						Readonly my %MESSAGES => (
68						error_table_invalid => 'Invalid table name "%s"',
69						error_table_open => 'Could not open table "%s": %s',
70						error_file_open => 'Could not open "%s": %s',
71						error_no_path => 'No path specified',
72						error_not_found => 'File or directory not found: %s',
73						error_dir_not_found => 'Directory not found: %s',
74						error_write_failed => 'Write failed: %s',
75						error_ext_required => 'Use a .csv, .sql, or .json filename extension',
76						error_upload_none => 'No file received',
77						error_upload_ext => 'Unsupported file type. Accepted: CSV, TSV, PSV, XML, SQLite (.sql, .sqlite, .sqlite3), Berkeley DB (.db), XLSX',
78						error_upload_too_large => 'File too large (maximum %s MiB)',
79						error_upload_save => 'Could not save uploaded file',
80						error_path_required => '"path" parameter is required',
81						error_url_required => 'Please enter a URL',
82						error_url_invalid => '"%s" is not a valid http:// or https:// URL',
83						error_url_fetch => 'Could not load HTML table from "%s": %s',
84						error_url_ssrf => '"%s" resolves to a private or reserved address and cannot be fetched',
85						warn_combine_sort => 'Sorting is applied in memory for /combine; result order may differ from a backend sort',
86						error_sort_column => 'Unknown sort column "%s"',
87						warn_measure_fallback => 'Measure "%s" on column "%s" is not uniformly numeric; totalled in Perl',
88						error_measure_fn => 'Unknown measure function "%s"',
89						error_measure_column => 'Measure column "%s" is not in the view',
90						error_pivot_rows_required => 'At least one rows= dimension is required',
91						error_pivot_measure_req => 'At least one m= measure (col:fn:as) is required',
92						error_pivot_measure_invalid => 'Invalid measure spec "%s"; expected col:fn:as where fn is one of: sum avg min max count count_distinct',
93						error_pivot_dim_not_found => 'Row/column dimension "%s" is not in the view',
94						error_pivot_dim_comma => 'Dimension name "%s" must not contain a comma',
95						error_calc_compile => 'Calculated field "%s": %s',
96						error_calc_name => 'Calculated field name "%s" is not a valid identifier',
97						error_topn_col => 'Top-N column "%s" is not a measure alias in this view',
98						warn_calc_undef => 'Calculated field "%s" returned undef for %d row(s)',
99						error_date_pattern => 'Unsupported date format pattern "%s"; allowed: %%m/%%d/%%Y, %%d/%%m/%%Y, %%d-%%b-%%Y',
100						);
101
102						# Maximum accepted upload body size. Enforced both here (application layer)
103						# and via Mojolicious max_request_size (transport layer) set in startup().
104						# Must match $MAX_REQUEST_SIZE in BI.pm.
105						Readonly my $MAX_UPLOAD_MIB => 50;
106						Readonly my $MAX_UPLOAD_BYTES => $MAX_UPLOAD_MIB * 1_048_576;
107						Readonly my $DEFAULT_JOIN_MAX_ROWS => 10_000;
108						Readonly my $MAX_PREFIX_LEN => 20;
109						Readonly my $DEFAULT_PER_PAGE => 200;
110						Readonly my $MAX_PER_PAGE => 2_000;
111
112						# Valid aggregate function vocabulary shared by _measure, _grouped_totals,
113						# and the /pivot measure-spec parser (Phase 2). Do not add functions here
114						# without a corresponding implementation in _grouped_totals's Perl fold AND
115						# a corresponding entry in the lower-layer aggregate() implementations.
116						Readonly my @MEASURE_FNS => qw(sum avg min max count count_distinct);
117						Readonly my %MEASURE_FN_OK => map { $_ => 1 } @MEASURE_FNS;
118
119						# Allowed strptime-style date format patterns for the /dates/save endpoint.
120						Readonly my %ALLOWED_DATE_PATTERNS => map { $_ => 1 }
121						qw(%m/%d/%Y %d/%m/%Y %d-%b-%Y);
122
123						# ---------------------------------------------------------------------------
124						# Protected helpers
125						# ---------------------------------------------------------------------------
126
127						# _pagination($self) -> ($page, $per_page, $offset)
128						#
129						# Reads ?page= and ?per_page= from the current request, clamps them to sane
130						# ranges, and returns the 1-based page number, the page size, and the
131						# 0-based row offset. Pagination is optional: when neither param is present
132						# per_page defaults to DEFAULT_PER_PAGE.
133						sub _pagination {
134	254			254	326	my $self = $_[0];
135
136	254		67		527	my $per_page = int($self->param('per_page') // $DEFAULT_PER_PAGE);
137	254	50			20175	$per_page = 1 if $per_page < 1;
138	254	50			477	$per_page = $MAX_PER_PAGE if $per_page > $MAX_PER_PAGE;
139	254		100		855	my $page = int($self->param('page') // 1);
140	254	50			5806	$page = 1 if $page < 1;
141	254				362	my $offset = ($page - 1) * $per_page;
142	254				423	return ($page, $per_page, $offset);
143						}
144
145						# _i18n($self, $key, @sprintf_args) -> $string
146						#
147						# Purpose: Look up a user-visible string from %MESSAGES and apply sprintf
148						# for positional arguments. The entry point for future i18n
149						# backend integration (e.g. Locale::Maketext).
150						# Entry: $key must be a key in %MESSAGES; @args are sprintf positionals.
151						# Exit: Returns the formatted string, or a fallback containing $key.
152						sub _i18n :Protected ($self, $key, @args) {
153						my $tmpl = $MESSAGES{$key} // return "Internal error: unknown message key '$key'";
154						return @args ? sprintf($tmpl, @args) : $tmpl;
155	12 12 12			12	5044 10 98	}
156
157						# _is_safe_url($url) -> bool
158						#
159						# Purpose: SSRF guard. Blocks the most dangerous classes of Server-Side Request
160						# Forgery targets: loopback aliases (localhost, 127/8) and literal
161						# private/link-local/CGNAT IPv4 addresses in the URL host component.
162						#
163						# Design rationale for scope:
164						# Resolving hostnames via DNS and checking the result is ineffective: a
165						# separate DNS lookup happens at LWP connect time (TOCTOU / DNS rebinding
166						# window). The authoritative defence against hostname-based SSRF is a
167						# network-layer egress firewall. This function handles the Perl-layer
168						# interception for the most common patterns that operators cannot easily
169						# filter at the network level: bare loopback aliases and literal private IPs
170						# hard-coded by an attacker.
171						#
172						# Blocked targets:
173						# localhost / 127.0.0.0/8 / 0.0.0.0 / ::1 -- loopback aliases
174						# 10.0.0.0/8 -- RFC 1918 private (literal IP)
175						# 172.16.0.0/12 -- RFC 1918 private (literal IP)
176						# 192.168.0.0/16-- RFC 1918 private (literal IP)
177						# 169.254.0.0/16-- link-local; AWS/GCP/Azure metadata endpoint (literal IP)
178						# 100.64.0.0/10 -- CGNAT / Tailscale shared space (literal IP)
179						#
180						# Hostname-based targets (e.g. http://internal.corp.example.com/) are allowed
181						# at this layer; block them with egress firewall rules instead.
182						sub _is_safe_url {
183	121			121	34294	my $url = $_[0];
184
185	121	100			358	return 0 unless $url =~ m{\Ahttps?://([^/:?\[\]#]+)}i;
186	106				141	my $host = lc $1;
187
188						# Block well-known loopback aliases.
189	106	100	80		413	return 0 if $host eq 'localhost'
190						\|\| $host =~ /\A127\./
191						\|\| $host eq '0.0.0.0'
192						\|\| $host eq '::1';
193
194						# For literal IPv4 addresses only: check private/link-local/CGNAT ranges.
195						# Skipping DNS for hostname targets avoids a live network call in tests and
196						# removes the TOCTOU window that makes DNS-resolved checks illusory anyway.
197	79	100			194	return 1 unless $host =~ /\A\d{1,3}(?:\.\d{1,3}){3}\z/;
198
199	59	100			239	my $packed = inet_aton($host) or return 1;
200	58				85	my $n = unpack 'N', $packed;
201
202	58	100			98	return 0 if ($n & 0xFF000000) == 0x0A000000; # 10/8
203	48	100			61	return 0 if ($n & 0xFFF00000) == 0xAC100000; # 172.16/12
204	39	100			49	return 0 if ($n & 0xFFFF0000) == 0xC0A80000; # 192.168/16
205	31	100			46	return 0 if ($n & 0xFFFF0000) == 0xA9FE0000; # 169.254/16 (link-local / metadata)
206	24	100			47	return 0 if ($n & 0xFFC00000) == 0x64400000; # 100.64/10 (CGNAT)
207	16				27	return 1;
208						}
209
210						# _safe_back_url($url) -> $url \| undef
211						#
212						# Purpose: Sanitise a user-supplied back-link URL before it is passed to the
213						# template and rendered inside an href="" attribute. Template Toolkit's
214						# \| html filter encodes <>&" but does NOT block the javascript: or
215						# data: URI schemes, so a raw param('back') = "javascript:alert(1)"
216						# would be rendered verbatim inside the href and execute on click.
217						#
218						# Rule: Only absolute http(s) URLs and root-relative paths (starting with /)
219						# are permitted. Anything else (javascript:, data:, vbscript:, empty
220						# strings, undef) returns undef so the template renders no href.
221						#
222						sub _safe_back_url {
223	649			649	51057	my ($url) = @_;
224	649	100	100		1982	return undef unless defined $url && length($url);
225	61	100			175	return $url if $url =~ m{\A(?:/(?!/)\|https?://)}i;
226	28				55	return undef;
227						}
228
229						# _resolve_template($self) -> ($platform, $language)
230						#
231						# Purpose: Read platform and language from config, then resolve the Accept-Language
232						# header to a language code -- falling back to the config default when
233						# no template directory exists for the resolved language.
234						# Exit: Returns ($platform, $language) -- both guaranteed non-empty strings.
235						sub _resolve_template :Protected ($self) {
236						my $conf = $self->app->config();
237						my $cfg_platform = $conf->{platform} // 'web';
238						my $cfg_language = $conf->{language} // 'en';
239
240						# Detect platform from the request User-Agent via CGI::Info.
241						# Falls back to the configured platform when:
242						# (a) CGI::Info is unavailable or throws, or
243						# (b) no templates/<detected>/ directory exists.
244						my $platform = _detect_platform(
245						$self->req->headers->user_agent // '',
246						$cfg_platform,
247						);
248						unless (-d $self->app->home->child("templates/$platform")) {
249						$platform = $cfg_platform;
250						}
251
252						my $language = $self->_resolve_language($platform, $cfg_language);
253						return ($platform, $language);
254	12 12 12			12	8694 13 54	}
255
256						# _detect_platform($user_agent, $fallback) -> $platform_string
257						#
258						# Purpose: Map a raw User-Agent string to a VWF platform dimension
259						# ('mobile', 'tablet', or 'web') via CGI::Info.
260						# Entry: $user_agent -- the raw HTTP User-Agent header value (may be empty).
261						# $fallback -- value to return if detection fails.
262						# Exit: Returns 'mobile', 'tablet', 'web', or $fallback.
263						# Side Effects: temporarily sets $ENV{HTTP_USER_AGENT} with local().
264	472 472 472 472			472	12175 461 491 371	sub _detect_platform ($user_agent, $fallback) {
265	472				411	my $platform = eval {
266	472				3241	local $ENV{HTTP_USER_AGENT} = $user_agent;
267	472				2300	my $info = CGI::Info->new();
268	472	50 100			1016196	$info->is_mobile() ? 'mobile'
269						: $info->is_tablet() ? 'tablet'
270						: 'web';
271						};
272	472		33		184899	return $platform // $fallback;
273						}
274
275						# _resolve_language($self, $platform, $default) -> $language_code
276						#
277						# Purpose: Determine the best ISO 639-1 language code for this request.
278						# When Accept-Language is present, CGI::Lingua selects the best
279						# match from the languages that have a template directory under
280						# templates/<platform>/. Falls back to $default when the header
281						# is absent, no templates exist for the matched language, or
282						# CGI::Lingua is unavailable.
283						# Entry: $platform is the resolved VWF platform string.
284						# $default is a non-empty fallback language code (e.g. 'en').
285						# Exit: Returns a two-letter ISO 639-1 language code string.
286						# Side Effects: filesystem stats for template directories;
287						# temporarily sets $ENV{HTTP_ACCEPT_LANGUAGE} with local().
288						sub _resolve_language :Protected ($self, $platform, $default) {
289						my $accept = $self->req->headers->accept_language() // '';
290						return $default unless $accept;
291
292						# Discover supported languages from template directories so CGI::Lingua
293						# only returns a code we can actually serve.
294						my $tmpl_base = $self->app->home->child("templates/$platform");
295						my @supported;
296						if (-d $tmpl_base) {
297						@supported = map { Mojo::File->new($_)->basename }
298						grep { -d $_ }
299						@{ $tmpl_base->list({ dir => 1 }) };
300						}
301						push @supported, $default unless grep { $_ eq $default } @supported;
302
303						my $lang = eval {
304						local $ENV{HTTP_ACCEPT_LANGUAGE} = $accept;
305						my $lingua = CGI::Lingua->new(supported => \@supported);
306						$lingua->language_code_alpha2();
307						};
308						$lang //= $default;
309
310						# Confirm a template directory exists for the chosen language.
311						if ($lang ne $default) {
312						my $dir = $self->app->home->child("templates/$platform/$lang");
313						$lang = $default unless -d $dir;
314						}
315						return $lang;
316	12 12 12			12	4513 13 44	}
317
318						# _scan_data_dir($self) -> \@table_list
319						#
320						# Purpose: Return an arrayref of { name, file } hashrefs for every supported
321						# data file in the configured data_dir. Used by the index action and
322						# by the join panel "available tables" dropdown.
323						# Entry: None.
324						# Exit: Returns [] when data_dir does not exist or contains no supported files.
325						# Side Effects: Filesystem directory read.
326						#
327						# Optimisation: single-pass map replaces a two-pass grep+map chain, and calls
328						# basename() only once per entry (the original chain called it twice: once in
329						# grep to check the extension and again in map to extract the stem).
330						# ->to_array avoids the extra flat-list expansion that ->each produced.
331						sub _scan_data_dir :Protected ($self) {
332						my $dir = $self->app->home->child($self->app->config->{data_dir} // 'data');
333						return [] unless -d $dir;
334						return $dir->list->map(sub {
335						my $base = $_->basename;
336						return unless $base =~ $EXT_RE;
337						(my $name = $base) =~ s/\.[^.]+\z//;
338						{ name => $name, file => $base, path => $_->to_string }
339						})->to_array;
340	12 12 12			12	2706 12 41	}
341
342						# _open_spec($self, $spec) -> ($DataSource, $label) or ()
343						#
344						# Purpose: Parse a "table:name" or "path:/abs/path" spec, verify the underlying
345						# file exists (Database::Abstraction creates empty objects silently for
346						# missing files, so we must check ourselves), and return a live
347						# DataSource object and a display label.
348						# Entry: $spec is a non-empty string.
349						# Exit: Returns ($datasource, $label) on success; an empty list on any failure
350						# (invalid spec format, file missing, DataSource init error).
351						# Side Effects: Filesystem stat; DataSource construction (reads file header).
352						sub _open_spec :Protected ($self, $spec) {
353						if ($spec =~ /\Atable:([A-Za-z0-9_]+)\z/) {
354						my $table = lc $1;
355						my $data_dir = $self->app->home->child($self->app->config->{data_dir} // 'data');
356						return () unless grep { -f $data_dir->child("$table.$_") } @SUPPORTED_EXT;
357						my $src = eval { $self->open_table($table, directory => $data_dir->to_string) };
358						return ($src, $table) if $src && !$@;
359						} elsif ($spec =~ /\Apath:(.+)\z/) {
360						my $path_arg = $1;
361						# Remote path: /../hostname/dir/file -- delegate to DataSource with host param.
362						# No EXT_RE check: security comes from REMOTE_HOST_RE. The original
363						# extension (if any) is passed as file_ext so _init_backend tries it first.
364						if ($path_arg =~ m{\A/\.\./([^/]+)((?:/.+)?)/([^/]+)\z}) {
365						my ($host, $dir_part, $file) = ($1, $2 // '', $3);
366						$dir_part = '/' unless length $dir_part;
367						return () unless $host =~ $REMOTE_HOST_RE;
368						my ($table, $ext) = $file =~ /\A(.+)\.([^.]+)\z/ ? ($1, $2) : ($file, undef);
369						my $src = eval { $self->open_table($table, directory => $dir_part, host => $host,
370						defined $ext ? (file_ext => $ext) : ()) };
371						return ($src, $file) if $src && !$@;
372						return ();
373						}
374						my $file = eval { Mojo::File->new($path_arg)->realpath };
375						if (defined $file && -f $file && $file->basename =~ $EXT_RE) {
376						my $dir = $file->dirname->to_string;
377						(my $table = $file->basename) =~ s/\.[^.]+\z//;
378						my $src = eval { $self->open_table($table, directory => $dir) };
379						return ($src, $file->basename) if $src && !$@;
380						}
381						} elsif($spec =~ $URL_SPEC_RE) {
382						my $url = $1;
383						return () unless _is_safe_url($url);
384						my $src = eval { $self->open_table('', url => $url) };
385						return ($src, $src->table_name) if $src && !$@;
386						} elsif($spec =~ $REDIS_SPEC_RE) {
387						my ($table, $redis_url) = ($1, $2);
388						my $src = eval { $self->open_table($table, redis => $redis_url) };
389						return ($src, $table) if $src && !$@;
390						}
391						return ();
392	12 12 12			12	5624 13 43	}
393
394						# _spec_to_url($self, $spec) -> $url_string
395						#
396						# Purpose: Convert a table/path spec back to a browseable URL (used for the
397						# back-link on join and export views).
398						# Entry: $spec is a "table:name" or "path:/abs" string.
399						# Exit: Returns a URL string beginning with '/'.
400						sub _spec_to_url :Protected ($self, $spec) {
401						return "/view/$1" if $spec =~ /\Atable:([A-Za-z0-9_]+)\z/;
402						return '/open?path=' . url_escape($1) if $spec =~ /\Apath:(.+)\z/;
403						return '/import?url=' . url_escape($1) if $spec =~ $URL_SPEC_RE;
404						return '/' if $spec =~ $REDIS_SPEC_RE;
405						return '/';
406	12 12 12			12	2910 12 41	}
407
408						# _url_attribution($self) -> ($url_string, $date_string) or (undef, undef)
409						#
410						# Purpose: Return source URL and access date for chart attribution when the
411						# left table was imported from a web URL. The date is the time of
412						# the current request (which is when the data is being accessed),
413						# formatted as "D Month YYYY".
414						# Entry: Reads the 'l' query param.
415						# Exit: ($url, $date) when the spec matches $URL_SPEC_RE; (undef, undef)
416						# for table: and path: specs.
417						sub _url_attribution :Protected ($self) {
418						my $spec = $self->param('l') // '';
419						return (undef, undef) unless $spec =~ $URL_SPEC_RE;
420						my $url = $1;
421						my @MON = qw(January February March April May June July August
422						September October November December);
423						my (undef, undef, undef, $mday, $mon, $year) = localtime;
424						return ($url, sprintf('%d %s %d', $mday, $MON[$mon], $year + 1900));
425	12 12 12			12	2630 9 37	}
426
427						# _get_columns($source, $records) -> @column_names
428						#
429						# Purpose: Return an ordered column list from a DataSource object.
430						# For CSV/TSV/PSV the DataSource stores the original file-header order.
431						# For SQLite/XML where no file-header order is available, the fallback
432						# is: id_column first (only if it actually appears in the data), then
433						# the remaining columns sorted alphabetically.
434						# Entry: $source is a DataSource; $records is an arrayref of hashrefs (may be empty).
435						# Exit: Returns a flat list of column-name strings (may be empty).
436						#
437						# Reduction: columns() is a pure accessor -- cache once to avoid a redundant
438						# method dispatch on the second reference.
439						sub _get_columns {
440	457			457	14940	my ($source, $records) = @_;
441	457				1080	my $cols = $source->columns;
442	457	100			10912	return @$cols if $cols;
443	15	100			27	return () unless $records->[0];
444	12 27 12				12 38 24	my %all = map { $_ => 1 } keys %{ $records->[0] };
445	12				31	my $c = $source->id_column;
446	12	100	100		51	my $id = ($c && $all{$c}) ? $c : (sort keys %all)[0];
447	12				15	delete $all{$id};
448	12				31	return ($id, sort keys %all);
449						}
450
451						# _apply_filter_spec($records, $spec) -> \@filtered_records
452						#
453						# Purpose: Apply one "col:op:val" filter to an arrayref of record hashrefs and
454						# return a new (possibly shorter) arrayref. The original is not mutated.
455						# Value may contain colons: "col:op:val:with:colons" -- split limit 3
456						# puts everything after the second colon into $val.
457						# Unknown operators fall through to 1 (all rows pass) so new operators
458						# added in future do not break existing callers.
459						# Entry: $records is an arrayref of hashrefs; $spec is a colon-delimited string.
460						# Exit: Returns filtered arrayref (same reference if spec is invalid/unparseable).
461						#
462						# Domain Constraints (operator names):
463						# Operator names are CASE-SENSITIVE. Only the exact lowercase forms below are
464						# recognised; an uppercase or mixed-case name (e.g. "EQ", "Lt") falls through
465						# to the default `1` branch and all rows pass unfiltered.
466						# Valid operators:
467						# String (value comparison is case-insensitive via lc()):
468						# eq, ne, contains, starts
469						# Numeric (Perl <, <=, >, >= coercion):
470						# lt (strict), le (inclusive), gt (strict), ge (inclusive)
471						# Unary (val is ignored):
472						# empty (cell eq ''), notempty (cell ne '')
473						# Boundary rules for numeric operators:
474						# le/ge include the boundary value; lt/gt exclude it.
475						# contains/starts with empty val ('') match every record (index always 0).
476						#
477						# Reduction: split(/:/, $spec, 3) always produces at least one defined element,
478						# so "defined $col" is structurally guaranteed true and is removed.
479						# "$_->{$col} // ''" replaces the equivalent ternary form.
480						#
481						# Optimisation: $lval = lc($val) is computed once before the grep. Without this
482						# precompute, every case-insensitive operator (eq, ne, contains, starts) would
483						# call lc($val) O(N) times for N records -- a pure O(N) waste since $val is
484						# constant within a single filter application.
485						sub _apply_filter_spec {
486	419			419	85633	my ($records, $spec) = @_;
487	419				564	my ($col, $op, $val) = split /:/, $spec, 3;
488	419	100	100 100		957	return $records unless length($col // '') && defined $op && length $op;
489	410		100		350	$val //= '';
490	410				300	my $lval = lc $val; # precompute once; avoids O(N) redundant lc() inside grep
491						return [grep {
492	410 978		100		396 1007	my $cell = $_->{$col} // '';
493	978	100 100 100 100 100 100 100 100 100 100			2664	$op eq 'eq' ? lc($cell) eq $lval :
494						$op eq 'ne' ? lc($cell) ne $lval :
495						$op eq 'contains' ? index(lc($cell), $lval) != -1 :
496						$op eq 'starts' ? index(lc($cell), $lval) == 0 :
497						$op eq 'lt' ? $cell < $val :
498						$op eq 'le' ? $cell <= $val :
499						$op eq 'gt' ? $cell > $val :
500						$op eq 'ge' ? $cell >= $val :
501						$op eq 'empty' ? $cell eq '' :
502						$op eq 'notempty' ? $cell ne '' :
503						1
504						} @$records];
505						}
506
507						# _apply_filters($self, $records) -> ($filtered_records, \@raw_specs, $json_string)
508						#
509						# Purpose: Read all "f=" query params, apply them in order via _apply_filter_spec,
510						# and return: the filtered arrayref, the raw spec strings (for building
511						# export URLs), and a script-safe JSON string for pre-populating the UI.
512						# Entry: $records is an arrayref of hashrefs.
513						# Exit: Three-element list; never croaks. $json_string has '</' escaped to
514						# '<\/' so it is safe to embed directly in a <script> block.
515						#
516						# Reduction: the original code had two sequential loops over @specs -- one to
517						# apply filters, one to parse them for JSON. By Modus Ponens, _apply_filter_spec
518						# returns $records unchanged for a malformed spec (same guard condition), so
519						# skipping the call for malformed specs is equivalent. Merging into one loop
520						# eliminates a full O(n) pass and the redundant split() on every spec.
521						sub _apply_filters :Protected ($self, $records) {
522						my @specs = @{ $self->every_param('f') // [] };
523						my @parsed;
524						for my $s (@specs) {
525						my ($col, $op, $val) = split /:/, $s, 3;
526						next unless length($col // '') && defined $op && length $op;
527						push @parsed, { col => $col, op => $op, val => $val // '' };
528						$records = _apply_filter_spec($records, $s);
529						}
530						my $json = encode_json(\@parsed);
531						$json =~ s{</}{<\\/}g;
532						return ($records, \@specs, $json);
533	12 12 12			12	5224 12 41	}
534
535						# _dedup_records(\@records, \@columns) -> \@unique_records
536						#
537						# Purpose: Remove duplicate rows from $records. Two rows are duplicates when
538						# every column value is identical (string comparison, undef treated as '').
539						# Preserves the order of first occurrence.
540						# Entry: $records is an arrayref of hashrefs; $columns is an arrayref of names.
541						# Exit: Returns a new arrayref; the input is not modified.
542						sub _dedup_records {
543	16			16	28930	my ($records, $columns) = @_;
544	16				11	my (%seen, @out);
545	16				20	for my $row (@$records) {
546	45 100		100		27 112	my $key = join "\x00", map { $row->{$_} // '' } @$columns;
547	45	100			68	push @out, $row unless $seen{$key}++;
548						}
549	16				23	return \@out;
550						}
551
552						# _filter_specs_to_criteria( \@specs, $source ) -> ( \%criteria, \@residual_specs )
553						#
554						# Purpose: Map the f= filter vocabulary onto Database::Abstraction / Database::Join
555						# criteria hashrefs so the backend can apply pushable filters before
556						# paginating. Specs that cannot be safely pushed are returned as
557						# @residual_specs for subsequent in-memory application.
558						#
559						# Pushdown is only performed when $source->dbi_source() confirms a SQL (SQLite)
560						# backend. For CSV (slurp path), in-memory, XLSX, BerkeleyDB and URL sources
561						# everything is placed in @residual_specs so the existing _apply_filter_spec
562						# Perl path handles them.
563						#
564						# Pushable mapping (SQLite only):
565						# eq / ne -- LIKE / NOT LIKE without wildcards. SQLite LIKE is
566						# case-insensitive for ASCII, matching the existing Perl
567						# lc() semantics. Values containing % or _ are pushed to
568						# residual to avoid LIKE metacharacter conflicts.
569						# contains -- LIKE '%val%'. Residual when value contains % or _.
570						# starts -- LIKE 'val%'. Residual when value contains % or _.
571						# lt / le / gt / ge -- SQL numeric comparison. Residual when the value is
572						# not a plain number (avoids column-affinity surprises
573						# with currency or comma-formatted values).
574						# empty / notempty -- Always residual. Must match both SQL NULL and the
575						# literal empty string; cannot be expressed as a single
576						# D::A criterion without an -or grouping.
577						#
578						# Column collision: if a column already has a pushable criterion, the second
579						# spec for that column is placed in @residual_specs. This keeps the AND logic
580						# simple and safe; callers with multiple conditions on one column (e.g. a range)
581						# still get correct results via the in-memory fallback.
582						sub _filter_specs_to_criteria {
583	72			72	32549	my ($specs, $source) = @_;
584
585						# Only push when the source has a live SQL (SQLite) backend.
586	72		100		255	my $is_sql = $source
587						&& $source->can('dbi_source')
588						&& $source->dbi_source();
589	72	100			164302	return ({}, [@$specs]) unless $is_sql;
590
591	20				181	require Scalar::Util;
592	20				26	my (%criteria, @residual);
593
594	20				27	for my $spec (@$specs) {
595	21				59	my ($col, $op, $val) = split /:/, $spec, 3;
596	21	50	50 25		113	next unless length($col // '') && defined $op && length $op;
597	21		50		163	$val //= '';
598
599						# A second spec on the same column goes to residual.
600	21	100			31	if (exists $criteria{$col}) {
601	1				2	push @residual, $spec;
602	1				1	next;
603						}
604
605	20	100 100 100 50 50 100 50	100		55	if ($op eq 'eq' \|\| $op eq 'ne') {
606	15	100			36	if ($val =~ /[%_]/) {
607	1				2	push @residual, $spec;
608						} else {
609	14	100			48	$criteria{$col} = ($op eq 'eq')
610						? { -like => $val }
611						: { -not_like => $val };
612						}
613						} elsif ($op eq 'contains') {
614	1	50			3	if ($val =~ /[%_]/) {
615	0				0	push @residual, $spec;
616						} else {
617	1				3	$criteria{$col} = { -like => "%${val}%" };
618						}
619						} elsif ($op eq 'starts') {
620	1	50			2	if ($val =~ /[%_]/) {
621	0				0	push @residual, $spec;
622						} else {
623	1				4	$criteria{$col} = { -like => "${val}%" };
624						}
625						} elsif ($op eq 'lt') {
626						Scalar::Util::looks_like_number($val)
627	0	0			0	? ($criteria{$col} = { '<' => $val })
628						: push @residual, $spec;
629						} elsif ($op eq 'le') {
630						Scalar::Util::looks_like_number($val)
631	0	0			0	? ($criteria{$col} = { '<=' => $val })
632						: push @residual, $spec;
633						} elsif ($op eq 'gt') {
634						Scalar::Util::looks_like_number($val)
635	2	100			8	? ($criteria{$col} = { '>' => $val })
636						: push @residual, $spec;
637						} elsif ($op eq 'ge') {
638						Scalar::Util::looks_like_number($val)
639	0	0			0	? ($criteria{$col} = { '>=' => $val })
640						: push @residual, $spec;
641						} else {
642						# empty, notempty, unknown operator: always residual.
643	1				2	push @residual, $spec;
644						}
645						}
646
647	20				57	return (\%criteria, \@residual);
648						}
649
650						# ---------------------------------------------------------------------------
651						# Phase 1 semantic-layer helpers
652						# ---------------------------------------------------------------------------
653
654						# _measure($fn, $col, $as) -> \%measure
655						#
656						# Build one measure descriptor in the vocabulary shared by Database::Abstraction
657						# and Database::Join (sum\|avg\|min\|max\|count\|count_distinct). $col is the
658						# source column name, or undef for COUNT(*). $as is the result-row key.
659						# The returned hashref is consumed directly by aggregate(measures => [...]).
660						sub _measure {
661	84			84	259	my ($fn, $col, $as) = @_;
662	84	100			268	return { fn => $fn, (defined $col ? (col => $col) : ()), as => $as };
663						}
664
665						# _numeric_cell($v) -> $number \| undef
666						#
667						# Extract a numeric value from a raw cell, handling currency prefixes
668						# (e.g. $1,234.56) and accounting-notation negatives ((1,234.56) -> -1234.56).
669						# Returns undef for empty, undef, or non-numeric input.
670						# Used by the Perl fold path of _grouped_totals so all four chart routes
671						# share one extraction function.
672						sub _numeric_cell {
673	188			188	160	my $v = shift;
674	188	100	67		317	return undef unless defined $v && length($v);
675	186				194	my $is_acct_neg = ($v =~ /\A\s*\(/);
676	186				257	(my $n = $v) =~ s/[^\d.\-]//g;
677	186	100	67		231	$n = "-$n" if $is_acct_neg && $n =~ /\A\d/;
678	186	100			329	return undef unless $n =~ /\A-?\d+(?:\.\d+)?\z/;
679	163				223	return $n + 0;
680						}
681
682						# _measure_pushable($source, $fn, $col, \@records) -> bool
683						#
684						# Returns true when the measure can be computed by aggregate() on $source and
685						# the result will be identical to the Perl fold. False means use the Perl fold.
686						#
687						# Decision table:
688						# count / count_distinct -- always pushable (no numeric coercion).
689						# sum / avg / min / max -- only when every sampled value in $col is either
690						# a plain number (looks_like_number) or empty/undef.
691						# Currency symbols or accounting parentheses in any
692						# value force the Perl fold, which strips them
693						# correctly; SQLite CAST would coerce them to 0.
694						# Missing $source -- never pushable.
695						# Missing $col -- sum/avg/min/max are not pushable without a column.
696						sub _measure_pushable {
697	88			88	150	my ($source, $fn, $col, $records) = @_;
698	88	50	33		237	return 0 unless $source && $source->can('aggregate');
699	88	100	67		765	return 1 if $fn eq 'count' \|\| $fn eq 'count_distinct';
700	69	50			93	return 0 unless defined $col;
701						# For sum/avg/min/max, only push when at least one value is a plain number
702						# and every non-null/non-blank value passes looks_like_number.
703						#
704						# Two cases where both paths must agree:
705						# - All values undef/blank: Perl fold produces no rows; SQL SUM(NULL)
706						# produces NULL, normalised to 0 by D::A â†’ discrepancy. Return 0 so
707						# the Perl fold runs and yields the expected "No plottable data" result.
708						# - Currency/accounting notation (e.g. ($1,234)): _numeric_cell strips
709						# these correctly; SQL sees non-numeric text â†’ SUM = NULL â†’ 0. Return 0
710						# so _numeric_cell is used on every value.
711	69				213	require Scalar::Util;
712	69				66	my $found = 0;
713	69 69		50		69 126	for my $row (@{ $records // [] }) {
714	265				202	my $v = $row->{$col};
715	265	100	67		342	next unless defined $v && length($v); # undef/blank: same effect as NULL
716	263	100			309	return 0 unless Scalar::Util::looks_like_number($v);
717	246				170	$found = 1;
718						}
719	52				101	return $found; # 0 (false) when every sampled value was undef or blank
720						}
721
722						# _parse_measure_param($spec_str) -> \%measure \| undef
723						#
724						# Parse 'col:fn:as' into { col => ..., fn => ..., as => ... }.
725						# Shared dialect for /pivot (Phase 2) so it does not invent a second format.
726						# Returns undef for an invalid or unrecognised spec.
727						sub _parse_measure_param {
728	25			25	32	my $str = shift;
729	25	50	33		117	return undef unless defined $str && length($str);
730	25				76	my ($col, $fn, $as) = split /:/, $str, 3;
731	25	50	20		176	return undef unless defined $fn && defined $as && length($fn) && length($as);
732	25				44	$fn = lc $fn;
733	25	100			127	return undef unless $MEASURE_FN_OK{$fn};
734	24				180	return { col => $col, fn => $fn, as => $as };
735						}
736
737						# _grouped_totals($self, \%pipeline, \%spec) -> \@rows
738						#
739						# Single GROUP BY entry point for all four chart routes. Returns an arrayref
740						# of hashrefs, each containing the 'by' column values and the aggregate result
741						# under $spec->{as}.
742						#
743						# $pipeline = { source => $src_or_undef, records => \@rows }
744						# source -- a DataSource or Database::Join for the push path; undef when
745						# the pipeline is a /combine union (must fold in Perl).
746						# records -- the already-fetched rows (pre-filtered by the caller).
747						#
748						# $spec = { by => [...], fn => ..., val => ..., as => ..., [sort_by, having, limit, offset] }
749						#
750						# Dispatch:
751						# Push path -- $source is defined, no active f= filters, measure is pushable
752						# (checked by _measure_pushable). Calls $source->aggregate().
753						# Phase 1 does not push filter criteria (that is Phase 0.3);
754						# when f= filters are active the Perl fold is always used.
755						# Perl fold -- Iterates $pipeline->{records} (pre-filtered) directly.
756						#
757						# $ENV{BI_FORCE_PERL_AGG}: set to a true value in tests to force the Perl fold
758						# regardless of source type, enabling cross-backend equivalence assertions.
759						sub _grouped_totals :Protected ($self, $pipeline, $spec) {
760						my $source = $pipeline->{source};
761						my $records = $pipeline->{records} // [];
762						my $by = $spec->{by} // [];
763						my $fn = lc($spec->{fn} // 'count');
764						my $val_col = $spec->{val};
765						my $as = $spec->{as} // 'value';
766
767						# Push path: use backend aggregate() when safe.
768						# Active f= filters block the push path in Phase 1 because
769						# _filter_specs_to_criteria is a stub that cannot push criteria to SQL yet.
770						my @f_specs = grep { /\S/ } @{ $self->every_param('f') // [] };
771						my $has_filter = !!@f_specs;
772
773						# SQL::Statement 1.414 (the SQL engine under DBD::CSV) uses
774						# "use warnings FATAL => 'all'" and calls join("\0", @row[@keycols])
775						# inside getAffectedResult without guarding against undef. When a GROUP BY
776						# column contains blank CSV cells (empty_is_undef => 1 converts them to
777						# undef), the join triggers a fatal "uninitialized value" exception and the
778						# execute() call dies. The correct fix is to use
779						# map { $_ // '' } @row[@keycols]
780						# in SQL::Statement::getAffectedResult, but the module has been unmaintained
781						# since 2020 (21 open RT tickets as of 2026-10).
782						# See: https://rt.cpan.org/Ticket/Display.html?id=181946
783						# Skip the push path whenever any 'by' column has a blank or undef value so
784						# DBD::CSV/SQL::Statement is never asked to GROUP BY a null key.
785						# TODO: remove this guard once SQL-Statement RT#181946 is fixed (last checked: 1.414).
786						my $has_null_by_key = @$by && do {
787						my $found;
788						KEY_SCAN: for my $row (@$records) {
789						for my $col (@$by) {
790						my $v = $row->{$col};
791						if (!defined($v) \|\| !length($v)) { $found = 1; last KEY_SCAN; }
792						}
793						}
794						$found;
795						};
796
797						unless ($ENV{BI_FORCE_PERL_AGG} \|\| $has_filter \|\| $has_null_by_key \|\| !$source
798						\|\| !_measure_pushable($source, $fn, $val_col, $records)) {
799						my $m = _measure($fn, $val_col, $as);
800						my $agg_rows = eval {
801						$source->aggregate(
802						by => $by,
803						measures => [$m],
804						($spec->{sort_by} ? (sort_by => $spec->{sort_by}) : ()),
805						($spec->{having} ? (having => $spec->{having}) : ()),
806						($spec->{limit} ? (limit => $spec->{limit}) : ()),
807						($spec->{offset} ? (offset => $spec->{offset}) : ()),
808						)
809						};
810						unless ($@) {
811						return $agg_rows // [];
812						}
813						carp "aggregate() push failed: $@; falling back to Perl fold";
814						}
815
816						# Perl fold over pre-filtered records.
817						my (%seen_warned, %seen_key, @key_order);
818						my (%totals, %count_map, %distinct_vals);
819
820						for my $row (@$records) {
821						# Skip rows where any 'by' column is empty/undef (mirrors SQL GROUP BY NULL exclusion).
822						# Note: calc field columns store '(unparseable)' (not undef) for failed expressions,
823						# so those rows pass this guard and appear in the (unparseable) group instead.
824						my @key_parts = map { $row->{$_} // '' } @$by;
825						next if @$by && grep { !length($_) } @key_parts;
826						my $key = join("\x00", @key_parts);
827
828						if ($fn eq 'count') {
829						push @key_order, $key unless $seen_key{$key}++;
830						$totals{$key}++;
831						} elsif ($fn eq 'count_distinct') {
832						push @key_order, $key unless $seen_key{$key}++;
833						my $dv = defined $val_col ? ($row->{$val_col} // '') : '';
834						$distinct_vals{$key}{$dv}++;
835						} else {
836						my $v = defined $val_col ? ($row->{$val_col} // '') : '';
837						my $n = _numeric_cell($v);
838						unless (defined $n) {
839						unless ($seen_warned{"$fn\x01" . ($val_col // '')}++) {
840						carp $self->_i18n('warn_measure_fallback', $fn, $val_col // '(none)');
841						}
842						next; # skip: do NOT add key to order for non-numeric rows
843						}
844						push @key_order, $key unless $seen_key{$key}++;
845						if ($fn eq 'sum') { $totals{$key} += $n }
846						elsif ($fn eq 'avg') { $totals{$key} += $n; $count_map{$key}++ }
847						elsif ($fn eq 'min') { $totals{$key} = (!exists $totals{$key} \|\| $n < $totals{$key}) ? $n : $totals{$key} }
848						elsif ($fn eq 'max') { $totals{$key} = (!exists $totals{$key} \|\| $n > $totals{$key}) ? $n : $totals{$key} }
849						}
850						}
851
852						if ($fn eq 'avg') {
853						for my $k (keys %totals) {
854						$totals{$k} = $count_map{$k} ? $totals{$k} / $count_map{$k} : undef;
855						}
856						} elsif ($fn eq 'count_distinct') {
857						for my $k (@key_order) {
858						$totals{$k} = scalar keys %{ $distinct_vals{$k} // {} };
859						}
860						}
861
862						# Assemble result rows in first-seen (insertion) order.
863						my @result;
864						for my $key (@key_order) {
865						my @parts = @$by ? (split /\x00/, $key, scalar @$by) : ();
866						my %row;
867						for my $i (0 .. $#$by) {
868						$row{$by->[$i]} = $parts[$i];
869						}
870						$row{$as} = $totals{$key} // ($fn =~ /\A(?:sum\|count\|count_distinct)\z/ ? 0 : undef);
871						push @result, \%row;
872						}
873
874						return \@result;
875	12 12 12			12	15062 13 50	}
876
877						# _fetch_page( $self, $source, \%params ) -> ( $records, $has_next )
878						# params: per_page -- page size (required)
879						# offset -- 0-based row offset (required)
880						# dedup -- truthy when ?d=1 dedup is requested
881						# sort_col -- column name to sort by (optional)
882						# sort_dir -- 'asc' or 'desc' (default 'asc'; ignored unless sort_col set)
883						#
884						# Purpose: Fetch and reduce one page of records from $source, honouring the
885						# reduce-before-paginate ordering contract. Two modes:
886						#
887						# Fast path (no f= filters, no dedup): uses the N+1 trick
888						# selectall_arrayref(limit => per_page+1, offset => offset). has_next is
889						# determined by the extra row before it is popped.
890						#
891						# Reduction path (f= filters or dedup present): materialises the full result
892						# in memory, applies all f= filters with _apply_filter_spec (case-insensitive),
893						# applies dedup if requested, then paginates in Perl. This guarantees that
894						# the Nth page contains the Nth page of the reduced set, not the Nth page
895						# of the raw set reduced to fewer rows. Memory cost: the full reduced set.
896						#
897						# Sort: sort_col/sort_dir are forwarded to selectall_arrayref as
898						# sort_by => [$sort_col, $sort_dir]. Both Database::Abstraction 0.49+
899						# and Database::Join 0.009.0 honour this parameter natively.
900						#
901						# Returns (undef, 0) when the underlying fetch throws; the caller must handle
902						# $records being undef.
903						sub _fetch_page :Protected ($self, $source, $params) {
904						my $per_page = $params->{per_page};
905						my $offset = $params->{offset};
906						my $dedup = $params->{dedup};
907						my $sort_col = $params->{sort_col};
908						my $sort_dir = ($params->{sort_dir} // 'asc') =~ /\Adesc\z/i ? 'desc' : 'asc';
909
910						# sort_by args forwarded to the backend when a sort column is requested.
911						# D::A 0.49+ and D::J 0.009.0 both support sort_by => [$col, $dir].
912						my @sort_args = $sort_col ? (sort_by => [$sort_col, $sort_dir]) : ();
913
914						# Collect and validate f= specs.
915						my @f_specs = grep {
916						my ($c, $o) = split /:/, $_, 3;
917						length($c // '') && defined $o && length $o;
918						} @{ $self->every_param('f') // [] };
919
920						unless (@f_specs \|\| $dedup) {
921						# Fast path: no filters, no dedup. Let the backend paginate via N+1 trick.
922						# Copy before pop: D::A may return a read-only ref to its internal cache.
923						my @records = @{ $source->selectall_arrayref(
924						limit => $per_page + 1, offset => $offset, @sort_args,
925						) // [] };
926						my $has_next = (@records > $per_page) ? 1 : 0;
927						pop @records if $has_next;
928						return (\@records, $has_next);
929						}
930
931						# Criteria pushdown: translate as many f= specs as possible into SQL
932						# criteria (_filter_specs_to_criteria returns a criteria hashref and a
933						# residual list for any spec that cannot be safely pushed to SQL).
934						my ($criteria, $residual) = _filter_specs_to_criteria(\@f_specs, $source);
935						my $has_criteria = %$criteria;
936
937						# Full-pushdown fast path: all specs translated, no dedup.
938						# Use N+1 trick with SQL criteria + LIMIT/OFFSET -- avoids full-table fetch.
939						# Copy before pop: D::A may return a read-only ref to its internal cache.
940						if (!$dedup && !@$residual) {
941						my @records = @{ $source->selectall_arrayref(
942						%$criteria, limit => $per_page + 1, offset => $offset, @sort_args,
943						) // [] };
944						my $has_next = (@records > $per_page) ? 1 : 0;
945						pop @records if $has_next;
946						return (\@records, $has_next);
947						}
948
949						# Partial-pushdown / dedup path: fetch the SQL-filtered (and sorted) set,
950						# apply residual specs and/or dedup in Perl, then paginate the reduced set.
951						# Memory cost: the full reduced set.
952						my $all = $has_criteria
953						? $source->selectall_arrayref(%$criteria, @sort_args)
954						: $source->selectall_arrayref(@sort_args);
955						$all //= [];
956
957						$all = _apply_filter_spec($all, $_) for @$residual;
958
959						if ($dedup) {
960						my $cols = $source->columns;
961						my @dcols = $cols ? @$cols : (keys %{ $all->[0] // {} });
962						$all = _dedup_records($all, \@dcols);
963						}
964
965						my $total = scalar @$all;
966						my $has_next = ($total > $offset + $per_page) ? 1 : 0;
967						my @page = splice(@$all, $offset, $per_page);
968
969						return (\@page, $has_next);
970	12 12 12			12	5728 11 45	}
971
972						# _combine_tables(\@sources) -> (\@merged_records, \@merged_columns)
973						#
974						# Purpose: Perform a vertical stack (UNION ALL equivalent) of two or more
975						# record sets. The merged column list is the union of all source
976						# column lists: the first source's columns appear first (in their
977						# original order), then each subsequent source contributes any new
978						# column names it introduces, in order. Where a source does not
979						# have a particular column, its rows receive an empty string for
980						# that column.
981						# Entry: $sources is an arrayref of [$records_aref, $columns_aref] pairs.
982						# At least one element is required; a single-element call returns
983						# that element's data unchanged (no allocation beyond the column copy).
984						# Exit: Returns (\@merged_records, \@merged_columns).
985						# Side Effects: None; allocates new record hashrefs (original rows are not mutated).
986						sub _combine_tables {
987	23			23	16777	my ($sources) = @_;
988
989						# Build the unified column order: first source's columns first, then any
990						# new columns introduced by each subsequent source in their file order.
991	23				22	my (@all_cols, %seen);
992	23				32	for my $src (@$sources) {
993	43 43				37 41	for my $col (@{ $src->[1] }) {
994	129	100			157	push @all_cols, $col unless $seen{$col}++;
995						}
996						}
997
998	23				23	my @merged;
999	23				26	for my $src (@$sources) {
1000	43				39	my ($recs, $cols) = @$src;
1001	43 129				46 128	my %has_col = map { $_ => 1 } @$cols;
1002	43				42	for my $row (@$recs) {
1003	161				97	my %new_row;
1004						$new_row{$_} = $has_col{$_} ? ($row->{$_} // '') : ''
1005	161	100	50		575	for @all_cols;
1006	161				144	push @merged, \%new_row;
1007						}
1008						}
1009
1010	23				40	return (\@merged, \@all_cols);
1011						}
1012
1013						# _csv_row(@fields) -> $csv_line_with_crlf
1014						#
1015						# Purpose: Format one row as an RFC 4180 CSV line. Fields containing commas,
1016						# double-quotes, or newlines are enclosed in double-quotes; embedded
1017						# double-quotes are doubled. The line ends with CRLF.
1018						# Entry: @fields may contain undef (treated as empty string).
1019						# Exit: Returns a string ending with "\r\n".
1020						sub _csv_row {
1021						return join(',', map {
1022	381 1966		100	381	13933 1335	my $f = $_ // '';
1023	1966 12 12	100			2052 18 25	$f =~ /[,"\r\n]/ ? do { (my $q = $f) =~ s/"/""/g; qq{"$q"} } : $f;
1024						} @_) . "\r\n";
1025						}
1026
1027						# _build_export_url($self, $left_spec, \@join_specs, \@filter_specs) -> $url_string
1028						#
1029						# Purpose: Assemble a /export?l=...&j=...&f=... URL string for the current
1030						# logical view. The caller must apply \| html in TT to escape & as &.
1031						# Entry: All args non-undef; spec arrays may be empty.
1032						# Exit: Returns a relative URL string beginning with '/export'.
1033						sub _build_export_url :Protected ($self, $left_spec, $join_specs, $filter_specs, $combine_specs = undef, $dedup = 0) {
1034						my $u = '/export?l=' . url_escape($left_spec);
1035						$u .= '&j=' . url_escape($_) for @$join_specs;
1036						$u .= '&c=' . url_escape($_) for @{ $combine_specs // [] };
1037						$u .= '&f=' . url_escape($_) for @$filter_specs;
1038						$u .= '&d=1' if $dedup;
1039						return $u;
1040	12 12 12			12	5367 12 48	}
1041
1042						# _list_dir($self, $dir, $want_files) -> { dirs => [...], files => [...] }
1043						#
1044						# Purpose: Shared directory-listing kernel used by browse (which needs files)
1045						# and dirs_api (which needs only subdirectories). Hidden entries
1046						# (names starting with ".") are excluded. Entries are sorted
1047						# case-insensitively.
1048						# Entry: $dir is a Mojo::File pointing to an existing readable directory.
1049						# $want_files: if true, populate 'files' with entries matching $EXT_RE.
1050						# Exit: Returns a hashref with 'dirs' and 'files' arrayrefs (files is always
1051						# present but empty when $want_files is false).
1052						# Side Effects: Filesystem directory read.
1053						sub _list_dir :Protected ($self, $dir, $want_files) {
1054						my (@dirs, @files);
1055						if (opendir my $dh, $dir->to_string) {
1056						while (my $entry = readdir $dh) {
1057						next if $entry eq '.' \|\| $entry eq '..' \|\| $entry =~ /\A\./;
1058						my $f = $dir->child($entry);
1059						if (-d $f) {
1060						push @dirs, { name => $entry, path => $f->to_string };
1061						}
1062						elsif ($want_files && $entry =~ $EXT_RE) {
1063						push @files, { name => $entry, path => $f->to_string };
1064						}
1065						}
1066						closedir $dh;
1067						}
1068						return {
1069						dirs => [ sort { lc($a->{name}) cmp lc($b->{name}) } @dirs ],
1070						files => [ sort { lc($a->{name}) cmp lc($b->{name}) } @files ],
1071						};
1072	12 12 12			12	4083 8 44	}
1073
1074						# _write_sqlite_db($self, $records, $columns) -> $raw_bytes
1075						#
1076						# Purpose: Write $records to an in-process SQLite database (single table named
1077						# "data"; every column declared TEXT) and return the raw file bytes.
1078						# The temporary file is created, written, read, and then unlinked in
1079						# one synchronous sequence. Used by both _render_sqlite (HTTP download)
1080						# and export_write (filesystem write) to eliminate code duplication.
1081						# Entry: $records is an arrayref of hashrefs; $columns is an arrayref of names.
1082						# Exit: Returns scalar binary string. Croaks on any DBI error.
1083						# Side Effects: Creates and unlinks one temporary file under system tmpdir.
1084						sub _write_sqlite_db :Protected ($self, $records, $columns) {
1085						# D~ fix: an empty column list produces "CREATE TABLE data ()" which is
1086						# invalid SQLite syntax. Croak before touching the filesystem.
1087						croak 'Cannot export SQLite: result set has no columns'
1088						unless @$columns;
1089
1090						require DBI;
1091						my ($tmp_fh, $tmpfile) = tempfile(SUFFIX => '.db', UNLINK => 0);
1092						close $tmp_fh;
1093
1094						my $dbh = eval { DBI->connect("dbi:SQLite:dbname=$tmpfile", '', '', {
1095						RaiseError => 1, AutoCommit => 1,
1096						}) };
1097						# Guard both the eval-caught die ($@) and the undef-without-die edge case.
1098						if ($@ \|\| !$dbh) {
1099						unlink $tmpfile;
1100						croak "DBI connect failed: $@";
1101						}
1102
1103						# O~ fix: wrap all DBI work in eval so any mid-flight exception still
1104						# triggers cleanup (disconnect + unlink) before the error propagates.
1105						eval {
1106						my @quoted = map { (my $c = $_) =~ s/"/""/g; qq{"$c"} } @$columns;
1107						$dbh->do('CREATE TABLE "data" (' . join(', ', map { "$_ TEXT" } @quoted) . ')');
1108						if (@$records) {
1109						my $ph = join(', ', ('?') x scalar @$columns);
1110						my $sth = $dbh->prepare(
1111						'INSERT INTO "data" (' . join(', ', @quoted) . ") VALUES ($ph)"
1112						);
1113						for my $row (@$records) {
1114						$sth->execute(map { $row->{$_} } @$columns);
1115						}
1116						}
1117						$dbh->disconnect;
1118						};
1119						if (my $err = $@) {
1120						eval { $dbh->disconnect }; # best-effort; may already be disconnected
1121						unlink $tmpfile;
1122						croak $err;
1123						}
1124
1125						my $data = Mojo::File->new($tmpfile)->slurp;
1126						unlink $tmpfile;
1127						return $data;
1128	12 12 12			12	5159 11 42	}
1129
1130						# _run_pipeline_source($self) -> ($src, $records, \@columns, $left_label) or ()
1131						#
1132						# Purpose: Inner pipeline: opens the left spec, builds the join chain, fetches
1133						# all rows, and runs any c= combine step. Does NOT apply f= filters,
1134						# dedup, or pagination -- that is the caller's responsibility.
1135						# Chart routes call this directly so they can access $src for the
1136						# Phase 1 aggregate() push path. Row-viewing routes and export routes
1137						# call the thin _run_export_pipeline wrapper instead.
1138						# Exit: On success: ($src_or_undef, $records_aref, $columns_aref, $label).
1139						# $src is undef when a c= combine makes the result non-aggregatable.
1140						# On failure: empty list (left table not found / fetch error).
1141						sub _run_pipeline_source :Protected ($self) {
1142						my $left_spec = $self->param('l') // '';
1143						my ($left_src, $left_label) = $self->_open_spec($left_spec);
1144						return () unless $left_src;
1145
1146						# Build the join chain lazily.
1147						my $max_rows = $self->app->config('join_max_rows') // $DEFAULT_JOIN_MAX_ROWS;
1148						my $join_type = $self->param('jtype') // 'left';
1149						$join_type = 'left' unless $join_type =~ /\A(?:left\|inner\|outer)\z/;
1150						my $src = $left_src;
1151						my @schema_warnings;
1152						for my $jspec (@{ $self->every_param('j') }) {
1153						my ($right_spec, $left_key, $right_key) = split /\\|/, $jspec, 3;
1154						next unless defined $right_spec && defined $left_key && defined $right_key;
1155
1156						my $cur_cols = $src->columns;
1157						next unless $cur_cols;
1158						next unless +{ map { $_ => 1 } @$cur_cols }->{$left_key};
1159
1160						my ($right_src, $right_label) = $self->_open_spec($right_spec);
1161						next unless $right_src;
1162
1163						my $right_cols = $right_src->columns;
1164						next unless $right_cols;
1165						next unless +{ map { $_ => 1 } @$right_cols }->{$right_key};
1166
1167						require Database::Join;
1168						local $SIG{__WARN__} = sub { push @schema_warnings, $_[0] };
1169						$src = Database::Join->new(
1170						databases => [$src, $right_src],
1171						join_column => $left_key,
1172						backend => 'auto',
1173						max_array_rows => $max_rows,
1174						join_type => $join_type,
1175						($left_key ne $right_key ? (join_map => {1 => $right_key}) : ()),
1176						($right_label ? (collision_prefix => {1 => $right_label}) : ()),
1177						);
1178						}
1179
1180						$self->stash(schema_warnings => \@schema_warnings) if @schema_warnings;
1181
1182						my $records = eval { $src->selectall_arrayref };
1183						return () if $@;
1184						$records //= [];
1185						my @columns = _get_columns($src, $records);
1186
1187						# Combine (vertical stack): sets $src = undef since the result is a union
1188						# with no single aggregatable object.
1189						my @cspecs = @{ $self->every_param('c') // [] };
1190						if (@cspecs) {
1191						my @sources = ([$records, \@columns]);
1192						for my $cspec (@cspecs) {
1193						my ($csrc) = $self->_open_spec($cspec);
1194						next unless $csrc;
1195						my $crecs = eval { $csrc->fetch_all } // [];
1196						next if $@;
1197						my @ccols = _get_columns($csrc, $crecs);
1198						push @sources, [$crecs, \@ccols];
1199						}
1200						if (@sources > 1) {
1201						($records, my $new_cols) = _combine_tables(\@sources);
1202						@columns = @$new_cols;
1203						$src = undef; # union: no single aggregatable source
1204						}
1205						}
1206
1207						return ($src, $records, \@columns, $left_label);
1208	12 12 12			12	6277 11 42	}
1209
1210						# _apply_date_normalization($self, $records, \@columns, $spec_key) -> void
1211						#
1212						# Reads date_patterns from .bi/models.json for $spec_key and normalises each
1213						# configured column's values to ISO-8601 in-place. A value that does not match
1214						# the stored pattern is left unchanged so YEAR/MONTH/etc. return undef (and the
1215						# row falls into the '(unparseable)' bucket in _grouped_totals).
1216						# Called at the top of _apply_calc_fields so registered patterns are applied
1217						# before any calc expression is evaluated.
1218						sub _apply_date_normalization :Protected ($self, $records, $columns, $spec_key) {
1219						return unless defined $spec_key && length $spec_key;
1220						my $models = $self->_read_models;
1221						my $patterns = $models->{date_patterns}{$spec_key};
1222						return unless $patterns && %{$patterns};
1223						my %col_set = map { $_ => 1 } @{$columns};
1224						require Database::BI::Calc;
1225						for my $col (keys %{$patterns}) {
1226						next unless $col_set{$col};
1227						my $pat = $patterns->{$col};
1228						for my $row (@{$records}) {
1229						my $v = $row->{$col};
1230						next unless defined $v && length $v;
1231						# Only overwrite when normalisation succeeds; leave unchanged on
1232						# mismatch so the row lands in the '(unparseable)' group.
1233						my $iso = Database::BI::Calc::date_normalise($v, $pat);
1234						$row->{$col} = $iso if defined $iso;
1235						}
1236						}
1237	12 12 12			12	4225 21 42	}
1238
1239						# _apply_calc_fields($self, $records, \@columns) -> ($records, \@columns)
1240						#
1241						# Reads ?c=<name>:<expression> params (those NOT matching a path:/table:/url:/redis:
1242						# source spec) and compiles each via Database::BI::Calc. Evaluates per row,
1243						# appending the virtual column to each row hashref. Croaks on compile error
1244						# (caller renders 400); runtime undef values are logged at warn level.
1245						# Later ?c= specs may reference names defined by earlier ones (evaluated in order).
1246						sub _apply_calc_fields :Protected ($self, $records, $columns) {
1247						# Normalise date columns before evaluating expressions so that date
1248						# functions (YEAR, MONTH, etc.) see ISO-8601 values even when the source
1249						# file uses a non-ISO format (e.g. M/D/YYYY).
1250						$self->_apply_date_normalization($records, $columns, $self->param('l'));
1251
1252						# Build calc spec list: stored fields from models.json first (lower priority),
1253						# then URL ?c= params (higher priority â€” they override stored fields of the
1254						# same name so the user can test a new expression without permanently saving).
1255						my (@calc_specs, %seen_calc);
1256						{
1257						my $sk = $self->param('l') // '';
1258						if (length $sk) {
1259						my $stored = ($self->_read_models)->{fields}{$sk} // {};
1260						for my $n (sort keys %{$stored}) {
1261						push @calc_specs, { name => $n, expr => $stored->{$n} };
1262						$seen_calc{$n} = $#calc_specs;
1263						}
1264						}
1265						}
1266						for my $spec (@{ $self->every_param('c') // [] }) {
1267						# Skip source specs handled by _run_pipeline_source.
1268						next if $spec =~ /\A(?:path:\|table:\|url:\|redis:)/i;
1269						my ($name, $expr) = ($spec =~ /\A([A-Za-z_][A-Za-z0-9_]*):(.+)\z/s);
1270						next unless defined $name && defined $expr;
1271						if (exists $seen_calc{$name}) {
1272						$calc_specs[$seen_calc{$name}]{expr} = $expr; # URL overrides stored
1273						} else {
1274						push @calc_specs, { name => $name, expr => $expr };
1275						$seen_calc{$name} = $#calc_specs;
1276						}
1277						}
1278
1279						my @cols = @{$columns};
1280
1281						if (@calc_specs) {
1282						require Database::BI::Calc;
1283						for my $cs (@calc_specs) {
1284						my $name = $cs->{name};
1285						my $calc = Database::BI::Calc->new(expr => $cs->{expr}, columns => \@cols);
1286						croak $self->_i18n('error_calc_compile', $name, $calc->error)
1287						if $calc->has_error;
1288
1289						my $undef_count = 0;
1290						for my $row (@{$records}) {
1291						my $val = $calc->evaluate($row);
1292						# Store '(unparseable)' rather than undef so that pivot/bar
1293						# grouping (which skips empty-string keys) keeps these rows in a
1294						# visible '(unparseable)' bucket rather than silently dropping them.
1295						$row->{$name} = defined $val ? $val : '(unparseable)';
1296						$undef_count++ unless defined $val;
1297						}
1298						if ($undef_count) {
1299						$self->app->log->warn(
1300						$self->_i18n('warn_calc_undef', $name, $undef_count)
1301						);
1302						}
1303						push @cols, $name unless grep { $_ eq $name } @cols;
1304						}
1305						}
1306
1307						# Apply named value groups from models.json.
1308						# For each source column that has groups registered under the current l=
1309						# spec, add a virtual "${col}_group" column to every row. Each row's value
1310						# is mapped to its group label; values not in any group become '(other)'.
1311						{
1312						my $spec_key = $self->param('l') // '';
1313						if (length $spec_key) {
1314						my $models = $self->_read_models;
1315						my $grps = $models->{groups}{$spec_key};
1316						if ($grps && %{$grps}) {
1317						my %col_set = map { $_ => 1 } @cols;
1318						for my $col (sort keys %{$grps}) {
1319						next unless $col_set{$col};
1320						# Build reverse map: value -> group label.
1321						my %val2group;
1322						for my $gname (keys %{$grps->{$col}}) {
1323						for my $v (@{$grps->{$col}{$gname}}) {
1324						$val2group{$v} = $gname;
1325						}
1326						}
1327						my $vcol = "${col}_group";
1328						for my $row (@{$records}) {
1329						my $v = $row->{$col} // '';
1330						$row->{$vcol} = $val2group{$v} // '(other)';
1331						}
1332						push @cols, $vcol unless grep { $_ eq $vcol } @cols;
1333						}
1334						}
1335						}
1336						}
1337
1338						return ($records, \@cols);
1339	12 12 12			12	8276 14 49	}
1340
1341						# ---------------------------------------------------------------------------
1342						# Calculated-field model storage (.bi/models.json)
1343						# ---------------------------------------------------------------------------
1344
1345						# _calc_models_path($self) -> $path_string_or_undef
1346						#
1347						# Returns the path to .bi/models.json (creating .bi/ on first call), or undef
1348						# when the write must be skipped (data_dir safety guard, mkdir failure).
1349						sub _calc_models_path :Protected ($self) {
1350						my $app = $self->app;
1351						my $home = $app->home;
1352						my $cfg_dir = $app->config('model_dir') // '.bi';
1353						my $bi_dir = $home->child($cfg_dir);
1354						my $data_dir = $home->child($app->config('data_dir') // 'data');
1355
1356						if ($bi_dir->to_string eq $data_dir->to_string) {
1357						$app->log->warn('model_dir equals data_dir; skipping model file write');
1358						return undef;
1359						}
1360						unless (-d $bi_dir) {
1361						mkdir $bi_dir->to_string
1362						or do { $app->log->warn("Cannot create $bi_dir: $!"); return undef };
1363						}
1364						return $bi_dir->child('models.json')->to_string;
1365	12 12 12			12	4001 12 41	}
1366
1367						# _read_models($self) -> \%models
1368						#
1369						# Returns the parsed models hashref from .bi/models.json, or an empty scaffold.
1370						sub _read_models :Protected ($self) {
1371						my $path = $self->_calc_models_path;
1372						my $scaffold = { version => 1, fields => {}, groups => {}, date_patterns => {} };
1373						return $scaffold unless defined $path && -f $path;
1374						my $json = eval { Mojo::File->new($path)->slurp };
1375						return $scaffold unless $json && !$@;
1376						my $data = eval { decode_json($json) };
1377						return $scaffold unless ref $data eq 'HASH';
1378						$data->{fields} //= {};
1379						$data->{groups} //= {};
1380						$data->{date_patterns} //= {};
1381						return $data;
1382	12 12 12			12	3114 9 41	}
1383
1384						# _write_models($self, \%models) -- persists models to .bi/models.json
1385						sub _write_models :Protected ($self, $models) {
1386						my $path = $self->_calc_models_path;
1387						return unless defined $path;
1388						eval { Mojo::File->new($path)->spurt(encode_json($models)) };
1389						$self->app->log->warn("Cannot write $path: $@") if $@;
1390	12 12 12			12	3055 11 35	}
1391
1392						# _run_export_pipeline($self) -> ($records, \@columns, $left_label) or ()
1393						#
1394						# Purpose: Thin wrapper over _run_pipeline_source that additionally applies
1395						# f= filters, d=1 dedup, and page/per_page pagination. Used by
1396						# export_data, export_write, folder_view, and import_url (row-viewing
1397						# routes that do not need the source object for aggregation).
1398						# Entry: Reads "l=", "j=" (repeatable), "c=" (repeatable), "f=" (repeatable),
1399						# "d=", "page=", "per_page=" query/body params.
1400						# Exit: On success: ($filtered_arrayref, \@column_names, $left_label_string).
1401						# On failure: empty list (left table not found / fetch error).
1402						sub _run_export_pipeline :Protected ($self) {
1403						my (undef, $records, $columns, $left_label) = $self->_run_pipeline_source;
1404						return () unless defined $records;
1405
1406						my @columns = @{ $columns // [] };
1407
1408						for my $s (@{ $self->every_param('f') }) {
1409						$records = _apply_filter_spec($records, $s);
1410						}
1411
1412						$records = _dedup_records($records, \@columns) if $self->param('d');
1413
1414						# Sort support for /export: applied in memory after filtering/dedup.
1415						my $sort = $self->param('sort');
1416						my $dir = ($self->param('dir') // 'asc') =~ /\Adesc\z/i ? 'desc' : 'asc';
1417						if (defined $sort && grep { $_ eq $sort } @columns) {
1418						@$records = sort { ($a->{$sort} // '') cmp ($b->{$sort} // '') } @$records;
1419						@$records = reverse @$records if $dir eq 'desc';
1420						} elsif (defined $sort) {
1421						carp $self->_i18n('error_sort_column', $sort);
1422						}
1423
1424						# Server-side pagination for /export.
1425						if (defined $self->param('page') \|\| defined $self->param('per_page')) {
1426						my ($page, $per_page, $offset) = $self->_pagination;
1427						my $total = scalar @$records;
1428						my $has_next = ($total > $offset + $per_page) ? 1 : 0;
1429						my @page_recs = splice(@$records, $offset, $per_page);
1430						$records = \@page_recs;
1431						$self->stash(export_has_next => $has_next, export_page => $page, export_per_page => $per_page);
1432						}
1433
1434						return ($records, \@columns, $left_label);
1435	12 12 12			12	5075 10 40	}
1436
1437						# _decode_cell($s) -> $character_string
1438						#
1439						# Purpose: Ensure $s is a Perl character string, not raw UTF-8 bytes.
1440						# URL-fetched data (via LWP::UserAgent::Cached + D::A HTML parsing)
1441						# arrives as byte strings without the UTF-8 flag set. encode_json
1442						# then treats each byte as a Latin-1 code point and re-encodes it,
1443						# producing mojibake (e.g. an o-umlaut character displayed as two garbage bytes). This helper
1444						# upgrades the flag in-place on a copy so the original hash key is
1445						# unchanged but the value passed to HTML::D3 is a proper character.
1446						# Entry: $s -- any defined scalar (undef returned as-is).
1447						# Exit: The same string value, but with the UTF-8 flag set if it was absent.
1448						sub _decode_cell {
1449	418			418	294	my $s = shift;
1450	418	50			339	return $s unless defined $s;
1451	418	50			576	utf8::decode($s) unless utf8::is_utf8($s);
1452	418				501	$s;
1453						}
1454
1455						# _serialize_csv($records, \@columns) -> $utf8_string
1456						#
1457						# Purpose: Build a complete RFC 4180 CSV document (header + data rows) from
1458						# $records. Shared by _render_csv (HTTP download) and the csv branch
1459						# of export_write (filesystem write) to eliminate duplicated logic.
1460						# Entry: $records is an arrayref of hashrefs; $columns is an arrayref of names.
1461						# Exit: Returns a UTF-8 Perl string ending with CRLF.
1462						#
1463						# Optimisation: rows are collected in @lines and joined in one operation.
1464						# The previous pattern ($out .= _csv_row(...) per row) triggers O(N) string
1465						# reallocations; joining a pre-built array is a single O(total_bytes) allocation.
1466						# For exports of thousands of rows the difference is measurable.
1467						#
1468						# XS note: for very large exports, replacing _csv_row with Text::CSV_XS
1469						# (available from CPAN) would further reduce serialisation time -- its C-level
1470						# implementation is roughly 5-10x faster than the pure-Perl version here.
1471						sub _serialize_csv {
1472	67			67	8703	my ($records, $columns) = @_;
1473	67				156	my @lines = _csv_row(@$columns);
1474	67				101	for my $row (@$records) {
1475	294 1608				219 1227	push @lines, _csv_row(map { $row->{$_} } @$columns);
1476						}
1477	67				185	return encode('UTF-8', join('', @lines));
1478						}
1479
1480						# _render_csv($self, $records, \@columns, $name) -> void (renders response)
1481						#
1482						# Purpose: Serialise $records to RFC 4180 CSV and emit as a UTF-8 download.
1483						# Entry: $name is a safe filename stem (alphanumeric/underscore).
1484						# Exit: Renders the Mojolicious response; does not return a meaningful value.
1485						# Side Effects: Writes HTTP response headers and body.
1486						sub _render_csv :Protected ($self, $records, $columns, $name) {
1487						$self->res->headers->content_type('text/csv; charset=UTF-8');
1488						$self->res->headers->content_disposition(qq{attachment; filename="${name}.csv"});
1489						$self->render(data => _serialize_csv($records, $columns));
1490	12 12 12			12	4369 81 58	}
1491
1492						# _render_sqlite($self, $records, \@columns, $name) -> void (renders response)
1493						#
1494						# Purpose: Write $records to a SQLite database and emit it as a binary download.
1495						# Entry: $name is a safe filename stem.
1496						# Exit: Renders the Mojolicious response.
1497						# Side Effects: Creates and unlinks a temporary file; writes HTTP response.
1498						sub _render_sqlite :Protected ($self, $records, $columns, $name) {
1499						my $data = $self->_write_sqlite_db($records, $columns);
1500						$self->res->headers->content_type('application/vnd.sqlite3');
1501						$self->res->headers->content_disposition(qq{attachment; filename="${name}.db"});
1502						$self->render(data => $data);
1503	12 12 12			12	3132 10 53	}
1504
1505						# _render_json($self, $records, \@columns, $name) -> void (renders response)
1506						#
1507						# Purpose: Emit $records as a JSON array download.
1508						# Entry: $records is an arrayref of hashrefs; $name is a safe filename stem.
1509						# Exit: Renders the Mojolicious response.
1510						# Side Effects: Writes HTTP response headers and body.
1511						sub _render_json :Protected ($self, $records, $columns, $name) {
1512						$self->res->headers->content_disposition(qq{attachment; filename="${name}.json"});
1513						$self->render(json => $records);
1514	12 12 12			12	2608 26 35	}
1515
1516						# ---------------------------------------------------------------------------
1517						# Public actions
1518						# ---------------------------------------------------------------------------
1519
1520 - 1555						=head1 ACTIONS =head2 index C<GET /> -- Scan C<data_dir> and present a card grid of available tables. =head3 API SPECIFICATION =head4 INPUT None (reads C<data_dir> from application config). =head4 OUTPUT Renders C<home.html.tt> with: tables ARRAYREF of { name => $stem, file => $basename } title 'Choose a Database' =head3 MESSAGES None produced by this action; any file-scan errors are silently ignored (empty directory yields an empty card grid). =head3 FORMAL SPECIFICATION index == lambda self . let dir = resolve self.app.config.data_dir in let tbls = { b \| b in dir /\ basename(b) =~ EXT_RE } in post render(home, tables: map(stem, tbls)) =head3 EXAMPLE GET / -> 200 text/html containing a card for each file in data/ =cut
1556
1557	20 20 20			20	181207 24 16	sub index ($self) {
1558	20				70	my ($platform, $language) = $self->_resolve_template;
1559
1560	20				86	$self->render(
1561						template => "$platform/$language/home",
1562						handler => 'tt',
1563						format => 'html',
1564						tables => $self->_scan_data_dir,
1565						title => 'Choose a Database',
1566						);
1567						}
1568
1569 - 1632						=head2 view C<GET /view/:table> -- Open and display the chosen table from C<data_dir>. =head3 API SPECIFICATION =head4 INPUT :table string Table name (alphanumeric + underscore). Returns 404 on other characters. ?f= string (repeatable) Filter spec: "col:op:val". =head4 DOMAIN CONSTRAINTS: :table C<:table> is validated against C<\A[A-Za-z_][A-Za-z0-9_]*\z> before C<open_table> is ever called. The first character must be a letter (A-Z, a-z) or an underscore; subsequent characters may also include digits (0-9). =over 4 =item Valid partition C<sales> (letters only), C<_temp> (underscore-start), C<report_2024> (mixed). A name that is valid but has no backing file returns 200 with an error message -- NOT 404. =item Invalid partition C<1sales> (digit-start, 404), C<my.data> (dot, 404), C<my-data> (hyphen, 404), non-ASCII characters (404). =item Boundary values C<a> (single letter, valid), C<_> (single underscore, valid), C<1> (single digit, 404), C<a1> (letter then digit, valid), C<1a> (digit then letter, 404). =back =head4 OUTPUT On success renders C<dashboard.html.tt> with table data. On error re-renders C<home.html.tt> with an C<error> stash variable. =head3 MESSAGES error_table_open -- DataSource initialisation or fetch_all threw. =head3 FORMAL SPECIFICATION view == lambda self . pre self.stash('table') =~ TABLE_NAME_RE let src = open_table(table) in let records = src.fetch_all() in let cols = get_columns(src, records) in post render(dashboard, records: filter(records, f_params)) =head3 EXAMPLE GET /view/sales -> 200 HTML table of all sales rows GET /view/sales?f=region:eq:North -> shows only North region rows GET /view/../etc -> 404 =cut
1633
1634	110 110 110			110	1610500 149 110	sub view ($self) {
1635	110				369	my ($platform, $language) = $self->_resolve_template;
1636	110				278	my $table = $self->stash('table');
1637
1638	110	100	67		1109	unless (defined $table && $table =~ $TABLE_NAME_RE) {
1639	14				128	return $self->reply->not_found;
1640						}
1641
1642	96				856	my ($page, $per_page, $offset) = $self->_pagination;
1643
1644	96	50			176	my $dedup = $self->param('d') ? 1 : 0;
1645	96				1904	my ($source, $records, $has_next, $is_multi);
1646	96				91	eval {
1647	96				288	$source = $self->open_table($table);
1648						# Multi-table SQLite: flag redirect without fetching data.
1649	96 1	100	50		368 3	if ($source && $source->sqlite_tables && @{ $source->sqlite_tables } > 1) {
1650	1				1	$is_multi = 1;
1651						} else {
1652						# _fetch_page applies reduce-before-paginate: full-fetch + filter + dedup
1653						# + Perl paginate when f= or d=1 are set; N+1 trick otherwise.
1654	95				462	($records, $has_next) = $self->_fetch_page($source,
1655						{ per_page => $per_page, offset => $offset, dedup => $dedup });
1656						}
1657						};
1658	96	100			11206	if ($@) {
1659	10				82	return $self->render(
1660						template => "$platform/$language/home",
1661						handler => 'tt',
1662						format => 'html',
1663						tables => [],
1664						title => 'Choose a Database',
1665						error => $self->_i18n('error_table_open', $table, $@),
1666						);
1667						}
1668
1669	86	100			163	if ($is_multi) {
1670	1				4	return $self->redirect_to('/tables?l=' . url_escape("table:$table"));
1671						}
1672
1673	85		50		146	$records //= [];
1674	85				195	my @columns = _get_columns($source, $records);
1675						# _apply_filters on already-reduced records is a no-op for filtering but
1676						# correctly builds filter_specs (for export URLs) and filters_json (for UI).
1677	85				290	my (undef, $filter_specs, $filters_json) = $self->_apply_filters($records);
1678
1679	85				176	my $page_url = $self->req->url->clone;
1680	85				4888	$page_url->query->remove('page')->remove('per_page');
1681	85				1555	my $page_base_url = $page_url->to_string;
1682
1683	85		100		11130	$self->render(
1684						template => "$platform/$language/dashboard",
1685						handler => 'tt',
1686						format => 'html',
1687						records => $records,
1688						columns => \@columns,
1689						table => $table,
1690						title => ucfirst($table),
1691						left_spec => "table:$table",
1692						combine_specs => [],
1693						current_joins => [],
1694						available_tables => $self->_scan_data_dir,
1695						join_summaries => [],
1696						filter_specs => $filter_specs,
1697						filters_json => $filters_json,
1698						dedup => $dedup,
1699						back_url => _safe_back_url($self->param('back2')),
1700						back_label => $self->param('back2_label') // 'Back',
1701						export_url => $self->_build_export_url("table:$table", [], $filter_specs, undef, $dedup),
1702						page => $page,
1703						per_page => $per_page,
1704						has_next => $has_next,
1705						page_base_url => $page_base_url,
1706						);
1707						}
1708
1709 - 1748						=head2 browse C<GET /browse> -- Navigate the filesystem and pick a data file. =head3 API SPECIFICATION =head4 INPUT ?path= string Absolute filesystem path to browse (default: $HOME). Returns 404 when the path does not exist or is not a directory. =head4 OUTPUT Renders C<browse.html.tt> with: current_path string parent_href string or undef (undef at filesystem root) crumbs ARRAYREF of { name, href } dirs ARRAYREF of { name, href } -- subdirectories, sorted files ARRAYREF of { name, href } -- supported data files, sorted =head3 MESSAGES None; errors render as 404. =head3 FORMAL SPECIFICATION browse == lambda self . let dir = realpath(param('path') // HOME) in pre is_dir(dir) post render(browse, dirs: subdirs(dir), files: supported_files(dir)) =head3 EXAMPLE GET /browse -> 200, lists $HOME GET /browse?path=/tmp -> 200, lists /tmp GET /browse?path=/nonexistent/xyz -> 404 =cut
1749
1750	33 33 33			33	277526 48 31	sub browse ($self) {
1751	33				105	my ($platform, $language) = $self->_resolve_template;
1752
1753	33		50 67		88	my $raw_path = $self->param('path') // $ENV{HOME} // '/';
1754	33 33				5054 71	my $dir = eval { Mojo::File->new($raw_path)->realpath };
1755	33	100	100		2014	return $self->reply->not_found unless defined $dir && -d $dir;
1756
1757	26				165	my $listing = $self->_list_dir($dir, 1);
1758
1759						# Add browse hrefs to file entries (dirs already have path; browse needs href).
1760						my @dirs = map {
1761	15				110	+{ name => $_->{name}, href => '/browse?path=' . url_escape($_->{path}) }
1762	26 26				38 51	} @{ $listing->{dirs} };
1763
1764						my @files = map {
1765	46				305	+{ name => $_->{name}, href => '/open?path=' . url_escape($_->{path}) }
1766	26 26				65 41	} @{ $listing->{files} };
1767
1768						# Build breadcrumb trail from filesystem root down to $dir.
1769	26				205	my @crumbs;
1770						{
1771	26 26				28 29	my $f = $dir;
1772	26				25	while (1) {
1773	86				100	my $name = $f->basename;
1774	86	50			933	$name = '/' unless length $name;
1775	86				90	unshift @crumbs, { name => $name, href => '/browse?path=' . url_escape($f->to_string) };
1776	86				653	my $parent = $f->dirname;
1777	86	100			1121	last if $parent->to_string eq $f->to_string;
1778	60				227	$f = $parent;
1779						}
1780						}
1781
1782	26				119	my $parent = $dir->dirname;
1783	26	50			253	my $parent_href = $parent->to_string ne $dir->to_string
1784						? '/browse?path=' . url_escape($parent->to_string)
1785						: undef;
1786
1787	26				298	$self->render(
1788						template => "$platform/$language/browse",
1789						handler => 'tt',
1790						format => 'html',
1791						title => 'Browse Files',
1792						current_path => $dir->to_string,
1793						parent_href => $parent_href,
1794						crumbs => \@crumbs,
1795						dirs => \@dirs,
1796						files => \@files,
1797						);
1798						}
1799
1800 - 1870						=head2 open_file C<GET /open> -- Open a supported data file from any absolute filesystem path. =head3 API SPECIFICATION =head4 INPUT ?path= string Absolute path to the data file. Returns 404 when missing, not a regular file, or the extension is not in SUPPORTED_EXT. ?f= string (repeatable) Filter spec: "col:op:val". =head4 DOMAIN CONSTRAINTS: ?path= =over 4 =item Extension filter (C<EXT_RE>) The basename must match C<\.(?:csv\|db\|sql\|xml\|tsv\|psv)\z> (case-insensitive). The C<\z> anchor (absolute end-of-string) means a URL-encoded trailing newline (e.g. C<file.csv%0A> decoded to C<file.csv\n>) does NOT pass -- the C<\n> falls after the C<\z> boundary and the extension check fails. =item Valid partition C</data/sales.csv> (lowercase extension), C</tmp/REPORT.CSV> (uppercase extension, /i matches), any C<.db>, C<.sql>, C<.xml>, C<.tsv>, C<.psv> regular file. =item Invalid partition Absent C<?path=> (404), non-existent file (404), directory instead of file (404), unsupported extension such as C<.txt> (404), empty string (404), path containing a C<%0A> (newline) suffix (404). =item Double-extension filenames A file like C<file.php.csv> passes C<EXT_RE> (last segment is C<.csv>) but produces table stem C<file.php> which fails C<DataSource>'s C<TABLE_NAME_RE>. The C<open_table> call is inside C<eval>, so the croak is caught and the action returns 200 with a friendly error, not a 500. =back =head4 OUTPUT On success renders C<dashboard.html.tt> with C<back_url> pointing to the directory's C</browse> page, and C<file_path> set to the resolved absolute path (used by the template to record the file in C<localStorage>). On error re-renders C<home.html.tt> with C<error>, C<back_url>, C<back_label>. =head3 MESSAGES error_file_open -- DataSource threw during initialisation or fetch_all. =head3 FORMAL SPECIFICATION open_file == lambda self . let file = realpath(param('path')) in pre is_file(file) /\ basename(file) =~ EXT_RE let src = open_table(stem(file), dir=dirname(file)) in post render(dashboard, file_path: file.to_string) =head3 EXAMPLE GET /open?path=/data/archive/sales.csv -> 200, table view GET /open -> 404 GET /open?path=/etc/passwd -> 404 =cut
1871
1872	109 109 109			109	1573539 149 117	sub open_file ($self) {
1873	109				378	my ($platform, $language) = $self->_resolve_template;
1874	109				297	my $file_path = $self->param('path');
1875
1876	109	100			17792	return $self->reply->not_found unless defined $file_path;
1877
1878	104				265	my ($page, $per_page, $offset) = $self->_pagination;
1879
1880						# Bare redis:// URL (no table name) -- redirect to key-listing page.
1881	104	50			296	if ($file_path =~ $REDIS_URL_RE) {
1882	0				0	return $self->redirect_to('/tables?l=' . url_escape($file_path));
1883						}
1884
1885						# Redis spec: redis:tablename\|redis://host:port -- delegate to _open_spec.
1886	104	50			769	if ($file_path =~ $REDIS_SPEC_RE) {
1887	0				0	my $lspec = $file_path;
1888	0				0	my ($source, $label) = $self->_open_spec($lspec);
1889	0	0			0	return $self->reply->not_found unless $source;
1890	0				0	my $table = $label;
1891	0	0			0	my $dedup = $self->param('d') ? 1 : 0;
1892	0				0	my ($records, $has_next);
1893	0				0	eval {
1894	0				0	($records, $has_next) = $self->_fetch_page($source,
1895						{ per_page => $per_page, offset => $offset, dedup => $dedup });
1896						};
1897	0	0			0	if ($@) {
1898	0				0	return $self->render(
1899						template => "$platform/$language/home",
1900						handler => 'tt',
1901						format => 'html',
1902						tables => [],
1903						title => 'Error',
1904						error => $self->_i18n('error_file_open', $label, $@),
1905						back_url => '/',
1906						back_label => 'Home',
1907						);
1908						}
1909	0		0		0	$records //= [];
1910	0				0	my @columns = _get_columns($source, $records);
1911	0				0	my (undef, $filter_specs, $filters_json) = $self->_apply_filters($records);
1912	0				0	my $rpage_url = $self->req->url->clone;
1913	0				0	$rpage_url->query->remove('page')->remove('per_page');
1914	0		0 0 0		0	return $self->render(
1915						template => "$platform/$language/dashboard",
1916						handler => 'tt',
1917						format => 'html',
1918						records => $records,
1919						columns => \@columns,
1920						table => $table,
1921						title => $label,
1922						back_url => _safe_back_url($self->param('back')) // '/',
1923						back_label => $self->param('back_label') // 'Home',
1924						back2_url => _safe_back_url($self->param('back2')),
1925						back2_label => $self->param('back2_label') // 'Back',
1926						file_path => $file_path,
1927						left_spec => $lspec,
1928						combine_specs => [],
1929						current_joins => [],
1930						available_tables => $self->_scan_data_dir,
1931						join_summaries => [],
1932						filter_specs => $filter_specs,
1933						filters_json => $filters_json,
1934						dedup => $dedup,
1935						export_url => $self->_build_export_url($lspec, [], $filter_specs, undef, $dedup),
1936						page => $page,
1937						per_page => $per_page,
1938						has_next => $has_next,
1939						page_base_url => $rpage_url->to_string,
1940						);
1941						}
1942
1943						# Remote path /../hostname/dir/file.ext: delegate opening to _open_spec
1944						# and render the dashboard directly, bypassing the realpath/local-file path.
1945	104	100			738	if ($file_path =~ m{\A/\.\./}) {
1946	4				6	my $lspec = 'path:' . $file_path;
1947	4				12	my ($source, $label) = $self->_open_spec($lspec);
1948	4	100			11	return $self->reply->not_found unless $source;
1949	3				5	my $filename = $label;
1950	3				11	(my $table = $filename) =~ s/\.[^.]+\z//;
1951	3	50			6	my $dedup = $self->param('d') ? 1 : 0;
1952	3				111	my ($records, $has_next);
1953	3				3	eval {
1954	3				12	($records, $has_next) = $self->_fetch_page($source,
1955						{ per_page => $per_page, offset => $offset, dedup => $dedup });
1956						};
1957	3	50			6	if ($@) {
1958	0				0	return $self->render(
1959						template => "$platform/$language/home",
1960						handler => 'tt',
1961						format => 'html',
1962						tables => [],
1963						title => 'Error',
1964						error => $self->_i18n('error_file_open', $filename, $@),
1965						back_url => '/',
1966						back_label => 'Home',
1967						);
1968						}
1969	3		50		7	$records //= [];
1970	3				9	my @columns = _get_columns($source, $records);
1971	3				11	my (undef, $filter_specs, $filters_json) = $self->_apply_filters($records);
1972	3				6	my $rpage_url = $self->req->url->clone;
1973	3				159	$rpage_url->query->remove('page')->remove('per_page');
1974	3		50		58	return $self->render(
1975						template => "$platform/$language/dashboard",
1976						handler => 'tt',
1977						format => 'html',
1978						records => $records,
1979						columns => \@columns,
1980						table => $table,
1981						title => $filename,
1982						back_url => '/',
1983						back_label => 'Home',
1984						back2_url => _safe_back_url($self->param('back2')),
1985						back2_label => $self->param('back2_label') // 'Back',
1986						file_path => $file_path,
1987						left_spec => $lspec,
1988						combine_specs => [],
1989						current_joins => [],
1990						available_tables => $self->_scan_data_dir,
1991						join_summaries => [],
1992						filter_specs => $filter_specs,
1993						filters_json => $filters_json,
1994						dedup => $dedup,
1995						export_url => $self->_build_export_url($lspec, [], $filter_specs, undef, $dedup),
1996						page => $page,
1997						per_page => $per_page,
1998						has_next => $has_next,
1999						page_base_url => $rpage_url->to_string,
2000						);
2001						}
2002
2003	100 100				93 206	my $file = eval { Mojo::File->new($file_path)->realpath };
2004	100	100	100		3739	return $self->reply->not_found
2005						unless defined $file && -f $file && $file->basename =~ $EXT_RE;
2006
2007	82				2972	my $dir = $file->dirname;
2008	82				1676	(my $table = $file->basename) =~ s/\.[^.]+\z//;
2009	82				909	my $back = '/browse?path=' . url_escape($dir->to_string);
2010	82				1089	my $filename = $file->basename;
2011	82				710	my $lspec = 'path:' . $file->to_string;
2012
2013	82				249	my $it = $self->param('it'); # optional: select a specific internal table
2014
2015						# Allow the tables view to override the default "Back to browser" link.
2016	82				1786	my $back_override = _safe_back_url($self->param('back'));
2017	82	100			161	if ($back_override) {
2018	1				2	$back = $back_override;
2019						}
2020	82	100	50		167	my $back_label_default = $back_override ? ($self->param('back_label') // 'Back') : 'Back to browser';
2021
2022	82	100			144	my $dedup = $self->param('d') ? 1 : 0;
2023	82				1596	my ($source, $records, $has_next, $is_multi_local);
2024	82				90	eval {
2025	82	100			130	$source = $self->open_table($table, directory => $dir->to_string,
2026						defined $it ? (internal_table => $it) : ());
2027						# Multi-table SQLite without it=: flag redirect without fetching data.
2028	82	100	80		546	if (!defined $it && $source && $source->sqlite_tables
2029	24				36	&& @{ $source->sqlite_tables } > 1) {
2030	1				1	$is_multi_local = 1;
2031						} else {
2032	81				373	($records, $has_next) = $self->_fetch_page($source,
2033						{ per_page => $per_page, offset => $offset, dedup => $dedup });
2034						}
2035						};
2036	82	100			9861	if ($@) {
2037						# Provide a SQLite-specific hint when the error looks like a table-name
2038						# mismatch or a missing-tables failure so the user knows what to do.
2039	5				21	my $hint;
2040	5	100			18	if ($filename =~ /\.(?:sql\|db)\z/i) {
2041	1				2	$hint = 'SQLite files must contain at least one user-defined table. '
2042						. 'The table name inside the database does not need to match the '
2043						. 'filename -- the application auto-detects and uses the first table found.';
2044						}
2045	5		50		24	return $self->render(
2046						template => "$platform/$language/home",
2047						handler => 'tt',
2048						format => 'html',
2049						tables => [],
2050						title => 'Error',
2051						error => $self->_i18n('error_file_open', $filename, $@),
2052						hint => $hint,
2053						back_url => $back,
2054						back_label => $back_label_default,
2055						back2_url => _safe_back_url($self->param('back2')),
2056						back2_label => $self->param('back2_label') // 'Back',
2057						);
2058						}
2059
2060	77	100			140	if ($is_multi_local) {
2061	1 1				1 3	return $self->redirect_to('/tables?l=' . url_escape("path:${\$file->to_string}"));
2062						}
2063
2064	76		50		128	$records //= [];
2065	76				218	my @columns = _get_columns($source, $records);
2066	76				222	my (undef, $filter_specs, $filters_json) = $self->_apply_filters($records);
2067
2068	76				147	my $lpage_url = $self->req->url->clone;
2069	76				4098	$lpage_url->query->remove('page')->remove('per_page');
2070
2071	76	100 100	100		1594	$self->render(
2072						template => "$platform/$language/dashboard",
2073						handler => 'tt',
2074						format => 'html',
2075						records => $records,
2076						columns => \@columns,
2077						table => defined $it ? $it : $table,
2078						title => defined $it ? "$filename ($it)" : $filename,
2079						back_url => $back,
2080						back_label => $back_label_default,
2081						back2_url => _safe_back_url($self->param('back2')),
2082						back2_label => $self->param('back2_label') // 'Back',
2083						file_path => $file->to_string,
2084						left_spec => $lspec,
2085						combine_specs => [],
2086						current_joins => [],
2087						available_tables => $self->_scan_data_dir,
2088						join_summaries => [],
2089						filter_specs => $filter_specs,
2090						filters_json => $filters_json,
2091						dedup => $dedup,
2092						export_url => $self->_build_export_url($lspec, [], $filter_specs, undef, $dedup),
2093						page => $page,
2094						per_page => $per_page,
2095						has_next => $has_next,
2096						page_base_url => $lpage_url->to_string,
2097						);
2098						}
2099
2100 - 2135						=head2 import_url C<GET /import> -- Fetch a remote HTML page, extract the first (or selected) table, and render it as a sortable data grid. =head3 API SPECIFICATION =head4 INPUT ?url= string Required. Full http:// or https:// URL of the page that contains the HTML table. Returns home with an error message if the scheme is wrong, the fetch fails, or no table is found at the specified index. ?table_index= integer Zero-based index of the C<< <table> >> to use when the page contains more than one table (default: 0). ?f= string (repeatable) Filter spec: "col:op:val". =head4 OUTPUT On success renders C<dashboard.html.tt> with the same stash shape as C<open_file>, plus C<source_url> (the original URL) for C<localStorage> tracking. On error re-renders C<home.html.tt> with an C<error> stash variable. =head3 MESSAGES error_url_required -- empty or missing C<url> param error_url_invalid -- URL does not begin with http:// or https:// error_url_fetch -- LWP fetch failure or no table found at the index =head3 EXAMPLE GET /import?url=https://matrix.perl-magpie.org/dist/Database-Abstraction/ GET /import?url=https://example.com/data.html&table_index=2 =cut
2136
2137	30 30 30			30	377624 31 31	sub import_url ($self) {
2138	30				82	my ($platform, $language) = $self->_resolve_template;
2139
2140	30		100		74	my $url = $self->param('url') // '';
2141	30		100		4519	my $idx = $self->param('table_index') // 0;
2142	30	100			734	$idx = 0 unless $idx =~ /\A[0-9]+\z/;
2143
2144	24 24 24 24			24	31 30 26 23	my $err_home = sub ($key, @args) {
2145	24				69	$self->render(
2146						template => "$platform/$language/home",
2147						handler => 'tt',
2148						format => 'html',
2149						tables => $self->_scan_data_dir,
2150						title => 'Choose a Database',
2151						error => $self->_i18n($key, @args),
2152						);
2153	30				76	};
2154
2155	30	100			56	return $err_home->('error_url_required') unless length $url;
2156	25	100			131	return $err_home->('error_url_invalid', $url)
2157						unless $url =~ m{\Ahttps?://}i;
2158	19	100			41	return $err_home->('error_url_ssrf', $url)
2159						unless _is_safe_url($url);
2160
2161	8 8				9 26	my $source = eval { $self->open_table('', url => $url, html_table_index => $idx) };
2162	8	100	67 50		368	return $err_home->('error_url_fetch', $url, $@ // 'unknown error') if $@ \|\| !$source;
2163
2164	7 7				9 19	my $records = eval { $source->fetch_all };
2165	7	100	50		222	return $err_home->('error_url_fetch', $url, $@ // 'empty result') if $@;
2166
2167	6				17	my $label = $source->table_name;
2168	6				10	my $lspec = "url:$url";
2169	6				16	my @columns = _get_columns($source, $records);
2170	6				19	my ($filtered, $filter_specs, $filters_json) = $self->_apply_filters($records);
2171	6	50			11	my $dedup = $self->param('d') ? 1 : 0;
2172	6	50			143	$filtered = _dedup_records($filtered, \@columns) if $dedup;
2173
2174	6				11	my $self_url = '/import?url=' . url_escape($url);
2175	6	50			78	$self_url .= '&table_index=' . $idx if $idx;
2176
2177	6		100		19	$self->render(
2178						template => "$platform/$language/dashboard",
2179						handler => 'tt',
2180						format => 'html',
2181						records => $filtered,
2182						columns => \@columns,
2183						table => $label,
2184						title => $label,
2185						source_url => $url,
2186						back_url => $self_url,
2187						back_label => $label,
2188						back2_url => _safe_back_url($self->param('back2')),
2189						back2_label => $self->param('back2_label') // 'Back',
2190						left_spec => $lspec,
2191						combine_specs => [],
2192						current_joins => [],
2193						available_tables => $self->_scan_data_dir,
2194						join_summaries => [],
2195						filter_specs => $filter_specs,
2196						filters_json => $filters_json,
2197						dedup => $dedup,
2198						export_url => $self->_build_export_url($lspec, [], $filter_specs, undef, $dedup),
2199						);
2200						}
2201
2202 - 2243						=head2 columns_api C<GET /api/columns> -- Return column names for a table or file as JSON. Used by the join UI to populate the right-key dropdown without a page reload. =head3 API SPECIFICATION =head4 INPUT ?table= string Table name from C<data_dir>. ?path= string Absolute path to a data file. ?spec= string Unified spec: C<"table:name"> or C<"path:/abs/path">. Parsed only when C<table> and C<path> are both absent. One of C<table>, C<path>, or C<spec> must be present; C<table> takes precedence over C<path>, and both take precedence over C<spec>. =head4 OUTPUT 200 application/json { "columns": ["col1", "col2", ...] } 404 application/json { "error": "not found" } =head3 MESSAGES None produced by this action directly; internal errors yield a 404. =head3 FORMAL SPECIFICATION columns_api == lambda self . let src = open_spec(table_param or path_param or parse_spec(spec_param)) in pre src /= undef post render_json({ columns: get_columns(src) }) =head3 EXAMPLE GET /api/columns?table=sales -> {"columns":["product","region","amount"]} GET /api/columns?spec=table:sales -> {"columns":["product","region","amount"]} GET /api/columns?spec=path:/data/f.csv -> {"columns":[...]} GET /api/columns?table=noexist -> 404 =cut
2244
2245	22 22 22			22	205084 26 21	sub columns_api ($self) {
2246	22				50	my $table_name = $self->param('table');
2247	22				2649	my $path = $self->param('path');
2248
2249						# Accept the unified spec format used by /join and /graph:
2250						# "table:name" or "path:/abs/path" -- mirrors _open_spec's parsing.
2251	22	100	100		514	if (!defined($table_name) && !defined($path)) {
2252	7		100		13	my $spec = $self->param('spec') // '';
2253	7	100 100			167	if ($spec =~ /\Atable:([A-Za-z_][A-Za-z0-9_]*)\z/) {
2254	3				5	$table_name = $1;
2255						} elsif ($spec =~ /\Apath:(.+)\z/s) {
2256	3				5	$path = $1;
2257						}
2258						}
2259
2260	22				23	my $source;
2261	22	100 100	100		129	if (defined $table_name && $table_name =~ $TABLE_NAME_RE) {
2262	14		50		108	my $data_dir = $self->app->home->child($self->app->config->{data_dir} // 'data');
2263						return $self->render(json => { error => 'not found' }, status => 404)
2264	14 126	100			320 1314	unless grep { -f $data_dir->child(lc($table_name) . ".$_") } @SUPPORTED_EXT;
2265	11 11				122 26	$source = eval { $self->open_table(lc $table_name, directory => $data_dir->to_string) };
2266						}
2267						elsif (defined $path) {
2268	6	100			24	if ($path =~ m{\A/\.\./([^/]+)((?:/.+)?)/([^/]+)\z}) {
2269	2		50		5	my ($host, $dir_part, $file) = ($1, $2 // '', $3);
2270	2	50			4	$dir_part = '/' unless length $dir_part;
2271	2	50			12	if ($host =~ $REMOTE_HOST_RE) {
2272	2	50			17	my ($tbl, $ext) = $file =~ /\A(.+)\.([^.]+)\z/ ? ($1, $2) : ($file, undef);
2273	2 2	50			2 8	$source = eval { $self->open_table($tbl, directory => $dir_part, host => $host,
2274						defined $ext ? (file_ext => $ext) : ()) };
2275						}
2276						} else {
2277	4 4				6 9	my $file = eval { Mojo::File->new($path)->realpath };
2278	4	100	50		96	if (defined $file && -f $file && $file->basename =~ $EXT_RE) {
2279	3				128	my $dir = $file->dirname->to_string;
2280	3				71	(my $tbl = $file->basename) =~ s/\.[^.]+\z//;
2281	3 3				32 7	$source = eval { $self->open_table($tbl, directory => $dir) };
2282						}
2283						}
2284						}
2285
2286	19	100			94	return $self->render(json => { error => 'not found' }, status => 404) unless $source;
2287
2288						# Use _get_columns to ensure consistent ordering with the view action.
2289	16 0	50	0		43 0	my $recs = ($source->columns ? [] : eval { $source->fetch_all } // []);
2290	16				2352	my @cols = _get_columns($source, $recs);
2291
2292	16				58	$self->render(json => { columns => \@cols });
2293						}
2294
2295 - 2344						=head2 join_tables C<GET /join> -- Perform one or more left joins and render the merged table. =head3 API SPECIFICATION =head4 INPUT ?l= string Required. Left table spec: "table:name" or "path:/abs/path". Returns 404 if unresolvable. ?j= string (repeatable) Join step: "<right-spec>\|<left-key>\|<right-key>". Invalid or non-existent steps are silently skipped. ?f= string (repeatable) Result filter: "col:op:val". =head4 OUTPUT Renders C<dashboard.html.tt> with the merged/filtered result set. =head3 MESSAGES error_table_open -- Left table fetch threw (re-renders home with error). =head3 FORMAL SPECIFICATION join_tables == lambda self . let left = open_spec(param('l')) in pre left /= undef let joined = fold(_left_join, left, param_list('j')) in let filtered = fold(_apply_filter_spec, joined, param_list('f')) in post render(dashboard, records: filtered) =head3 PSEUDOCODE 1. Parse and open left table spec; 404 on failure. 2. For each j= param (in order): a. Parse right-spec, left-key, right-key from "\|"-split. b. Verify left-key exists in current column list. c. Open right table; skip step on any error. d. Verify right-key exists in right column list. e. Call _left_join; update records and columns. 3. Apply all f= filters via _apply_filter_spec. 4. Build stable table key for localStorage ("join:left:right1:..."). 5. Render dashboard. =head3 EXAMPLE GET /join?l=table:sales&j=table:products\|product\|name -> merged left join of sales and products on product/name columns =cut
2345
2346	29 29 29			29	346221 49 29	sub join_tables ($self) {
2347	29				97	my ($platform, $language) = $self->_resolve_template;
2348
2349	29		100		77	my $left_spec = $self->param('l') // '';
2350	29				5046	my ($left_src, $left_label) = $self->_open_spec($left_spec);
2351	29	100			226	return $self->reply->not_found unless $left_src;
2352
2353	22 22				25 55	my @join_specs = @{ $self->every_param('j') };
2354	22				778	my @summaries;
2355
2356						# Build the join chain: each step wraps the previous source in a
2357						# Database::Join. Data is not fetched until after the loop.
2358	22		33		41	my $max_rows = $self->app->config('join_max_rows') // $DEFAULT_JOIN_MAX_ROWS;
2359	22		50		344	my $join_type = $self->param('jtype') // 'left';
2360	22	50			577	$join_type = 'left' unless $join_type =~ /\A(?:left\|inner\|outer)\z/;
2361	22				26	my $src = $left_src;
2362	22				28	my @schema_warnings;
2363	22				34	for my $jspec (@join_specs) {
2364	11				39	my ($right_spec, $left_key, $right_key) = split /\\|/, $jspec, 3;
2365	11	50	25		55	next unless defined $right_spec && defined $left_key && defined $right_key;
2366
2367	11				28	my $cur_cols = $src->columns;
2368	11	50			23	next unless $cur_cols;
2369	11 57	50			17 77	next unless +{ map { $_ => 1 } @$cur_cols }->{$left_key};
2370
2371	11				33	my ($right_src, $right_label) = $self->_open_spec($right_spec);
2372	11	100			100	next unless $right_src;
2373
2374	9				17	my $right_cols = $right_src->columns;
2375	9	50			19	next unless $right_cols;
2376	9 32	50			15 49	next unless +{ map { $_ => 1 } @$right_cols }->{$right_key};
2377
2378	9				1929	require Database::Join;
2379	9 0			0	75023 0	local $SIG{__WARN__} = sub { push @schema_warnings, $_[0] };
2380	9	100 50			74	$src = Database::Join->new(
2381						databases => [$src, $right_src],
2382						join_column => $left_key,
2383						backend => 'auto',
2384						max_array_rows => $max_rows,
2385						join_type => $join_type,
2386						($left_key ne $right_key ? (join_map => {1 => $right_key}) : ()),
2387						($right_label ? (collision_prefix => {1 => $right_label}) : ()),
2388						);
2389	9				5641	push @summaries, { label => $right_label, left_key => $left_key, right_key => $right_key };
2390						}
2391
2392	22				63	my ($page, $per_page, $offset) = $self->_pagination;
2393	22	50			44	my $dedup = $self->param('d') ? 1 : 0;
2394	22				459	my $sort = $self->param('sort');
2395	22	100	100		418	my $dir = ($self->param('dir') // 'asc') =~ /\Adesc\z/i ? 'desc' : 'asc';
2396
2397	22				488	my ($records, $has_next);
2398	22				21	eval {
2399	22				113	($records, $has_next) = $self->_fetch_page($src,
2400						{ per_page => $per_page, offset => $offset,
2401						dedup => $dedup, sort_col => $sort,
2402						sort_dir => $dir });
2403						};
2404	22	50			50	if ($@) {
2405	0				0	return $self->render(
2406						template => "$platform/$language/home",
2407						handler => 'tt',
2408						format => 'html',
2409						tables => [],
2410						title => 'Error',
2411						error => $self->_i18n('error_table_open', $left_label, $@),
2412						);
2413						}
2414	22		50		43	$records //= [];
2415	22				57	my @columns = _get_columns($src, $records);
2416
2417	22 6	50	67		67 10	if (defined $sort && !grep { $_ eq $sort } @columns) {
2418	0				0	carp $self->_i18n('error_sort_column', $sort);
2419						}
2420
2421	22				69	my (undef, $filter_specs, $filters_json) = $self->_apply_filters($records);
2422
2423	22				33	my $title = $left_label;
2424	22 9	100			52 25	$title .= ' + ' . join(' + ', map { $_->{label} } @summaries) if @summaries;
2425	22				35	my $table_key = 'join:' . lc($left_label);
2426	22				46	$table_key .= ':' . lc($_->{label}) for @summaries;
2427
2428	22				33	my $page_url = $self->req->url->clone;
2429	22				1431	$page_url->query->remove('page')->remove('per_page');
2430
2431	22		100		478	$self->render(
2432						template => "$platform/$language/dashboard",
2433						handler => 'tt',
2434						format => 'html',
2435						records => $records,
2436						columns => \@columns,
2437						table => $table_key,
2438						title => $title,
2439						back_url => $self->_spec_to_url($left_spec),
2440						back_label => "Back to $left_label",
2441						back2_url => _safe_back_url($self->param('back2')),
2442						back2_label => $self->param('back2_label') // 'Back',
2443						left_spec => $left_spec,
2444						combine_specs => [],
2445						current_joins => \@join_specs,
2446						available_tables => $self->_scan_data_dir,
2447						join_summaries => \@summaries,
2448						filter_specs => $filter_specs,
2449						filters_json => $filters_json,
2450						dedup => $dedup,
2451						export_url => $self->_build_export_url($left_spec, \@join_specs, $filter_specs, undef, $dedup),
2452						schema_warnings => \@schema_warnings,
2453						page => $page,
2454						per_page => $per_page,
2455						has_next => $has_next,
2456						page_base_url => $page_url->to_string,
2457						);
2458						}
2459
2460 - 2509						=head2 combine_tables C<GET /combine> -- Stack rows from two or more tables vertically into a single unified view. Unlike C</join> (which appends columns from a matching row in a second table), C</combine> appends the I<rows> from a second table beneath the rows of the first. All columns from all sources appear as headers; where a row has no value for a particular column (because that column did not exist in its source file) the cell is left blank. This is equivalent to a SQL C<UNION ALL> across heterogeneous schemas. =head3 API SPECIFICATION =head4 INPUT ?l= string (required) Left table spec: "table:name" or "path:/abs/path". Returns 404 if unresolvable. ?c= string (repeatable) Additional table spec to stack beneath the current result. Invalid or non-existent specs are silently skipped. ?f= string (repeatable) Result filter: "col:op:val". =head4 OUTPUT Renders C<dashboard.html.tt> with the combined result set. =head3 MESSAGES error_table_open -- Left table fetch threw (re-renders home with error). =head3 FORMAL SPECIFICATION combine_tables == lambda self . let left = open_spec(param('l')) in pre left /= undef let sources = [left] ++ map(open_spec, param_list('c')) in let combined = _combine_tables(sources) in let filtered = fold(_apply_filter_spec, combined, param_list('f')) in post render(dashboard, records: filtered) =head3 EXAMPLE GET /combine?l=table:cats&c=table:dogs -> unified view: all cat and dog rows; Species/Name/Color/Breed/Eye Color appear for both; Environment (cats-only) and Sex/Fixed (dogs-only) are blank where the source file lacks that column. =cut
2510
2511	18 18 18			18	224660 24 17	sub combine_tables ($self) {
2512	18				64	my ($platform, $language) = $self->_resolve_template;
2513
2514	18		100		50	my $left_spec = $self->param('l') // '';
2515	18				3241	my ($left_src, $left_label) = $self->_open_spec($left_spec);
2516	18	100			153	return $self->reply->not_found unless $left_src;
2517
2518	14 14				14 41	my $left_recs = eval { $left_src->fetch_all };
2519	14	50			28	if ($@) {
2520	0				0	return $self->render(
2521						template => "$platform/$language/home",
2522						handler => 'tt',
2523						format => 'html',
2524						tables => [],
2525						title => 'Error',
2526						error => $self->_i18n('error_table_open', $left_label, $@),
2527						);
2528						}
2529	14		50		29	$left_recs //= [];
2530
2531	14				94	my @left_cols = _get_columns($left_src, $left_recs);
2532	14 14				16 33	my @combine_specs = @{ $self->every_param('c') };
2533
2534	14				527	my @sources = ([$left_recs, \@left_cols]);
2535	14				14	my @summaries;
2536
2537	14				21	for my $cspec (@combine_specs) {
2538	12				24	my ($csrc, $clabel) = $self->_open_spec($cspec);
2539	12	100			135	next unless $csrc;
2540	11 11		50		11 24	my $crecs = eval { $csrc->fetch_all } // [];
2541	11	50			18	next if $@;
2542	11				22	my @ccols = _get_columns($csrc, $crecs);
2543	11				21	push @sources, [$crecs, \@ccols];
2544	11				48	push @summaries, { label => $clabel };
2545						}
2546
2547	14	100			630	my ($records, $cols_ref) = @sources > 1
2548						? _combine_tables(\@sources)
2549						: ($left_recs, \@left_cols);
2550	14				29	my @columns = @$cols_ref;
2551
2552						# Apply f= filters in memory before paginating (reduce-before-paginate).
2553	14 14		50		18 30	for my $s (@{ $self->every_param('f') // [] }) {
2554	2				77	$records = _apply_filter_spec($records, $s);
2555						}
2556	14	50			410	my $dedup = $self->param('d') ? 1 : 0;
2557	14	50			323	$records = _dedup_records($records, \@columns) if $dedup;
2558
2559						# In-memory sort for /combine (no single backend to delegate to).
2560	14				24	my $sort = $self->param('sort');
2561	14	100	100		277	my $dir = ($self->param('dir') // 'asc') =~ /\Adesc\z/i ? 'desc' : 'asc';
2562	14 4	100 50	67		325 6	if (defined $sort && grep { $_ eq $sort } @columns) {
2563	2				6	carp $self->_i18n('warn_combine_sort');
2564	2 10		50 50		376 28	@$records = sort { ($a->{$sort} // '') cmp ($b->{$sort} // '') } @$records;
2565	2	100			6	@$records = reverse @$records if $dir eq 'desc';
2566						} elsif (defined $sort) {
2567	0				0	carp $self->_i18n('error_sort_column', $sort);
2568						}
2569
2570						# Server-side pagination: slice the fully-reduced combined set.
2571	14				35	my ($page, $per_page, $offset) = $self->_pagination;
2572	14				19	my $total = scalar @$records;
2573	14	100			29	my $has_next = ($total > $offset + $per_page) ? 1 : 0;
2574	14				28	my @page_recs = splice(@$records, $offset, $per_page);
2575	14				20	$records = \@page_recs;
2576
2577	14				37	my (undef, $filter_specs, $filters_json) = $self->_apply_filters($records);
2578
2579	14				17	my $title = $left_label;
2580	14 11	100			39 30	$title .= ' + ' . join(' + ', map { $_->{label} } @summaries) if @summaries;
2581	14				23	my $table_key = 'combine:' . lc($left_label);
2582	14				32	$table_key .= ':' . lc($_->{label}) for @summaries;
2583
2584	14				22	my $page_url = $self->req->url->clone;
2585	14				782	$page_url->query->remove('page')->remove('per_page');
2586
2587	14		100		297	$self->render(
2588						template => "$platform/$language/dashboard",
2589						handler => 'tt',
2590						format => 'html',
2591						records => $records,
2592						columns => \@columns,
2593						table => $table_key,
2594						title => $title,
2595						back_url => $self->_spec_to_url($left_spec),
2596						back_label => "Back to $left_label",
2597						back2_url => _safe_back_url($self->param('back2')),
2598						back2_label => $self->param('back2_label') // 'Back',
2599						left_spec => $left_spec,
2600						combine_specs => \@combine_specs,
2601						current_joins => [],
2602						available_tables => $self->_scan_data_dir,
2603						join_summaries => \@summaries,
2604						filter_specs => $filter_specs,
2605						filters_json => $filters_json,
2606						dedup => $dedup,
2607						export_url => $self->_build_export_url($left_spec, [], $filter_specs, \@combine_specs, $dedup),
2608						page => $page,
2609						per_page => $per_page,
2610						has_next => $has_next,
2611						page_base_url => $page_url->to_string,
2612						);
2613						}
2614
2615 - 2671						=head2 export_data C<GET /export> -- Stream the current logical view as a browser file download. =head3 API SPECIFICATION =head4 INPUT ?l= string (required) Left table spec. ?j= string (repeatable) Join steps. ?f= string (repeatable) Filter specs. ?format= string "csv" (default), "sqlite", or "json". =head4 DOMAIN CONSTRAINTS: ?format= Exact lowercase string match. =over 4 =item Valid partitions C<csv> (explicit CSV), C<sqlite> (SQLite binary), C<json> (JSON array), absent/undef (defaults to CSV). =item Invalid partitions (all fall back to CSV) Any value not in the valid set (e.g. C<SQLITE>, C<Json>). =back =head4 OUTPUT 200 text/csv Content-Disposition: attachment; filename=<name>.csv 200 application/vnd.sqlite3 Content-Disposition: attachment; filename=<name>.db 200 application/json Content-Disposition: attachment; filename=<name>.json 404 application/json { "error": "Table not found" } =head3 MESSAGES None beyond the 404 response. =head3 FORMAL SPECIFICATION export_data == lambda self . let (recs, cols, label) = _run_export_pipeline() in pre recs /= undef post if format = 'sqlite' then render_sqlite(recs, cols) else if format = 'json' then render_json(recs, cols) else render_csv(recs, cols) =head3 EXAMPLE GET /export?l=table:sales&format=csv -> downloads sales.csv GET /export?l=table:sales&format=sqlite -> downloads sales.db GET /export?l=table:sales&format=json -> downloads sales.json =cut
2672
2673	55 55 55			55	538307 73 59	sub export_data ($self) {
2674	55				173	my ($records, $columns, $left_label) = $self->_run_export_pipeline;
2675	55	100			128	return $self->reply->not_found unless $records;
2676
2677						# Surface schema-type-mismatch warnings in a response header so API
2678						# consumers (and the user via browser dev tools) can see them even
2679						# though exports render no HTML template.
2680	49		50		88	my $warnings = $self->stash('schema_warnings') // [];
2681	49	50			325	if (@$warnings) {
2682	0 0				0 0	my $hdr = join('; ', map { s/\s+/ /gr =~ s/^\s+\|\s+$//gr } @$warnings);
2683	0				0	$self->res->headers->header('X-BI-Warnings' => $hdr);
2684						}
2685
2686	49		100		85	my $format = $self->param('format') // 'csv';
2687	49				1113	(my $safe_name = lc $left_label) =~ s/[^a-z0-9_]+/_/g;
2688
2689	49	100 100			228	return $format eq 'sqlite' ? $self->_render_sqlite($records, $columns, $safe_name)
2690						: $format eq 'json' ? $self->_render_json($records, $columns, $safe_name)
2691						: $self->_render_csv($records, $columns, $safe_name);
2692						}
2693
2694 - 2763						=head2 export_write C<POST /export> -- Write the current logical view to a chosen filesystem path. =head3 API SPECIFICATION =head4 INPUT l= string (required) Left table spec. j= string (repeatable) Join steps. f= string (repeatable) Filter specs. dir= string Target directory (must exist; resolved via realpath). filename= string Output filename including extension. Extension determines format: C<.csv> -> RFC 4180 CSV; C<.sql> -> SQLite; C<.json> -> JSON array of row objects. =head4 DOMAIN CONSTRAINTS: filename= The extension check uses C</\.csv\z/i> (CSV), C</\.sql\z/i> (SQLite), or C</\.json\z/i> (JSON): the C</i> flag makes matching case-insensitive, so C<.CSV>, C<.SQL>, and C<.JSON> are accepted alongside lowercase forms. Everything else returns 415. Path separator characters (C</> and C<\>) in C<filename> are stripped first via C<m{([^/\\]+)\z}> -- only the basename is kept, preventing directory traversal. =over 4 =item Valid partitions C<report.csv>, C<report.sql>, C<report.json>, C<REPORT.CSV>, C<report.SQL>. A single-character stem (C<a.csv>) is also valid. =item Invalid partitions (415) C<report.txt>, C<report> (no extension), empty string. =back =head4 OUTPUT 200 application/json { "saved": "/abs/path/to/file" } 404 application/json { "error": "..." } -- bad dir or table not found 415 application/json { "error": "..." } -- unsupported extension 500 application/json { "error": "..." } -- write failure =head3 MESSAGES error_dir_not_found -- realpath of dir failed or result is not a directory. error_ext_required -- filename extension is not .csv or .sql. error_write_failed -- DBI or filesystem write threw. =head3 FORMAL SPECIFICATION export_write == lambda self . let dir = realpath(param('dir')) in let file = dir / strip_path(param('filename')) in pre is_dir(dir) /\ ext(file) in {csv, sql} let (recs, cols, _) = _run_export_pipeline() in pre recs /= undef post spurt(file, serialise(recs, cols)) /\ render_json({ saved: file.to_string }) =head3 EXAMPLE POST /export l=table:sales dir=/home/user/exports filename=report.csv -> { "saved": "/home/user/exports/report.csv" } =cut
2764
2765	43 43 43			43	280128 48 35	sub export_write ($self) {
2766	43		50		82	my $dir = $self->param('dir') // '';
2767	43		50		7216	my $filename = $self->param('filename') // '';
2768
2769	43 43				1003 129	my $dest_dir = eval { Mojo::File->new($dir)->realpath };
2770	43	100	100		2075	unless (defined $dest_dir && -d $dest_dir) {
2771	5				29	return $self->render(
2772						json => { error => $self->_i18n('error_dir_not_found', $dir) },
2773						status => 404,
2774						);
2775						}
2776
2777						# Strip any path separators the browser might include.
2778	38				283	($filename) = $filename =~ m{([^/\\]+)\z};
2779	38				43	my $format;
2780	38 24	100 100 50	67 100 100		241 29	if ($filename && $filename =~ /\.csv\z/i) { $format = 'csv'; }
2781	4				7	elsif ($filename && $filename =~ /\.sql\z/i) { $format = 'sqlite'; }
2782	0				0	elsif ($filename && $filename =~ /\.json\z/i) { $format = 'json'; }
2783						else {
2784	10				29	return $self->render(
2785						json => { error => $self->_i18n('error_ext_required') },
2786						status => 415,
2787						);
2788						}
2789
2790	28				80	my ($records, $columns, $left_label) = $self->_run_export_pipeline;
2791	28	100			64	return $self->render(json => { error => 'Table not found' }, status => 404)
2792						unless $records;
2793
2794	26				70	my $dest = $dest_dir->child($filename);
2795	26				289	eval {
2796	26	100 50			57	if ($format eq 'csv') {
2797	22				46	$dest->spurt(_serialize_csv($records, $columns));
2798						}
2799						elsif ($format eq 'json') {
2800	0				0	$dest->spurt(encode_json($records));
2801						}
2802						else {
2803	4				12	$dest->spurt($self->_write_sqlite_db($records, $columns));
2804						}
2805						};
2806	26	100			2884	return $self->render(
2807						json => { error => $self->_i18n('error_write_failed', $@) },
2808						status => 500,
2809						) if $@;
2810
2811	25				66	$self->render(json => { saved => $dest->to_string });
2812						}
2813
2814 - 2852						=head2 dirs_api C<GET /api/dirs> -- Return a JSON directory listing for the export panel. =head3 API SPECIFICATION =head4 INPUT ?path= string Directory to list (default: $HOME). Returns 404 when not a directory. Hidden entries (names starting with ".") are excluded. =head4 OUTPUT 200 application/json { "path": "/abs/path", "parent": "/abs/parent" or null (at filesystem root), "dirs": [ { "name": "alpha", "path": "/abs/path/alpha" }, ... ] } 404 application/json { "error": "Not a directory" } =head3 MESSAGES None beyond the 404 response. =head3 FORMAL SPECIFICATION dirs_api == lambda self . let dir = realpath(param('path') // HOME) in pre is_dir(dir) post render_json({ path: dir, parent: parent(dir), dirs: subdirs(dir) }) =head3 EXAMPLE GET /api/dirs?path=/home/user -> {"path":"/home/user","parent":"/home","dirs":[...]} =cut
2853
2854	12 12 12			12	61082 11 11	sub dirs_api ($self) {
2855	12		50 67		23	my $raw = $self->param('path') // $ENV{HOME} // '/';
2856	12 12				1359 24	my $dir = eval { Mojo::File->new($raw)->realpath };
2857	12	100	100		860	return $self->render(json => { error => 'Not a directory' }, status => 404)
2858						unless defined $dir && -d $dir;
2859
2860	7				52	my $listing = $self->_list_dir($dir, 0);
2861	7				20	my $parent = $dir->dirname;
2862
2863						$self->render(json => {
2864						path => $dir->to_string,
2865						parent => ($parent->to_string ne $dir->to_string ? $parent->to_string : undef),
2866						dirs => $listing->{dirs},
2867	7	100			208	});
2868						}
2869
2870 - 2919						=head2 stat_api C<GET /api/stat> -- Return filesystem metadata for a file path. Used by the home page tooltip to show modification time and size for recently opened files without a page reload. =head3 API SPECIFICATION =head4 INPUT ?path= string Absolute path to query. Returns HTTP 400 when absent. =head4 OUTPUT 200 application/json (file exists) { "exists": true, "path": "/resolved/path", "mtime": 1700000000, "size": 4096 } 200 application/json (file does not exist) { "exists": false, "path": "/original/path" } 400 application/json { "error": "\"path\" parameter is required" } C<mtime> is Unix epoch seconds. C<size> is bytes. A missing/unresolvable path returns HTTP 200 with C<exists: false> (not 404) so the UI can distinguish "file was deleted" from a request error. =head3 MESSAGES error_path_required -- the "path" query parameter was not supplied. =head3 FORMAL SPECIFICATION stat_api == lambda self . let path = param('path') in pre path /= undef let file = realpath(path) in post if is_file(file) then render_json({ exists: true, mtime: mtime(file), size: size(file) }) else render_json({ exists: false }) =head3 EXAMPLE GET /api/stat?path=/data/sales.csv -> { "exists": true, "path": "/data/sales.csv", "mtime": 1700000000, "size": 1234 } GET /api/stat?path=/deleted.csv -> { "exists": false, "path": "/deleted.csv" } =cut
2920
2921	30 30 30			30	175932 37 24	sub stat_api ($self) {
2922	30				65	my $path = $self->param('path');
2923	30	100	100		3630	unless (defined $path && length $path) {
2924	6				24	return $self->render(
2925						json => { error => $self->_i18n('error_path_required') },
2926						status => 400,
2927						);
2928						}
2929
2930	24 24				23 44	my $file = eval { Mojo::File->new($path)->realpath };
2931						# Restrict to files with a supported data extension so stat_api cannot be
2932						# used as a filesystem oracle to probe /etc/shadow, /root/.ssh/, etc.
2933	24	100	100		1406	return $self->render(json => { exists => \0, path => $path })
2934						unless defined $file && -f $file && $file->basename =~ $EXT_RE;
2935
2936	12				517	my @s = stat $file->to_string;
2937
2938						# For SQLite files, count user tables so the home-page tooltip can show
2939						# "SQLite database - N tables". Silently omit the count if the file is
2940						# not actually a SQLite file (e.g. a Berkeley DB .db file).
2941	12				60	my $table_count;
2942	12	100			20	if ($file->basename =~ /\.(?:sql\|sqlite\|sqlite3\|db)\z/i) {
2943	1				12	eval {
2944	1				4	require DBI;
2945	1				1	my $dbh = DBI->connect(
2946						'dbi:SQLite:dbname=' . $file->to_string,
2947						'', '',
2948						{ RaiseError => 1, PrintError => 0, AutoCommit => 1 },
2949						);
2950	1				308	my $tbls = $dbh->selectcol_arrayref(
2951						q{SELECT name FROM sqlite_master WHERE type='table' AND name NOT LIKE 'sqlite_%'}
2952						);
2953	1 1		50		80 2	$table_count = scalar @{ $tbls // [] };
2954	1				35	$dbh->disconnect;
2955						};
2956						}
2957
2958	12	100			167	$self->render(json => {
2959						exists => \1,
2960						path => $file->to_string,
2961						mtime => $s[9],
2962						size => $s[7],
2963						(defined $table_count ? (table_count => $table_count) : ()),
2964						});
2965						}
2966
2967 - 3025						=head2 upload_file C<POST /upload> -- Accept a drag-and-dropped data file and return a redirect URL. The file is saved under its original filename in a managed subdirectory of C<< <app_home>/.uploads/ >>. The subdirectory name is randomised so that concurrent uploads of files with the same name do not collide. =head3 API SPECIFICATION =head4 INPUT Multipart form upload, field name: C<file>. file upload Supported extensions: csv, db, sql, xml, tsv, psv. =head4 OUTPUT 200 application/json { "url": "/open?path=/abs/path/file.csv", "path": "/abs/path/file.csv" } 400 application/json { "error": "No file received" } 413 application/json { "error": "File too large to upload (limit: 50 MB)" } 415 application/json { "error": "Unsupported file type. Accepted: ..." } 500 application/json { "error": "Could not save uploaded file" } =head3 MESSAGES error_upload_none -- no file was received in the multipart upload. error_upload_ext -- the file's extension is not in the supported list. error_upload_too_large -- the upload body exceeded MAX_UPLOAD_MIB (50 MiB). error_upload_save -- move_to failed or the destination file was not created (I/O error, full disk, permission error). =head3 IMPLEMENTATION NOTES The C<move_to> call is wrapped with the C<eval { ...; 1 }> idiom (not C<eval {}> + C<if ($@)>). Mojolicious dispatch and DESTROY-phase evals can leave C<$@> set before the action runs; checking C<if ($@)> after a new eval may fire falsely on that stale value. C<eval { move_to(); 1 }> returns 1 on success and C<undef> on exception, so the result is independent of any prior C<$@> value. =head3 FORMAL SPECIFICATION upload_file == lambda self . let upload = req.upload('file') in pre upload /= undef /\ basename(upload.filename) =~ EXT_RE /\ NOT req->is_limit_exceeded /\ upload.size <= MAX_UPLOAD_BYTES let dest = home/.uploads/<random>/<filename> in let ok = eval { upload.move_to(dest); 1 } in pre ok /\ -f dest post render_json({ url: '/open?path=' ++ url_escape(dest), path: dest }) =head3 EXAMPLE POST /upload (multipart: file=@sales.csv) -> { "url": "/open?path=%2F...%2Fsales.csv", "path": "/.../.uploads/abc123/sales.csv" } =cut
3026
3027	43 43 43			43	364897 53 41	sub upload_file ($self) {
3028	43				67	my $upload = $self->req->upload('file');
3029	43	100	67		3561	unless ($upload && $upload->filename) {
3030	4				13	return $self->render(
3031						json => { error => $self->_i18n('error_upload_none') },
3032						status => 400,
3033						);
3034						}
3035
3036						# Enforce upload size limit. max_request_size in startup() sets the
3037						# transport-layer cap, but Mojolicious still calls the controller when the
3038						# limit fires (with req->is_limit_exceeded true and partial content in the
3039						# upload asset). Check is_limit_exceeded first; fall through to an asset
3040						# size check as a belt-and-braces guard for any bytes that slipped through.
3041	39	100	67		169	if ($self->req->is_limit_exceeded \|\| $upload->size > $MAX_UPLOAD_BYTES) {
3042	3				24	return $self->render(
3043						json => { error => $self->_i18n('error_upload_too_large', $MAX_UPLOAD_MIB) },
3044						status => 413,
3045						);
3046						}
3047
3048						# /s so .* matches \n; a percent-decoded newline inside a browser filename
3049						# must not silently truncate the directory-strip, leaving "dir\ncomponent" in.
3050	36				636	(my $filename = $upload->filename) =~ s{.*[/\\]}{}s;
3051	36	100	67		215	unless ($filename && $filename =~ $EXT_RE) {
3052	5				57	return $self->render(
3053						json => { error => $self->_i18n('error_upload_ext') },
3054						status => 415,
3055						);
3056						}
3057
3058						# Store uploads in <app_home>/.uploads/<random_subdir>/<original_filename>.
3059						# Using the original filename is essential: Database::Abstraction derives
3060						# the table name from the file stem, so "sales.csv" must stay "sales.csv".
3061						# The random subdirectory prevents collisions from concurrent same-name uploads.
3062	31				298	my $uploads_base = $self->app->home->child('.uploads');
3063	31	100			559	$uploads_base->make_path unless -d $uploads_base;
3064	31				487	my $sub_dir = tempdir(DIR => $uploads_base->to_string, CLEANUP => 0);
3065	31				5708	my $dest = Mojo::File->new($sub_dir)->child($filename)->to_string;
3066
3067						# move_to returns the destination Mojo::File on success; croaks on I/O
3068						# failure. Wrap in eval so a disk error becomes a 500 JSON response
3069						# rather than a bare Mojolicious exception page.
3070						# Use the "eval { ...; 1 }" idiom: $ok is undef only when THIS eval
3071						# threw, avoiding false positives from a stale $@ left by Mojo's
3072						# internal dispatch code that runs before the controller action.
3073	31 31 30				450 78 1930	my $ok = eval { $upload->move_to($dest); 1 };
3074	31	100	100		482	if (!$ok \|\| !-f $dest) {
3075	2				249	remove_tree($sub_dir);
3076	2				8	return $self->render(
3077						json => { error => $self->_i18n('error_upload_save') },
3078						status => 500,
3079						);
3080						}
3081
3082	29				71	$self->render(json => {
3083						url => '/open?path=' . url_escape($dest),
3084						path => $dest,
3085						});
3086						}
3087
3088	5 5 5			5	41239 7 5	sub clear_uploads ($self) {
3089	5				8	my $uploads_dir = $self->app->home->child('.uploads');
3090
3091	5	50			80	return $self->render(json => { freed => 0, count => 0 })
3092						unless -d $uploads_dir;
3093
3094	5				50	my ($freed, $count) = (0, 0);
3095
3096						# Each upload lands in <uploads_dir>/<random_subdir>/<filename>.
3097						# Iterate the subdirs, tally file sizes, then remove each subdir tree.
3098						$uploads_dir->list({ dir => 1 })->each(sub {
3099	29			29	2451	my ($entry) = @_;
3100	29	50 0			26	if (-d $entry) {
3101						$entry->list->each(sub {
3102	29				808	my ($file) = @_;
3103	29	50			27	return unless -f $file;
3104	29		50		95	$freed += (-s $file) // 0;
3105	29				91	$count++;
3106	29				108	});
3107	29				76	$entry->remove_tree;
3108						} elsif (-f $entry) {
3109	0		0		0	$freed += (-s $entry) // 0;
3110	0				0	$count++;
3111	0				0	unlink $entry->to_string;
3112						}
3113	5				17	});
3114
3115	5				311	$self->render(json => { freed => $freed, count => $count });
3116						}
3117
3118						# graph_view
3119						#
3120						# Purpose: Render a D3.js line chart from the current data pipeline.
3121						# Entry: Query params identical to /join (l=, j=, c=, f=, d=) plus:
3122						# x=<column> -- X-axis column name
3123						# y=<column> -- Y-axis column name (values must be numeric)
3124						# back=<url> -- URL for the "Back to table" link (set by JS)
3125						# Exit: Emits a TT-rendered HTML page with a brush-to-zoom HTML::D3 snippet.
3126						# Each data point carries an "extra" hash of every column not used
3127						# as the X or Y axis; HTML::D3 displays these in the hover tooltip.
3128						# A "Reset zoom" button appears after the user brushes to zoom in.
3129						# Returns HTTP 400 for missing/invalid column names, 404 if the
3130						# data source cannot be opened, 200 with an error message when
3131						# no plottable rows exist.
3132	34 34 34			34	336102 41 41	sub graph_view ($self) {
3133	34		100		74	my $x_col = $self->param('x') // '';
3134	34		100		5606	my $y_col = $self->param('y') // '';
3135	34		100		816	my $series_col = $self->param('series') // '';
3136	34		100		744	my $back = _safe_back_url($self->param('back')) // '/';
3137	34				60	my $back2 = _safe_back_url($self->param('back2'));
3138	34		50		55	my $back2_lbl = $self->param('back2_label') // '';
3139
3140	34	100	100		763	return $self->render(text => 'Missing x or y column parameter', status => 400)
3141						unless length($x_col) && length($y_col);
3142
3143	32				87	my ($src, $records, $columns) = $self->_run_pipeline_source;
3144	32	100			77	return $self->render(text => 'Could not open data source', status => 404)
3145						unless defined $records;
3146
3147	30 30				31 83	eval { ($records, $columns) = $self->_apply_calc_fields($records, $columns) };
3148	30 0 0	50			51 0 0	if ($@) { (my $e = $@) =~ s/ at \S+ line \d+\.?\n?$//; return $self->render(text => $e, status => 400) }
3149
3150						# Apply f= filters (pre-filter before building pairs, same as _run_export_pipeline).
3151	30 30				29 44	for my $s (@{ $self->every_param('f') }) {
3152	1				20	$records = _apply_filter_spec($records, $s);
3153						}
3154
3155	30 104 30				565 114 36	my %col_set = map { $_ => 1 } @{$columns};
3156						return $self->render(text => "Column not found: $x_col", status => 400)
3157	30	100			78	unless $col_set{$x_col};
3158						return $self->render(text => "Column not found: $y_col", status => 400)
3159	29	100			55	unless $col_set{$y_col};
3160	28	100			48	if (length $series_col) {
3161						return $self->render(text => "Column not found: $series_col", status => 400)
3162	3	100			7	unless $col_set{$series_col};
3163						}
3164
3165						# --- Multi-series path: ?series=<col> groups records into one line per value ---
3166	27	100			47	if (length $series_col) {
3167	2				2	my %by_series;
3168						my @series_order;
3169	2 2				2 4	for my $row (@{$records}) {
3170	12		50		14	my $x = $row->{$x_col} // '';
3171	12		50		13	my $y = $row->{$y_col} // '';
3172	12		50		5	my $grp = $row->{$series_col} // '';
3173	12	50	25		28	next unless length($x) && length($y) && length($grp);
3174	12				6	my $yn = _numeric_cell($y);
3175	12	50			8	next unless defined $yn;
3176	12	100			13	unless (exists $by_series{$grp}) {
3177	4				5	push @series_order, $grp;
3178	4				3	$by_series{$grp} = [];
3179						}
3180	12 12				9 12	push @{$by_series{$grp}}, { label => _decode_cell($x), value => $yn };
3181						}
3182
3183	2	50			4	return $self->render(
3184						text => 'No plottable data: no rows have valid numeric values in the Y column.',
3185						status => 200,
3186						) unless @series_order;
3187
3188	2 4				3 8	my @series_data = map { { name => $_, data => $by_series{$_} } } @series_order;
3189
3190	2				6	require HTML::D3;
3191	2				3	my $title = "$y_col vs $x_col by $series_col";
3192	2				9	my $html = HTML::D3->new(title => $title, width => 1100, height => 580)
3193						->render_multi_series_line_chart_with_interactive_legends(\@series_data);
3194
3195	2	50			3611	utf8::decode($html) unless utf8::is_utf8($html);
3196	2				6	return $self->render(data => encode('UTF-8', $html), format => 'html');
3197						}
3198
3199						# --- Single-series path (original behaviour when ?series= is absent) ---
3200
3201						# Extract [label, value] pairs; skip rows where Y is missing or non-numeric.
3202	25				23	my @pairs;
3203	25 25				23 38	for my $row (@{$records}) {
3204	90		50		110	my $x = $row->{$x_col} // '';
3205	90		100		92	my $y = $row->{$y_col} // '';
3206	90	100	67		139	next unless length($x) && length($y);
3207	87				90	my $yn = _numeric_cell($y);
3208	87	100			83	next unless defined $yn;
3209	75 158 308 75	100			53 161 331 54	my %extra = map { $_ => _decode_cell($row->{$_}) } grep { $_ ne $x_col && $_ ne $y_col } @{$columns};
3210	75				78	push @pairs, [_decode_cell($x), $yn, \%extra];
3211						}
3212
3213	25	100			46	return $self->render(
3214						text => 'No plottable data: no rows have valid numeric values in the Y column.',
3215						status => 200,
3216						) unless @pairs;
3217
3218	20 75				26 64	my @y_vals = map { $_->[1] } @pairs;
3219	20				24	my ($min_y, $max_y, $avg_y);
3220
3221						# Try aggregate() push path for the global min/max/avg reference lines.
3222						# Falls back to List::Util on the already-extracted @y_vals when push is
3223						# not available (no source, filters active, or non-pushable column).
3224	20 1 20		50		21 22 166	my @f_specs = grep { /\S/ } @{ $self->every_param('f') // [] };
3225	20				401	my $has_filter = !!@f_specs;
3226	20	100	60		124	if (!$ENV{BI_FORCE_PERL_AGG} && $src && !$has_filter
3227						&& _measure_pushable($src, 'avg', $y_col, $records)) {
3228	7				8	my $ref = eval {
3229	7				17	$src->aggregate(
3230						by => [],
3231						measures => [
3232						_measure('min', $y_col, 'lo'),
3233						_measure('max', $y_col, 'hi'),
3234						_measure('avg', $y_col, 'mean'),
3235						],
3236						)
3237						};
3238	7	50	25		43433	if (!$@ && $ref && @$ref) {
3239	7				11	$min_y = $ref->[0]{lo};
3240	7				11	$max_y = $ref->[0]{hi};
3241	7				13	$avg_y = $ref->[0]{mean};
3242						}
3243						}
3244						# Perl fallback: compute from the already-stripped @y_vals.
3245	20	100			38	unless (defined $min_y) {
3246	13				24	$min_y = min(@y_vals);
3247	13				21	$max_y = max(@y_vals);
3248	13				38	$avg_y = sum(@y_vals) / scalar(@y_vals);
3249						}
3250
3251	20				57	my ($source_url, $source_accessed) = $self->_url_attribution;
3252
3253	20				154	require HTML::D3;
3254	20				29	my $title = "$y_col vs $x_col";
3255	20				114	my $snippet = HTML::D3->new(title => $title, width => 1100, height => 580, responsive => 1)
3256						->render_zoomable_line_chart_snippet(\@pairs, { animated => 1 });
3257
3258	20				40660	my $graph_html = $snippet->{html};
3259	20	50			52	utf8::decode($graph_html) unless utf8::is_utf8($graph_html);
3260
3261	20				61	my ($platform, $language) = $self->_resolve_template;
3262	20	50 50	0 33		254	$self->render(
3263						handler => 'tt',
3264						template => "$platform/$language/graph",
3265						format => 'html',
3266						title => $title,
3267						graph_html => $graph_html,
3268						back_url => ($back2 // $back),
3269						back_label => ($back2 ? ($back2_lbl \|\| 'Back') : 'Back to table'),
3270						($back2 ? (back2_url => $back, back2_label => 'Back to table') : ()),
3271						point_count => scalar @pairs,
3272						ref_min_y => $min_y,
3273						ref_max_y => $max_y,
3274						ref_avg_y => sprintf('%.4g', $avg_y),
3275						source_url => $source_url,
3276						source_accessed => $source_accessed,
3277						);
3278						}
3279
3280	23 23 23			23	193561 30 20	sub pie_view ($self) {
3281	23		100		49	my $cat_col = $self->param('cat') // '';
3282	23		100		3822	my $val_col = $self->param('val') // '';
3283	23	100			557	my $donut = $self->param('donut') ? 1 : 0;
3284	23		100		479	my $back = _safe_back_url($self->param('back')) // '/';
3285	23				166	my $back2 = _safe_back_url($self->param('back2'));
3286	23		50		38	my $back2_lbl = $self->param('back2_label') // '';
3287
3288	23	100	100		531	return $self->render(text => 'Missing cat or val column parameter', status => 400)
3289						unless length($cat_col) && length($val_col);
3290
3291	19				56	my ($src, $records, $columns) = $self->_run_pipeline_source;
3292	19	100			41	return $self->render(text => 'Could not open data source', status => 404)
3293						unless defined $records;
3294
3295	18 18				17 58	eval { ($records, $columns) = $self->_apply_calc_fields($records, $columns) };
3296	18 0 0	50			40 0 0	if ($@) { (my $e = $@) =~ s/ at \S+ line \d+\.?\n?$//; return $self->render(text => $e, status => 400) }
3297
3298						# Apply f= filters.
3299	18 18				21 27	for my $s (@{ $self->every_param('f') }) {
3300	0				0	$records = _apply_filter_spec($records, $s);
3301						}
3302
3303	18 72 18				379 78 22	my %col_set = map { $_ => 1 } @{$columns};
3304						return $self->render(text => "Column not found: $cat_col", status => 400)
3305	18	100			48	unless $col_set{$cat_col};
3306
3307						# '__count__' is the sentinel value sent when the user picks "Count (rows)".
3308	17				25	my $count_mode = ($val_col eq '__count__');
3309						return $self->render(text => "Column not found: $val_col", status => 400)
3310	17	50	67		51	unless $count_mode \|\| $col_set{$val_col};
3311
3312						# Detect the currency symbol from the first non-empty source value.
3313						# This is a display concern; derive from the pre-filtered source rows so the
3314						# $/$GBP/EUR prefix on the legend is unchanged regardless of the push path.
3315	17				20	my $currency_symbol = '';
3316	17	100			31	if (!$count_mode) {
3317	14				17	for my $row (@$records) {
3318	53		50		72	my $v = $row->{$val_col} // '';
3319	53	50			43	next unless length($v);
3320	53	100			84	if ($v =~ /\A\s\(?\s([^\d\s.,\-\(])/) {
3321	4				6	$currency_symbol = $1;
3322	4				6	last;
3323						}
3324						}
3325						}
3326
3327						# Aggregate via _grouped_totals (push path or Perl fold).
3328	17	100 100			129	my $agg_rows = $self->_grouped_totals(
3329						{ source => $src, records => $records },
3330						{
3331						by => [$cat_col],
3332						fn => $count_mode ? 'count' : 'sum',
3333						val => $count_mode ? undef : $val_col,
3334						as => 'value',
3335						},
3336						);
3337
3338						# Top-N: keep the highest-N slices, aggregate the rest as "Other".
3339	17		50		67	my $topn_n = int($self->param('topn') // 0);
3340	17	50	33		734	if ($topn_n > 0 && @$agg_rows > $topn_n) {
3341	0 0		0 0		0 0	my @sorted = sort { ($b->{value} // 0) <=> ($a->{value} // 0) } @$agg_rows;
3342	0				0	my @top_agg = @sorted[0 .. $topn_n - 1];
3343	0 0		0		0 0	my %top_cats = map { ($_->{$cat_col} // '') => 1 } @top_agg;
3344						my $other_rec = [
3345	0 0		0		0 0	grep { !$top_cats{$_->{$cat_col} // ''} } @$records
3346						];
3347	0	0			0	if (@$other_rec) {
3348	0	0 0			0	my $other = $self->_grouped_totals(
3349						{ source => undef, records => $other_rec },
3350						{ by => [], fn => ($count_mode ? 'count' : 'sum'),
3351						val => ($count_mode ? undef : $val_col), as => 'value' },
3352						);
3353						push @top_agg, { $cat_col => 'Other', value => $other->[0]{value} }
3354	0	0	0		0	if @$other && defined $other->[0]{value};
3355						}
3356	0				0	$agg_rows = \@top_agg;
3357						}
3358
3359	17	100			34	return $self->render(
3360						text => 'No plottable data: no rows have valid data in the selected columns.',
3361						status => 200,
3362						) unless @$agg_rows;
3363
3364	16 49				21 81	my @slices = map { [_decode_cell($_->{$cat_col}), $_->{value}] } @$agg_rows;
3365
3366	16				48	my ($source_url, $source_accessed) = $self->_url_attribution;
3367
3368	16				139	require HTML::D3;
3369	16		50		26	my $scheme = $self->param('scheme') // 'tableau10';
3370	16	100			373	my $title = $count_mode ? "Count by $cat_col" : "$val_col by $cat_col";
3371	16				86	my $snippet = HTML::D3->new(title => $title, width => 600, height => 500, responsive => 1)
3372						->render_pie_chart_snippet(\@slices, {
3373						animated => 1,
3374						donut => $donut,
3375						sort_slices => 'value',
3376						max_slices => 12,
3377						legend => 1,
3378						color_scheme => $scheme,
3379						});
3380
3381	16				32687	my $pie_html = $snippet->{html};
3382	16	50			39	utf8::decode($pie_html) unless utf8::is_utf8($pie_html);
3383
3384	16				47	my ($platform, $language) = $self->_resolve_template;
3385	16	50 50	0 33		128	$self->render(
3386						handler => 'tt',
3387						template => "$platform/$language/pie",
3388						format => 'html',
3389						title => $title,
3390						pie_html => $pie_html,
3391						back_url => ($back2 // $back),
3392						back_label => ($back2 ? ($back2_lbl \|\| 'Back') : 'Back to table'),
3393						($back2 ? (back2_url => $back, back2_label => 'Back to table') : ()),
3394						drill_back_url => $back,
3395						slice_count => scalar @slices,
3396						cat_col => $cat_col,
3397						val_col => $val_col,
3398						currency_symbol => $currency_symbol,
3399						source_url => $source_url,
3400						source_accessed => $source_accessed,
3401						);
3402						}
3403
3404 - 3455						=head2 heatmap_view C<GET /heatmap> -- Render a D3.js grid heatmap for two categorical axes. Accepts the same C<l=>, C<j=>, C<f=> pipeline params as C</join>, plus: x=<col> X-axis (horizontal) categorical column (required) y=<col> Y-axis (vertical) categorical column (required) val=<col> Cell value column (optional; when absent, cells show row count) scheme=<name> D3 sequential colour scheme name (default: YlOrRd) show_val=1 Overlay the numeric value inside each cell back=<url> URL for the "Back to table" breadcrumb link =head3 API SPECIFICATION =head4 INPUT l spec Required. Left table spec (table:name or path:/abs/path). x string Required. Name of the X-axis categorical column. y string Required. Name of the Y-axis categorical column. val string Optional. Name of the value column; omit for count mode. scheme string Optional. D3 sequential colour scheme name. show_val flag Optional. Set to 1 to render values inside cells. back url Optional. Safe back-link URL (sanitised by _safe_back_url). =head4 OUTPUT 200 text/html Rendered heatmap page. 200 text/plain "No plottable data: ..." when grid is empty. 400 text/plain Missing x= or y= parameter. 400 text/plain Column not found: <col>. 404 text/plain "Could not open data source" when l= is absent/invalid. =head3 MESSAGES error_heatmap_no_data -- no (x,y) pair has a non-empty value. =head3 FORMAL SPECIFICATION heatmap_view == lambda self . pre length(x_col) > 0 /\ length(y_col) > 0 /\ x_col in columns /\ y_col in columns let triples = { (row[x_col], row[y_col], row[val_col]) \| row in records, all three fields non-empty } in post render(heatmap, triples) =head3 EXAMPLE GET /heatmap?l=table:sales&x=region&y=product&val=amount -> 200 HTML page containing D3 heatmap SVG =cut
3456
3457	15 15 15			15	98102 21 13	sub heatmap_view ($self) {
3458	15		100		23	my $x_col = $self->param('x') // '';
3459	15		100		2299	my $y_col = $self->param('y') // '';
3460	15		100		339	my $val_col = $self->param('val') // '';
3461	15		50		306	my $scheme = $self->param('scheme') // 'YlOrRd';
3462	15	50			305	my $show_v = $self->param('show_val') ? 1 : 0;
3463	15		50		293	my $back = _safe_back_url($self->param('back')) // '/';
3464	15				22	my $back2 = _safe_back_url($self->param('back2'));
3465	15		50		19	my $back2_lbl = $self->param('back2_label') // '';
3466
3467	15	100	100		328	return $self->render(text => 'Missing x or y column parameter', status => 400)
3468						unless length($x_col) && length($y_col);
3469
3470	11				34	my ($src, $records, $columns) = $self->_run_pipeline_source;
3471	11	100			29	return $self->render(text => 'Could not open data source', status => 404)
3472						unless defined $records;
3473
3474	10 10				8 31	eval { ($records, $columns) = $self->_apply_calc_fields($records, $columns) };
3475	10 0 0	50			16 0 0	if ($@) { (my $e = $@) =~ s/ at \S+ line \d+\.?\n?$//; return $self->render(text => $e, status => 400) }
3476
3477						# Apply f= filters.
3478	10 10				12 16	for my $s (@{ $self->every_param('f') }) {
3479	0				0	$records = _apply_filter_spec($records, $s);
3480						}
3481
3482	10 31 10				190 37 11	my %col_set = map { $_ => 1 } @{$columns};
3483						return $self->render(text => "Column not found: $x_col", status => 400)
3484	10	100			29	unless $col_set{$x_col};
3485						return $self->render(text => "Column not found: $y_col", status => 400)
3486	8	100			21	unless $col_set{$y_col};
3487						return $self->render(text => "Column not found: $val_col", status => 400)
3488	7	50	67		25	if length($val_col) && !$col_set{$val_col};
3489
3490						# Collect first-seen axis order from the filtered source rows.
3491						# The aggregate path returns groups ordered by (x,y) ascending, which
3492						# differs from first-seen. We re-derive the layout order from the source
3493						# so the grid renders in natural data order regardless of backend.
3494	7				7	my (@x_order, @y_order, %seen_x, %seen_y);
3495	7				9	for my $row (@$records) {
3496	24		100		29	my $x = $row->{$x_col} // next;
3497	22		50		24	my $y = $row->{$y_col} // next;
3498	22	50	33		31	next unless length($x) && length($y);
3499	22	100			28	push @x_order, $x unless $seen_x{$x}++;
3500	22	100			33	push @y_order, $y unless $seen_y{$y}++;
3501						}
3502
3503						# Aggregate with _grouped_totals (push or Perl fold).
3504	7	100 100			59	my $agg_rows = $self->_grouped_totals(
3505						{ source => $src, records => $records },
3506						{
3507						by => [$x_col, $y_col],
3508						fn => length($val_col) ? 'sum' : 'count',
3509						val => length($val_col) ? $val_col : undef,
3510						as => 'value',
3511						},
3512						);
3513
3514						# Index aggregate rows by [x][y] for O(1) lookup.
3515	7				17	my %grid;
3516	7				11	for my $row (@$agg_rows) {
3517	22				35	$grid{$row->{$x_col}}{$row->{$y_col}} = $row->{value};
3518						}
3519
3520						my @triples = map {
3521	7 12				11 22	my ($raw_x, $xv) = ($_, _decode_cell($_));
3522	12 24		100		13 18	map { [$xv, _decode_cell($_), $grid{$raw_x}{$_} // 0] } @y_order
3523						} @x_order;
3524
3525	7	100			16	return $self->render(
3526						text => 'No plottable data: check that x and y columns contain values.',
3527						status => 200,
3528						) unless @triples;
3529
3530	6				21	my ($source_url, $source_accessed) = $self->_url_attribution;
3531
3532	6				552	require HTML::D3;
3533	6	100			3819	my $title = length($val_col) ? "$val_col by $x_col and $y_col"
3534						: "Count by $x_col and $y_col";
3535	6	100			35	my $snippet = HTML::D3->new(title => $title, width => 900, height => 500, responsive => 1)
3536						->render_heatmap_snippet(\@triples, {
3537						x_label => $x_col,
3538						y_label => $y_col,
3539						val_label => (length($val_col) ? $val_col : 'Count'),
3540						color_scheme => $scheme,
3541						show_values => $show_v,
3542						animated => 1,
3543						});
3544
3545	6				12367	my $heatmap_html = $snippet->{html};
3546	6	50			15	utf8::decode($heatmap_html) unless utf8::is_utf8($heatmap_html);
3547
3548	6				19	my ($platform, $language) = $self->_resolve_template;
3549	6	50 50	0 33		43	$self->render(
3550						handler => 'tt',
3551						template => "$platform/$language/heatmap",
3552						format => 'html',
3553						title => $title,
3554						heatmap_html => $heatmap_html,
3555						cell_count => scalar @triples,
3556						back_url => ($back2 // $back),
3557						back_label => ($back2 ? ($back2_lbl \|\| 'Back') : 'Back to table'),
3558						($back2 ? (back2_url => $back, back2_label => 'Back to table') : ()),
3559						source_url => $source_url,
3560						source_accessed => $source_accessed,
3561						);
3562						}
3563
3564 - 3616						=head2 bar_view C<GET /bar> -- Render a D3.js bar chart grouped by a categorical column. Accepts the same C<l=>, C<j=>, C<f=> pipeline params as C</join>, plus: cat=<col> Category (X-axis) column (required) val=<col> Value column to sum per category; omit or use C<__count__> to count rows instead of summing (optional) orient=h Horizontal bars (default: vertical) sort=value\|label Sort bars by descending value or ascending label max=N Collapse bars beyond the top-N into an "Other" bar back=<url> URL for the "Back to table" breadcrumb link =head3 API SPECIFICATION =head4 INPUT l spec Required. Left table spec (table:name or path:/abs/path). cat string Required. Name of the category column. val string Optional. Name of the value column; use __count__ or omit entirely to count rows per category. orient string Optional. "h" for horizontal bars; default vertical. sort string Optional. "value" or "label"; default file order. max integer Optional. Collapse beyond top-N categories into "Other". back url Optional. Safe back-link URL (sanitised by _safe_back_url). =head4 OUTPUT 200 text/html Rendered bar chart page (SVG element id="bar_chart"). 200 text/plain "No plottable data: ..." when no categories exist. 400 text/plain Missing cat= parameter. 400 text/plain Column not found: <col>. 404 text/plain "Could not open data source" when l= is absent/invalid. =head3 MESSAGES error_bar_no_data -- no row has a non-empty category value. =head3 FORMAL SPECIFICATION bar_view == lambda self . pre length(cat_col) > 0 /\ cat_col in columns let bars = { (cat, sum(val)) \| row in records, row[cat_col] = cat, val /= undef } in post render(bar, bars, orientation, sort, max_bars) =head3 EXAMPLE GET /bar?l=table:sales&cat=region&val=amount&sort=value -> 200 HTML page with id="bar_chart" SVG element =cut
3617
3618	27 27 27			27	212313 30 30	sub bar_view ($self) {
3619	27		100		45	my $cat_col = $self->param('cat') // '';
3620	27		100		4231	my $val_col = $self->param('val') // '';
3621	27		100		626	my $orient = $self->param('orient') // 'vertical';
3622	27		100		582	my $sort = $self->param('sort') // 'none';
3623	27		50		553	my $max_bars = int($self->param('max') // 0);
3624	27		50		576	my $back = _safe_back_url($self->param('back')) // '/';
3625	27				43	my $back2 = _safe_back_url($self->param('back2'));
3626	27		50		41	my $back2_lbl = $self->param('back2_label') // '';
3627
3628	27	100			555	return $self->render(text => 'Missing cat column parameter', status => 400)
3629						unless length($cat_col);
3630
3631	24				64	my ($src, $records, $columns) = $self->_run_pipeline_source;
3632	24	100			46	return $self->render(text => 'Could not open data source', status => 404)
3633						unless defined $records;
3634
3635	23 23				26 63	eval { ($records, $columns) = $self->_apply_calc_fields($records, $columns) };
3636	23 0 0	50			41 0 0	if ($@) { (my $e = $@) =~ s/ at \S+ line \d+\.?\n?$//; return $self->render(text => $e, status => 400) }
3637
3638						# Apply f= filters.
3639	23 23				27 36	for my $s (@{ $self->every_param('f') }) {
3640	0				0	$records = _apply_filter_spec($records, $s);
3641						}
3642
3643	23 68 23				435 78 37	my %col_set = map { $_ => 1 } @{$columns};
3644						return $self->render(text => "Column not found: $cat_col", status => 400)
3645	23	100			67	unless $col_set{$cat_col};
3646
3647						# '__count__' sentinel: count rows per category instead of summing a column.
3648	21		100		59	my $count_mode = ($val_col eq '__count__' \|\| !length($val_col));
3649						return $self->render(text => "Column not found: $val_col", status => 400)
3650	21	100	100		61	unless $count_mode \|\| $col_set{$val_col};
3651
3652						# Aggregate via _grouped_totals (push path or Perl fold).
3653	20	100 100			159	my $agg_rows = $self->_grouped_totals(
3654						{ source => $src, records => $records },
3655						{
3656						by => [$cat_col],
3657						fn => $count_mode ? 'count' : 'sum',
3658						val => $count_mode ? undef : $val_col,
3659						as => 'value',
3660						},
3661						);
3662
3663						# Top-N: keep the highest-N categories, aggregate the rest as "Other".
3664	20		100		82	my $topn_n = int($self->param('topn') // 0);
3665	20	100	67		855	if ($topn_n > 0 && @$agg_rows > $topn_n) {
3666	1 8		50 50		2 10	my @sorted = sort { ($b->{value} // 0) <=> ($a->{value} // 0) } @$agg_rows;
3667	1				3	my @top_agg = @sorted[0 .. $topn_n - 1];
3668	1 3		50		2 5	my %top_cats = map { ($_->{$cat_col} // '') => 1 } @top_agg;
3669						my $other_rec = [
3670	1 5		50		2 7	grep { !$top_cats{$_->{$cat_col} // ''} } @$records
3671						];
3672	1	50			2	if (@$other_rec) {
3673	1	50 50			7	my $other = $self->_grouped_totals(
3674						{ source => undef, records => $other_rec },
3675						{ by => [], fn => ($count_mode ? 'count' : 'sum'),
3676						val => ($count_mode ? undef : $val_col), as => 'value' },
3677						);
3678						push @top_agg, { $cat_col => 'Other', value => $other->[0]{value} }
3679	1	50	33		6	if @$other && defined $other->[0]{value};
3680						}
3681	1				2	$agg_rows = \@top_agg;
3682						}
3683
3684	20	100			45	return $self->render(
3685						text => 'No plottable data: no rows have valid data in the selected columns.',
3686						status => 200,
3687						) unless @$agg_rows;
3688
3689	18 54				25 76	my @bars = map { [_decode_cell($_->{$cat_col}), $_->{value}] } @$agg_rows;
3690
3691	18	100			35	my $orientation = ($orient eq 'h') ? 'horizontal' : 'vertical';
3692	18	100	67		65	my $sort_bars = ($sort eq 'value' \|\| $sort eq 'label') ? $sort : 'none';
3693
3694	18				56	my ($source_url, $source_accessed) = $self->_url_attribution;
3695
3696	18				184	require HTML::D3;
3697	18	100			47	my $title = $count_mode ? "Count by $cat_col"
3698						: "$val_col by $cat_col";
3699	18	100 50			104	my $snippet = HTML::D3->new(title => $title, width => 800, height => 480, responsive => 1)
3700						->render_bar_chart_snippet(\@bars, {
3701						animated => 1,
3702						orientation => $orientation,
3703						sort_bars => $sort_bars,
3704						color => 'categorical',
3705						show_values => 0,
3706						value_label => ($count_mode ? 'Count' : $val_col),
3707						x_label => $cat_col,
3708						($max_bars > 0 ? (max_bars => $max_bars) : ()),
3709						});
3710
3711	18				36935	my $bar_html = $snippet->{html};
3712	18	50			52	utf8::decode($bar_html) unless utf8::is_utf8($bar_html);
3713
3714	18				57	my ($platform, $language) = $self->_resolve_template;
3715	18	50 50	0 33		137	$self->render(
3716						handler => 'tt',
3717						template => "$platform/$language/bar",
3718						format => 'html',
3719						title => $title,
3720						bar_html => $bar_html,
3721						bar_count => scalar @bars,
3722						cat_col => $cat_col,
3723						back_url => ($back2 // $back),
3724						back_label => ($back2 ? ($back2_lbl \|\| 'Back') : 'Back to table'),
3725						($back2 ? (back2_url => $back, back2_label => 'Back to table') : ()),
3726						source_url => $source_url,
3727						source_accessed => $source_accessed,
3728						);
3729						}
3730
3731 - 3791						=head2 folder_view C<GET /folder> -- Browse a data table grouped by the letter-prefix hierarchy of an order-number column (e.g. A10, CT4, B3). The top level displays one folder icon per initial letter group (A, B, C ...). Clicking a folder with sub-prefixes (e.g. C contains CA and CB items) shows the sub-folders; clicking a leaf prefix shows the actual data rows sorted numerically by the embedded digit sequence. Accepts the same C<l=>, C<j=>, C<f=> pipeline params as C</join>, plus: col=<col> Column whose values contain order codes (optional; auto- detected when absent by scanning the first 10 rows for values matching C<[A-Z]{1,4}\d+[A-Z]?>) prefix=<str> Current drill-down prefix, e.g. "CA" (optional; top-level when absent) back=<url> URL for the "Back to table" breadcrumb link (optional; derived from C<l=> when absent) =head3 API SPECIFICATION =head4 INPUT l spec Required. Left table spec (table:name or path:/abs/path). col string Optional. Order-code column name. prefix string Optional. Current letter prefix; max length MAX_PREFIX_LEN. back url Optional. Safe back-link URL (sanitised by _safe_back_url). =head4 OUTPUT 200 text/html Rendered folder page with folder grid and/or item table. 400 text/plain "Missing l= parameter" when l= is absent. 400 text/plain "Prefix too long" when prefix exceeds MAX_PREFIX_LEN (20). 404 text/plain "Could not open data source" when the data source is unavailable. =head3 MESSAGES None -- all failure paths render plain text with an HTTP status code. =head3 FORMAL SPECIFICATION folder_view == lambda self . pre length(left_spec) > 0 /\ length(prefix) <= MAX_PREFIX_LEN let records = pipeline(left_spec, joins, filters) prefix_map = { p -> [row] \| row in records, row[col] =~ /[A-Z]+/ -> p } in IF prefix = "" THEN post render(folder, folders = first_letters(prefix_map)) ELSE post render(folder, folders = sub_prefixes(prefix, prefix_map), items = sort_numeric(prefix_map[prefix])) =head3 EXAMPLE GET /folder?l=table:orders&col=order_no -> 200 HTML folder grid showing A (12 items), B (7 items), C (4 items) GET /folder?l=table:orders&col=order_no&prefix=A -> 200 HTML folder grid for sub-prefixes and items directly under "A" =cut
3792
3793	32 32 32			32	238259 37 30	sub folder_view ($self) {
3794	32		100		61	my $key_col = $self->param('col') // '';
3795	32		100		4319	my $prefix = $self->param('prefix') // '';
3796	32		100		730	my $left_spec = $self->param('l') // '';
3797
3798	32	100			685	return $self->render(text => 'Missing l= parameter', status => 400)
3799						unless length($left_spec);
3800
3801						# Guard against DoS: a crafted prefix longer than any real order-code would
3802						# generate O(N) breadcrumb entries and a proportionally large HTML response.
3803	27	100			90	return $self->render(text => 'Prefix too long', status => 400)
3804						if length($prefix) > $MAX_PREFIX_LEN;
3805
3806						# Fall back to the table's own URL when no explicit back= is supplied,
3807						# so the breadcrumb always has a "Back to table" link.
3808	23		33		80	my $back = _safe_back_url($self->param('back'))
3809						\|\| $self->_spec_to_url($left_spec);
3810
3811	23				181	my ($records, $columns) = $self->_run_export_pipeline;
3812	23	100			41	return $self->render(text => 'Could not open data source', status => 404)
3813						unless $records;
3814
3815						# Auto-detect key column: find the first column whose sampled values look
3816						# like order-number codes (1-4 uppercase letters followed by digits).
3817	21	100			36	if (!length($key_col)) {
3818	12 12 12	50			12 24 9	my $sample_end = $#{$records} < 9 ? $#{$records} : 9;
3819	12 12				16 22	OUTER: for my $col (@{$columns}) {
3820	57 57				41 55	for my $row (@{$records}[0 .. $sample_end]) {
3821	327	100	50		337	if (($row->{$col} // '') =~ /\A[A-Z]{1,4}\d+[A-Z]?\z/) {
3822	3				3	$key_col = $col;
3823	3				5	last OUTER;
3824						}
3825						}
3826						}
3827	12		67		31	$key_col \|\|= ($columns->[0] // '');
3828						}
3829
3830						# Build prefix -> [rows] map. Prefix is the leading letter-run of each
3831						# key value: "A10" -> "A", "CT4" -> "CT", "CC30A" -> "CC".
3832	21				25	my %prefix_to_rows;
3833	21 21				21 27	for my $row (@{$records}) {
3834	111		100		110	my $val = $row->{$key_col} // '';
3835	111				108	my ($p) = $val =~ /\A([A-Z]+)/;
3836	111	100			103	next unless defined $p;
3837	45 45				28 49	push @{ $prefix_to_rows{$p} }, $row;
3838						}
3839
3840						# Return the sorted list of "one-step" child prefixes of $par: all known
3841						# prefixes that share the parent as a strict prefix and extend it by
3842						# exactly one letter.
3843						my $sub_prefixes = sub {
3844	10			10	16	my ($par) = @_;
3845	10				12	my $len = length($par);
3846	10				14	my %seen;
3847	10				15	for my $p (keys %prefix_to_rows) {
3848	15	100			20	next if length($p) <= $len;
3849	4	100			6	next if substr($p, 0, $len) ne $par;
3850	2				3	$seen{ substr($p, 0, $len + 1) } = 1;
3851						}
3852	10				24	return sort keys %seen;
3853	21				53	};
3854
3855						# Count total items underneath a prefix (including all deeper sub-prefixes).
3856						my $deep_count = sub {
3857	16			16	13	my ($par) = @_;
3858	16				13	my $n = 0;
3859	16				14	for my $p (keys %prefix_to_rows) {
3860	52 18	100			51 17	$n += scalar @{ $prefix_to_rows{$p} }
3861						if substr($p, 0, length($par)) eq $par;
3862						}
3863	16				21	return $n;
3864	21				40	};
3865
3866	21				54	my ($platform, $language) = $self->_resolve_template;
3867
3868						# Base URL carries the table spec (and optional col=) so every sub-link
3869						# re-uses the same data source without repeating params.
3870	21				48	my $base_url = '/folder?l=' . url_escape($left_spec);
3871	21	50			233	$base_url .= '&col=' . url_escape($key_col) if length($key_col);
3872
3873	21				101	my (@folders, @items, @breadcrumb);
3874
3875	21	100			39	if (!length($prefix)) {
3876						# Top level: group all prefixes by their first letter.
3877	11				12	my %first_letter;
3878	11				15	for my $p (keys %prefix_to_rows) {
3879	16				20	$first_letter{ substr($p, 0, 1) } = 1;
3880						}
3881	11				23	for my $fl (sort keys %first_letter) {
3882	14				53	push @folders, {
3883						name => $fl,
3884						count => $deep_count->($fl),
3885						href => $base_url . '&prefix=' . url_escape($fl),
3886						};
3887						}
3888						} else {
3889						# Build breadcrumb: one entry per letter-prefix layer up to current.
3890						# e.g. prefix="CD" -> [ {name="C", href=...}, {name="CD", href=undef} ]
3891	10				21	for my $i (1 .. length($prefix)) {
3892	46				147	my $p = substr($prefix, 0, $i);
3893	46	100			65	push @breadcrumb, {
3894						name => $p,
3895						href => ($i < length($prefix))
3896						? ($base_url . '&prefix=' . url_escape($p))
3897						: undef,
3898						};
3899						}
3900
3901						# One-step child prefixes of the current prefix (sub-folders).
3902	10				18	for my $sp ($sub_prefixes->($prefix)) {
3903	2				7	push @folders, {
3904						name => $sp,
3905						count => $deep_count->($sp),
3906						href => $base_url . '&prefix=' . url_escape($sp),
3907						};
3908						}
3909
3910						# Items whose prefix matches exactly (e.g. prefix="C" shows C1, C3, ...).
3911	10 10		100		16 30	@items = @{ $prefix_to_rows{$prefix} // [] };
3912
3913						# Sort by the numeric part of the key value so A9 < A10.
3914						@items = sort {
3915	10 5		50		23 13	my ($an) = ($a->{$key_col} // '') =~ /(\d+)/;
3916	5		50		12	my ($bn) = ($b->{$key_col} // '') =~ /(\d+)/;
3917						($an // 0) <=> ($bn // 0)
3918	5	50	50 0 0 50		20	\|\| ($a->{$key_col} // '') cmp ($b->{$key_col} // '');
3919						} @items;
3920						}
3921
3922	21	100			65	my $title = length($prefix) ? "Folder: $prefix" : 'Folder view';
3923
3924	21				81	$self->render(
3925						handler => 'tt',
3926						template => "$platform/$language/folder",
3927						format => 'html',
3928						title => $title,
3929						folders => \@folders,
3930						items => \@items,
3931						columns => $columns,
3932						key_col => $key_col,
3933						prefix => $prefix,
3934						breadcrumb => \@breadcrumb,
3935						base_url => $base_url,
3936						back_url => $back,
3937						back_label => 'Back to table',
3938						left_spec => $left_spec,
3939						);
3940						}
3941
3942 - 3965						=head2 tables_view C<GET /tables> -- Schema browser for multi-table databases (SQLite, etc.). Lists all internal tables with their columns; clicking a table opens it. =head3 API SPECIFICATION =head4 INPUT ?l= string Required. Table spec: "table:name" (data_dir) or "path:/abs/path" (filesystem path). The file must be a SQLite database. =head4 OUTPUT Renders C<tables.html.tt> with: db_label string Short name / stem of the database file tables ARRAYREF of { name, columns => [...], href } spec string The raw l= spec (for building back links) back_url string URL to navigate back one level back_label string Label for the back link =cut
3966
3967	13 13 13			13	144045 17 12	sub tables_view ($self) {
3968	13				35	my ($platform, $language) = $self->_resolve_template;
3969	13				36	my $spec = $self->param('l');
3970	13	100	100		1892	return $self->reply->not_found unless defined $spec && length $spec;
3971
3972	10				17	my ($file_path, $db_label, $back_url, $back_label);
3973	10				0	my @tables;
3974
3975	10	100 100 50			56	if ($spec =~ /\Atable:([A-Za-z0-9_]+)\z/) {
3976	3				7	my $table_name = lc $1;
3977						my $data_dir = $self->app->home->child(
3978	3		50		6	$self->app->config->{data_dir} // 'data');
3979	3				50	for my $ext (qw(sql sqlite sqlite3 db)) {
3980	12				53	my $p = $data_dir->child("$table_name.$ext");
3981	12	100			68	if (-f $p) {
3982	2				12	$file_path = $p->to_string;
3983	2				6	last;
3984						}
3985						}
3986	3	100			12	return $self->reply->not_found unless defined $file_path;
3987	2				2	$db_label = $table_name;
3988	2				2	$back_url = '/';
3989	2				3	$back_label = 'Home';
3990						} elsif ($spec =~ /\Apath:(.+)\z/) {
3991	5				8	my $path_arg = $1;
3992	5 5				6 9	my $file = eval { Mojo::File->new($path_arg)->realpath };
3993	5	100	75		669	return $self->reply->not_found
3994						unless defined $file && -f $file && $file->basename =~ /\.(?:sql\|sqlite\|sqlite3\|db)\z/i;
3995	3				88	$file_path = $file->to_string;
3996	3				10	($db_label = $file->basename) =~ s/\.[^.]+\z//;
3997	3				34	$back_url = '/browse?path=' . url_escape($file->dirname->to_string);
3998	3				84	$back_label = 'Back to browser';
3999						} elsif ($spec =~ $REDIS_URL_RE) {
4000						# Bare redis:// URL -- scan keys and present a picker.
4001						# Parse redis://[:password@]host[:port][/db]
4002	0				0	my ($password, $hostport, $db_idx);
4003	0	0			0	if ($spec =~ m{\Aredis://(?::([^@]*)@)?([^/]+)(?:/(\d+))?\z}i) {
4004	0				0	($password, $hostport, $db_idx) = ($1, $2, $3);
4005						}
4006	0		0		0	$hostport //= 'localhost:6379';
4007	0				0	$db_label = "redis://$hostport";
4008	0				0	$back_url = '/';
4009	0				0	$back_label = 'Home';
4010
4011	0				0	eval {
4012						# Load Redis::Fast if available, fall back to Redis.
4013						# Use the file-path form ("Redis/Fast.pm") because require with a
4014						# plain string treats it as a filename, not a module name.
4015	0				0	my $pkg;
4016	0				0	for my $mod ('Redis::Fast', 'Redis') {
4017	0				0	(my $file = $mod) =~ s{::}{/}g;
4018	0 0 0 0 0	0			0 0 0 0 0	if (eval { require "$file.pm"; 1 }) { $pkg = $mod; last }
4019						}
4020	0	0			0	croak 'Redis or Redis::Fast must be installed to browse a Redis server'
4021						unless $pkg;
4022
4023	0				0	my $redis = $pkg->new(
4024						server => $hostport,
4025						cnx_timeout => 5,
4026						read_timeout => 10,
4027						);
4028	0	0	0		0	$redis->auth($password) if defined $password && length $password;
4029	0	0	0		0	$redis->select(int($db_idx)) if defined $db_idx && int($db_idx) > 0;
4030
4031						# SCAN in a loop; stop at 200 keys -- enough for a picker.
4032	0				0	my $cursor = 0;
4033	0				0	my @all_keys;
4034	0		0		0	do {
4035	0				0	my ($new_cursor, $batch) = $redis->scan($cursor, 'COUNT', 100);
4036	0				0	$cursor = $new_cursor;
4037	0 0		0		0 0	push @all_keys, @{ $batch // [] };
4038						} while ($cursor ne '0' && @all_keys < 200);
4039
4040	0				0	my $tables_url = '/tables?l=' . url_escape($spec);
4041	0				0	for my $key (sort @all_keys) {
4042	0				0	my $open_url = '/open?path=' . url_escape("redis:$key\|$spec")
4043						. '&back=' . url_escape($tables_url)
4044						. '&back_label=Redis+keys';
4045	0				0	push @tables, { name => $key, columns => [], href => $open_url };
4046						}
4047						};
4048	0	0			0	return $self->reply->not_found if $@;
4049						} else {
4050	2				13	return $self->reply->not_found;
4051						}
4052
4053	5 5	50			11 5	if (defined $file_path) { eval {
4054	5				19	require DBI;
4055	5				28	my $dbh = DBI->connect(
4056						"dbi:SQLite:dbname=$file_path", q{}, q{},
4057						{ RaiseError => 1, PrintError => 0, AutoCommit => 1 });
4058	5				1364	my $tnames = $dbh->selectcol_arrayref(
4059						q{SELECT name FROM sqlite_master }
4060						. q{WHERE type='table' AND name NOT LIKE 'sqlite_%' }
4061						. q{ORDER BY name});
4062	5 5		50		416 12	for my $tname (@{ $tnames // [] }) {
4063	12				7	my @cols;
4064	12 12				10 24	my $sth = eval { $dbh->prepare("PRAGMA table_info(\"$tname\")") };
4065	12	50			182	if ($sth) {
4066	12				65	$sth->execute;
4067	12				96	while (my $row = $sth->fetchrow_hashref) {
4068	35				144	push @cols, $row->{name};
4069						}
4070						}
4071	12				21	my $open_url = '/open?path=' . url_escape($file_path)
4072						. '&it=' . url_escape($tname)
4073						. '&back=' . url_escape('/tables?l=' . $spec)
4074						. '&back_label=' . url_escape(ucfirst($db_label) . ' schema');
4075	12				369	push @tables, { name => $tname, columns => \@cols, href => $open_url };
4076						}
4077	5				165	$dbh->disconnect;
4078	5	50			11	}; return $self->reply->not_found if $@; }
4079
4080						$self->render(
4081	5				23	template => "$platform/$language/tables",
4082						handler => 'tt',
4083						format => 'html',
4084						title => ucfirst($db_label) . ' -- Tables',
4085						db_label => $db_label,
4086						tables => \@tables,
4087						spec => $spec,
4088						back_url => $back_url,
4089						back_label => $back_label,
4090						);
4091						}
4092
4093 - 4109						=head2 pivot_view C<GET /pivot> -- Crosstab / pivot table view. Accepts the same C<l=>, C<j=>, C<f=> pipeline params as C</join>, plus: rows=<col>[,<col>...] Row dimensions (required, comma-separated column names) cols=<col>[,<col>...] Column dimensions (optional) m=<col>:<fn>:<as> Measure spec, repeatable (required); col may be empty for count h=<as>:<op>:<val> Post-aggregation HAVING filter (repeatable, optional) totals=1 Include row subtotals, column subtotals, and grand total scheme=<name> Colour scheme for cell shading (optional) max_cols=<n> Collapse column headers beyond top-N into "Other" page= / per_page= Pagination over row groups format=csv\|sqlite\|json Export the pivot grid =cut
4110
4111	27 27 27			27	185630 31 32	sub pivot_view ($self) {
4112	27		50		59	my $left_spec = $self->param('l') // '';
4113	27	50			4990	return $self->render(text => 'Missing l= parameter', status => 400)
4114						unless length $left_spec;
4115
4116	27		50		56	my $back = _safe_back_url($self->param('back')) // '/';
4117	27				48	my $back2 = _safe_back_url($self->param('back2'));
4118	27		50		45	my $back2_lbl = $self->param('back2_label') // '';
4119
4120	27		100		607	my $rows_str = $self->param('rows') // '';
4121	27	100			599	return $self->render(text => $self->_i18n('error_pivot_rows_required'), status => 400)
4122						unless length $rows_str;
4123
4124	26 26		50		33 44	my @measure_strs = @{ $self->every_param('m') // [] };
4125	26	100			540	return $self->render(text => $self->_i18n('error_pivot_measure_req'), status => 400)
4126						unless @measure_strs;
4127
4128						# Split dimensions on comma. A dimension name containing a comma
4129						# would produce an ambiguous split; that must be rejected.
4130	25				64	my @rows = split /,/, $rows_str, -1;
4131	25		100		39	my @cols = split /,/, ($self->param('cols') // ''), -1;
4132	25 1				584 2	@cols = grep { length $_ } @cols;
4133
4134	25				29	my @measures;
4135	25				35	for my $ms (@measure_strs) {
4136	25				54	my $m = _parse_measure_param($ms);
4137	25	100			60	return $self->render(
4138						text => $self->_i18n('error_pivot_measure_invalid', $ms),
4139						status => 400,
4140						) unless $m;
4141	24				38	push @measures, $m;
4142						}
4143
4144	24	100	100		39	my $show_totals = ($self->param('totals') // '') ? 1 : 0;
4145	24		50		568	my $scheme = $self->param('scheme') // '';
4146	24		50		523	my $max_cols_n = int($self->param('max_cols') // 0);
4147	24		100		555	my $format = lc($self->param('format') // '');
4148
4149						# Build the data pipeline.
4150	24				581	my ($src, $records, $columns) = $self->_run_pipeline_source;
4151	24	50			57	return $self->render(text => 'Could not open data source', status => 404)
4152						unless defined $records;
4153
4154						# Calculated fields (?c=name:expr) -- evaluated before aggregation so calc
4155						# columns are available as row/col dimensions and measure columns.
4156						{
4157	24 24				27 24	my $err;
4158	24 24				25 67	eval { ($records, $columns) = $self->_apply_calc_fields($records, $columns) };
4159	24 6 6	100			1342 18 141	if ($@) { (my $e = $@) =~ s/ at \S+ line \d+\.?\n?$//; return $self->render(text => $e, status => 400) }
4160						}
4161
4162	18 18				17 29	for my $s (@{ $self->every_param('f') }) {
4163	0				0	$records = _apply_filter_spec($records, $s);
4164						}
4165
4166	18 47 18				357 57 22	my %col_set = map { $_ => 1 } @{$columns};
4167
4168	18				30	for my $dim (@rows, @cols) {
4169						return $self->render(
4170						text => $self->_i18n('error_pivot_dim_not_found', $dim),
4171						status => 400,
4172	19	50			47	) unless $col_set{$dim};
4173						}
4174
4175	18				25	for my $m (@measures) {
4176	18	100	67		64	next unless defined $m->{col} && length $m->{col};
4177						return $self->render(
4178						text => $self->_i18n('error_measure_column', $m->{col}),
4179						status => 400,
4180	16	50			37	) unless $col_set{$m->{col}};
4181						}
4182
4183	18				41	my $pipeline = { source => $src, records => $records };
4184
4185						# -----------------------------------------------------------------------
4186						# Aggregate: one _grouped_totals call per measure, grouped by all
4187						# row AND column dimensions together.
4188						# -----------------------------------------------------------------------
4189	18				39	my (%cells, %row_combos, %col_combos);
4190	18				0	my (@row_key_order, @col_key_order);
4191	18				0	my (%row_seen, %col_seen);
4192
4193	18				22	for my $m (@measures) {
4194	18	100	67		66	my $cv = (defined $m->{col} && length $m->{col}) ? $m->{col} : undef;
4195						my $agg = $self->_grouped_totals($pipeline, {
4196						by => [@rows, @cols],
4197						fn => $m->{fn},
4198						val => $cv,
4199						as => $m->{as},
4200	18				99	});
4201	18				51	for my $row (@$agg) {
4202	74 74		50		64 118	my $rkey = join("\x00", map { $row->{$_} // '' } @rows);
4203	74 4		50		76 5	my $ckey = join("\x00", map { $row->{$_} // '' } @cols);
4204	74	100			98	unless ($row_seen{$rkey}++) {
4205	72				65	push @row_key_order, $rkey;
4206	72 72		50		63 136	$row_combos{$rkey} = { map { $_ => ($row->{$_} // '') } @rows };
4207						}
4208	74	100			102	unless ($col_seen{$ckey}++) {
4209	19				28	push @col_key_order, $ckey;
4210	19 2		50		41 4	$col_combos{$ckey} = { map { $_ => ($row->{$_} // '') } @cols };
4211						}
4212	74				154	$cells{$rkey}{$ckey}{$m->{as}} = $row->{$m->{as}};
4213						}
4214						}
4215
4216						# -----------------------------------------------------------------------
4217						# Post-aggregation HAVING filters (h=<as>:<op>:<val>) applied row-by-row.
4218						# Each filter operates on a virtual row whose keys are the measure aliases.
4219						# -----------------------------------------------------------------------
4220	18 18		50		24 51	my @h_specs = @{ $self->every_param('h') // [] };
4221	18	50			814	if (@h_specs) {
4222	0				0	my @keep;
4223	0				0	for my $rkey (@row_key_order) {
4224						# Build a virtual row containing each measure's cell value
4225						# (using first col-combo as representative, or grand-total style).
4226						# For HAVING, we filter on the row subtotal value, not a single cell.
4227						# We'll compute a temp subtotal row for each row key.
4228	0				0	my %vrow;
4229	0				0	for my $m (@measures) {
4230						# Sum across cols for this row as representative value.
4231	0				0	my $v = 0;
4232	0				0	for my $ck (@col_key_order) {
4233	0				0	my $cv = $cells{$rkey}{$ck}{$m->{as}};
4234	0	0			0	$v += $cv if defined $cv;
4235						}
4236	0				0	$vrow{$m->{as}} = $v;
4237						}
4238	0				0	my $ok = 1;
4239	0				0	for my $hs (@h_specs) {
4240	0				0	my $passed = _apply_filter_spec([\%vrow], $hs);
4241	0	0			0	$ok = 0 unless @$passed;
4242						}
4243	0	0			0	push @keep, $rkey if $ok;
4244						}
4245	0				0	@row_key_order = @keep;
4246						}
4247
4248						# -----------------------------------------------------------------------
4249						# Top-N rows: keep only the top-N row groups (ranked by measure sum
4250						# across all col combos); aggregate the remaining rows as an "Other" row.
4251						# -----------------------------------------------------------------------
4252						{
4253	18 18		100		21 35	my $topn_n = int($self->param('topn') // 0);
4254	18		100		515	my $topn_col = $self->param('topn_col') // '';
4255
4256	18	100	67		475	if ($topn_n > 0 && @row_key_order > $topn_n) {
4257	2 2				2 4	my %m_aliases = map { $_->{as} => 1 } @measures;
4258	2	100	67		7	if (length $topn_col && !$m_aliases{$topn_col}) {
4259	1				3	return $self->render(
4260						text => $self->_i18n('error_topn_col', $topn_col),
4261						status => 400,
4262						);
4263						}
4264	1	50			2	my $sort_as = length($topn_col) ? $topn_col : $measures[0]{as};
4265
4266						# Sort rows by descending sum of sort_as across all column combos.
4267						my @sorted_rkeys = sort {
4268	1 7 7 7		50		3 1 10 6	(do { my $s = 0; $s += ($cells{$b}{$_}{$sort_as} // 0) for @col_key_order; $s })
4269						<=>
4270	7 7 7 7		50		7 2 10 5	(do { my $s = 0; $s += ($cells{$a}{$_}{$sort_as} // 0) for @col_key_order; $s })
4271						} @row_key_order;
4272
4273	1				3	my @top_rkeys = @sorted_rkeys[0 .. $topn_n - 1];
4274	1				2	my @rest_rkeys = @sorted_rkeys[$topn_n .. $#sorted_rkeys];
4275
4276	1	50			2	if (@rest_rkeys) {
4277	1 2				2 2	my %top_rkey_set = map { $_ => 1 } @top_rkeys;
4278						my $other_rec = [
4279						grep {
4280	1 5				3 2	my $r = $_;
4281	5 5		50		4 9	!$top_rkey_set{ join("\x00", map { $r->{$_} // '' } @rows) }
4282						} @$records
4283						];
4284	1	50			2	if (@$other_rec) {
4285	1				1	my $ork = '__topn_other__';
4286	1 1				2 5	$row_combos{$ork} = { map { $_ => 'Other' } @rows };
4287	1				1	for my $m (@measures) {
4288	1	50	33		4	my $cv = (defined $m->{col} && length $m->{col}) ? $m->{col} : undef;
4289						my $oa = $self->_grouped_totals(
4290						{ source => undef, records => $other_rec },
4291						{ by => [@cols], fn => $m->{fn}, val => $cv, as => $m->{as} },
4292	1				16	);
4293	1				3	for my $row (@$oa) {
4294	1 0		0		2 0	my $ck = join("\x00", map { $row->{$_} // '' } @cols);
4295	1				3	$cells{$ork}{$ck}{$m->{as}} = $row->{$m->{as}};
4296						}
4297						}
4298	1				3	@row_key_order = (@top_rkeys, $ork);
4299						} else {
4300	0				0	@row_key_order = @top_rkeys;
4301						}
4302						} else {
4303	0				0	@row_key_order = @top_rkeys;
4304						}
4305						}
4306						}
4307
4308						# -----------------------------------------------------------------------
4309						# Subtotals and grand total (three additional _grouped_totals calls
4310						# per measure when totals=1).
4311						# -----------------------------------------------------------------------
4312	17				20	my (%row_subtotals, %col_subtotals, %grand_total);
4313
4314	17	100			26	if ($show_totals) {
4315	2				3	for my $m (@measures) {
4316	2	50	33		10	my $cv = (defined $m->{col} && length $m->{col}) ? $m->{col} : undef;
4317
4318						# Row subtotals: group by @rows only.
4319						my $rsub = $self->_grouped_totals($pipeline, {
4320						by => [@rows],
4321						fn => $m->{fn},
4322						val => $cv,
4323						as => $m->{as},
4324	2				11	});
4325	2				5	for my $r (@$rsub) {
4326	8 8		50		8 13	my $rk = join("\x00", map { $r->{$_} // '' } @rows);
4327	8				13	$row_subtotals{$rk}{$m->{as}} = $r->{$m->{as}};
4328						}
4329
4330						# Column subtotals: group by @cols only.
4331	2	100			5	if (@cols) {
4332						my $csub = $self->_grouped_totals($pipeline, {
4333						by => [@cols],
4334						fn => $m->{fn},
4335						val => $cv,
4336						as => $m->{as},
4337	1				6	});
4338	1				3	for my $c (@$csub) {
4339	2 2		50		2 4	my $ck = join("\x00", map { $c->{$_} // '' } @cols);
4340	2				5	$col_subtotals{$ck}{$m->{as}} = $c->{$m->{as}};
4341						}
4342						}
4343
4344						# Grand total: group by nothing (all rows â†’ one result row).
4345						my $gtot = $self->_grouped_totals($pipeline, {
4346						by => [],
4347						fn => $m->{fn},
4348						val => $cv,
4349						as => $m->{as},
4350	2				8	});
4351	2	50			11	$grand_total{$m->{as}} = $gtot->[0]{$m->{as}} if @$gtot;
4352						}
4353						}
4354
4355						# -----------------------------------------------------------------------
4356						# max_cols: collapse the tail of column combos beyond top-N into "Other".
4357						# The top-N are ranked by the first measure's column subtotal (or cell sum).
4358						# -----------------------------------------------------------------------
4359	17	50	33		38	if ($max_cols_n > 0 && @col_key_order > $max_cols_n) {
4360	0				0	my $first_as = $measures[0]{as};
4361						my @sorted_ckeys = sort {
4362	0				0	( $show_totals
4363						? ($col_subtotals{$b}{$first_as} // 0)
4364	0 0 0		0		0 0 0	: (do { my $s = 0; $s += ($cells{$_}{$b}{$first_as} // 0) for @row_key_order; $s })
4365						)
4366						<=>
4367						( $show_totals
4368						? ($col_subtotals{$a}{$first_as} // 0)
4369	0 0 0 0	0 0	0 0 0		0 0 0 0	: (do { my $s = 0; $s += ($cells{$_}{$a}{$first_as} // 0) for @row_key_order; $s })
4370						)
4371						} @col_key_order;
4372	0				0	my @top_ckeys = @sorted_ckeys[0 .. $max_cols_n - 1];
4373	0				0	my @rest_ckeys = @sorted_ckeys[$max_cols_n .. $#sorted_ckeys];
4374	0	0			0	if (@rest_ckeys) {
4375	0				0	my $other_key = '__other__';
4376	0 0				0 0	$col_combos{$other_key} = { map { $_ => 'Other' } @cols };
4377	0				0	for my $rk (@row_key_order) {
4378	0				0	for my $m (@measures) {
4379	0				0	my ($v, $have) = (0, 0);
4380	0				0	for my $ck (@rest_ckeys) {
4381	0				0	my $cv = $cells{$rk}{$ck}{$m->{as}};
4382	0 0 0	0			0 0 0	if (defined $cv) { $v += $cv; $have = 1 }
4383						}
4384	0	0			0	$cells{$rk}{$other_key}{$m->{as}} = $have ? $v : undef;
4385						}
4386						}
4387	0				0	@col_key_order = (@top_ckeys, $other_key);
4388						} else {
4389	0				0	@col_key_order = @top_ckeys;
4390						}
4391						}
4392
4393						# -----------------------------------------------------------------------
4394						# Export path: build flat records from the grid.
4395						# -----------------------------------------------------------------------
4396	17	100	67		43	if ($format && $format =~ /\A(?:csv\|sqlite\|sql\|json\|xlsx)\z/) {
4397	2				3	my @grid_records;
4398	2				3	for my $rk (@row_key_order) {
4399	8				6	for my $ck (@col_key_order) {
4400	8				6	my %rec;
4401	8		50		13	$rec{$_} = $row_combos{$rk}{$_} // '' for @rows;
4402	8		0		6	$rec{$_} = $col_combos{$ck}{$_} // '' for @cols;
4403	8		50		15	$rec{$_->{as}} = $cells{$rk}{$ck}{$_->{as}} // '' for @measures;
4404	8				8	push @grid_records, \%rec;
4405						}
4406						}
4407	2 2				3 4	my @export_cols = (@rows, @cols, map { $_->{as} } @measures);
4408	2	50			10	return $self->_render_csv(\@grid_records, \@export_cols, 'pivot')
4409						if $format eq 'csv';
4410	0	0	0		0	return $self->_render_sqlite(\@grid_records, \@export_cols, 'pivot')
4411						if $format eq 'sqlite' \|\| $format eq 'sql';
4412	0	0			0	return $self->_render_json(\@grid_records, \@export_cols, 'pivot')
4413						if $format eq 'json';
4414	0	0			0	if ($format eq 'xlsx') {
4415	0				0	require Excel::Writer::XLSX;
4416	0				0	my $out = '';
4417	0	0			0	open my $fh, '>', \$out
4418						or return $self->render(text => 'Cannot open XLSX buffer', status => 500);
4419	0				0	my $wb = Excel::Writer::XLSX->new($fh);
4420	0				0	my $ws = $wb->add_worksheet('pivot');
4421	0				0	$ws->write_row(0, 0, \@export_cols);
4422	0				0	my $row_idx = 1;
4423	0				0	for my $rec (@grid_records) {
4424	0 0		0		0 0	$ws->write_row($row_idx++, 0, [ map { $rec->{$_} // '' } @export_cols ]);
4425						}
4426	0				0	$wb->close;
4427	0				0	$self->res->headers->content_type(
4428						'application/vnd.openxmlformats-officedocument.spreadsheetml.sheet'
4429						);
4430	0				0	$self->res->headers->content_disposition(
4431						'attachment; filename="pivot.xlsx"'
4432						);
4433	0				0	return $self->render(data => $out);
4434						}
4435						}
4436
4437						# -----------------------------------------------------------------------
4438						# Pagination: slice @row_key_order using the N+1 trick.
4439						# Must come after the export early-return above (exports use the full set)
4440						# and after subtotals/grand total (computed from $pipeline, not @row_key_order).
4441						# -----------------------------------------------------------------------
4442	15				34	my ($page, $per_page, $offset) = $self->_pagination;
4443	15				19	my $total_row_groups = scalar @row_key_order;
4444	15	100			31	my $piv_has_next = ($total_row_groups > $offset + $per_page) ? 1 : 0;
4445	15	100 100			67	@row_key_order = $offset < $total_row_groups
4446						? @row_key_order[$offset .. ($piv_has_next ? $offset + $per_page - 1 : $#row_key_order)]
4447						: ();
4448
4449	15				22	my $piv_page_url = $self->req->url->clone;
4450	15				897	$piv_page_url->query->remove('page')->remove('per_page');
4451
4452						# -----------------------------------------------------------------------
4453						# Build the template-ready data structure.
4454						# -----------------------------------------------------------------------
4455						my @col_combo_list = map {
4456	15 16				306 22	my $ck = $_;
4457						{
4458						key => $ck,
4459						dim_vals => $col_combos{$ck},
4460	16 2		50		68 7	label => join(' / ', map { $col_combos{$ck}{$_} // '' } @cols),
4461						}
4462						} @col_key_order;
4463
4464	15				17	my @grid_rows;
4465	15				22	for my $rk (@row_key_order) {
4466	35				25	my %row_cells;
4467	35				28	for my $ck (@col_key_order) {
4468	37		50		61	$row_cells{$ck} = $cells{$rk}{$ck} // {};
4469						}
4470						push @grid_rows, {
4471						row_vals => $row_combos{$rk},
4472						cells => \%row_cells,
4473	35	100	50		98	subtotals => $show_totals ? ($row_subtotals{$rk} // {}) : {},
4474						};
4475						}
4476
4477	15				65	(my $left_label = $left_spec) =~ s/\A(?:table:\|path:\|url:)//;
4478
4479	15				53	my ($platform, $language) = $self->_resolve_template;
4480	15	50 50	0 33 0 50		113	$self->render(
4481						handler => 'tt',
4482						template => "$platform/$language/pivot",
4483						format => 'html',
4484						title => 'Pivot: ' . join(', ', @rows),
4485						rows_dims => \@rows,
4486						cols_dims => \@cols,
4487						measures => \@measures,
4488						col_combos => \@col_combo_list,
4489						grid_rows => \@grid_rows,
4490						show_totals => $show_totals,
4491						col_subtotals => \%col_subtotals,
4492						grand_total => \%grand_total,
4493						scheme => $scheme,
4494						left_spec => $left_spec,
4495						left_label => $left_label,
4496						back_url => ($back2 // $back),
4497						back_label => ($back2 ? ($back2_lbl \|\| 'Back') : ($self->param('back_label') // 'Back to table')),
4498						($back2 ? (back2_url => $back, back2_label => ($self->param('back_label') // 'Back to table')) : ()),
4499						page => $page,
4500						per_page => $per_page,
4501						has_next => $piv_has_next,
4502						page_base_url => $piv_page_url->to_string,
4503						total_row_groups => $total_row_groups,
4504						);
4505						}
4506
4507 - 4518						=head2 stats_view C<GET /stats> -- Column statistics panel. Accepts the same C<l=>, C<j=>, C<f=> pipeline params as C</join> and displays per-column statistics: min, max, mean, median, null_count, distinct_count, row_count. Statistics are computed through C<_grouped_totals> so they agree with the pivot view. Median is computed in Perl by sorting the column values. =cut
4519
4520	2 2 2			2	13549 2 2	sub stats_view ($self) {
4521	2		100		6	my $left_spec = $self->param('l') // '';
4522	2	100			210	return $self->render(text => 'Missing l= parameter', status => 400)
4523						unless length $left_spec;
4524
4525	1		50		2	my $back = _safe_back_url($self->param('back')) // '/';
4526	1				2	my $back2 = _safe_back_url($self->param('back2'));
4527	1		50		2	my $back2_lbl = $self->param('back2_label') // '';
4528
4529	1				22	my ($src, $records, $columns) = $self->_run_pipeline_source;
4530	1	50			2	return $self->render(text => 'Could not open data source', status => 404)
4531						unless defined $records;
4532
4533	1 1				2 3	eval { ($records, $columns) = $self->_apply_calc_fields($records, $columns) };
4534	1 0 0	50			2 0 0	if ($@) { (my $e = $@) =~ s/ at \S+ line \d+\.?\n?$//; return $self->render(text => $e, status => 400) }
4535
4536	1 1				2 2	for my $s (@{ $self->every_param('f') }) {
4537	0				0	$records = _apply_filter_spec($records, $s);
4538						}
4539
4540	1				18	my $row_count = scalar @$records;
4541	1				2	my $pipeline = { source => $src, records => $records };
4542
4543	1				2	my @stats;
4544	1 1				1 2	for my $col (@{$columns}) {
4545						# null_count = rows where cell is undef or '' (phase 2 definition).
4546	2 6	50			4 11	my @nonnull = grep { defined $_->{$col} && length($_->{$col}) } @$records;
4547	2				3	my $null_count = $row_count - scalar @nonnull;
4548
4549						# distinct_count via _grouped_totals (count groups by the column).
4550	2				8	my $dist_rows = $self->_grouped_totals($pipeline, {
4551						by => [$col],
4552						fn => 'count',
4553						as => 'cnt',
4554						});
4555	2				3	my $distinct_count = scalar @$dist_rows;
4556
4557						# Numeric statistics.
4558	2 6 6				4 5 5	my @nums = grep { defined $_ } map { _numeric_cell($_->{$col}) } @nonnull;
4559	2				3	my ($min_val, $max_val, $avg_val, $median_val);
4560	2	100			4	if (@nums) {
4561	1 3				1 3	my @sorted = sort { $a <=> $b } @nums;
4562	1				2	$min_val = $sorted[0];
4563	1				1	$max_val = $sorted[-1];
4564	1				1	my $sum = 0;
4565	1				2	$sum += $_ for @nums;
4566	1				1	$avg_val = $sum / @nums;
4567	1				2	my $mid = int(@sorted / 2);
4568	1	50			3	$median_val = @sorted % 2
4569						? $sorted[$mid]
4570						: ($sorted[$mid - 1] + $sorted[$mid]) / 2;
4571						}
4572
4573	2	100			16	push @stats, {
4574						col => $col,
4575						row_count => $row_count,
4576						null_count => $null_count,
4577						distinct_count => $distinct_count,
4578						(defined $min_val ? (
4579						min => $min_val,
4580						max => $max_val,
4581						avg => sprintf('%.4g', $avg_val),
4582						median => sprintf('%.4g', $median_val),
4583						) : ()),
4584						};
4585						}
4586
4587	1				4	(my $left_label = $left_spec) =~ s/\A(?:table:\|path:\|url:)//;
4588
4589	1				3	my ($platform, $language) = $self->_resolve_template;
4590	1	50 50 50	0 33 0 50		5	$self->render(
4591						handler => 'tt',
4592						template => "$platform/$language/stats",
4593						format => 'html',
4594						title => 'Column statistics',
4595						stats => \@stats,
4596						row_count => $row_count,
4597						left_spec => $left_spec,
4598						left_label => $left_label,
4599						drill_back_url => $back,
4600						drill_sep => (CORE::index($back, '?') >= 0 ? '&' : '?'),
4601						stats_url => $self->req->url->path_query,
4602						back_url => ($back2 // $back),
4603						back_label => ($back2 ? ($back2_lbl \|\| 'Back') : ($self->param('back_label') // 'Back to table')),
4604						($back2 ? (back2_url => $back, back2_label => ($self->param('back_label') // 'Back to table')) : ()),
4605						);
4606						}
4607
4608						# ---------------------------------------------------------------------------
4609						# Calculated-field CRUD (POST /calc/save, POST /calc/delete, GET /calc/list)
4610						# ---------------------------------------------------------------------------
4611
4612	5 5 5			5	24410 5 4	sub calc_save ($self) {
4613	5		100		8	my $spec = $self->param('l') // '';
4614	5		50		753	my $name = $self->param('name') // '';
4615	5		100		118	my $expr = $self->param('expr') // '';
4616
4617	5	100			106	return $self->render(json => { error => 'l= required' }, status => 400)
4618						unless length $spec;
4619	4	100			14	return $self->render(
4620						json => { error => $self->_i18n('error_calc_name', $name) },
4621						status => 400,
4622						) unless $name =~ /\A[A-Za-z_][A-Za-z0-9_]*\z/;
4623	3	100			9	return $self->render(json => { error => 'expr= required' }, status => 400)
4624						unless length $expr;
4625
4626	2				4	my $models = $self->_read_models;
4627	2				5	$models->{fields}{$spec}{$name} = $expr;
4628	2				5	$self->_write_models($models);
4629	2				5	$self->render(json => { ok => 1 });
4630						}
4631
4632	2 2 2			2	8017 3 1	sub calc_delete ($self) {
4633	2		50		3	my $spec = $self->param('l') // '';
4634	2		50		266	my $name = $self->param('name') // '';
4635
4636	2	50			45	return $self->render(json => { error => 'l= required' }, status => 400)
4637						unless length $spec;
4638
4639	2				5	my $models = $self->_read_models;
4640	2				7	delete $models->{fields}{$spec}{$name};
4641	2				3	$self->_write_models($models);
4642	2				7	$self->render(json => { ok => 1 });
4643						}
4644
4645	7 7 7			7	27824 10 6	sub calc_list ($self) {
4646	7		100		13	my $spec = $self->param('l') // '';
4647	7	100			722	return $self->render(json => { error => 'l= required' }, status => 400)
4648						unless length $spec;
4649
4650	5				10	my $models = $self->_read_models;
4651	5		100		19	$self->render(json => { fields => $models->{fields}{$spec} // {} });
4652						}
4653
4654						# ---------------------------------------------------------------------------
4655						# Named-group CRUD (POST /groups/save, POST /groups/delete, GET /groups/list)
4656						# ---------------------------------------------------------------------------
4657
4658	2 2 2			2	15528 2 2	sub groups_save ($self) {
4659	2		50		4	my $spec = $self->param('l') // '';
4660	2		50		395	my $col = $self->param('col') // '';
4661	2		50		48	my $group_name = $self->param('group') // '';
4662	2 2		50		43 3	my @values = @{ $self->every_param('values') // [] };
4663
4664	2	50			41	return $self->render(json => { error => 'l= required' }, status => 400)
4665						unless length $spec;
4666	2	50			3	return $self->render(json => { error => 'col= required' }, status => 400)
4667						unless length $col;
4668	2	50			2	return $self->render(json => { error => 'group= required' }, status => 400)
4669						unless length $group_name;
4670
4671	2				4	my $models = $self->_read_models;
4672	2				7	$models->{groups}{$spec}{$col}{$group_name} = \@values;
4673	2				5	$self->_write_models($models);
4674	2				6	$self->render(json => { ok => 1 });
4675						}
4676
4677	1 1 1			1	8576 1 1	sub groups_delete ($self) {
4678	1		50		2	my $spec = $self->param('l') // '';
4679	1		50		136	my $col = $self->param('col') // '';
4680	1		50		25	my $group_name = $self->param('group') // '';
4681
4682	1	50			20	return $self->render(json => { error => 'l= required' }, status => 400)
4683						unless length $spec;
4684
4685	1				3	my $models = $self->_read_models;
4686	1	50 50	33		4	if (length $col && length $group_name) {
4687	0				0	delete $models->{groups}{$spec}{$col}{$group_name};
4688						} elsif (length $col) {
4689	0				0	delete $models->{groups}{$spec}{$col};
4690						} else {
4691	1				3	delete $models->{groups}{$spec};
4692						}
4693	1				3	$self->_write_models($models);
4694	1				4	$self->render(json => { ok => 1 });
4695						}
4696
4697	1 1 1			1	4515 1 2	sub groups_list ($self) {
4698	1		50		2	my $spec = $self->param('l') // '';
4699	1	50			136	return $self->render(json => { error => 'l= required' }, status => 400)
4700						unless length $spec;
4701
4702	1				3	my $models = $self->_read_models;
4703	1		50		4	$self->render(json => { groups => $models->{groups}{$spec} // {} });
4704						}
4705
4706						# ---------------------------------------------------------------------------
4707						# Date-pattern CRUD (POST /dates/save, POST /dates/delete, GET /dates/list)
4708						# ---------------------------------------------------------------------------
4709
4710						# dates_save: POST /dates/save?l=<spec>&col=<col>&pattern=<fmt>
4711						# Stores a strptime-style date normalisation pattern for $col in models.json.
4712						# Only the three patterns in %ALLOWED_DATE_PATTERNS are accepted.
4713	4 4 4			4	18864 4 5	sub dates_save ($self) {
4714	4		100		24	my $spec = $self->param('l') // '';
4715	4		50		638	my $col = $self->param('col') // '';
4716	4		50		93	my $pattern = $self->param('pattern') // '';
4717
4718	4	100			86	return $self->render(json => { error => 'l= required' }, status => 400)
4719						unless length $spec;
4720	3	50			4	return $self->render(json => { error => 'col= required' }, status => 400)
4721						unless length $col;
4722						return $self->render(
4723						json => { error => $self->_i18n('error_date_pattern', $pattern) },
4724						status => 400,
4725	3	100			12	) unless $ALLOWED_DATE_PATTERNS{$pattern};
4726
4727	2				12	my $models = $self->_read_models;
4728	2				5	$models->{date_patterns}{$spec}{$col} = $pattern;
4729	2				6	$self->_write_models($models);
4730	2				8	$self->render(json => { ok => 1 });
4731						}
4732
4733						# dates_delete: POST /dates/delete?l=<spec>&col=<col>
4734						# Removes the pattern for $col (or all patterns for $spec when col is absent).
4735	2 2 2			2	12321 2 2	sub dates_delete ($self) {
4736	2		50		4	my $spec = $self->param('l') // '';
4737	2		100		265	my $col = $self->param('col') // '';
4738
4739	2	50			46	return $self->render(json => { error => 'l= required' }, status => 400)
4740						unless length $spec;
4741
4742	2				4	my $models = $self->_read_models;
4743	2	100			4	if (length $col) {
4744	1				3	delete $models->{date_patterns}{$spec}{$col};
4745						} else {
4746	1				2	delete $models->{date_patterns}{$spec};
4747						}
4748	2				6	$self->_write_models($models);
4749	2				6	$self->render(json => { ok => 1 });
4750						}
4751
4752						# dates_list: GET /dates/list?l=<spec>
4753						# Returns { patterns: { col: pattern, ... } } for $spec.
4754	4 4 4			4	18867 6 4	sub dates_list ($self) {
4755	4		100		7	my $spec = $self->param('l') // '';
4756	4	100			439	return $self->render(json => { error => 'l= required' }, status => 400)
4757						unless length $spec;
4758
4759	3				6	my $models = $self->_read_models;
4760	3		100		14	$self->render(json => { patterns => $models->{date_patterns}{$spec} // {} });
4761						}
4762
4763						# ---------------------------------------------------------------------------
4764						# Scatter chart (GET /scatter)
4765						# ---------------------------------------------------------------------------
4766
4767	3 3 3			3	17243 4 2	sub scatter_view ($self) {
4768	3		100		6	my $x_col = $self->param('x') // '';
4769	3		100		431	my $y_col = $self->param('y') // '';
4770	3		50		71	my $back = _safe_back_url($self->param('back')) // '/';
4771	3				5	my $back2 = _safe_back_url($self->param('back2'));
4772	3		50		5	my $back2_lbl = $self->param('back2_label') // '';
4773
4774	3	100			60	return $self->render(text => 'Missing x= parameter', status => 400) unless length $x_col;
4775	2	100			6	return $self->render(text => 'Missing y= parameter', status => 400) unless length $y_col;
4776
4777	1				4	my ($src, $records, $columns) = $self->_run_pipeline_source;
4778	1	50			2	return $self->render(text => 'Could not open data source', status => 404) unless defined $records;
4779
4780	1 1				1 3	eval { ($records, $columns) = $self->_apply_calc_fields($records, $columns) };
4781	1 0 0	50			3 0 0	if ($@) { (my $e = $@) =~ s/ at \S+ line \d+\.?\n?$//; return $self->render(text => $e, status => 400) }
4782
4783	1 1				2 1	for my $s (@{ $self->every_param('f') }) {
4784	0				0	$records = _apply_filter_spec($records, $s);
4785						}
4786
4787	1 2 1				20 3 2	my %col_set = map { $_ => 1 } @{$columns};
4788	1	50			2	return $self->render(text => "Column not found: $x_col", status => 400) unless $col_set{$x_col};
4789	1	50			2	return $self->render(text => "Column not found: $y_col", status => 400) unless $col_set{$y_col};
4790
4791	1				2	my @points;
4792	1				1	for my $row (@$records) {
4793	5		50		7	my $xv = _numeric_cell($row->{$x_col} // '');
4794	5		50		5	my $yv = _numeric_cell($row->{$y_col} // '');
4795	5	50	33		7	next unless defined $xv && defined $yv;
4796	0		0		0	my %extra = map { $_ => _decode_cell($row->{$_} // '') }
4797	5 10	100			5 11	grep { $_ ne $x_col && $_ ne $y_col } @$columns;
4798	5				7	push @points, [$xv, $yv, \%extra];
4799						}
4800
4801	1	50			2	return $self->render(
4802						text => 'No plottable data: no rows have valid numeric values in both selected columns.',
4803						status => 200,
4804						) unless @points;
4805
4806	1				3	my ($source_url, $source_accessed) = $self->_url_attribution;
4807
4808	1				12	require HTML::D3;
4809	1				2	my $title = "$y_col vs $x_col";
4810	1				6	my $snippet = HTML::D3->new(title => $title, width => 800, height => 480, responsive => 1)
4811						->render_scatter_chart_snippet(\@points, {
4812						animated => 1,
4813						x_label => $x_col,
4814						y_label => $y_col,
4815						});
4816
4817	1				2132	my $scatter_html = $snippet->{html};
4818	1	50			3	utf8::decode($scatter_html) unless utf8::is_utf8($scatter_html);
4819
4820	1				3	my ($platform, $language) = $self->_resolve_template;
4821	1	50 50	0 33		7	$self->render(
4822						handler => 'tt',
4823						template => "$platform/$language/scatter",
4824						format => 'html',
4825						title => $title,
4826						scatter_html => $scatter_html,
4827						point_count => scalar @points,
4828						x_col => $x_col,
4829						y_col => $y_col,
4830						back_url => ($back2 // $back),
4831						back_label => ($back2 ? ($back2_lbl \|\| 'Back') : 'Back to table'),
4832						($back2 ? (back2_url => $back, back2_label => 'Back to table') : ()),
4833						source_url => $source_url,
4834						source_accessed => $source_accessed,
4835						);
4836						}
4837
4838						# ---------------------------------------------------------------------------
4839						# Stacked bar chart (GET /stacked)
4840						# ---------------------------------------------------------------------------
4841
4842	5 5 5			5	31058 7 5	sub stacked_view ($self) {
4843	5		100		10	my $cat_col = $self->param('cat') // '';
4844	5		100		736	my $seg_col = $self->param('seg') // '';
4845	5		100		113	my $val_col = $self->param('val') // '';
4846	5		50		106	my $orient = $self->param('orient') // 'v';
4847	5		50		103	my $back = _safe_back_url($self->param('back')) // '/';
4848	5				8	my $back2 = _safe_back_url($self->param('back2'));
4849	5		50		9	my $back2_lbl = $self->param('back2_label') // '';
4850
4851	5	100			101	return $self->render(text => 'Missing cat= parameter', status => 400) unless length $cat_col;
4852	4	100			7	return $self->render(text => 'Missing seg= parameter', status => 400) unless length $seg_col;
4853
4854	3				8	my ($src, $records, $columns) = $self->_run_pipeline_source;
4855	3	50			5	return $self->render(text => 'Could not open data source', status => 404) unless defined $records;
4856
4857	3 3				4 8	eval { ($records, $columns) = $self->_apply_calc_fields($records, $columns) };
4858	3 0 0	50			6 0 0	if ($@) { (my $e = $@) =~ s/ at \S+ line \d+\.?\n?$//; return $self->render(text => $e, status => 400) }
4859
4860	3 3				3 4	for my $s (@{ $self->every_param('f') }) {
4861	0				0	$records = _apply_filter_spec($records, $s);
4862						}
4863
4864	3 9 3				55 12 5	my %col_set = map { $_ => 1 } @{$columns};
4865	3	50			8	return $self->render(text => "Column not found: $cat_col", status => 400) unless $col_set{$cat_col};
4866	3	50			5	return $self->render(text => "Column not found: $seg_col", status => 400) unless $col_set{$seg_col};
4867
4868	3		67		8	my $count_mode = (!length $val_col \|\| $val_col eq '__count__');
4869						return $self->render(text => "Column not found: $val_col", status => 400)
4870	3	50	67		7	unless $count_mode \|\| $col_set{$val_col};
4871
4872						# Build [{cat=>, seg=>, val=>N}] via Perl fold.
4873	3				3	my (%totals, %cat_seen, %seg_seen, @cat_order);
4874	3				5	for my $row (@$records) {
4875	12		50		17	my $cat = _decode_cell($row->{$cat_col} // '');
4876	12		50		15	my $seg = _decode_cell($row->{$seg_col} // '');
4877	12	50	33		13	next unless length $cat && length $seg;
4878	12	100			16	push @cat_order, $cat unless $cat_seen{$cat}++;
4879	12				12	$seg_seen{$seg} = 1;
4880	12	100			10	if ($count_mode) {
4881	8				8	$totals{$cat}{$seg}++;
4882						} else {
4883	4		50		7	my $v = _numeric_cell($row->{$val_col} // '');
4884	4	50	50		6	$totals{$cat}{$seg} += ($v // 0) if defined $v;
4885						}
4886						}
4887
4888	3				4	my @data;
4889	3				3	for my $cat (@cat_order) {
4890	6				9	for my $seg (sort keys %seg_seen) {
4891	12		50		24	push @data, { cat => $cat, seg => $seg, val => $totals{$cat}{$seg} // 0 };
4892						}
4893						}
4894
4895	3	50			3	return $self->render(
4896						text => 'No plottable data: no rows have valid data in the selected columns.',
4897						status => 200,
4898						) unless @data;
4899
4900	3				8	my ($source_url, $source_accessed) = $self->_url_attribution;
4901
4902	3				29	require HTML::D3;
4903	3	100			7	my $title = $count_mode ? "Count by $cat_col and $seg_col"
4904						: "$val_col by $cat_col and $seg_col";
4905	3	50			13	my $snippet = HTML::D3->new(title => $title, width => 900, height => 500, responsive => 1)
4906						->render_stacked_bar_snippet(\@data, {
4907						orient => ($orient eq 'h') ? 'h' : 'v',
4908						x_label => $cat_col,
4909						});
4910
4911	3				5673	my $stacked_html = $snippet->{html};
4912	3	50			6	utf8::decode($stacked_html) unless utf8::is_utf8($stacked_html);
4913
4914	3				7	my ($platform, $language) = $self->_resolve_template;
4915	3	50 50	0 33		21	$self->render(
4916						handler => 'tt',
4917						template => "$platform/$language/stacked",
4918						format => 'html',
4919						title => $title,
4920						stacked_html => $stacked_html,
4921						bar_count => scalar keys %cat_seen,
4922						back_url => ($back2 // $back),
4923						back_label => ($back2 ? ($back2_lbl \|\| 'Back') : 'Back to table'),
4924						($back2 ? (back2_url => $back, back2_label => 'Back to table') : ()),
4925						source_url => $source_url,
4926						source_accessed => $source_accessed,
4927						);
4928						}
4929
4930						# ---------------------------------------------------------------------------
4931						# Combo bar+line chart (GET /combo)
4932						# ---------------------------------------------------------------------------
4933
4934	4 4 4			4	20491 4 5	sub combo_view ($self) {
4935	4		100		9	my $x_col = $self->param('x') // '';
4936	4		100		639	my $bar_col = $self->param('bar') // '';
4937	4		100		96	my $line_col = $self->param('line') // '';
4938	4		50		86	my $bar_label = $self->param('bar_label') // '';
4939	4		50		84	my $line_label = $self->param('line_label') // '';
4940	4		50		79	my $back = _safe_back_url($self->param('back')) // '/';
4941	4				6	my $back2 = _safe_back_url($self->param('back2'));
4942	4		50		6	my $back2_lbl = $self->param('back2_label') // '';
4943
4944	4	100			83	return $self->render(text => 'Missing x= parameter', status => 400) unless length $x_col;
4945	3	100			7	return $self->render(text => 'Missing bar= parameter', status => 400) unless length $bar_col;
4946	2	100			6	return $self->render(text => 'Missing line= parameter', status => 400) unless length $line_col;
4947
4948	1				3	my ($src, $records, $columns) = $self->_run_pipeline_source;
4949	1	50			3	return $self->render(text => 'Could not open data source', status => 404) unless defined $records;
4950
4951	1 1				2 3	eval { ($records, $columns) = $self->_apply_calc_fields($records, $columns) };
4952	1 0 0	50			2 0 0	if ($@) { (my $e = $@) =~ s/ at \S+ line \d+\.?\n?$//; return $self->render(text => $e, status => 400) }
4953
4954	1 1				2 1	for my $s (@{ $self->every_param('f') }) {
4955	0				0	$records = _apply_filter_spec($records, $s);
4956						}
4957
4958	1 3 1				20 4 2	my %col_set = map { $_ => 1 } @{$columns};
4959	1	50			3	return $self->render(text => "Column not found: $x_col", status => 400) unless $col_set{$x_col};
4960	1	50			3	return $self->render(text => "Column not found: $bar_col", status => 400) unless $col_set{$bar_col};
4961	1	50			2	return $self->render(text => "Column not found: $line_col", status => 400) unless $col_set{$line_col};
4962
4963						# Aggregate bar and line values by x via Perl fold.
4964	1				1	my (%bar_sum, %line_sum, @x_order, %x_seen);
4965	1				2	for my $row (@$records) {
4966	3		50		6	my $xv = _decode_cell($row->{$x_col} // '');
4967	3	50			4	next unless length $xv;
4968	3	50			4	push @x_order, $xv unless $x_seen{$xv}++;
4969	3		50		6	my $bv = _numeric_cell($row->{$bar_col} // '');
4970	3		50		5	my $lv = _numeric_cell($row->{$line_col} // '');
4971	3		50		5	$bar_sum{$xv} += ($bv // 0);
4972	3		50		4	$line_sum{$xv} += ($lv // 0);
4973						}
4974
4975	1				2	my @data = map { {
4976						x => $_,
4977						bar_val => $bar_sum{$_} // 0,
4978	3		50 50		7	line_val => $line_sum{$_} // 0,
4979						} } @x_order;
4980
4981	1	50			2	return $self->render(
4982						text => 'No plottable data: no rows have valid data in the selected columns.',
4983						status => 200,
4984						) unless @data;
4985
4986	1				3	my ($source_url, $source_accessed) = $self->_url_attribution;
4987
4988	1				11	require HTML::D3;
4989	1		33		4	my $eff_bar_lbl = $bar_label \|\| $bar_col;
4990	1		33		3	my $eff_line_lbl = $line_label \|\| $line_col;
4991	1				2	my $title = "$eff_bar_lbl and $eff_line_lbl by $x_col";
4992	1				5	my $snippet = HTML::D3->new(title => $title, width => 900, height => 500, responsive => 1)
4993						->render_combo_snippet(\@data, {
4994						bar_label => $eff_bar_lbl,
4995						line_label => $eff_line_lbl,
4996						});
4997
4998	1				1954	my $combo_html = $snippet->{html};
4999	1	50			3	utf8::decode($combo_html) unless utf8::is_utf8($combo_html);
5000
5001	1				2	my ($platform, $language) = $self->_resolve_template;
5002	1	50 50	0 33		10	$self->render(
5003						handler => 'tt',
5004						template => "$platform/$language/combo",
5005						format => 'html',
5006						title => $title,
5007						combo_html => $combo_html,
5008						point_count => scalar @data,
5009						back_url => ($back2 // $back),
5010						back_label => ($back2 ? ($back2_lbl \|\| 'Back') : 'Back to table'),
5011						($back2 ? (back2_url => $back, back2_label => 'Back to table') : ()),
5012						source_url => $source_url,
5013						source_accessed => $source_accessed,
5014						);
5015						}
5016
5017						# ---------------------------------------------------------------------------
5018						# Treemap (GET /treemap)
5019						# ---------------------------------------------------------------------------
5020
5021	3 3 3			3	21386 5 3	sub treemap_view ($self) {
5022	3		100		6	my $cat_col = $self->param('cat') // '';
5023	3		50		390	my $val_col = $self->param('val') // '';
5024	3		50		73	my $scheme = $self->param('scheme') // 'tableau10';
5025	3		50		130	my $back = _safe_back_url($self->param('back')) // '/';
5026	3				5	my $back2 = _safe_back_url($self->param('back2'));
5027	3		50		6	my $back2_lbl = $self->param('back2_label') // '';
5028
5029	3	100			62	return $self->render(text => 'Missing cat= parameter', status => 400) unless length $cat_col;
5030
5031	2				5	my ($src, $records, $columns) = $self->_run_pipeline_source;
5032	2	50			5	return $self->render(text => 'Could not open data source', status => 404) unless defined $records;
5033
5034	2 2				2 7	eval { ($records, $columns) = $self->_apply_calc_fields($records, $columns) };
5035	2 0 0	50			4 0 0	if ($@) { (my $e = $@) =~ s/ at \S+ line \d+\.?\n?$//; return $self->render(text => $e, status => 400) }
5036
5037	2 2				2 4	for my $s (@{ $self->every_param('f') }) {
5038	0				0	$records = _apply_filter_spec($records, $s);
5039						}
5040
5041	2 12 2				37 11 3	my %col_set = map { $_ => 1 } @{$columns};
5042	2	50			5	return $self->render(text => "Column not found: $cat_col", status => 400) unless $col_set{$cat_col};
5043
5044	2		33		4	my $count_mode = (!length $val_col \|\| $val_col eq '__count__');
5045						return $self->render(text => "Column not found: $val_col", status => 400)
5046	2	0	33		2	unless $count_mode \|\| $col_set{$val_col};
5047
5048	2	50 50			16	my $agg_rows = $self->_grouped_totals(
5049						{ source => $src, records => $records },
5050						{
5051						by => [$cat_col],
5052						fn => $count_mode ? 'count' : 'sum',
5053						val => $count_mode ? undef : $val_col,
5054						as => 'value',
5055						},
5056						);
5057
5058						# Top-N: keep the highest-N tiles, aggregate the rest as "Other".
5059	2		50		9	my $topn_n = int($self->param('topn') // 0);
5060	2	50	33		83	if ($topn_n > 0 && @$agg_rows > $topn_n) {
5061	0 0		0 0		0 0	my @sorted = sort { ($b->{value} // 0) <=> ($a->{value} // 0) } @$agg_rows;
5062	0				0	my @top_agg = @sorted[0 .. $topn_n - 1];
5063	0 0		0		0 0	my %top_cats = map { ($_->{$cat_col} // '') => 1 } @top_agg;
5064						my $other_rec = [
5065	0 0		0		0 0	grep { !$top_cats{$_->{$cat_col} // ''} } @$records
5066						];
5067	0	0			0	if (@$other_rec) {
5068	0	0 0			0	my $other = $self->_grouped_totals(
5069						{ source => undef, records => $other_rec },
5070						{ by => [], fn => ($count_mode ? 'count' : 'sum'),
5071						val => ($count_mode ? undef : $val_col), as => 'value' },
5072						);
5073						push @top_agg, { $cat_col => 'Other', value => $other->[0]{value} }
5074	0	0	0		0	if @$other && defined $other->[0]{value};
5075						}
5076	0				0	$agg_rows = \@top_agg;
5077						}
5078
5079	2	50			4	return $self->render(
5080						text => 'No plottable data: no rows have valid data in the selected column.',
5081						status => 200,
5082						) unless @$agg_rows;
5083
5084						my @data = map {
5085	2				3	{ path => 'Root/' . _decode_cell($_->{$cat_col}), value => $_->{value} }
5086	7				10	} @$agg_rows;
5087
5088	2				7	my ($source_url, $source_accessed) = $self->_url_attribution;
5089
5090	2				18	require HTML::D3;
5091	2	50			5	my $title = $count_mode ? "Treemap of $cat_col by count" : "Treemap of $cat_col by $val_col";
5092	2				11	my $snippet = HTML::D3->new(title => $title, width => 800, height => 500, responsive => 1)
5093						->render_treemap_snippet(\@data, {
5094						scheme => $scheme,
5095						});
5096
5097	2				3859	my $treemap_html = $snippet->{html};
5098	2	50			6	utf8::decode($treemap_html) unless utf8::is_utf8($treemap_html);
5099
5100	2				5	my ($platform, $language) = $self->_resolve_template;
5101	2	50 50	0 33		16	$self->render(
5102						handler => 'tt',
5103						template => "$platform/$language/treemap",
5104						format => 'html',
5105						title => $title,
5106						treemap_html => $treemap_html,
5107						tile_count => scalar @data,
5108						cat_col => $cat_col,
5109						drill_back_url => $back,
5110						back_url => ($back2 // $back),
5111						back_label => ($back2 ? ($back2_lbl \|\| 'Back') : 'Back to table'),
5112						($back2 ? (back2_url => $back, back2_label => 'Back to table') : ()),
5113						source_url => $source_url,
5114						source_accessed => $source_accessed,
5115						);
5116						}
5117
5118						# ---------------------------------------------------------------------------
5119						# Histogram (GET /histogram)
5120						# ---------------------------------------------------------------------------
5121
5122	4 4 4			4	24999 4 3	sub histogram_view ($self) {
5123	4		100		8	my $col = $self->param('col') // '';
5124	4		100		541	my $bins = $self->param('bins') // 20;
5125	4		50		93	my $back = _safe_back_url($self->param('back')) // '/';
5126	4				6	my $back2 = _safe_back_url($self->param('back2'));
5127	4		50		7	my $back2_lbl = $self->param('back2_label') // '';
5128
5129	4	100			82	return $self->render(text => 'Missing col= parameter', status => 400) unless length $col;
5130
5131	3				8	my ($src, $records, $columns) = $self->_run_pipeline_source;
5132	3	50			7	return $self->render(text => 'Could not open data source', status => 404) unless defined $records;
5133
5134	3 3				3 7	eval { ($records, $columns) = $self->_apply_calc_fields($records, $columns) };
5135	3 0 0	50			6 0 0	if ($@) { (my $e = $@) =~ s/ at \S+ line \d+\.?\n?$//; return $self->render(text => $e, status => 400) }
5136
5137	3 3				2 6	for my $s (@{ $self->every_param('f') }) {
5138	0				0	$records = _apply_filter_spec($records, $s);
5139						}
5140
5141	3 8 3				55 10 5	my %col_set = map { $_ => 1 } @{$columns};
5142	3	50			8	return $self->render(text => "Column not found: $col", status => 400) unless $col_set{$col};
5143
5144	3				3	my @values;
5145	3				4	for my $row (@$records) {
5146	26		50		25	my $v = _numeric_cell($row->{$col} // '');
5147	26	100			24	push @values, $v if defined $v;
5148						}
5149
5150	3	100			7	return $self->render(
5151						text => 'No plottable data: no rows have valid numeric values in the selected column.',
5152						status => 200,
5153						) unless @values;
5154
5155	2				3	$bins = int($bins);
5156	2	50			3	$bins = 1 if $bins < 1;
5157	2	50			4	$bins = 200 if $bins > 200;
5158
5159	2				5	my ($source_url, $source_accessed) = $self->_url_attribution;
5160
5161	2				18	require HTML::D3;
5162	2				2	my $title = "Distribution of $col";
5163	2				10	my $snippet = HTML::D3->new(title => $title, width => 800, height => 480, responsive => 1)
5164						->render_histogram_snippet(\@values, {
5165						bins => $bins,
5166						x_label => $col,
5167						});
5168
5169	2				3877	my $histogram_html = $snippet->{html};
5170	2	50			4	utf8::decode($histogram_html) unless utf8::is_utf8($histogram_html);
5171
5172	2				5	my ($platform, $language) = $self->_resolve_template;
5173	2	50 50	0 33		14	$self->render(
5174						handler => 'tt',
5175						template => "$platform/$language/histogram",
5176						format => 'html',
5177						title => $title,
5178						histogram_html => $histogram_html,
5179						value_count => scalar @values,
5180						bins => $bins,
5181						back_url => ($back2 // $back),
5182						back_label => ($back2 ? ($back2_lbl \|\| 'Back') : 'Back to table'),
5183						($back2 ? (back2_url => $back, back2_label => 'Back to table') : ()),
5184						source_url => $source_url,
5185						source_accessed => $source_accessed,
5186						);
5187						}
5188
5189						1;
5190