TER1 (Statement): 89.09%
TER2 (Branch): 71.99%
TER3 (LCSAJ): 100.0% (112/112)
Approximate LCSAJ segments: 865
● Covered — this LCSAJ path was executed during testing.
● Not covered — this LCSAJ path was never executed. These are the paths to focus on.
Multiple dots on a line indicate that multiple control-flow paths begin at that line. Hovering over any dot shows:
start → end → jump
Uncovered paths show [NOT COVERED] in the tooltip.
1: package Database::BI::Controller::Dashboard; 2: 3: use strict; 4: use warnings; 5: 6: our $VERSION = '0.012.0'; 7: 8: use Mojo::Base 'Mojolicious::Controller', -strict, -signatures; 9: 10: use Carp qw(croak carp); 11: use List::Util qw(min max sum); 12: use CGI::Info; 13: use CGI::Lingua; 14: use Mojo::File; 15: use Mojo::JSON qw(encode_json decode_json); 16: use Mojo::Util qw(url_escape encode); 17: use File::Path qw(remove_tree); 18: use File::Temp qw(tempfile tempdir); 19: use Readonly; 20: use Socket qw(inet_aton); 21: 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.Mutants (Total: 3, Killed: 3, Survived: 0)
133: sub _pagination {
Mutants (Total: 3, Killed: 3, Survived: 0)
134: my $self = $_[0]; 135:
Mutants (Total: 3, Killed: 3, Survived: 0)
136: my $per_page = int($self->param('per_page') // $DEFAULT_PER_PAGE); 137: $per_page = 1 if $per_page < 1; 138: $per_page = $MAX_PER_PAGE if $per_page > $MAX_PER_PAGE; 139: my $page = int($self->param('page') // 1); 140: $page = 1 if $page < 1; 141: my $offset = ($page - 1) * $per_page; 142: 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).
Mutants (Total: 2, Killed: 2, Survived: 0)
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: } 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
Mutants (Total: 2, Killed: 2, Survived: 0)
181: # at this layer; block them with egress firewall rules instead. 182: sub _is_safe_url { 183: my $url = $_[0]; 184:
Mutants (Total: 2, Killed: 2, Survived: 0)
185: return 0 unless $url =~ m{\Ahttps?://([^/:?\[\]#]+)}i; 186: my $host = lc $1; 187: 188: # Block well-known loopback aliases. 189: return 0 if $host eq 'localhost' 190: || $host =~ /\A127\./ 191: || $host eq '0.0.0.0' 192: || $host eq '::1';
Mutants (Total: 2, Killed: 2, Survived: 0)
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: return 1 unless $host =~ /\A\d{1,3}(?:\.\d{1,3}){3}\z/;
Mutants (Total: 3, Killed: 3, Survived: 0)
198:
Mutants (Total: 3, Killed: 3, Survived: 0)
199: my $packed = inet_aton($host) or return 1;
Mutants (Total: 3, Killed: 3, Survived: 0)
200: my $n = unpack 'N', $packed;
Mutants (Total: 3, Killed: 3, Survived: 0)
201:
Mutants (Total: 3, Killed: 3, Survived: 0)
202: return 0 if ($n & 0xFF000000) == 0x0A000000; # 10/8
Mutants (Total: 2, Killed: 2, Survived: 0)
203: return 0 if ($n & 0xFFF00000) == 0xAC100000; # 172.16/12 204: return 0 if ($n & 0xFFFF0000) == 0xC0A80000; # 192.168/16 205: return 0 if ($n & 0xFFFF0000) == 0xA9FE0000; # 169.254/16 (link-local / metadata) 206: return 0 if ($n & 0xFFC00000) == 0x64400000; # 100.64/10 (CGNAT) 207: 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
Mutants (Total: 2, Killed: 2, Survived: 0)
220: # strings, undef) returns undef so the template renders no href.
Mutants (Total: 2, Killed: 2, Survived: 0)
221: #
Mutants (Total: 2, Killed: 2, Survived: 0)
222: sub _safe_back_url { 223: my ($url) = @_; 224: return undef unless defined $url && length($url); 225: return $url if $url =~ m{\A(?:/(?!/)|https?://)}i; 226: 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 → 248 → 252 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.
Mutants (Total: 1, Killed: 1, Survived: 0)
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: } 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: sub _detect_platform ($user_agent, $fallback) { 265: my $platform = eval { 266: local $ENV{HTTP_USER_AGENT} = $user_agent; 267: my $info = CGI::Info->new();
Mutants (Total: 2, Killed: 2, Survived: 0)
268: $info->is_mobile() ? 'mobile' 269: : $info->is_tablet() ? 'tablet' 270: : 'web'; 271: }; 272: 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.
Mutants (Total: 2, Killed: 2, Survived: 0)
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 → 296 → 301 289: my $accept = $self->req->headers->accept_language() // ''; 290: return $default unless $accept; 291:
Mutants (Total: 1, Killed: 1, Survived: 0)
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 → 311 → 315 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();
Mutants (Total: 1, Killed: 1, Survived: 0)
307: }; 308: $lang //= $default; 309: 310: # Confirm a template directory exists for the chosen language.
Mutants (Total: 2, Killed: 2, Survived: 0)
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: } 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).
Mutants (Total: 2, Killed: 2, Survived: 0)
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: } 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.
Mutants (Total: 1, Killed: 1, Survived: 0)
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 → 353 → 391 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/) {
Mutants (Total: 1, Killed: 1, Survived: 0)
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) : ()) };
Mutants (Total: 1, Killed: 1, Survived: 0)
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: } 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
Mutants (Total: 2, Killed: 2, Survived: 0)
397: # back-link on join and export views).
Mutants (Total: 2, Killed: 2, Survived: 0)
398: # Entry: $spec is a "table:name" or "path:/abs" string.
Mutants (Total: 2, Killed: 2, Survived: 0)
399: # Exit: Returns a URL string beginning with '/'.
Mutants (Total: 2, Killed: 2, Survived: 0)
400: sub _spec_to_url :Protected ($self, $spec) {
Mutants (Total: 2, Killed: 2, Survived: 0)
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: } 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: } 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
Mutants (Total: 2, Killed: 2, Survived: 0)
438: # method dispatch on the second reference. 439: sub _get_columns { 440: my ($source, $records) = @_; 441: my $cols = $source->columns; 442: return @$cols if $cols; 443: return () unless $records->[0]; 444: my %all = map { $_ => 1 } keys %{ $records->[0] }; 445: my $c = $source->id_column; 446: my $id = ($c && $all{$c}) ? $c : (sort keys %all)[0]; 447: delete $all{$id}; 448: 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
Mutants (Total: 2, Killed: 2, Survived: 0)
484: # constant within a single filter application. 485: sub _apply_filter_spec { 486: my ($records, $spec) = @_; 487: my ($col, $op, $val) = split /:/, $spec, 3; 488: return $records unless length($col // '') && defined $op && length $op; 489: $val //= ''; 490: my $lval = lc $val; # precompute once; avoids O(N) redundant lc() inside grep
Mutants (Total: 1, Killed: 1, Survived: 0)
491: return [grep {
Mutants (Total: 1, Killed: 1, Survived: 0)
492: my $cell = $_->{$col} // '';
Mutants (Total: 3, Killed: 3, Survived: 0)
493: $op eq 'eq' ? lc($cell) eq $lval :
Mutants (Total: 3, Killed: 3, Survived: 0)
494: $op eq 'ne' ? lc($cell) ne $lval :
Mutants (Total: 3, Killed: 3, Survived: 0)
495: $op eq 'contains' ? index(lc($cell), $lval) != -1 :
Mutants (Total: 3, Killed: 3, Survived: 0)
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 → 524 → 530 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: } 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 → 545 → 549 543: my ($records, $columns) = @_; 544: my (%seen, @out);
Mutants (Total: 2, Killed: 2, Survived: 0)
545: for my $row (@$records) { 546: my $key = join "\x00", map { $row->{$_} // '' } @$columns; 547: push @out, $row unless $seen{$key}++; 548: } 549: 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 → 594 → 647 583: my ($specs, $source) = @_; 584: 585: # Only push when the source has a live SQL (SQLite) backend. 586: my $is_sql = $source 587: && $source->can('dbi_source') 588: && $source->dbi_source();
Mutants (Total: 2, Killed: 2, Survived: 0)
589: return ({}, [@$specs]) unless $is_sql; 590: 591: require Scalar::Util; 592: my (%criteria, @residual);
Mutants (Total: 2, Killed: 2, Survived: 0)
593:
Mutants (Total: 2, Killed: 2, Survived: 0)
594: for my $spec (@$specs) { 595: my ($col, $op, $val) = split /:/, $spec, 3; 596: next unless length($col // '') && defined $op && length $op; 597: $val //= ''; 598: 599: # A second spec on the same column goes to residual. 600: if (exists $criteria{$col}) { 601: push @residual, $spec; 602: next; 603: } 604: 605: if ($op eq 'eq' || $op eq 'ne') { 606: if ($val =~ /[%_]/) { 607: push @residual, $spec; 608: } else { 609: $criteria{$col} = ($op eq 'eq') 610: ? { -like => $val } 611: : { -not_like => $val }; 612: }
Mutants (Total: 2, Killed: 2, Survived: 0)
613: } elsif ($op eq 'contains') {
Mutants (Total: 2, Killed: 2, Survived: 0)
614: if ($val =~ /[%_]/) {
Mutants (Total: 2, Killed: 2, Survived: 0)
615: push @residual, $spec; 616: } else { 617: $criteria{$col} = { -like => "%${val}%" }; 618: } 619: } elsif ($op eq 'starts') { 620: if ($val =~ /[%_]/) { 621: push @residual, $spec; 622: } else { 623: $criteria{$col} = { -like => "${val}%" }; 624: } 625: } elsif ($op eq 'lt') { 626: Scalar::Util::looks_like_number($val) 627: ? ($criteria{$col} = { '<' => $val }) 628: : push @residual, $spec; 629: } elsif ($op eq 'le') { 630: Scalar::Util::looks_like_number($val)
Mutants (Total: 2, Killed: 2, Survived: 0)
631: ? ($criteria{$col} = { '<=' => $val }) 632: : push @residual, $spec; 633: } elsif ($op eq 'gt') {
Mutants (Total: 2, Killed: 2, Survived: 0)
634: Scalar::Util::looks_like_number($val) 635: ? ($criteria{$col} = { '>' => $val }) 636: : push @residual, $spec; 637: } elsif ($op eq 'ge') { 638: Scalar::Util::looks_like_number($val) 639: ? ($criteria{$col} = { '>=' => $val }) 640: : push @residual, $spec; 641: } else { 642: # empty, notempty, unknown operator: always residual. 643: push @residual, $spec;
Mutants (Total: 2, Killed: 2, Survived: 0)
644: } 645: }
Mutants (Total: 2, Killed: 2, Survived: 0)
646: 647: return (\%criteria, \@residual);
Mutants (Total: 2, Killed: 2, Survived: 0)
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: my ($fn, $col, $as) = @_; 662: 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: my $v = shift; 674: return undef unless defined $v && length($v); 675: my $is_acct_neg = ($v =~ /\A\s*\(/); 676: (my $n = $v) =~ s/[^\d.\-]//g; 677: $n = "-$n" if $is_acct_neg && $n =~ /\A\d/; 678: return undef unless $n =~ /\A-?\d+(?:\.\d+)?\z/; 679: 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 → 713 → 719 697: my ($source, $fn, $col, $records) = @_; 698: return 0 unless $source && $source->can('aggregate'); 699: return 1 if $fn eq 'count' || $fn eq 'count_distinct'; 700: 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)
Mutants (Total: 1, Killed: 1, Survived: 0)
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: require Scalar::Util;
Mutants (Total: 1, Killed: 1, Survived: 0)
712: my $found = 0; 713: for my $row (@{ $records // [] }) { 714: my $v = $row->{$col}; 715: next unless defined $v && length($v); # undef/blank: same effect as NULL 716: return 0 unless Scalar::Util::looks_like_number($v); 717: $found = 1; 718: } 719: 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 => ... }.
Mutants (Total: 1, Killed: 1, Survived: 0)
725: # Shared dialect for /pivot (Phase 2) so it does not invent a second format.
Mutants (Total: 2, Killed: 2, Survived: 0)
726: # Returns undef for an invalid or unrecognised spec. 727: sub _parse_measure_param { 728: my $str = shift; 729: return undef unless defined $str && length($str); 730: my ($col, $fn, $as) = split /:/, $str, 3; 731: return undef unless defined $fn && defined $as && length($fn) && length($as); 732: $fn = lc $fn; 733: return undef unless $MEASURE_FN_OK{$fn}; 734: 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
Mutants (Total: 1, Killed: 1, Survived: 0)
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:
Mutants (Total: 1, Killed: 1, Survived: 0)
751: # Push path -- $source is defined, no active f= filters, measure is pushable
Mutants (Total: 1, Killed: 1, Survived: 0)
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
Mutants (Total: 1, Killed: 1, Survived: 0)
758: # regardless of source type, enabling cross-backend equivalence assertions. 759: sub _grouped_totals :Protected ($self, $pipeline, $spec) {
Mutants (Total: 3, Killed: 3, Survived: 0)
●760 → 797 → 817 760: my $source = $pipeline->{source};
Mutants (Total: 3, Killed: 3, Survived: 0)
761: my $records = $pipeline->{records} // []; 762: my $by = $spec->{by} // []; 763: my $fn = lc($spec->{fn} // 'count'); 764: my $val_col = $spec->{val};
Mutants (Total: 1, Killed: 1, Survived: 0)
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 {
Mutants (Total: 2, Killed: 2, Survived: 0)
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 → 820 → 852 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,
Mutants (Total: 1, Killed: 1, Survived: 0)
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') {
Mutants (Total: 3, Killed: 3, Survived: 0)
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)');
Mutants (Total: 1, Killed: 1, Survived: 0)
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} }
Mutants (Total: 3, Killed: 3, Survived: 0)
848: elsif ($fn eq 'max') { $totals{$key} = (!exists $totals{$key} || $n > $totals{$key}) ? $n : $totals{$key} } 849: } 850: } 851: ●852 → 852 → 863 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 → 864 → 874 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: } 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.
Mutants (Total: 2, Killed: 2, Survived: 0)
903: sub _fetch_page :Protected ($self, $source, $params) { ●904 → 920 → 934 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) {
Mutants (Total: 2, Killed: 2, Survived: 0)
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 → 940 → 952 934: my ($criteria, $residual) = _filter_specs_to_criteria(\@f_specs, $source); 935: my $has_criteria = %$criteria; 936:
Mutants (Total: 1, Killed: 1, Survived: 0)
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) {
Mutants (Total: 1, Killed: 1, Survived: 0)
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 → 959 → 965 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: } 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
Mutants (Total: 1, Killed: 1, Survived: 0)
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 → 992 → 998 987: my ($sources) = @_; 988: 989: # Build the unified column order: first source's columns first, then any
Mutants (Total: 1, Killed: 1, Survived: 0)
990: # new columns introduced by each subsequent source in their file order. 991: my (@all_cols, %seen); 992: for my $src (@$sources) { 993: for my $col (@{ $src->[1] }) { 994: push @all_cols, $col unless $seen{$col}++; 995: } 996: } 997: ●998 → 999 → 1010 998: my @merged; 999: for my $src (@$sources) { 1000: my ($recs, $cols) = @$src;
Mutants (Total: 1, Killed: 1, Survived: 0)
1001: my %has_col = map { $_ => 1 } @$cols; 1002: for my $row (@$recs) { 1003: my %new_row; 1004: $new_row{$_} = $has_col{$_} ? ($row->{$_} // '') : '' 1005: for @all_cols; 1006: push @merged, \%new_row; 1007: } 1008: }
Mutants (Total: 2, Killed: 2, Survived: 0)
1009: 1010: 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: my $f = $_ // ''; 1023: $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: } 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 → 1055 → 1068 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: };
Mutants (Total: 1, Killed: 1, Survived: 0)
1072: } 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.
Mutants (Total: 4, Killed: 4, Survived: 0)
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 → 1098 → 1105 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 → 1119 → 1125 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: } 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 → 1152 → 1180 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/;Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_1124_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomesMutants (Total: 1, Killed: 1, Survived: 0)
1150: my $src = $left_src; 1151: my @schema_warnings;
Mutants (Total: 2, Killed: 2, Survived: 0)
1152: for my $jspec (@{ $self->every_param('j') }) { 1153: my ($right_spec, $left_key, $right_key) = split /\|/, $jspec, 3;
Mutants (Total: 1, Killed: 1, Survived: 0)
1154: next unless defined $right_spec && defined $left_key && defined $right_key; 1155:
Mutants (Total: 2, Killed: 2, Survived: 0)
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:Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_1157_2: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes🧪 Suggested Test# Boolean branch test suggestion ok( !func(INPUT), 'Verify boolean branch behaviour' );- RETURN_UNDEF_1157_2: Replace return expression with undef
LOW: Mutation survived, but impact may be minor🧪 Suggested Test# Return value assertion is( func(INPUT), EXPECTED, 'Verify correct return value' );Mutants (Total: 2, Killed: 2, Survived: 0)
1167: require Database::Join; 1168: local $SIG{__WARN__} = sub { push @schema_warnings, $_[0] };
1169: $src = Database::Join->new( 1170: databases => [$src, $right_src],Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_1168_2: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes🧪 Suggested Test# Boolean branch test suggestion ok( !func(INPUT), 'Verify boolean branch behaviour' );- RETURN_UNDEF_1168_2: Replace return expression with undef
LOW: Mutation survived, but impact may be minor🧪 Suggested Test# Return value assertion is( func(INPUT), EXPECTED, 'Verify correct return value' );Mutants (Total: 2, Killed: 2, Survived: 0)
1171: join_column => $left_key, 1172: backend => 'auto', 1173: max_array_rows => $max_rows,
Mutants (Total: 2, Killed: 2, Survived: 0)
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 → 1190 → 1207 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);
Mutants (Total: 1, Killed: 1, Survived: 0)
1208: } 1209: 1210: # _apply_date_normalization($self, $records, \@columns, $spec_key) -> void
Mutants (Total: 3, Killed: 3, Survived: 0)
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 → 1225 → 0 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.
Mutants (Total: 2, Killed: 2, Survived: 0)
1233: my $iso = Database::BI::Calc::date_normalise($v, $pat); 1234: $row->{$col} = $iso if defined $iso; 1235: } 1236: } 1237: } 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 → 1266 → 1279 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} // {};
Mutants (Total: 2, Killed: 2, Survived: 0)
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 → 1281 → 1305 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: } 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 → 1356 → 1360 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 → 1360 → 1364 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: } 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: } 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: } 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 → 1408 → 1412 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 → 1417 → 1425 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) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1421: carp $self->_i18n('error_sort_column', $sort);
Mutants (Total: 2, Killed: 2, Survived: 0)
1422: } 1423: 1424: # Server-side pagination for /export. ●1425 → 1425 → 1434 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);
Mutants (Total: 4, Killed: 4, Survived: 0)
1432: } 1433: 1434: return ($records, \@columns, $left_label); 1435: } 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)
Mutants (Total: 1, Killed: 1, Survived: 0)
1441: # arrives as byte strings without the UTF-8 flag set. encode_json
Mutants (Total: 2, Killed: 2, Survived: 0)
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: my $s = shift; 1450: return $s unless defined $s; 1451: utf8::decode($s) unless utf8::is_utf8($s);
Mutants (Total: 1, Killed: 1, Survived: 0)
1452: $s;
Mutants (Total: 2, Killed: 2, Survived: 0)
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 → 1474 → 1477 1472: my ($records, $columns) = @_; 1473: my @lines = _csv_row(@$columns); 1474: for my $row (@$records) { 1475: push @lines, _csv_row(map { $row->{$_} } @$columns); 1476: } 1477: 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: } 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: } 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: } 1515: 1516: # --------------------------------------------------------------------------- 1517: # Public actions 1518: # --------------------------------------------------------------------------- 1519: 1520: =head1 ACTIONS 1521: 1522: =head2 index 1523: 1524: C<GET /> -- Scan C<data_dir> and present a card grid of available tables. 1525: 1526: =head3 API SPECIFICATION 1527: 1528: =head4 INPUT 1529: 1530: None (reads C<data_dir> from application config). 1531: 1532: =head4 OUTPUT 1533: 1534: Renders C<home.html.tt> with: 1535: 1536: tables ARRAYREF of { name => $stem, file => $basename } 1537: title 'Choose a Database'
Mutants (Total: 2, Killed: 2, Survived: 0)
1538: 1539: =head3 MESSAGES 1540: 1541: None produced by this action; any file-scan errors are silently ignored 1542: (empty directory yields an empty card grid). 1543: 1544: =head3 FORMAL SPECIFICATION 1545: 1546: index == lambda self . 1547: let dir = resolve self.app.config.data_dir in 1548: let tbls = { b | b in dir /\ basename(b) =~ EXT_RE } in 1549: post render(home, tables: map(stem, tbls)) 1550: 1551: =head3 EXAMPLE 1552: 1553: GET / -> 200 text/html containing a card for each file in data/ 1554: 1555: =cut 1556: 1557: sub index ($self) { 1558: my ($platform, $language) = $self->_resolve_template; 1559: 1560: $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: =head2 view 1570: 1571: C<GET /view/:table> -- Open and display the chosen table from C<data_dir>. 1572: 1573: =head3 API SPECIFICATION 1574: 1575: =head4 INPUT 1576: 1577: :table string Table name (alphanumeric + underscore). Returns 404 on 1578: other characters. 1579: ?f= string (repeatable) Filter spec: "col:op:val". 1580: 1581: =head4 DOMAIN CONSTRAINTS: :table 1582: 1583: C<:table> is validated against C<\A[A-Za-z_][A-Za-z0-9_]*\z> before C<open_table> 1584: is ever called. The first character must be a letter (A-Z, a-z) or an 1585: underscore; subsequent characters may also include digits (0-9). 1586: 1587: =over 4 1588: 1589: =item Valid partition 1590: 1591: C<sales> (letters only), C<_temp> (underscore-start), C<report_2024> 1592: (mixed). A name that is valid but has no backing file returns 200 with 1593: an error message -- NOT 404. 1594: 1595: =item Invalid partition 1596: 1597: C<1sales> (digit-start, 404), C<my.data> (dot, 404), C<my-data> 1598: (hyphen, 404), non-ASCII characters (404). 1599: 1600: =item Boundary values 1601: 1602: C<a> (single letter, valid), C<_> (single underscore, valid), C<1> 1603: (single digit, 404), C<a1> (letter then digit, valid), C<1a> (digit 1604: then letter, 404). 1605: 1606: =back 1607: 1608: =head4 OUTPUT 1609: 1610: On success renders C<dashboard.html.tt> with table data. 1611: On error re-renders C<home.html.tt> with an C<error> stash variable. 1612: 1613: =head3 MESSAGES 1614: 1615: error_table_open -- DataSource initialisation or fetch_all threw. 1616: 1617: =head3 FORMAL SPECIFICATION 1618: 1619: view == lambda self . 1620: pre self.stash('table') =~ TABLE_NAME_RE 1621: let src = open_table(table) in 1622: let records = src.fetch_all() in 1623: let cols = get_columns(src, records) in 1624: post render(dashboard, records: filter(records, f_params)) 1625: 1626: =head3 EXAMPLE 1627: 1628: GET /view/sales -> 200 HTML table of all sales rows 1629: GET /view/sales?f=region:eq:North -> shows only North region rows 1630: GET /view/../etc -> 404 1631: 1632: =cut 1633: 1634: sub view ($self) { ●1635 → 1638 → 1642 1635: my ($platform, $language) = $self->_resolve_template; 1636: my $table = $self->stash('table'); 1637: 1638: unless (defined $table && $table =~ $TABLE_NAME_RE) { 1639: return $self->reply->not_found; 1640: } 1641: ●1642 → 1658 → 1669 1642: my ($page, $per_page, $offset) = $self->_pagination; 1643: 1644: my $dedup = $self->param('d') ? 1 : 0; 1645: my ($source, $records, $has_next, $is_multi); 1646: eval { 1647: $source = $self->open_table($table); 1648: # Multi-table SQLite: flag redirect without fetching data. 1649: if ($source && $source->sqlite_tables && @{ $source->sqlite_tables } > 1) { 1650: $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: ($records, $has_next) = $self->_fetch_page($source, 1655: { per_page => $per_page, offset => $offset, dedup => $dedup }); 1656: } 1657: }; 1658: if ($@) {
Mutants (Total: 2, Killed: 2, Survived: 0)
1659: return $self->render( 1660: template => "$platform/$language/home", 1661: handler => 'tt', 1662: format => 'html', 1663: tables => [],
Mutants (Total: 1, Killed: 1, Survived: 0)
1664: title => 'Choose a Database',
Mutants (Total: 2, Killed: 2, Survived: 0)
1665: error => $self->_i18n('error_table_open', $table, $@), 1666: ); 1667: } 1668:
Mutants (Total: 1, Killed: 1, Survived: 0)
●1669 → 1669 → 1673 1669: if ($is_multi) { 1670: return $self->redirect_to('/tables?l=' . url_escape("table:$table")); 1671: }
Mutants (Total: 2, Killed: 2, Survived: 0)
1672: 1673: $records //= []; 1674: 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: my (undef, $filter_specs, $filters_json) = $self->_apply_filters($records); 1678: 1679: my $page_url = $self->req->url->clone;
Mutants (Total: 1, Killed: 1, Survived: 0)
1680: $page_url->query->remove('page')->remove('per_page');
Mutants (Total: 2, Killed: 2, Survived: 0)
1681: my $page_base_url = $page_url->to_string; 1682: 1683: $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,
Mutants (Total: 2, Killed: 2, Survived: 0)
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: =head2 browse 1710: 1711: C<GET /browse> -- Navigate the filesystem and pick a data file. 1712: 1713: =head3 API SPECIFICATION 1714: 1715: =head4 INPUT 1716: 1717: ?path= string Absolute filesystem path to browse (default: $HOME). 1718: Returns 404 when the path does not exist or is not a 1719: directory. 1720: 1721: =head4 OUTPUT 1722: 1723: Renders C<browse.html.tt> with: 1724: 1725: current_path string 1726: parent_href string or undef (undef at filesystem root) 1727: crumbs ARRAYREF of { name, href }
Mutants (Total: 1, Killed: 1, Survived: 0)
1728: dirs ARRAYREF of { name, href } -- subdirectories, sorted 1729: files ARRAYREF of { name, href } -- supported data files, sorted 1730:
Mutants (Total: 2, Killed: 2, Survived: 0)
1731: =head3 MESSAGES 1732: 1733: None; errors render as 404. 1734: 1735: =head3 FORMAL SPECIFICATION 1736: 1737: browse == lambda self . 1738: let dir = realpath(param('path') // HOME) in 1739: pre is_dir(dir)
Mutants (Total: 1, Killed: 1, Survived: 0)
1740: post render(browse, dirs: subdirs(dir), files: supported_files(dir))
Mutants (Total: 2, Killed: 2, Survived: 0)
1741: 1742: =head3 EXAMPLE 1743: 1744: GET /browse -> 200, lists $HOME 1745: GET /browse?path=/tmp -> 200, lists /tmp 1746: GET /browse?path=/nonexistent/xyz -> 404 1747: 1748: =cut 1749: 1750: sub browse ($self) { 1751: my ($platform, $language) = $self->_resolve_template; 1752: 1753: my $raw_path = $self->param('path') // $ENV{HOME} // '/'; 1754: my $dir = eval { Mojo::File->new($raw_path)->realpath }; 1755: return $self->reply->not_found unless defined $dir && -d $dir; 1756:
Mutants (Total: 2, Killed: 2, Survived: 0)
1757: 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: +{ name => $_->{name}, href => '/browse?path=' . url_escape($_->{path}) } 1762: } @{ $listing->{dirs} }; 1763: 1764: my @files = map { 1765: +{ name => $_->{name}, href => '/open?path=' . url_escape($_->{path}) } 1766: } @{ $listing->{files} }; 1767: 1768: # Build breadcrumb trail from filesystem root down to $dir. 1769: my @crumbs; 1770: { 1771: my $f = $dir; 1772: while (1) { 1773: my $name = $f->basename; 1774: $name = '/' unless length $name; 1775: unshift @crumbs, { name => $name, href => '/browse?path=' . url_escape($f->to_string) }; 1776: my $parent = $f->dirname; 1777: last if $parent->to_string eq $f->to_string; 1778: $f = $parent; 1779: } 1780: } 1781: 1782: my $parent = $dir->dirname; 1783: my $parent_href = $parent->to_string ne $dir->to_string 1784: ? '/browse?path=' . url_escape($parent->to_string) 1785: : undef; 1786:
Mutants (Total: 2, Killed: 2, Survived: 0)
1787: $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:
Mutants (Total: 1, Killed: 1, Survived: 0)
1800: =head2 open_file 1801: 1802: C<GET /open> -- Open a supported data file from any absolute filesystem path. 1803: 1804: =head3 API SPECIFICATION 1805: 1806: =head4 INPUT 1807: 1808: ?path= string Absolute path to the data file. Returns 404 when missing, 1809: not a regular file, or the extension is not in SUPPORTED_EXT. 1810: ?f= string (repeatable) Filter spec: "col:op:val".
Mutants (Total: 1, Killed: 1, Survived: 0)
1811:
Mutants (Total: 3, Killed: 3, Survived: 0)
1812: =head4 DOMAIN CONSTRAINTS: ?path= 1813: 1814: =over 4 1815: 1816: =item Extension filter (C<EXT_RE>) 1817: 1818: The basename must match C<\.(?:csv|db|sql|xml|tsv|psv)\z> (case-insensitive).
Mutants (Total: 1, Killed: 1, Survived: 0)
1819: The C<\z> anchor (absolute end-of-string) means a URL-encoded trailing 1820: newline (e.g. C<file.csv%0A> decoded to C<file.csv\n>) does NOT pass -- 1821: the C<\n> falls after the C<\z> boundary and the extension check fails. 1822:
Mutants (Total: 1, Killed: 1, Survived: 0)
1823: =item Valid partition 1824: 1825: C</data/sales.csv> (lowercase extension), C</tmp/REPORT.CSV> (uppercase 1826: extension, /i matches), any C<.db>, C<.sql>, C<.xml>, C<.tsv>, C<.psv> regular 1827: file.
Mutants (Total: 2, Killed: 2, Survived: 0)
1828: 1829: =item Invalid partition 1830: 1831: Absent C<?path=> (404), non-existent file (404), directory instead of 1832: file (404), unsupported extension such as C<.txt> (404), empty string 1833: (404), path containing a C<%0A> (newline) suffix (404). 1834: 1835: =item Double-extension filenames 1836: 1837: A file like C<file.php.csv> passes C<EXT_RE> (last segment is C<.csv>) 1838: but produces table stem C<file.php> which fails C<DataSource>'s 1839: C<TABLE_NAME_RE>. The C<open_table> call is inside C<eval>, so the 1840: croak is caught and the action returns 200 with a friendly error, not 1841: a 500. 1842:
Mutants (Total: 1, Killed: 1, Survived: 0)
1843: =back
Mutants (Total: 2, Killed: 2, Survived: 0)
1844: 1845: =head4 OUTPUT 1846: 1847: On success renders C<dashboard.html.tt> with C<back_url> pointing to the 1848: directory's C</browse> page, and C<file_path> set to the resolved absolute 1849: path (used by the template to record the file in C<localStorage>). 1850: On error re-renders C<home.html.tt> with C<error>, C<back_url>, C<back_label>. 1851: 1852: =head3 MESSAGES 1853: 1854: error_file_open -- DataSource threw during initialisation or fetch_all. 1855: 1856: =head3 FORMAL SPECIFICATION 1857: 1858: open_file == lambda self . 1859: let file = realpath(param('path')) in 1860: pre is_file(file) /\ basename(file) =~ EXT_RE 1861: let src = open_table(stem(file), dir=dirname(file)) in 1862: post render(dashboard, file_path: file.to_string) 1863: 1864: =head3 EXAMPLE 1865: 1866: GET /open?path=/data/archive/sales.csv -> 200, table view 1867: GET /open -> 404 1868: GET /open?path=/etc/passwd -> 404 1869: 1870: =cut 1871: 1872: sub open_file ($self) { ●1873 → 1881 → 1886 1873: my ($platform, $language) = $self->_resolve_template; 1874: my $file_path = $self->param('path'); 1875: 1876: return $self->reply->not_found unless defined $file_path; 1877: 1878: my ($page, $per_page, $offset) = $self->_pagination; 1879: 1880: # Bare redis:// URL (no table name) -- redirect to key-listing page. 1881: if ($file_path =~ $REDIS_URL_RE) { 1882: 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 → 1886 → 1945 1886: if ($file_path =~ $REDIS_SPEC_RE) { 1887: my $lspec = $file_path; 1888: my ($source, $label) = $self->_open_spec($lspec); 1889: return $self->reply->not_found unless $source; 1890: my $table = $label; 1891: my $dedup = $self->param('d') ? 1 : 0; 1892: my ($records, $has_next); 1893: eval { 1894: ($records, $has_next) = $self->_fetch_page($source, 1895: { per_page => $per_page, offset => $offset, dedup => $dedup }); 1896: }; 1897: if ($@) { 1898: 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: $records //= []; 1910: my @columns = _get_columns($source, $records); 1911: my (undef, $filter_specs, $filters_json) = $self->_apply_filters($records); 1912: my $rpage_url = $self->req->url->clone; 1913: $rpage_url->query->remove('page')->remove('per_page'); 1914: 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,
Mutants (Total: 2, Killed: 2, Survived: 0)
1938: has_next => $has_next,
Mutants (Total: 2, Killed: 2, Survived: 0)
1939: page_base_url => $rpage_url->to_string, 1940: );
Mutants (Total: 2, Killed: 2, Survived: 0)
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.
Mutants (Total: 2, Killed: 2, Survived: 0)
●1945 → 1945 → 2003 1945: if ($file_path =~ m{\A/\.\./}) { 1946: my $lspec = 'path:' . $file_path; 1947: my ($source, $label) = $self->_open_spec($lspec);
Mutants (Total: 2, Killed: 2, Survived: 0)
1948: return $self->reply->not_found unless $source; 1949: my $filename = $label; 1950: (my $table = $filename) =~ s/\.[^.]+\z//; 1951: my $dedup = $self->param('d') ? 1 : 0; 1952: my ($records, $has_next); 1953: eval { 1954: ($records, $has_next) = $self->_fetch_page($source, 1955: { per_page => $per_page, offset => $offset, dedup => $dedup }); 1956: }; 1957: if ($@) { 1958: 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: $records //= []; 1970: my @columns = _get_columns($source, $records); 1971: my (undef, $filter_specs, $filters_json) = $self->_apply_filters($records); 1972: my $rpage_url = $self->req->url->clone; 1973: $rpage_url->query->remove('page')->remove('per_page'); 1974: 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 → 2017 → 2020 2003: my $file = eval { Mojo::File->new($file_path)->realpath }; 2004: return $self->reply->not_found 2005: unless defined $file && -f $file && $file->basename =~ $EXT_RE; 2006: 2007: my $dir = $file->dirname; 2008: (my $table = $file->basename) =~ s/\.[^.]+\z//; 2009: my $back = '/browse?path=' . url_escape($dir->to_string); 2010: my $filename = $file->basename; 2011: my $lspec = 'path:' . $file->to_string; 2012: 2013: 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: my $back_override = _safe_back_url($self->param('back')); 2017: if ($back_override) { 2018: $back = $back_override; 2019: } ●2020 → 2036 → 2060 2020: my $back_label_default = $back_override ? ($self->param('back_label') // 'Back') : 'Back to browser'; 2021: 2022: my $dedup = $self->param('d') ? 1 : 0; 2023: my ($source, $records, $has_next, $is_multi_local); 2024: eval { 2025: $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: if (!defined $it && $source && $source->sqlite_tables 2029: && @{ $source->sqlite_tables } > 1) { 2030: $is_multi_local = 1; 2031: } else { 2032: ($records, $has_next) = $self->_fetch_page($source, 2033: { per_page => $per_page, offset => $offset, dedup => $dedup });
Mutants (Total: 1, Killed: 1, Survived: 0)
2034: } 2035: };
Mutants (Total: 1, Killed: 1, Survived: 0)
2036: 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: my $hint; 2040: if ($filename =~ /\.(?:sql|db)\z/i) { 2041: $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.';
Mutants (Total: 1, Killed: 1, Survived: 0)
2044: } 2045: return $self->render(
Mutants (Total: 2, Killed: 2, Survived: 0)
2046: template => "$platform/$language/home", 2047: handler => 'tt', 2048: format => 'html', 2049: tables => [], 2050: title => 'Error',
Mutants (Total: 1, Killed: 1, Survived: 0)
2051: error => $self->_i18n('error_file_open', $filename, $@), 2052: hint => $hint, 2053: back_url => $back,
Mutants (Total: 1, Killed: 1, Survived: 0)
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 → 2060 → 2064 2060: if ($is_multi_local) {
Mutants (Total: 1, Killed: 1, Survived: 0)
2061: return $self->redirect_to('/tables?l=' . url_escape("path:${\$file->to_string}")); 2062: } 2063: 2064: $records //= []; 2065: my @columns = _get_columns($source, $records); 2066: my (undef, $filter_specs, $filters_json) = $self->_apply_filters($records); 2067: 2068: my $lpage_url = $self->req->url->clone;
Mutants (Total: 2, Killed: 2, Survived: 0)
2069: $lpage_url->query->remove('page')->remove('per_page'); 2070: 2071: $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: =head2 import_url 2101: 2102: C<GET /import> -- Fetch a remote HTML page, extract the first (or selected) 2103: table, and render it as a sortable data grid. 2104: 2105: =head3 API SPECIFICATION 2106: 2107: =head4 INPUT 2108: 2109: ?url= string Required. Full http:// or https:// URL of the page 2110: that contains the HTML table. Returns home with an 2111: error message if the scheme is wrong, the fetch fails, 2112: or no table is found at the specified index. 2113: ?table_index= integer Zero-based index of the C<< <table> >> to use when 2114: the page contains more than one table (default: 0). 2115: ?f= string (repeatable) Filter spec: "col:op:val". 2116: 2117: =head4 OUTPUT 2118: 2119: On success renders C<dashboard.html.tt> with the same stash shape as C<open_file>, 2120: plus C<source_url> (the original URL) for C<localStorage> tracking. 2121: 2122: On error re-renders C<home.html.tt> with an C<error> stash variable. 2123: 2124: =head3 MESSAGES 2125: 2126: error_url_required -- empty or missing C<url> param 2127: error_url_invalid -- URL does not begin with http:// or https:// 2128: error_url_fetch -- LWP fetch failure or no table found at the index 2129: 2130: =head3 EXAMPLE 2131: 2132: GET /import?url=https://matrix.perl-magpie.org/dist/Database-Abstraction/ 2133: GET /import?url=https://example.com/data.html&table_index=2
Mutants (Total: 2, Killed: 2, Survived: 0)
2134: 2135: =cut 2136: 2137: sub import_url ($self) { 2138: my ($platform, $language) = $self->_resolve_template; 2139: 2140: my $url = $self->param('url') // ''; 2141: my $idx = $self->param('table_index') // 0; 2142: $idx = 0 unless $idx =~ /\A[0-9]+\z/; 2143: 2144: my $err_home = sub ($key, @args) { 2145: $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: }; 2154: 2155: return $err_home->('error_url_required') unless length $url; 2156: return $err_home->('error_url_invalid', $url) 2157: unless $url =~ m{\Ahttps?://}i; 2158: return $err_home->('error_url_ssrf', $url) 2159: unless _is_safe_url($url); 2160: 2161: my $source = eval { $self->open_table('', url => $url, html_table_index => $idx) }; 2162: return $err_home->('error_url_fetch', $url, $@ // 'unknown error') if $@ || !$source; 2163: 2164: my $records = eval { $source->fetch_all }; 2165: return $err_home->('error_url_fetch', $url, $@ // 'empty result') if $@; 2166: 2167: my $label = $source->table_name; 2168: my $lspec = "url:$url"; 2169: my @columns = _get_columns($source, $records); 2170: my ($filtered, $filter_specs, $filters_json) = $self->_apply_filters($records); 2171: my $dedup = $self->param('d') ? 1 : 0; 2172: $filtered = _dedup_records($filtered, \@columns) if $dedup; 2173: 2174: my $self_url = '/import?url=' . url_escape($url); 2175: $self_url .= '&table_index=' . $idx if $idx; 2176: 2177: $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,
Mutants (Total: 1, Killed: 1, Survived: 0)
2185: source_url => $url,
Mutants (Total: 2, Killed: 2, Survived: 0)
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),
Mutants (Total: 1, Killed: 1, Survived: 0)
2199: ); 2200: } 2201: 2202: =head2 columns_api 2203: 2204: C<GET /api/columns> -- Return column names for a table or file as JSON. 2205: 2206: Used by the join UI to populate the right-key dropdown without a page reload. 2207: 2208: =head3 API SPECIFICATION 2209: 2210: =head4 INPUT 2211: 2212: ?table= string Table name from C<data_dir>. 2213: ?path= string Absolute path to a data file. 2214: ?spec= string Unified spec: C<"table:name"> or C<"path:/abs/path">. 2215: Parsed only when C<table> and C<path> are both absent. 2216: 2217: One of C<table>, C<path>, or C<spec> must be present; C<table> takes 2218: precedence over C<path>, and both take precedence over C<spec>. 2219: 2220: =head4 OUTPUT 2221: 2222: 200 application/json { "columns": ["col1", "col2", ...] } 2223: 404 application/json { "error": "not found" } 2224: 2225: =head3 MESSAGES 2226: 2227: None produced by this action directly; internal errors yield a 404. 2228: 2229: =head3 FORMAL SPECIFICATION 2230: 2231: columns_api == lambda self . 2232: let src = open_spec(table_param or path_param or parse_spec(spec_param)) in 2233: pre src /= undef 2234: post render_json({ columns: get_columns(src) }) 2235: 2236: =head3 EXAMPLE 2237: 2238: GET /api/columns?table=sales -> {"columns":["product","region","amount"]} 2239: GET /api/columns?spec=table:sales -> {"columns":["product","region","amount"]} 2240: GET /api/columns?spec=path:/data/f.csv -> {"columns":[...]} 2241: GET /api/columns?table=noexist -> 404 2242: 2243: =cut 2244: 2245: sub columns_api ($self) { ●2246 → 2251 → 2260 2246: my $table_name = $self->param('table'); 2247: 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: if (!defined($table_name) && !defined($path)) { 2252: my $spec = $self->param('spec') // ''; 2253: if ($spec =~ /\Atable:([A-Za-z_][A-Za-z0-9_]*)\z/) { 2254: $table_name = $1; 2255: } elsif ($spec =~ /\Apath:(.+)\z/s) { 2256: $path = $1; 2257: } 2258: } 2259: ●2260 → 2261 → 2286 2260: my $source; 2261: if (defined $table_name && $table_name =~ $TABLE_NAME_RE) { 2262: my $data_dir = $self->app->home->child($self->app->config->{data_dir} // 'data'); 2263: return $self->render(json => { error => 'not found' }, status => 404) 2264: unless grep { -f $data_dir->child(lc($table_name) . ".$_") } @SUPPORTED_EXT; 2265: $source = eval { $self->open_table(lc $table_name, directory => $data_dir->to_string) }; 2266: } 2267: elsif (defined $path) { 2268: if ($path =~ m{\A/\.\./([^/]+)((?:/.+)?)/([^/]+)\z}) { 2269: my ($host, $dir_part, $file) = ($1, $2 // '', $3); 2270: $dir_part = '/' unless length $dir_part; 2271: if ($host =~ $REMOTE_HOST_RE) { 2272: my ($tbl, $ext) = $file =~ /\A(.+)\.([^.]+)\z/ ? ($1, $2) : ($file, undef); 2273: $source = eval { $self->open_table($tbl, directory => $dir_part, host => $host, 2274: defined $ext ? (file_ext => $ext) : ()) }; 2275: } 2276: } else { 2277: my $file = eval { Mojo::File->new($path)->realpath }; 2278: if (defined $file && -f $file && $file->basename =~ $EXT_RE) { 2279: my $dir = $file->dirname->to_string; 2280: (my $tbl = $file->basename) =~ s/\.[^.]+\z//; 2281: $source = eval { $self->open_table($tbl, directory => $dir) }; 2282: } 2283: } 2284: } 2285: 2286: 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: my $recs = ($source->columns ? [] : eval { $source->fetch_all } // []); 2290: my @cols = _get_columns($source, $recs); 2291: 2292: $self->render(json => { columns => \@cols }); 2293: } 2294: 2295: =head2 join_tables 2296: 2297: C<GET /join> -- Perform one or more left joins and render the merged table. 2298: 2299: =head3 API SPECIFICATION 2300: 2301: =head4 INPUT
Mutants (Total: 2, Killed: 2, Survived: 0)
2302: 2303: ?l= string Required. Left table spec: "table:name" or "path:/abs/path". 2304: Returns 404 if unresolvable.
Mutants (Total: 1, Killed: 1, Survived: 0)
2305: ?j= string (repeatable) Join step: "<right-spec>|<left-key>|<right-key>".
Mutants (Total: 2, Killed: 2, Survived: 0)
2306: Invalid or non-existent steps are silently skipped. 2307: ?f= string (repeatable) Result filter: "col:op:val". 2308: 2309: =head4 OUTPUT 2310: 2311: Renders C<dashboard.html.tt> with the merged/filtered result set. 2312: 2313: =head3 MESSAGES 2314: 2315: error_table_open -- Left table fetch threw (re-renders home with error). 2316: 2317: =head3 FORMAL SPECIFICATION 2318: 2319: join_tables == lambda self . 2320: let left = open_spec(param('l')) in 2321: pre left /= undef 2322: let joined = fold(_left_join, left, param_list('j')) in 2323: let filtered = fold(_apply_filter_spec, joined, param_list('f')) in 2324: post render(dashboard, records: filtered) 2325: 2326: =head3 PSEUDOCODE 2327: 2328: 1. Parse and open left table spec; 404 on failure. 2329: 2. For each j= param (in order): 2330: a. Parse right-spec, left-key, right-key from "|"-split. 2331: b. Verify left-key exists in current column list. 2332: c. Open right table; skip step on any error.
Mutants (Total: 3, Killed: 3, Survived: 0)
2333: d. Verify right-key exists in right column list. 2334: e. Call _left_join; update records and columns. 2335: 3. Apply all f= filters via _apply_filter_spec. 2336: 4. Build stable table key for localStorage ("join:left:right1:..."). 2337: 5. Render dashboard. 2338: 2339: =head3 EXAMPLE 2340: 2341: GET /join?l=table:sales&j=table:products|product|name 2342: -> merged left join of sales and products on product/name columns 2343: 2344: =cut 2345: 2346: sub join_tables ($self) { ●2347 → 2363 → 2392 2347: my ($platform, $language) = $self->_resolve_template;
Mutants (Total: 1, Killed: 1, Survived: 0)
2348: 2349: my $left_spec = $self->param('l') // ''; 2350: my ($left_src, $left_label) = $self->_open_spec($left_spec); 2351: return $self->reply->not_found unless $left_src; 2352: 2353: my @join_specs = @{ $self->every_param('j') }; 2354: 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: my $max_rows = $self->app->config('join_max_rows') // $DEFAULT_JOIN_MAX_ROWS;
Mutants (Total: 3, Killed: 3, Survived: 0)
2359: my $join_type = $self->param('jtype') // 'left'; 2360: $join_type = 'left' unless $join_type =~ /\A(?:left|inner|outer)\z/; 2361: my $src = $left_src; 2362: my @schema_warnings; 2363: for my $jspec (@join_specs) { 2364: my ($right_spec, $left_key, $right_key) = split /\|/, $jspec, 3; 2365: next unless defined $right_spec && defined $left_key && defined $right_key; 2366: 2367: my $cur_cols = $src->columns; 2368: next unless $cur_cols; 2369: next unless +{ map { $_ => 1 } @$cur_cols }->{$left_key}; 2370: 2371: my ($right_src, $right_label) = $self->_open_spec($right_spec); 2372: next unless $right_src; 2373: 2374: my $right_cols = $right_src->columns; 2375: next unless $right_cols; 2376: next unless +{ map { $_ => 1 } @$right_cols }->{$right_key}; 2377: 2378: require Database::Join; 2379: local $SIG{__WARN__} = sub { push @schema_warnings, $_[0] }; 2380: $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: push @summaries, { label => $right_label, left_key => $left_key, right_key => $right_key }; 2390: } 2391: ●2392 → 2404 → 2414 2392: my ($page, $per_page, $offset) = $self->_pagination; 2393: my $dedup = $self->param('d') ? 1 : 0; 2394: my $sort = $self->param('sort'); 2395: my $dir = ($self->param('dir') // 'asc') =~ /\Adesc\z/i ? 'desc' : 'asc'; 2396: 2397: my ($records, $has_next); 2398: eval { 2399: ($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: if ($@) { 2405: 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 → 2417 → 2421 2414: $records //= []; 2415: my @columns = _get_columns($src, $records); 2416: 2417: if (defined $sort && !grep { $_ eq $sort } @columns) { 2418: carp $self->_i18n('error_sort_column', $sort); 2419: } 2420: 2421: my (undef, $filter_specs, $filters_json) = $self->_apply_filters($records); 2422: 2423: my $title = $left_label; 2424: $title .= ' + ' . join(' + ', map { $_->{label} } @summaries) if @summaries; 2425: my $table_key = 'join:' . lc($left_label); 2426: $table_key .= ':' . lc($_->{label}) for @summaries; 2427: 2428: my $page_url = $self->req->url->clone; 2429: $page_url->query->remove('page')->remove('per_page'); 2430: 2431: $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: =head2 combine_tables
Mutants (Total: 2, Killed: 2, Survived: 0)
2461: 2462: C<GET /combine> -- Stack rows from two or more tables vertically into a single 2463: unified view. 2464: 2465: Unlike C</join> (which appends columns from a matching row in a second table), 2466: C</combine> appends the I<rows> from a second table beneath the rows of the
Mutants (Total: 1, Killed: 1, Survived: 0)
2467: first. All columns from all sources appear as headers; where a row has no 2468: value for a particular column (because that column did not exist in its source 2469: file) the cell is left blank. 2470: 2471: This is equivalent to a SQL C<UNION ALL> across heterogeneous schemas. 2472: 2473: =head3 API SPECIFICATION 2474:
Mutants (Total: 2, Killed: 2, Survived: 0)
2475: =head4 INPUT 2476: 2477: ?l= string (required) Left table spec: "table:name" or "path:/abs/path". 2478: Returns 404 if unresolvable. 2479: ?c= string (repeatable) Additional table spec to stack beneath the 2480: current result. Invalid or non-existent specs are silently 2481: skipped. 2482: ?f= string (repeatable) Result filter: "col:op:val". 2483: 2484: =head4 OUTPUT 2485: 2486: Renders C<dashboard.html.tt> with the combined result set. 2487: 2488: =head3 MESSAGES 2489: 2490: error_table_open -- Left table fetch threw (re-renders home with error). 2491: 2492: =head3 FORMAL SPECIFICATION 2493: 2494: combine_tables == lambda self . 2495: let left = open_spec(param('l')) in 2496: pre left /= undef 2497: let sources = [left] ++ map(open_spec, param_list('c')) in 2498: let combined = _combine_tables(sources) in 2499: let filtered = fold(_apply_filter_spec, combined, param_list('f')) in 2500: post render(dashboard, records: filtered) 2501: 2502: =head3 EXAMPLE 2503: 2504: GET /combine?l=table:cats&c=table:dogs 2505: -> unified view: all cat and dog rows; Species/Name/Color/Breed/Eye Color 2506: appear for both; Environment (cats-only) and Sex/Fixed (dogs-only) 2507: are blank where the source file lacks that column. 2508: 2509: =cut 2510: 2511: sub combine_tables ($self) { ●2512 → 2519 → 2529 2512: my ($platform, $language) = $self->_resolve_template; 2513: 2514: my $left_spec = $self->param('l') // ''; 2515: my ($left_src, $left_label) = $self->_open_spec($left_spec); 2516: return $self->reply->not_found unless $left_src; 2517: 2518: my $left_recs = eval { $left_src->fetch_all }; 2519: if ($@) { 2520: 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 → 2537 → 2547 2529: $left_recs //= []; 2530: 2531: my @left_cols = _get_columns($left_src, $left_recs); 2532: my @combine_specs = @{ $self->every_param('c') }; 2533: 2534: my @sources = ([$left_recs, \@left_cols]); 2535: my @summaries; 2536: 2537: for my $cspec (@combine_specs) { 2538: my ($csrc, $clabel) = $self->_open_spec($cspec); 2539: next unless $csrc; 2540: my $crecs = eval { $csrc->fetch_all } // []; 2541: next if $@; 2542: my @ccols = _get_columns($csrc, $crecs); 2543: push @sources, [$crecs, \@ccols]; 2544: push @summaries, { label => $clabel }; 2545: } 2546: ●2547 → 2553 → 2556 2547: my ($records, $cols_ref) = @sources > 1 2548: ? _combine_tables(\@sources) 2549: : ($left_recs, \@left_cols); 2550: my @columns = @$cols_ref; 2551: 2552: # Apply f= filters in memory before paginating (reduce-before-paginate). 2553: for my $s (@{ $self->every_param('f') // [] }) { 2554: $records = _apply_filter_spec($records, $s); 2555: }
Mutants (Total: 1, Killed: 1, Survived: 0)
●2556 → 2562 → 2571 2556: my $dedup = $self->param('d') ? 1 : 0;
Mutants (Total: 2, Killed: 2, Survived: 0)
2557: $records = _dedup_records($records, \@columns) if $dedup; 2558: 2559: # In-memory sort for /combine (no single backend to delegate to). 2560: my $sort = $self->param('sort'); 2561: my $dir = ($self->param('dir') // 'asc') =~ /\Adesc\z/i ? 'desc' : 'asc'; 2562: if (defined $sort && grep { $_ eq $sort } @columns) { 2563: carp $self->_i18n('warn_combine_sort'); 2564: @$records = sort { ($a->{$sort} // '') cmp ($b->{$sort} // '') } @$records; 2565: @$records = reverse @$records if $dir eq 'desc';
Mutants (Total: 1, Killed: 1, Survived: 0)
2566: } elsif (defined $sort) { 2567: carp $self->_i18n('error_sort_column', $sort); 2568: } 2569:
Mutants (Total: 2, Killed: 2, Survived: 0)
2570: # Server-side pagination: slice the fully-reduced combined set. 2571: my ($page, $per_page, $offset) = $self->_pagination; 2572: my $total = scalar @$records; 2573: my $has_next = ($total > $offset + $per_page) ? 1 : 0; 2574: my @page_recs = splice(@$records, $offset, $per_page); 2575: $records = \@page_recs; 2576:
Mutants (Total: 2, Killed: 2, Survived: 0)
2577: my (undef, $filter_specs, $filters_json) = $self->_apply_filters($records); 2578: 2579: my $title = $left_label; 2580: $title .= ' + ' . join(' + ', map { $_->{label} } @summaries) if @summaries; 2581: my $table_key = 'combine:' . lc($left_label);
Mutants (Total: 1, Killed: 1, Survived: 0)
2582: $table_key .= ':' . lc($_->{label}) for @summaries; 2583: 2584: my $page_url = $self->req->url->clone; 2585: $page_url->query->remove('page')->remove('per_page'); 2586: 2587: $self->render( 2588: template => "$platform/$language/dashboard", 2589: handler => 'tt', 2590: format => 'html', 2591: records => $records,
Mutants (Total: 2, Killed: 2, Survived: 0)
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: =head2 export_data 2616: 2617: C<GET /export> -- Stream the current logical view as a browser file download. 2618: 2619: =head3 API SPECIFICATION 2620: 2621: =head4 INPUT 2622: 2623: ?l= string (required) Left table spec. 2624: ?j= string (repeatable) Join steps. 2625: ?f= string (repeatable) Filter specs. 2626: ?format= string "csv" (default), "sqlite", or "json". 2627: 2628: =head4 DOMAIN CONSTRAINTS: ?format= 2629: 2630: Exact lowercase string match. 2631: 2632: =over 4 2633: 2634: =item Valid partitions 2635: 2636: C<csv> (explicit CSV), C<sqlite> (SQLite binary), C<json> (JSON array), 2637: absent/undef (defaults to CSV). 2638: 2639: =item Invalid partitions (all fall back to CSV) 2640: 2641: Any value not in the valid set (e.g. C<SQLITE>, C<Json>). 2642:
2643: =back 2644: 2645: =head4 OUTPUT 2646: 2647: 200 text/csv Content-Disposition: attachment; filename=<name>.csv 2648: 200 application/vnd.sqlite3 Content-Disposition: attachment; filename=<name>.db 2649: 200 application/json Content-Disposition: attachment; filename=<name>.json 2650: 404 application/json { "error": "Table not found" } 2651: 2652: =head3 MESSAGES 2653: 2654: None beyond the 404 response. 2655: 2656: =head3 FORMAL SPECIFICATION 2657: 2658: export_data == lambda self . 2659: let (recs, cols, label) = _run_export_pipeline() in 2660: pre recs /= undef 2661: post if format = 'sqlite' then render_sqlite(recs, cols) 2662: else if format = 'json' then render_json(recs, cols) 2663: else render_csv(recs, cols) 2664: 2665: =head3 EXAMPLE 2666: 2667: GET /export?l=table:sales&format=csv -> downloads sales.csv 2668: GET /export?l=table:sales&format=sqlite -> downloads sales.db 2669: GET /export?l=table:sales&format=json -> downloads sales.json 2670: 2671: =cut 2672: 2673: sub export_data ($self) { ●2674 → 2681 → 2686 2674: my ($records, $columns, $left_label) = $self->_run_export_pipeline; 2675: 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: my $warnings = $self->stash('schema_warnings') // []; 2681: if (@$warnings) { 2682: my $hdr = join('; ', map { s/\s+/ /gr =~ s/^\s+|\s+$//gr } @$warnings); 2683: $self->res->headers->header('X-BI-Warnings' => $hdr); 2684: } 2685: 2686: my $format = $self->param('format') // 'csv'; 2687: (my $safe_name = lc $left_label) =~ s/[^a-z0-9_]+/_/g; 2688: 2689: 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: =head2 export_write 2695: 2696: C<POST /export> -- Write the current logical view to a chosen filesystem path. 2697: 2698: =head3 API SPECIFICATION 2699: 2700: =head4 INPUT 2701: 2702: l= string (required) Left table spec. 2703: j= string (repeatable) Join steps. 2704: f= string (repeatable) Filter specs. 2705: dir= string Target directory (must exist; resolved via realpath). 2706: filename= string Output filename including extension. Extension determines 2707: format: C<.csv> -> RFC 4180 CSV; C<.sql> -> SQLite; 2708: C<.json> -> JSON array of row objects.Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_2642_2: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes🧪 Suggested Test# Boolean branch test suggestion ok( !func(INPUT), 'Verify boolean branch behaviour' );- RETURN_UNDEF_2642_2: Replace return expression with undef
LOW: Mutation survived, but impact may be minor🧪 Suggested Test# Return value assertion is( func(INPUT), EXPECTED, 'Verify correct return value' );Mutants (Total: 1, Killed: 1, Survived: 0)
2709:
Mutants (Total: 2, Killed: 2, Survived: 0)
2710: =head4 DOMAIN CONSTRAINTS: filename= 2711: 2712: The extension check uses C</\.csv\z/i> (CSV), C</\.sql\z/i> (SQLite), or 2713: C</\.json\z/i> (JSON): the C</i> flag makes matching case-insensitive, so 2714: C<.CSV>, C<.SQL>, and C<.JSON> are accepted alongside lowercase forms. 2715: Everything else returns 415. 2716: 2717: Path separator characters (C</> and C<\>) in C<filename> are stripped 2718: first via C<m{([^/\\]+)\z}> -- only the basename is kept, preventing
Mutants (Total: 2, Killed: 2, Survived: 0)
2719: directory traversal. 2720: 2721: =over 4 2722: 2723: =item Valid partitions 2724: 2725: C<report.csv>, C<report.sql>, C<report.json>, C<REPORT.CSV>, C<report.SQL>. 2726: A single-character stem (C<a.csv>) is also valid. 2727:
Mutants (Total: 1, Killed: 1, Survived: 0)
2728: =item Invalid partitions (415) 2729: 2730: C<report.txt>, C<report> (no extension), empty string. 2731: 2732: =back 2733: 2734: =head4 OUTPUT 2735: 2736: 200 application/json { "saved": "/abs/path/to/file" } 2737: 404 application/json { "error": "..." } -- bad dir or table not found 2738: 415 application/json { "error": "..." } -- unsupported extension 2739: 500 application/json { "error": "..." } -- write failure 2740: 2741: =head3 MESSAGES 2742: 2743: error_dir_not_found -- realpath of dir failed or result is not a directory. 2744: error_ext_required -- filename extension is not .csv or .sql. 2745: error_write_failed -- DBI or filesystem write threw. 2746: 2747: =head3 FORMAL SPECIFICATION 2748: 2749: export_write == lambda self . 2750: let dir = realpath(param('dir')) in 2751: let file = dir / strip_path(param('filename')) in 2752: pre is_dir(dir) /\ ext(file) in {csv, sql} 2753: let (recs, cols, _) = _run_export_pipeline() in 2754: pre recs /= undef 2755: post spurt(file, serialise(recs, cols)) 2756: /\ render_json({ saved: file.to_string }) 2757: 2758: =head3 EXAMPLE 2759: 2760: POST /export l=table:sales dir=/home/user/exports filename=report.csv 2761: -> { "saved": "/home/user/exports/report.csv" } 2762: 2763: =cut 2764: 2765: sub export_write ($self) { ●2766 → 2770 → 2775 2766: my $dir = $self->param('dir') // ''; 2767: my $filename = $self->param('filename') // ''; 2768: 2769: my $dest_dir = eval { Mojo::File->new($dir)->realpath }; 2770: unless (defined $dest_dir && -d $dest_dir) { 2771: return $self->render( 2772: json => { error => $self->_i18n('error_dir_not_found', $dir) }, 2773: status => 404, 2774: ); ●2775 → 2780 → 2790 2775: } 2776: 2777: # Strip any path separators the browser might include. 2778: ($filename) = $filename =~ m{([^/\\]+)\z}; 2779: my $format; 2780: if ($filename && $filename =~ /\.csv\z/i) { $format = 'csv'; } 2781: elsif ($filename && $filename =~ /\.sql\z/i) { $format = 'sqlite'; } 2782: elsif ($filename && $filename =~ /\.json\z/i) { $format = 'json'; } 2783: else { 2784: return $self->render( 2785: json => { error => $self->_i18n('error_ext_required') }, 2786: status => 415, 2787: ); 2788: } 2789: 2790: my ($records, $columns, $left_label) = $self->_run_export_pipeline; 2791: return $self->render(json => { error => 'Table not found' }, status => 404) 2792: unless $records; 2793: 2794: my $dest = $dest_dir->child($filename); 2795: eval { 2796: if ($format eq 'csv') { 2797: $dest->spurt(_serialize_csv($records, $columns)); 2798: } 2799: elsif ($format eq 'json') { 2800: $dest->spurt(encode_json($records)); 2801: } 2802: else { 2803: $dest->spurt($self->_write_sqlite_db($records, $columns)); 2804: } 2805: }; 2806: return $self->render( 2807: json => { error => $self->_i18n('error_write_failed', $@) }, 2808: status => 500, 2809: ) if $@; 2810: 2811: $self->render(json => { saved => $dest->to_string }); 2812: } 2813: 2814: =head2 dirs_api
Mutants (Total: 1, Killed: 1, Survived: 0)
2815:
Mutants (Total: 2, Killed: 2, Survived: 0)
2816: C<GET /api/dirs> -- Return a JSON directory listing for the export panel. 2817: 2818: =head3 API SPECIFICATION 2819: 2820: =head4 INPUT 2821: 2822: ?path= string Directory to list (default: $HOME). Returns 404 when not 2823: a directory. Hidden entries (names starting with ".") are 2824: excluded. 2825: 2826: =head4 OUTPUT
Mutants (Total: 4, Killed: 4, Survived: 0)
2827:
Mutants (Total: 2, Killed: 2, Survived: 0)
2828: 200 application/json 2829: { 2830: "path": "/abs/path", 2831: "parent": "/abs/parent" or null (at filesystem root), 2832: "dirs": [ { "name": "alpha", "path": "/abs/path/alpha" }, ... ] 2833: } 2834: 2835: 404 application/json { "error": "Not a directory" } 2836:
Mutants (Total: 1, Killed: 1, Survived: 0)
2837: =head3 MESSAGES
Mutants (Total: 2, Killed: 2, Survived: 0)
2838: 2839: None beyond the 404 response. 2840: 2841: =head3 FORMAL SPECIFICATION 2842: 2843: dirs_api == lambda self . 2844: let dir = realpath(param('path') // HOME) in 2845: pre is_dir(dir) 2846: post render_json({ path: dir, parent: parent(dir), dirs: subdirs(dir) }) 2847: 2848: =head3 EXAMPLE 2849: 2850: GET /api/dirs?path=/home/user -> {"path":"/home/user","parent":"/home","dirs":[...]} 2851: 2852: =cut 2853: 2854: sub dirs_api ($self) { 2855: my $raw = $self->param('path') // $ENV{HOME} // '/'; 2856: my $dir = eval { Mojo::File->new($raw)->realpath }; 2857: return $self->render(json => { error => 'Not a directory' }, status => 404) 2858: unless defined $dir && -d $dir; 2859:
Mutants (Total: 1, Killed: 1, Survived: 0)
2860: my $listing = $self->_list_dir($dir, 0); 2861: my $parent = $dir->dirname;
Mutants (Total: 2, Killed: 2, Survived: 0)
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: }); 2868: } 2869: 2870: =head2 stat_api 2871: 2872: C<GET /api/stat> -- Return filesystem metadata for a file path. 2873: 2874: Used by the home page tooltip to show modification time and size for recently 2875: opened files without a page reload. 2876:
Mutants (Total: 2, Killed: 2, Survived: 0)
2877: =head3 API SPECIFICATION 2878: 2879: =head4 INPUT 2880: 2881: ?path= string Absolute path to query. Returns HTTP 400 when absent. 2882: 2883: =head4 OUTPUT 2884: 2885: 200 application/json (file exists)
Mutants (Total: 1, Killed: 1, Survived: 0)
2886: { "exists": true, "path": "/resolved/path", "mtime": 1700000000, "size": 4096 } 2887: 2888: 200 application/json (file does not exist) 2889: { "exists": false, "path": "/original/path" } 2890: 2891: 400 application/json { "error": "\"path\" parameter is required" } 2892: 2893: C<mtime> is Unix epoch seconds. C<size> is bytes. A missing/unresolvable 2894: path returns HTTP 200 with C<exists: false> (not 404) so the UI can 2895: distinguish "file was deleted" from a request error. 2896: 2897: =head3 MESSAGES 2898: 2899: error_path_required -- the "path" query parameter was not supplied. 2900: 2901: =head3 FORMAL SPECIFICATION 2902: 2903: stat_api == lambda self . 2904: let path = param('path') in 2905: pre path /= undef 2906: let file = realpath(path) in 2907: post if is_file(file) then 2908: render_json({ exists: true, mtime: mtime(file), size: size(file) }) 2909: else render_json({ exists: false }) 2910: 2911: =head3 EXAMPLE 2912: 2913: GET /api/stat?path=/data/sales.csv 2914: -> { "exists": true, "path": "/data/sales.csv", "mtime": 1700000000, "size": 1234 } 2915: 2916: GET /api/stat?path=/deleted.csv 2917: -> { "exists": false, "path": "/deleted.csv" } 2918: 2919: =cut 2920: 2921: sub stat_api ($self) { ●2922 → 2923 → 2930 2922: my $path = $self->param('path'); 2923: unless (defined $path && length $path) { 2924: return $self->render(
Mutants (Total: 2, Killed: 2, Survived: 0)
2925: json => { error => $self->_i18n('error_path_required') }, 2926: status => 400, 2927: ); 2928: }
Mutants (Total: 2, Killed: 2, Survived: 0)
2929: ●2930 → 2942 → 2958 2930: 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.
Mutants (Total: 3, Killed: 3, Survived: 0)
2933: return $self->render(json => { exists => \0, path => $path }) 2934: unless defined $file && -f $file && $file->basename =~ $EXT_RE; 2935: 2936: 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).
Mutants (Total: 2, Killed: 2, Survived: 0)
2941: my $table_count; 2942: if ($file->basename =~ /\.(?:sql|sqlite|sqlite3|db)\z/i) {
Mutants (Total: 2, Killed: 2, Survived: 0)
2943: eval { 2944: require DBI; 2945: my $dbh = DBI->connect( 2946: 'dbi:SQLite:dbname=' . $file->to_string, 2947: '', '', 2948: { RaiseError => 1, PrintError => 0, AutoCommit => 1 }, 2949: ); 2950: my $tbls = $dbh->selectcol_arrayref( 2951: q{SELECT name FROM sqlite_master WHERE type='table' AND name NOT LIKE 'sqlite_%'} 2952: ); 2953: $table_count = scalar @{ $tbls // [] }; 2954: $dbh->disconnect; 2955: }; 2956: } 2957:
Mutants (Total: 2, Killed: 2, Survived: 0)
2958: $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: =head2 upload_file 2968: 2969: C<POST /upload> -- Accept a drag-and-dropped data file and return a redirect URL. 2970:
Mutants (Total: 1, Killed: 1, Survived: 0)
2971: The file is saved under its original filename in a managed subdirectory of 2972: C<< <app_home>/.uploads/ >>. The subdirectory name is randomised so that 2973: concurrent uploads of files with the same name do not collide. 2974: 2975: =head3 API SPECIFICATION 2976: 2977: =head4 INPUT 2978: 2979: Multipart form upload, field name: C<file>. 2980: 2981: file upload Supported extensions: csv, db, sql, xml, tsv, psv. 2982:
Mutants (Total: 1, Killed: 1, Survived: 0)
2983: =head4 OUTPUT 2984: 2985: 200 application/json { "url": "/open?path=/abs/path/file.csv", "path": "/abs/path/file.csv" } 2986: 400 application/json { "error": "No file received" } 2987: 413 application/json { "error": "File too large to upload (limit: 50 MB)" } 2988: 415 application/json { "error": "Unsupported file type. Accepted: ..." } 2989: 500 application/json { "error": "Could not save uploaded file" }
Mutants (Total: 1, Killed: 1, Survived: 0)
2990: 2991: =head3 MESSAGES 2992: 2993: error_upload_none -- no file was received in the multipart upload. 2994: error_upload_ext -- the file's extension is not in the supported list. 2995: error_upload_too_large -- the upload body exceeded MAX_UPLOAD_MIB (50 MiB). 2996: error_upload_save -- move_to failed or the destination file was not 2997: created (I/O error, full disk, permission error). 2998: 2999: =head3 IMPLEMENTATION NOTES 3000: 3001: The C<move_to> call is wrapped with the C<eval { ...; 1 }> idiom (not 3002: C<eval {}> + C<if ($@)>). Mojolicious dispatch and DESTROY-phase evals can 3003: leave C<$@> set before the action runs; checking C<if ($@)> after a new eval 3004: may fire falsely on that stale value. C<eval { move_to(); 1 }> returns 1 on 3005: success and C<undef> on exception, so the result is independent of any prior 3006: C<$@> value. 3007: 3008: =head3 FORMAL SPECIFICATION 3009: 3010: upload_file == lambda self . 3011: let upload = req.upload('file') in 3012: pre upload /= undef /\ basename(upload.filename) =~ EXT_RE 3013: /\ NOT req->is_limit_exceeded 3014: /\ upload.size <= MAX_UPLOAD_BYTES 3015: let dest = home/.uploads/<random>/<filename> in 3016: let ok = eval { upload.move_to(dest); 1 } in 3017: pre ok /\ -f dest 3018: post render_json({ url: '/open?path=' ++ url_escape(dest), path: dest }) 3019: 3020: =head3 EXAMPLE 3021: 3022: POST /upload (multipart: file=@sales.csv) 3023: -> { "url": "/open?path=%2F...%2Fsales.csv", "path": "/.../.uploads/abc123/sales.csv" } 3024: 3025: =cut 3026: 3027: sub upload_file ($self) { ●3028 → 3029 → 3041 3028: my $upload = $self->req->upload('file'); 3029: unless ($upload && $upload->filename) { 3030: return $self->render( 3031: json => { error => $self->_i18n('error_upload_none') }, 3032: status => 400,
Mutants (Total: 2, Killed: 2, Survived: 0)
3033: ); 3034: } 3035: 3036: # Enforce upload size limit. max_request_size in startup() sets the
Mutants (Total: 2, Killed: 2, Survived: 0)
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.
Mutants (Total: 3, Killed: 3, Survived: 0)
●3041 → 3041 → 3046 3041: if ($self->req->is_limit_exceeded || $upload->size > $MAX_UPLOAD_BYTES) { 3042: return $self->render( 3043: json => { error => $self->_i18n('error_upload_too_large', $MAX_UPLOAD_MIB) }, 3044: status => 413, 3045: ); ●3046 → 3051 → 3062 3046: } 3047: 3048: # /s so .* matches \n; a percent-decoded newline inside a browser filename
Mutants (Total: 2, Killed: 2, Survived: 0)
3049: # must not silently truncate the directory-strip, leaving "dir\ncomponent" in. 3050: (my $filename = $upload->filename) =~ s{.*[/\\]}{}s; 3051: unless ($filename && $filename =~ $EXT_RE) { 3052: return $self->render( 3053: json => { error => $self->_i18n('error_upload_ext') },
Mutants (Total: 2, Killed: 2, Survived: 0)
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".
Mutants (Total: 1, Killed: 1, Survived: 0)
3061: # The random subdirectory prevents collisions from concurrent same-name uploads. ●3062 → 3074 → 3082 3062: my $uploads_base = $self->app->home->child('.uploads'); 3063: $uploads_base->make_path unless -d $uploads_base; 3064: my $sub_dir = tempdir(DIR => $uploads_base->to_string, CLEANUP => 0);
Mutants (Total: 1, Killed: 1, Survived: 0)
3065: 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: my $ok = eval { $upload->move_to($dest); 1 }; 3074: if (!$ok || !-f $dest) { 3075: remove_tree($sub_dir); 3076: return $self->render( 3077: json => { error => $self->_i18n('error_upload_save') }, 3078: status => 500, 3079: ); 3080: } 3081: 3082: $self->render(json => {
Mutants (Total: 2, Killed: 2, Survived: 0)
3083: url => '/open?path=' . url_escape($dest), 3084: path => $dest, 3085: }); 3086: } 3087: 3088: sub clear_uploads ($self) { 3089: my $uploads_dir = $self->app->home->child('.uploads'); 3090: 3091: return $self->render(json => { freed => 0, count => 0 }) 3092: unless -d $uploads_dir; 3093: 3094: 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: my ($entry) = @_; 3100: if (-d $entry) { 3101: $entry->list->each(sub { 3102: my ($file) = @_; 3103: return unless -f $file; 3104: $freed += (-s $file) // 0; 3105: $count++; 3106: }); 3107: $entry->remove_tree; 3108: } elsif (-f $entry) { 3109: $freed += (-s $entry) // 0; 3110: $count++; 3111: unlink $entry->to_string; 3112: } 3113: }); 3114: 3115: $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: sub graph_view ($self) { ●3133 → 3148 → 3151 3133: my $x_col = $self->param('x') // ''; 3134: my $y_col = $self->param('y') // ''; 3135: my $series_col = $self->param('series') // ''; 3136: my $back = _safe_back_url($self->param('back')) // '/'; 3137: my $back2 = _safe_back_url($self->param('back2')); 3138: my $back2_lbl = $self->param('back2_label') // ''; 3139: 3140: return $self->render(text => 'Missing x or y column parameter', status => 400) 3141: unless length($x_col) && length($y_col); 3142: 3143: my ($src, $records, $columns) = $self->_run_pipeline_source; 3144: return $self->render(text => 'Could not open data source', status => 404) 3145: unless defined $records; 3146: 3147: eval { ($records, $columns) = $self->_apply_calc_fields($records, $columns) }; 3148: 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 → 3151 → 3155 3151: for my $s (@{ $self->every_param('f') }) { 3152: $records = _apply_filter_spec($records, $s); 3153: } 3154: ●3155 → 3160 → 3166 3155: my %col_set = map { $_ => 1 } @{$columns}; 3156: return $self->render(text => "Column not found: $x_col", status => 400) 3157: unless $col_set{$x_col}; 3158: return $self->render(text => "Column not found: $y_col", status => 400) 3159: unless $col_set{$y_col}; 3160: if (length $series_col) { 3161: return $self->render(text => "Column not found: $series_col", status => 400) 3162: unless $col_set{$series_col}; 3163: } 3164: 3165: # --- Multi-series path: ?series=<col> groups records into one line per value --- ●3166 → 3166 → 3202 3166: if (length $series_col) { 3167: my %by_series; 3168: my @series_order; 3169: for my $row (@{$records}) { 3170: my $x = $row->{$x_col} // ''; 3171: my $y = $row->{$y_col} // ''; 3172: my $grp = $row->{$series_col} // ''; 3173: next unless length($x) && length($y) && length($grp); 3174: my $yn = _numeric_cell($y); 3175: next unless defined $yn; 3176: unless (exists $by_series{$grp}) { 3177: push @series_order, $grp; 3178: $by_series{$grp} = []; 3179: } 3180: push @{$by_series{$grp}}, { label => _decode_cell($x), value => $yn }; 3181: } 3182: 3183: 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: my @series_data = map { { name => $_, data => $by_series{$_} } } @series_order; 3189:
Mutants (Total: 2, Killed: 2, Survived: 0)
3190: require HTML::D3; 3191: my $title = "$y_col vs $x_col by $series_col"; 3192: my $html = HTML::D3->new(title => $title, width => 1100, height => 580) 3193: ->render_multi_series_line_chart_with_interactive_legends(\@series_data);
Mutants (Total: 2, Killed: 2, Survived: 0)
3194: 3195: utf8::decode($html) unless utf8::is_utf8($html); 3196: return $self->render(data => encode('UTF-8', $html), format => 'html'); 3197: }
Mutants (Total: 3, Killed: 3, Survived: 0)
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 → 3203 → 3213 3202: my @pairs; 3203: for my $row (@{$records}) { 3204: my $x = $row->{$x_col} // ''; 3205: my $y = $row->{$y_col} // '';
Mutants (Total: 2, Killed: 2, Survived: 0)
3206: next unless length($x) && length($y); 3207: my $yn = _numeric_cell($y);
Mutants (Total: 2, Killed: 2, Survived: 0)
3208: next unless defined $yn; 3209: my %extra = map { $_ => _decode_cell($row->{$_}) } grep { $_ ne $x_col && $_ ne $y_col } @{$columns};
Mutants (Total: 2, Killed: 2, Survived: 0)
3210: push @pairs, [_decode_cell($x), $yn, \%extra]; 3211: } 3212: ●3213 → 3226 → 3245 3213: 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: my @y_vals = map { $_->[1] } @pairs; 3219: 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: my @f_specs = grep { /\S/ } @{ $self->every_param('f') // [] }; 3225: my $has_filter = !!@f_specs; 3226: if (!$ENV{BI_FORCE_PERL_AGG} && $src && !$has_filter 3227: && _measure_pushable($src, 'avg', $y_col, $records)) { 3228: my $ref = eval { 3229: $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: if (!$@ && $ref && @$ref) { 3239: $min_y = $ref->[0]{lo}; 3240: $max_y = $ref->[0]{hi}; 3241: $avg_y = $ref->[0]{mean}; 3242: } 3243: } 3244: # Perl fallback: compute from the already-stripped @y_vals. ●3245 → 3245 → 3251 3245: unless (defined $min_y) { 3246: $min_y = min(@y_vals); 3247: $max_y = max(@y_vals);
Mutants (Total: 2, Killed: 2, Survived: 0)
3248: $avg_y = sum(@y_vals) / scalar(@y_vals); 3249: } 3250: 3251: my ($source_url, $source_accessed) = $self->_url_attribution; 3252: 3253: require HTML::D3; 3254: my $title = "$y_col vs $x_col"; 3255: my $snippet = HTML::D3->new(title => $title, width => 1100, height => 580, responsive => 1) 3256: ->render_zoomable_line_chart_snippet(\@pairs, { animated => 1 }); 3257: 3258: my $graph_html = $snippet->{html}; 3259: utf8::decode($graph_html) unless utf8::is_utf8($graph_html); 3260: 3261: my ($platform, $language) = $self->_resolve_template; 3262: $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: sub pie_view ($self) { ●3281 → 3296 → 3299 3281: my $cat_col = $self->param('cat') // ''; 3282: my $val_col = $self->param('val') // ''; 3283: my $donut = $self->param('donut') ? 1 : 0; 3284: my $back = _safe_back_url($self->param('back')) // '/'; 3285: my $back2 = _safe_back_url($self->param('back2')); 3286: my $back2_lbl = $self->param('back2_label') // ''; 3287: 3288: return $self->render(text => 'Missing cat or val column parameter', status => 400) 3289: unless length($cat_col) && length($val_col); 3290: 3291: my ($src, $records, $columns) = $self->_run_pipeline_source; 3292: return $self->render(text => 'Could not open data source', status => 404) 3293: unless defined $records; 3294: 3295: eval { ($records, $columns) = $self->_apply_calc_fields($records, $columns) }; 3296: if ($@) { (my $e = $@) =~ s/ at \S+ line \d+\.?\n?$//; return $self->render(text => $e, status => 400) } 3297: 3298: # Apply f= filters. ●3299 → 3299 → 3303 3299: for my $s (@{ $self->every_param('f') }) { 3300: $records = _apply_filter_spec($records, $s); 3301: } 3302: ●3303 → 3316 → 3328 3303: my %col_set = map { $_ => 1 } @{$columns}; 3304: return $self->render(text => "Column not found: $cat_col", status => 400) 3305: unless $col_set{$cat_col}; 3306: 3307: # '__count__' is the sentinel value sent when the user picks "Count (rows)". 3308: my $count_mode = ($val_col eq '__count__'); 3309: return $self->render(text => "Column not found: $val_col", status => 400) 3310: 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: my $currency_symbol = ''; 3316: if (!$count_mode) { 3317: for my $row (@$records) { 3318: my $v = $row->{$val_col} // ''; 3319: next unless length($v); 3320: if ($v =~ /\A\s*\(?\s*([^\d\s.,\-\(])/) { 3321: $currency_symbol = $1; 3322: last; 3323: } 3324: } 3325: } 3326: 3327: # Aggregate via _grouped_totals (push path or Perl fold). ●3328 → 3340 → 3359 3328: 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: my $topn_n = int($self->param('topn') // 0); 3340: if ($topn_n > 0 && @$agg_rows > $topn_n) { 3341: my @sorted = sort { ($b->{value} // 0) <=> ($a->{value} // 0) } @$agg_rows; 3342: my @top_agg = @sorted[0 .. $topn_n - 1]; 3343: my %top_cats = map { ($_->{$cat_col} // '') => 1 } @top_agg; 3344: my $other_rec = [ 3345: grep { !$top_cats{$_->{$cat_col} // ''} } @$records 3346: ]; 3347: if (@$other_rec) { 3348: my $other = $self->_grouped_totals( 3349: { source => undef, records => $other_rec }, 3350: { by => [], fn => ($count_mode ? 'count' : 'sum'),
Mutants (Total: 2, Killed: 2, Survived: 0)
3351: val => ($count_mode ? undef : $val_col), as => 'value' }, 3352: ); 3353: push @top_agg, { $cat_col => 'Other', value => $other->[0]{value} } 3354: if @$other && defined $other->[0]{value};
Mutants (Total: 2, Killed: 2, Survived: 0)
3355: } 3356: $agg_rows = \@top_agg; 3357: } 3358:
Mutants (Total: 3, Killed: 3, Survived: 0)
3359: 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: my @slices = map { [_decode_cell($_->{$cat_col}), $_->{value}] } @$agg_rows; 3365: 3366: my ($source_url, $source_accessed) = $self->_url_attribution;
Mutants (Total: 2, Killed: 2, Survived: 0)
3367: 3368: require HTML::D3; 3369: my $scheme = $self->param('scheme') // 'tableau10'; 3370: my $title = $count_mode ? "Count by $cat_col" : "$val_col by $cat_col"; 3371: my $snippet = HTML::D3->new(title => $title, width => 600, height => 500, responsive => 1)
Mutants (Total: 2, Killed: 2, Survived: 0)
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: my $pie_html = $snippet->{html}; 3382: utf8::decode($pie_html) unless utf8::is_utf8($pie_html); 3383: 3384: my ($platform, $language) = $self->_resolve_template; 3385: $self->render(
Mutants (Total: 2, Killed: 2, Survived: 0)
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: =head2 heatmap_view 3405: 3406: C<GET /heatmap> -- Render a D3.js grid heatmap for two categorical axes. 3407: 3408: Accepts the same C<l=>, C<j=>, C<f=> pipeline params as C</join>, plus: 3409:
Mutants (Total: 3, Killed: 3, Survived: 0)
3410: x=<col> X-axis (horizontal) categorical column (required) 3411: y=<col> Y-axis (vertical) categorical column (required) 3412: val=<col> Cell value column (optional; when absent, cells show row count) 3413: scheme=<name> D3 sequential colour scheme name (default: YlOrRd) 3414: show_val=1 Overlay the numeric value inside each cell 3415: back=<url> URL for the "Back to table" breadcrumb link 3416: 3417: =head3 API SPECIFICATION 3418: 3419: =head4 INPUT 3420: 3421: l spec Required. Left table spec (table:name or path:/abs/path). 3422: x string Required. Name of the X-axis categorical column. 3423: y string Required. Name of the Y-axis categorical column. 3424: val string Optional. Name of the value column; omit for count mode. 3425: scheme string Optional. D3 sequential colour scheme name. 3426: show_val flag Optional. Set to 1 to render values inside cells. 3427: back url Optional. Safe back-link URL (sanitised by _safe_back_url). 3428: 3429: =head4 OUTPUT 3430: 3431: 200 text/html Rendered heatmap page. 3432: 200 text/plain "No plottable data: ..." when grid is empty. 3433: 400 text/plain Missing x= or y= parameter. 3434: 400 text/plain Column not found: <col>. 3435: 404 text/plain "Could not open data source" when l= is absent/invalid. 3436: 3437: =head3 MESSAGES 3438: 3439: error_heatmap_no_data -- no (x,y) pair has a non-empty value. 3440: 3441: =head3 FORMAL SPECIFICATION 3442: 3443: heatmap_view == lambda self . 3444: pre length(x_col) > 0 /\ length(y_col) > 0 3445: /\ x_col in columns /\ y_col in columns 3446: let triples = { (row[x_col], row[y_col], row[val_col]) | row in records, 3447: all three fields non-empty } in 3448: post render(heatmap, triples) 3449: 3450: =head3 EXAMPLE 3451: 3452: GET /heatmap?l=table:sales&x=region&y=product&val=amount 3453: -> 200 HTML page containing D3 heatmap SVG 3454: 3455: =cut 3456: 3457: sub heatmap_view ($self) { ●3458 → 3475 → 3478 3458: my $x_col = $self->param('x') // ''; 3459: my $y_col = $self->param('y') // ''; 3460: my $val_col = $self->param('val') // ''; 3461: my $scheme = $self->param('scheme') // 'YlOrRd'; 3462: my $show_v = $self->param('show_val') ? 1 : 0; 3463: my $back = _safe_back_url($self->param('back')) // '/'; 3464: my $back2 = _safe_back_url($self->param('back2')); 3465: my $back2_lbl = $self->param('back2_label') // ''; 3466: 3467: return $self->render(text => 'Missing x or y column parameter', status => 400) 3468: unless length($x_col) && length($y_col); 3469: 3470: my ($src, $records, $columns) = $self->_run_pipeline_source; 3471: return $self->render(text => 'Could not open data source', status => 404) 3472: unless defined $records; 3473: 3474: eval { ($records, $columns) = $self->_apply_calc_fields($records, $columns) }; 3475: if ($@) { (my $e = $@) =~ s/ at \S+ line \d+\.?\n?$//; return $self->render(text => $e, status => 400) } 3476: 3477: # Apply f= filters. ●3478 → 3478 → 3482 3478: for my $s (@{ $self->every_param('f') }) { 3479: $records = _apply_filter_spec($records, $s); 3480: } 3481: ●3482 → 3495 → 3504 3482: my %col_set = map { $_ => 1 } @{$columns}; 3483: return $self->render(text => "Column not found: $x_col", status => 400) 3484: unless $col_set{$x_col}; 3485: return $self->render(text => "Column not found: $y_col", status => 400) 3486: unless $col_set{$y_col}; 3487: return $self->render(text => "Column not found: $val_col", status => 400) 3488: 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: my (@x_order, @y_order, %seen_x, %seen_y); 3495: for my $row (@$records) { 3496: my $x = $row->{$x_col} // next; 3497: my $y = $row->{$y_col} // next; 3498: next unless length($x) && length($y); 3499: push @x_order, $x unless $seen_x{$x}++;
Mutants (Total: 2, Killed: 2, Survived: 0)
3500: push @y_order, $y unless $seen_y{$y}++; 3501: } 3502: 3503: # Aggregate with _grouped_totals (push or Perl fold). ●3504 → 3516 → 3520 3504: my $agg_rows = $self->_grouped_totals(
Mutants (Total: 2, Killed: 2, Survived: 0)
3505: { source => $src, records => $records },
Mutants (Total: 3, Killed: 3, Survived: 0)
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:
Mutants (Total: 2, Killed: 2, Survived: 0)
3514: # Index aggregate rows by [x][y] for O(1) lookup. 3515: my %grid; 3516: for my $row (@$agg_rows) { 3517: $grid{$row->{$x_col}}{$row->{$y_col}} = $row->{value}; 3518: }
Mutants (Total: 1, Killed: 1, Survived: 0)
3519:
Mutants (Total: 3, Killed: 3, Survived: 0)
3520: my @triples = map { 3521: my ($raw_x, $xv) = ($_, _decode_cell($_)); 3522: map { [$xv, _decode_cell($_), $grid{$raw_x}{$_} // 0] } @y_order
Mutants (Total: 1, Killed: 1, Survived: 0)
3523: } @x_order; 3524: 3525: return $self->render( 3526: text => 'No plottable data: check that x and y columns contain values.', 3527: status => 200, 3528: ) unless @triples; 3529: 3530: my ($source_url, $source_accessed) = $self->_url_attribution; 3531: 3532: require HTML::D3; 3533: my $title = length($val_col) ? "$val_col by $x_col and $y_col" 3534: : "Count by $x_col and $y_col"; 3535: 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: my $heatmap_html = $snippet->{html}; 3546: utf8::decode($heatmap_html) unless utf8::is_utf8($heatmap_html); 3547: 3548: my ($platform, $language) = $self->_resolve_template; 3549: $self->render(
Mutants (Total: 3, Killed: 3, Survived: 0)
3550: handler => 'tt', 3551: template => "$platform/$language/heatmap", 3552: format => 'html', 3553: title => $title,
Mutants (Total: 2, Killed: 2, Survived: 0)
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: =head2 bar_view
Mutants (Total: 2, Killed: 2, Survived: 0)
3565: 3566: C<GET /bar> -- Render a D3.js bar chart grouped by a categorical column. 3567: 3568: Accepts the same C<l=>, C<j=>, C<f=> pipeline params as C</join>, plus: 3569: 3570: cat=<col> Category (X-axis) column (required) 3571: val=<col> Value column to sum per category; omit or use C<__count__> 3572: to count rows instead of summing (optional) 3573: orient=h Horizontal bars (default: vertical) 3574: sort=value|label Sort bars by descending value or ascending label 3575: max=N Collapse bars beyond the top-N into an "Other" bar 3576: back=<url> URL for the "Back to table" breadcrumb link
Mutants (Total: 1, Killed: 1, Survived: 0)
3577: 3578: =head3 API SPECIFICATION 3579: 3580: =head4 INPUT 3581: 3582: l spec Required. Left table spec (table:name or path:/abs/path). 3583: cat string Required. Name of the category column. 3584: val string Optional. Name of the value column; use __count__ or 3585: omit entirely to count rows per category. 3586: orient string Optional. "h" for horizontal bars; default vertical. 3587: sort string Optional. "value" or "label"; default file order. 3588: max integer Optional. Collapse beyond top-N categories into "Other". 3589: back url Optional. Safe back-link URL (sanitised by _safe_back_url). 3590: 3591: =head4 OUTPUT 3592: 3593: 200 text/html Rendered bar chart page (SVG element id="bar_chart"). 3594: 200 text/plain "No plottable data: ..." when no categories exist. 3595: 400 text/plain Missing cat= parameter. 3596: 400 text/plain Column not found: <col>.
Mutants (Total: 3, Killed: 3, Survived: 0)
3597: 404 text/plain "Could not open data source" when l= is absent/invalid. 3598: 3599: =head3 MESSAGES 3600: 3601: error_bar_no_data -- no row has a non-empty category value. 3602: 3603: =head3 FORMAL SPECIFICATION 3604: 3605: bar_view == lambda self . 3606: pre length(cat_col) > 0 /\ cat_col in columns 3607: let bars = { (cat, sum(val)) | row in records, row[cat_col] = cat, 3608: val /= undef } in 3609: post render(bar, bars, orientation, sort, max_bars) 3610: 3611: =head3 EXAMPLE 3612: 3613: GET /bar?l=table:sales&cat=region&val=amount&sort=value 3614: -> 200 HTML page with id="bar_chart" SVG element 3615: 3616: =cut 3617: 3618: sub bar_view ($self) { ●3619 → 3636 → 3639 3619: my $cat_col = $self->param('cat') // ''; 3620: my $val_col = $self->param('val') // ''; 3621: my $orient = $self->param('orient') // 'vertical'; 3622: my $sort = $self->param('sort') // 'none'; 3623: my $max_bars = int($self->param('max') // 0); 3624: my $back = _safe_back_url($self->param('back')) // '/'; 3625: my $back2 = _safe_back_url($self->param('back2')); 3626: my $back2_lbl = $self->param('back2_label') // ''; 3627: 3628: return $self->render(text => 'Missing cat column parameter', status => 400) 3629: unless length($cat_col); 3630: 3631: my ($src, $records, $columns) = $self->_run_pipeline_source; 3632: return $self->render(text => 'Could not open data source', status => 404) 3633: unless defined $records; 3634: 3635: eval { ($records, $columns) = $self->_apply_calc_fields($records, $columns) }; 3636: if ($@) { (my $e = $@) =~ s/ at \S+ line \d+\.?\n?$//; return $self->render(text => $e, status => 400) } 3637: 3638: # Apply f= filters. ●3639 → 3639 → 3643 3639: for my $s (@{ $self->every_param('f') }) { 3640: $records = _apply_filter_spec($records, $s); 3641: } 3642: ●3643 → 3665 → 3684 3643: my %col_set = map { $_ => 1 } @{$columns}; 3644: return $self->render(text => "Column not found: $cat_col", status => 400) 3645: unless $col_set{$cat_col}; 3646: 3647: # '__count__' sentinel: count rows per category instead of summing a column. 3648: my $count_mode = ($val_col eq '__count__' || !length($val_col)); 3649: return $self->render(text => "Column not found: $val_col", status => 400) 3650: unless $count_mode || $col_set{$val_col}; 3651: 3652: # Aggregate via _grouped_totals (push path or Perl fold). 3653: 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: my $topn_n = int($self->param('topn') // 0); 3665: if ($topn_n > 0 && @$agg_rows > $topn_n) { 3666: my @sorted = sort { ($b->{value} // 0) <=> ($a->{value} // 0) } @$agg_rows; 3667: my @top_agg = @sorted[0 .. $topn_n - 1]; 3668: my %top_cats = map { ($_->{$cat_col} // '') => 1 } @top_agg; 3669: my $other_rec = [ 3670: grep { !$top_cats{$_->{$cat_col} // ''} } @$records 3671: ];
Mutants (Total: 2, Killed: 2, Survived: 0)
3672: if (@$other_rec) { 3673: 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' },
Mutants (Total: 1, Killed: 1, Survived: 0)
3677: ); 3678: push @top_agg, { $cat_col => 'Other', value => $other->[0]{value} } 3679: if @$other && defined $other->[0]{value}; 3680: } 3681: $agg_rows = \@top_agg; 3682: }
Mutants (Total: 1, Killed: 1, Survived: 0)
3683: 3684: return $self->render( 3685: text => 'No plottable data: no rows have valid data in the selected columns.', 3686: status => 200, 3687: ) unless @$agg_rows;
Mutants (Total: 2, Killed: 2, Survived: 0)
3688: 3689: my @bars = map { [_decode_cell($_->{$cat_col}), $_->{value}] } @$agg_rows; 3690: 3691: my $orientation = ($orient eq 'h') ? 'horizontal' : 'vertical'; 3692: my $sort_bars = ($sort eq 'value' || $sort eq 'label') ? $sort : 'none'; 3693: 3694: my ($source_url, $source_accessed) = $self->_url_attribution;
Mutants (Total: 2, Killed: 2, Survived: 0)
3695: 3696: require HTML::D3; 3697: my $title = $count_mode ? "Count by $cat_col" 3698: : "$val_col by $cat_col"; 3699: 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',
Mutants (Total: 1, Killed: 1, Survived: 0)
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: my $bar_html = $snippet->{html}; 3712: utf8::decode($bar_html) unless utf8::is_utf8($bar_html); 3713: 3714: my ($platform, $language) = $self->_resolve_template; 3715: $self->render( 3716: handler => 'tt', 3717: template => "$platform/$language/bar", 3718: format => 'html', 3719: title => $title,
Mutants (Total: 1, Killed: 1, Survived: 0)
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:
Mutants (Total: 3, Killed: 3, Survived: 0)
3731: =head2 folder_view 3732: 3733: C<GET /folder> -- Browse a data table grouped by the letter-prefix hierarchy 3734: of an order-number column (e.g. A10, CT4, B3). 3735: 3736: The top level displays one folder icon per initial letter group (A, B, C ...). 3737: Clicking a folder with sub-prefixes (e.g. C contains CA and CB items) shows 3738: the sub-folders; clicking a leaf prefix shows the actual data rows sorted 3739: numerically by the embedded digit sequence.
Mutants (Total: 3, Killed: 3, Survived: 0)
3740: 3741: Accepts the same C<l=>, C<j=>, C<f=> pipeline params as C</join>, plus: 3742: 3743: col=<col> Column whose values contain order codes (optional; auto- 3744: detected when absent by scanning the first 10 rows for 3745: values matching C<[A-Z]{1,4}\d+[A-Z]?>) 3746: prefix=<str> Current drill-down prefix, e.g. "CA" (optional; top-level 3747: when absent) 3748: back=<url> URL for the "Back to table" breadcrumb link (optional; 3749: derived from C<l=> when absent)
Mutants (Total: 2, Killed: 2, Survived: 0)
3750: 3751: =head3 API SPECIFICATION
Mutants (Total: 2, Killed: 2, Survived: 0)
3752: 3753: =head4 INPUT 3754:
Mutants (Total: 1, Killed: 1, Survived: 0)
3755: l spec Required. Left table spec (table:name or path:/abs/path). 3756: col string Optional. Order-code column name. 3757: prefix string Optional. Current letter prefix; max length MAX_PREFIX_LEN. 3758: back url Optional. Safe back-link URL (sanitised by _safe_back_url). 3759: 3760: =head4 OUTPUT 3761: 3762: 200 text/html Rendered folder page with folder grid and/or item table. 3763: 400 text/plain "Missing l= parameter" when l= is absent. 3764: 400 text/plain "Prefix too long" when prefix exceeds MAX_PREFIX_LEN (20). 3765: 404 text/plain "Could not open data source" when the data source is unavailable. 3766:
Mutants (Total: 1, Killed: 1, Survived: 0)
3767: =head3 MESSAGES 3768: 3769: None -- all failure paths render plain text with an HTTP status code. 3770: 3771: =head3 FORMAL SPECIFICATION 3772: 3773: folder_view == lambda self . 3774: pre length(left_spec) > 0 /\ length(prefix) <= MAX_PREFIX_LEN 3775: let records = pipeline(left_spec, joins, filters) 3776: prefix_map = { p -> [row] | row in records, row[col] =~ /[A-Z]+/ -> p } in 3777: IF prefix = "" THEN 3778: post render(folder, folders = first_letters(prefix_map)) 3779: ELSE
3780: post render(folder, folders = sub_prefixes(prefix, prefix_map), 3781: items = sort_numeric(prefix_map[prefix])) 3782: 3783: =head3 EXAMPLE 3784: 3785: GET /folder?l=table:orders&col=order_no 3786: -> 200 HTML folder grid showing A (12 items), B (7 items), C (4 items) 3787: 3788: GET /folder?l=table:orders&col=order_no&prefix=A 3789: -> 200 HTML folder grid for sub-prefixes and items directly under "A" 3790: 3791: =cut 3792: 3793: sub folder_view ($self) { ●3794 → 3817 → 3832 3794: my $key_col = $self->param('col') // ''; 3795: my $prefix = $self->param('prefix') // ''; 3796: my $left_spec = $self->param('l') // ''; 3797: 3798: 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: 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: my $back = _safe_back_url($self->param('back')) 3809: || $self->_spec_to_url($left_spec); 3810: 3811: my ($records, $columns) = $self->_run_export_pipeline; 3812: return $self->render(text => 'Could not open data source', status => 404) 3813: unless $records; 3814:Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_3779_5: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes🧪 Suggested Test# Boolean branch test suggestion ok( !func(INPUT), 'Verify boolean branch behaviour' );- RETURN_UNDEF_3779_5: Replace return expression with undef
LOW: Mutation survived, but impact may be minor🧪 Suggested Test# Return value assertion is( func(INPUT), EXPECTED, 'Verify correct return value' );Mutants (Total: 2, Killed: 2, Survived: 0)
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: if (!length($key_col)) { 3818: my $sample_end = $#{$records} < 9 ? $#{$records} : 9; 3819: OUTER: for my $col (@{$columns}) { 3820: for my $row (@{$records}[0 .. $sample_end]) { 3821: if (($row->{$col} // '') =~ /\A[A-Z]{1,4}\d+[A-Z]?\z/) { 3822: $key_col = $col;
Mutants (Total: 2, Killed: 2, Survived: 0)
3823: last OUTER; 3824: } 3825: } 3826: }
Mutants (Total: 2, Killed: 2, Survived: 0)
3827: $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 → 3833 → 3843 3832: my %prefix_to_rows; 3833: for my $row (@{$records}) { 3834: my $val = $row->{$key_col} // ''; 3835: my ($p) = $val =~ /\A([A-Z]+)/; 3836: next unless defined $p; 3837: 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 → 3875 → 3922 3843: my $sub_prefixes = sub { 3844: my ($par) = @_; 3845: my $len = length($par); 3846: my %seen; 3847: for my $p (keys %prefix_to_rows) { 3848: next if length($p) <= $len; 3849: next if substr($p, 0, $len) ne $par; 3850: $seen{ substr($p, 0, $len + 1) } = 1; 3851: } 3852: return sort keys %seen;Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_3838_3: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes🧪 Suggested Test# Boolean branch test suggestion ok( !func(INPUT), 'Verify boolean branch behaviour' );- RETURN_UNDEF_3838_3: Replace return expression with undef
LOW: Mutation survived, but impact may be minor🧪 Suggested Test# Return value assertion is( func(INPUT), EXPECTED, 'Verify correct return value' );Mutants (Total: 2, Killed: 2, Survived: 0)
3853: }; 3854: 3855: # Count total items underneath a prefix (including all deeper sub-prefixes). 3856: my $deep_count = sub { 3857: my ($par) = @_; 3858: my $n = 0; 3859: for my $p (keys %prefix_to_rows) { 3860: $n += scalar @{ $prefix_to_rows{$p} }
Mutants (Total: 3, Killed: 3, Survived: 0)
3861: if substr($p, 0, length($par)) eq $par; 3862: } 3863: return $n; 3864: }; 3865: 3866: 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: my $base_url = '/folder?l=' . url_escape($left_spec);
3871: $base_url .= '&col=' . url_escape($key_col) if length($key_col); 3872: 3873: my (@folders, @items, @breadcrumb); 3874: 3875: if (!length($prefix)) { 3876: # Top level: group all prefixes by their first letter. 3877: my %first_letter; 3878: for my $p (keys %prefix_to_rows) {Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_3870_3: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes🧪 Suggested Test# Boolean branch test suggestion ok( !func(INPUT), 'Verify boolean branch behaviour' );- RETURN_UNDEF_3870_3: Replace return expression with undef
LOW: Mutation survived, but impact may be minor🧪 Suggested Test# Return value assertion is( func(INPUT), EXPECTED, 'Verify correct return value' );Mutants (Total: 2, Killed: 2, Survived: 0)
3879: $first_letter{ substr($p, 0, 1) } = 1; 3880: } 3881: for my $fl (sort keys %first_letter) { 3882: 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: for my $i (1 .. length($prefix)) { 3892: my $p = substr($prefix, 0, $i); 3893: 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: for my $sp ($sub_prefixes->($prefix)) { 3903: push @folders, { 3904: name => $sp, 3905: count => $deep_count->($sp),
Mutants (Total: 1, Killed: 1, Survived: 0)
3906: href => $base_url . '&prefix=' . url_escape($sp), 3907: }; 3908: } 3909:
Mutants (Total: 1, Killed: 1, Survived: 0)
3910: # Items whose prefix matches exactly (e.g. prefix="C" shows C1, C3, ...). 3911: @items = @{ $prefix_to_rows{$prefix} // [] }; 3912: 3913: # Sort by the numeric part of the key value so A9 < A10. 3914: @items = sort { 3915: my ($an) = ($a->{$key_col} // '') =~ /(\d+)/; 3916: my ($bn) = ($b->{$key_col} // '') =~ /(\d+)/; 3917: ($an // 0) <=> ($bn // 0) 3918: || ($a->{$key_col} // '') cmp ($b->{$key_col} // ''); 3919: } @items; 3920: } 3921: 3922: my $title = length($prefix) ? "Folder: $prefix" : 'Folder view';
Mutants (Total: 1, Killed: 1, Survived: 0)
3923: 3924: $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: =head2 tables_view 3943: 3944: C<GET /tables> -- Schema browser for multi-table databases (SQLite, etc.). 3945: Lists all internal tables with their columns; clicking a table opens it. 3946: 3947: =head3 API SPECIFICATION 3948: 3949: =head4 INPUT 3950: 3951: ?l= string Required. Table spec: "table:name" (data_dir) or 3952: "path:/abs/path" (filesystem path). The file must be a 3953: SQLite database. 3954: 3955: =head4 OUTPUT
Mutants (Total: 1, Killed: 1, Survived: 0)
3956: 3957: Renders C<tables.html.tt> with: 3958: 3959: db_label string Short name / stem of the database file 3960: tables ARRAYREF of { name, columns => [...], href } 3961: spec string The raw l= spec (for building back links) 3962: back_url string URL to navigate back one level 3963: back_label string Label for the back link 3964: 3965: =cut 3966: 3967: sub tables_view ($self) { ●3968 → 3975 → 4053 3968: my ($platform, $language) = $self->_resolve_template; 3969: my $spec = $self->param('l'); 3970: return $self->reply->not_found unless defined $spec && length $spec; 3971: 3972: my ($file_path, $db_label, $back_url, $back_label);
Mutants (Total: 1, Killed: 1, Survived: 0)
3973: my @tables; 3974: 3975: if ($spec =~ /\Atable:([A-Za-z0-9_]+)\z/) { 3976: my $table_name = lc $1; 3977: my $data_dir = $self->app->home->child( 3978: $self->app->config->{data_dir} // 'data'); 3979: for my $ext (qw(sql sqlite sqlite3 db)) { 3980: my $p = $data_dir->child("$table_name.$ext"); 3981: if (-f $p) { 3982: $file_path = $p->to_string; 3983: last; 3984: } 3985: } 3986: return $self->reply->not_found unless defined $file_path; 3987: $db_label = $table_name; 3988: $back_url = '/'; 3989: $back_label = 'Home'; 3990: } elsif ($spec =~ /\Apath:(.+)\z/) { 3991: my $path_arg = $1; 3992: my $file = eval { Mojo::File->new($path_arg)->realpath }; 3993: return $self->reply->not_found 3994: unless defined $file && -f $file && $file->basename =~ /\.(?:sql|sqlite|sqlite3|db)\z/i; 3995: $file_path = $file->to_string; 3996: ($db_label = $file->basename) =~ s/\.[^.]+\z//; 3997: $back_url = '/browse?path=' . url_escape($file->dirname->to_string); 3998: $back_label = 'Back to browser'; 3999: } elsif ($spec =~ $REDIS_URL_RE) { 4000: # Bare redis:// URL -- scan keys and present a picker.
Mutants (Total: 4, Killed: 4, Survived: 0)
4001: # Parse redis://[:password@]host[:port][/db] 4002: my ($password, $hostport, $db_idx); 4003: if ($spec =~ m{\Aredis://(?::([^@]*)@)?([^/]+)(?:/(\d+))?\z}i) { 4004: ($password, $hostport, $db_idx) = ($1, $2, $3); 4005: } 4006: $hostport //= 'localhost:6379'; 4007: $db_label = "redis://$hostport"; 4008: $back_url = '/'; 4009: $back_label = 'Home'; 4010: 4011: 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: my $pkg;
Mutants (Total: 1, Killed: 1, Survived: 0)
4016: for my $mod ('Redis::Fast', 'Redis') { 4017: (my $file = $mod) =~ s{::}{/}g; 4018: if (eval { require "$file.pm"; 1 }) { $pkg = $mod; last } 4019: } 4020: croak 'Redis or Redis::Fast must be installed to browse a Redis server' 4021: unless $pkg; 4022: 4023: my $redis = $pkg->new(
Mutants (Total: 1, Killed: 1, Survived: 0)
4024: server => $hostport, 4025: cnx_timeout => 5, 4026: read_timeout => 10, 4027: ); 4028: $redis->auth($password) if defined $password && length $password; 4029: $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: my $cursor = 0; 4033: my @all_keys; 4034: do { 4035: my ($new_cursor, $batch) = $redis->scan($cursor, 'COUNT', 100); 4036: $cursor = $new_cursor; 4037: push @all_keys, @{ $batch // [] };
Mutants (Total: 1, Killed: 1, Survived: 0)
4038: } while ($cursor ne '0' && @all_keys < 200); 4039: 4040: my $tables_url = '/tables?l=' . url_escape($spec); 4041: for my $key (sort @all_keys) { 4042: my $open_url = '/open?path=' . url_escape("redis:$key|$spec") 4043: . '&back=' . url_escape($tables_url) 4044: . '&back_label=Redis+keys'; 4045: push @tables, { name => $key, columns => [], href => $open_url }; 4046: } 4047: }; 4048: return $self->reply->not_found if $@; 4049: } else {
Mutants (Total: 2, Killed: 2, Survived: 0)
4050: return $self->reply->not_found; 4051: }
Mutants (Total: 2, Killed: 2, Survived: 0)
4052: ●4053 → 4053 → 4080 4053: if (defined $file_path) { eval {
Mutants (Total: 2, Killed: 2, Survived: 0)
4054: require DBI; 4055: my $dbh = DBI->connect(
4056: "dbi:SQLite:dbname=$file_path", q{}, q{}, 4057: { RaiseError => 1, PrintError => 0, AutoCommit => 1 }); 4058: 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: for my $tname (@{ $tnames // [] }) { 4063: my @cols; 4064: my $sth = eval { $dbh->prepare("PRAGMA table_info(\"$tname\")") }; 4065: if ($sth) { 4066: $sth->execute; 4067: while (my $row = $sth->fetchrow_hashref) { 4068: push @cols, $row->{name}; 4069: } 4070: } 4071: 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');Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_4055_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomesMutants (Total: 2, Killed: 2, Survived: 0)
4075: push @tables, { name => $tname, columns => \@cols, href => $open_url }; 4076: } 4077: $dbh->disconnect; 4078: }; return $self->reply->not_found if $@; } 4079: 4080: $self->render( 4081: 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: =head2 pivot_view 4094: 4095: C<GET /pivot> -- Crosstab / pivot table view. 4096: 4097: Accepts the same C<l=>, C<j=>, C<f=> pipeline params as C</join>, plus: 4098: 4099: rows=<col>[,<col>...] Row dimensions (required, comma-separated column names) 4100: cols=<col>[,<col>...] Column dimensions (optional) 4101: m=<col>:<fn>:<as> Measure spec, repeatable (required); col may be empty for count 4102: h=<as>:<op>:<val> Post-aggregation HAVING filter (repeatable, optional) 4103: totals=1 Include row subtotals, column subtotals, and grand total 4104: scheme=<name> Colour scheme for cell shading (optional) 4105: max_cols=<n> Collapse column headers beyond top-N into "Other" 4106: page= / per_page= Pagination over row groups 4107: format=csv|sqlite|json Export the pivot grid 4108: 4109: =cut 4110: 4111: sub pivot_view ($self) { ●4112 → 4135 → 4144 4112: my $left_spec = $self->param('l') // ''; 4113: return $self->render(text => 'Missing l= parameter', status => 400) 4114: unless length $left_spec; 4115: 4116: my $back = _safe_back_url($self->param('back')) // '/'; 4117: my $back2 = _safe_back_url($self->param('back2')); 4118: my $back2_lbl = $self->param('back2_label') // ''; 4119: 4120: my $rows_str = $self->param('rows') // ''; 4121: return $self->render(text => $self->_i18n('error_pivot_rows_required'), status => 400) 4122: unless length $rows_str; 4123: 4124: my @measure_strs = @{ $self->every_param('m') // [] }; 4125: 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: my @rows = split /,/, $rows_str, -1; 4131: my @cols = split /,/, ($self->param('cols') // ''), -1; 4132: @cols = grep { length $_ } @cols; 4133: 4134: my @measures; 4135: for my $ms (@measure_strs) { 4136: my $m = _parse_measure_param($ms); 4137: return $self->render( 4138: text => $self->_i18n('error_pivot_measure_invalid', $ms), 4139: status => 400, 4140: ) unless $m; 4141: push @measures, $m; 4142: } 4143:
Mutants (Total: 2, Killed: 2, Survived: 0)
●4144 → 4162 → 4166 4144: my $show_totals = ($self->param('totals') // '') ? 1 : 0; 4145: my $scheme = $self->param('scheme') // ''; 4146: my $max_cols_n = int($self->param('max_cols') // 0); 4147: my $format = lc($self->param('format') // ''); 4148: 4149: # Build the data pipeline. 4150: my ($src, $records, $columns) = $self->_run_pipeline_source; 4151: return $self->render(text => 'Could not open data source', status => 404)
Mutants (Total: 2, Killed: 2, Survived: 0)
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.
Mutants (Total: 3, Killed: 3, Survived: 0)
4156: { 4157: my $err; 4158: eval { ($records, $columns) = $self->_apply_calc_fields($records, $columns) }; 4159: if ($@) { (my $e = $@) =~ s/ at \S+ line \d+\.?\n?$//; return $self->render(text => $e, status => 400) } 4160: } 4161: 4162: for my $s (@{ $self->every_param('f') }) { 4163: $records = _apply_filter_spec($records, $s); 4164: } 4165: ●4166 → 4168 → 4175 4166: my %col_set = map { $_ => 1 } @{$columns}; 4167: 4168: for my $dim (@rows, @cols) { 4169: return $self->render( 4170: text => $self->_i18n('error_pivot_dim_not_found', $dim), 4171: status => 400, 4172: ) unless $col_set{$dim}; 4173: } 4174: ●4175 → 4175 → 4183 4175: for my $m (@measures) { 4176: 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: ) unless $col_set{$m->{col}}; 4181: }
Mutants (Total: 1, Killed: 1, Survived: 0)
4182: ●4183 → 4193 → 4220 4183: 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: my (%cells, %row_combos, %col_combos); 4190: my (@row_key_order, @col_key_order); 4191: my (%row_seen, %col_seen); 4192: 4193: for my $m (@measures) { 4194: 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: }); 4201: for my $row (@$agg) { 4202: my $rkey = join("\x00", map { $row->{$_} // '' } @rows); 4203: my $ckey = join("\x00", map { $row->{$_} // '' } @cols); 4204: unless ($row_seen{$rkey}++) { 4205: push @row_key_order, $rkey; 4206: $row_combos{$rkey} = { map { $_ => ($row->{$_} // '') } @rows }; 4207: } 4208: unless ($col_seen{$ckey}++) { 4209: push @col_key_order, $ckey; 4210: $col_combos{$ckey} = { map { $_ => ($row->{$_} // '') } @cols }; 4211: } 4212: $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 → 4221 → 4246 4220: my @h_specs = @{ $self->every_param('h') // [] }; 4221: if (@h_specs) { 4222: my @keep; 4223: 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: my %vrow; 4229: for my $m (@measures) { 4230: # Sum across cols for this row as representative value. 4231: my $v = 0; 4232: for my $ck (@col_key_order) { 4233: my $cv = $cells{$rkey}{$ck}{$m->{as}}; 4234: $v += $cv if defined $cv;
Mutants (Total: 2, Killed: 2, Survived: 0)
4235: } 4236: $vrow{$m->{as}} = $v;
Mutants (Total: 2, Killed: 2, Survived: 0)
4237: } 4238: my $ok = 1; 4239: for my $hs (@h_specs) { 4240: my $passed = _apply_filter_spec([\%vrow], $hs);
Mutants (Total: 2, Killed: 2, Survived: 0)
4241: $ok = 0 unless @$passed; 4242: } 4243: push @keep, $rkey if $ok; 4244: } 4245: @row_key_order = @keep; ●4246 → 4314 → 4359 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: my $topn_n = int($self->param('topn') // 0);
Mutants (Total: 2, Killed: 2, Survived: 0)
4254: my $topn_col = $self->param('topn_col') // ''; 4255: 4256: if ($topn_n > 0 && @row_key_order > $topn_n) { 4257: my %m_aliases = map { $_->{as} => 1 } @measures; 4258: if (length $topn_col && !$m_aliases{$topn_col}) { 4259: return $self->render( 4260: text => $self->_i18n('error_topn_col', $topn_col), 4261: status => 400, 4262: ); 4263: } 4264: 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: (do { my $s = 0; $s += ($cells{$b}{$_}{$sort_as} // 0) for @col_key_order; $s }) 4269: <=> 4270: (do { my $s = 0; $s += ($cells{$a}{$_}{$sort_as} // 0) for @col_key_order; $s }) 4271: } @row_key_order; 4272: 4273: my @top_rkeys = @sorted_rkeys[0 .. $topn_n - 1]; 4274: my @rest_rkeys = @sorted_rkeys[$topn_n .. $#sorted_rkeys]; 4275: 4276: if (@rest_rkeys) { 4277: my %top_rkey_set = map { $_ => 1 } @top_rkeys; 4278: my $other_rec = [ 4279: grep { 4280: my $r = $_; 4281: !$top_rkey_set{ join("\x00", map { $r->{$_} // '' } @rows) }Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_4264_2: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes🧪 Suggested Test# Boolean branch test suggestion ok( !func(INPUT), 'Verify boolean branch behaviour' );- RETURN_UNDEF_4264_2: Replace return expression with undef
LOW: Mutation survived, but impact may be minor🧪 Suggested Test# Return value assertion is( func(INPUT), EXPECTED, 'Verify correct return value' );Mutants (Total: 2, Killed: 2, Survived: 0)
4282: } @$records 4283: ];
Mutants (Total: 2, Killed: 2, Survived: 0)
4284: if (@$other_rec) { 4285: my $ork = '__topn_other__';
Mutants (Total: 2, Killed: 2, Survived: 0)
4286: $row_combos{$ork} = { map { $_ => 'Other' } @rows }; 4287: for my $m (@measures) { 4288: 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: ); 4293: for my $row (@$oa) { 4294: my $ck = join("\x00", map { $row->{$_} // '' } @cols); 4295: $cells{$ork}{$ck}{$m->{as}} = $row->{$m->{as}}; 4296: } 4297: } 4298: @row_key_order = (@top_rkeys, $ork); 4299: } else {
Mutants (Total: 2, Killed: 2, Survived: 0)
4300: @row_key_order = @top_rkeys; 4301: } 4302: } else { 4303: @row_key_order = @top_rkeys;
Mutants (Total: 1, Killed: 1, Survived: 0)
4304: } 4305: } 4306: } 4307: 4308: # ----------------------------------------------------------------------- 4309: # Subtotals and grand total (three additional _grouped_totals calls 4310: # per measure when totals=1). 4311: # ----------------------------------------------------------------------- 4312: my (%row_subtotals, %col_subtotals, %grand_total); 4313: 4314: if ($show_totals) { 4315: for my $m (@measures) { 4316: my $cv = (defined $m->{col} && length $m->{col}) ? $m->{col} : undef;
Mutants (Total: 2, Killed: 2, Survived: 0)
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: }); 4325: for my $r (@$rsub) { 4326: my $rk = join("\x00", map { $r->{$_} // '' } @rows); 4327: $row_subtotals{$rk}{$m->{as}} = $r->{$m->{as}}; 4328: } 4329: 4330: # Column subtotals: group by @cols only. 4331: if (@cols) { 4332: my $csub = $self->_grouped_totals($pipeline, { 4333: by => [@cols], 4334: fn => $m->{fn},
Mutants (Total: 2, Killed: 2, Survived: 0)
4335: val => $cv,
Mutants (Total: 2, Killed: 2, Survived: 0)
4336: as => $m->{as}, 4337: }); 4338: for my $c (@$csub) {
Mutants (Total: 2, Killed: 2, Survived: 0)
4339: my $ck = join("\x00", map { $c->{$_} // '' } @cols); 4340: $col_subtotals{$ck}{$m->{as}} = $c->{$m->{as}}; 4341: }
Mutants (Total: 3, Killed: 3, Survived: 0)
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,
Mutants (Total: 2, Killed: 2, Survived: 0)
4349: as => $m->{as},
Mutants (Total: 2, Killed: 2, Survived: 0)
4350: }); 4351: $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 → 4359 → 4396 4359: if ($max_cols_n > 0 && @col_key_order > $max_cols_n) { 4360: my $first_as = $measures[0]{as}; 4361: my @sorted_ckeys = sort {
Mutants (Total: 2, Killed: 2, Survived: 0)
4362: ( $show_totals 4363: ? ($col_subtotals{$b}{$first_as} // 0) 4364: : (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: : (do { my $s = 0; $s += ($cells{$_}{$a}{$first_as} // 0) for @row_key_order; $s }) 4370: ) 4371: } @col_key_order; 4372: my @top_ckeys = @sorted_ckeys[0 .. $max_cols_n - 1]; 4373: my @rest_ckeys = @sorted_ckeys[$max_cols_n .. $#sorted_ckeys]; 4374: if (@rest_ckeys) { 4375: my $other_key = '__other__'; 4376: $col_combos{$other_key} = { map { $_ => 'Other' } @cols }; 4377: for my $rk (@row_key_order) { 4378: for my $m (@measures) { 4379: my ($v, $have) = (0, 0); 4380: for my $ck (@rest_ckeys) { 4381: my $cv = $cells{$rk}{$ck}{$m->{as}}; 4382: if (defined $cv) { $v += $cv; $have = 1 } 4383: } 4384: $cells{$rk}{$other_key}{$m->{as}} = $have ? $v : undef; 4385: } 4386: } 4387: @col_key_order = (@top_ckeys, $other_key); 4388: } else { 4389: @col_key_order = @top_ckeys; 4390: } 4391: } 4392: 4393: # ----------------------------------------------------------------------- 4394: # Export path: build flat records from the grid. 4395: # ----------------------------------------------------------------------- ●4396 → 4396 → 4442 4396: if ($format && $format =~ /\A(?:csv|sqlite|sql|json|xlsx)\z/) { 4397: my @grid_records; 4398: for my $rk (@row_key_order) { 4399: for my $ck (@col_key_order) { 4400: my %rec; 4401: $rec{$_} = $row_combos{$rk}{$_} // '' for @rows; 4402: $rec{$_} = $col_combos{$ck}{$_} // '' for @cols; 4403: $rec{$_->{as}} = $cells{$rk}{$ck}{$_->{as}} // '' for @measures; 4404: push @grid_records, \%rec; 4405: } 4406: } 4407: my @export_cols = (@rows, @cols, map { $_->{as} } @measures); 4408: return $self->_render_csv(\@grid_records, \@export_cols, 'pivot') 4409: if $format eq 'csv'; 4410: return $self->_render_sqlite(\@grid_records, \@export_cols, 'pivot') 4411: if $format eq 'sqlite' || $format eq 'sql';
Mutants (Total: 2, Killed: 2, Survived: 0)
4412: return $self->_render_json(\@grid_records, \@export_cols, 'pivot')
Mutants (Total: 2, Killed: 2, Survived: 0)
4413: if $format eq 'json'; 4414: if ($format eq 'xlsx') { 4415: require Excel::Writer::XLSX;
Mutants (Total: 2, Killed: 2, Survived: 0)
4416: my $out = ''; 4417: open my $fh, '>', \$out 4418: or return $self->render(text => 'Cannot open XLSX buffer', status => 500);
Mutants (Total: 3, Killed: 3, Survived: 0)
4419: my $wb = Excel::Writer::XLSX->new($fh); 4420: my $ws = $wb->add_worksheet('pivot'); 4421: $ws->write_row(0, 0, \@export_cols); 4422: my $row_idx = 1; 4423: for my $rec (@grid_records) { 4424: $ws->write_row($row_idx++, 0, [ map { $rec->{$_} // '' } @export_cols ]); 4425: }
Mutants (Total: 2, Killed: 2, Survived: 0)
4426: $wb->close;
Mutants (Total: 2, Killed: 2, Survived: 0)
4427: $self->res->headers->content_type( 4428: 'application/vnd.openxmlformats-officedocument.spreadsheetml.sheet' 4429: );
Mutants (Total: 2, Killed: 2, Survived: 0)
4430: $self->res->headers->content_disposition( 4431: 'attachment; filename="pivot.xlsx"' 4432: ); 4433: 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).
Mutants (Total: 1, Killed: 1, Survived: 0)
4441: # ----------------------------------------------------------------------- ●4442 → 4465 → 4475 4442: my ($page, $per_page, $offset) = $self->_pagination; 4443: my $total_row_groups = scalar @row_key_order; 4444: my $piv_has_next = ($total_row_groups > $offset + $per_page) ? 1 : 0; 4445: @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: my $piv_page_url = $self->req->url->clone; 4450: $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 {
Mutants (Total: 2, Killed: 2, Survived: 0)
4456: my $ck = $_; 4457: { 4458: key => $ck, 4459: dim_vals => $col_combos{$ck}, 4460: label => join(' / ', map { $col_combos{$ck}{$_} // '' } @cols), 4461: } 4462: } @col_key_order; 4463: 4464: my @grid_rows; 4465: for my $rk (@row_key_order) { 4466: my %row_cells; 4467: for my $ck (@col_key_order) { 4468: $row_cells{$ck} = $cells{$rk}{$ck} // {}; 4469: } 4470: push @grid_rows, { 4471: row_vals => $row_combos{$rk}, 4472: cells => \%row_cells, 4473: subtotals => $show_totals ? ($row_subtotals{$rk} // {}) : {}, 4474: }; 4475: } 4476: 4477: (my $left_label = $left_spec) =~ s/\A(?:table:|path:|url:)//; 4478: 4479: my ($platform, $language) = $self->_resolve_template; 4480: $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: );
Mutants (Total: 2, Killed: 2, Survived: 0)
4505: }
4506:Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_4505_2: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes🧪 Suggested Test# Boolean branch test suggestion ok( !func(INPUT), 'Verify boolean branch behaviour' );- RETURN_UNDEF_4505_2: Replace return expression with undef
LOW: Mutation survived, but impact may be minor🧪 Suggested Test# Return value assertion is( func(INPUT), EXPECTED, 'Verify correct return value' );Mutants (Total: 2, Killed: 2, Survived: 0)
4507: =head2 stats_view 4508: 4509: C<GET /stats> -- Column statistics panel.
Mutants (Total: 2, Killed: 2, Survived: 0)
4510: 4511: Accepts the same C<l=>, C<j=>, C<f=> pipeline params as C</join> and displays 4512: per-column statistics: min, max, mean, median, null_count, distinct_count,
4513: row_count. 4514: 4515: Statistics are computed through C<_grouped_totals> so they agree with the pivot 4516: view. Median is computed in Perl by sorting the column values. 4517: 4518: =cut 4519:Mutants (Total: 3, Killed: 2, Survived: 1)
- COND_INV_4512_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomesMutants (Total: 2, Killed: 2, Survived: 0)
4520: sub stats_view ($self) {
Mutants (Total: 2, Killed: 2, Survived: 0)
●4521 → 4534 → 4536 4521: my $left_spec = $self->param('l') // '';
Mutants (Total: 2, Killed: 2, Survived: 0)
4522: return $self->render(text => 'Missing l= parameter', status => 400) 4523: unless length $left_spec; 4524: 4525: my $back = _safe_back_url($self->param('back')) // '/'; 4526: my $back2 = _safe_back_url($self->param('back2')); 4527: my $back2_lbl = $self->param('back2_label') // ''; 4528: 4529: my ($src, $records, $columns) = $self->_run_pipeline_source; 4530: return $self->render(text => 'Could not open data source', status => 404) 4531: unless defined $records; 4532: 4533: eval { ($records, $columns) = $self->_apply_calc_fields($records, $columns) }; 4534: if ($@) { (my $e = $@) =~ s/ at \S+ line \d+\.?\n?$//; return $self->render(text => $e, status => 400) } 4535: ●4536 → 4536 → 4540 4536: for my $s (@{ $self->every_param('f') }) { 4537: $records = _apply_filter_spec($records, $s); 4538: } 4539: ●4540 → 4544 → 4585 4540: my $row_count = scalar @$records; 4541: my $pipeline = { source => $src, records => $records };
Mutants (Total: 2, Killed: 2, Survived: 0)
4542: 4543: my @stats; 4544: for my $col (@{$columns}) { 4545: # null_count = rows where cell is undef or '' (phase 2 definition). 4546: my @nonnull = grep { defined $_->{$col} && length($_->{$col}) } @$records; 4547: my $null_count = $row_count - scalar @nonnull; 4548: 4549: # distinct_count via _grouped_totals (count groups by the column). 4550: my $dist_rows = $self->_grouped_totals($pipeline, { 4551: by => [$col], 4552: fn => 'count', 4553: as => 'cnt', 4554: }); 4555: my $distinct_count = scalar @$dist_rows; 4556: 4557: # Numeric statistics. 4558: my @nums = grep { defined $_ } map { _numeric_cell($_->{$col}) } @nonnull; 4559: my ($min_val, $max_val, $avg_val, $median_val); 4560: if (@nums) { 4561: my @sorted = sort { $a <=> $b } @nums; 4562: $min_val = $sorted[0]; 4563: $max_val = $sorted[-1]; 4564: my $sum = 0; 4565: $sum += $_ for @nums; 4566: $avg_val = $sum / @nums; 4567: my $mid = int(@sorted / 2); 4568: $median_val = @sorted % 2 4569: ? $sorted[$mid] 4570: : ($sorted[$mid - 1] + $sorted[$mid]) / 2; 4571: } 4572: 4573: 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: (my $left_label = $left_spec) =~ s/\A(?:table:|path:|url:)//; 4588: 4589: my ($platform, $language) = $self->_resolve_template;
Mutants (Total: 2, Killed: 2, Survived: 0)
4590: $self->render( 4591: handler => 'tt', 4592: template => "$platform/$language/stats",
Mutants (Total: 2, Killed: 2, Survived: 0)
4593: format => 'html', 4594: title => 'Column statistics', 4595: stats => \@stats,
Mutants (Total: 3, Killed: 3, Survived: 0)
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),
Mutants (Total: 2, Killed: 2, Survived: 0)
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: );
Mutants (Total: 2, Killed: 2, Survived: 0)
4606: } 4607: 4608: # --------------------------------------------------------------------------- 4609: # Calculated-field CRUD (POST /calc/save, POST /calc/delete, GET /calc/list) 4610: # --------------------------------------------------------------------------- 4611: 4612: sub calc_save ($self) { 4613: my $spec = $self->param('l') // ''; 4614: my $name = $self->param('name') // ''; 4615: my $expr = $self->param('expr') // ''; 4616: 4617: return $self->render(json => { error => 'l= required' }, status => 400) 4618: unless length $spec;
Mutants (Total: 2, Killed: 2, Survived: 0)
4619: 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: return $self->render(json => { error => 'expr= required' }, status => 400) 4624: unless length $expr; 4625: 4626: my $models = $self->_read_models; 4627: $models->{fields}{$spec}{$name} = $expr; 4628: $self->_write_models($models); 4629: $self->render(json => { ok => 1 }); 4630: } 4631: 4632: sub calc_delete ($self) { 4633: my $spec = $self->param('l') // ''; 4634: my $name = $self->param('name') // ''; 4635: 4636: return $self->render(json => { error => 'l= required' }, status => 400) 4637: unless length $spec; 4638: 4639: my $models = $self->_read_models; 4640: delete $models->{fields}{$spec}{$name}; 4641: $self->_write_models($models); 4642: $self->render(json => { ok => 1 }); 4643: } 4644: 4645: sub calc_list ($self) { 4646: my $spec = $self->param('l') // ''; 4647: return $self->render(json => { error => 'l= required' }, status => 400) 4648: unless length $spec; 4649: 4650: my $models = $self->_read_models; 4651: $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: sub groups_save ($self) { 4659: my $spec = $self->param('l') // ''; 4660: my $col = $self->param('col') // ''; 4661: my $group_name = $self->param('group') // ''; 4662: my @values = @{ $self->every_param('values') // [] }; 4663: 4664: return $self->render(json => { error => 'l= required' }, status => 400) 4665: unless length $spec; 4666: return $self->render(json => { error => 'col= required' }, status => 400)
Mutants (Total: 2, Killed: 2, Survived: 0)
4667: unless length $col; 4668: return $self->render(json => { error => 'group= required' }, status => 400) 4669: unless length $group_name;
Mutants (Total: 2, Killed: 2, Survived: 0)
4670: 4671: my $models = $self->_read_models; 4672: $models->{groups}{$spec}{$col}{$group_name} = \@values;
Mutants (Total: 3, Killed: 3, Survived: 0)
4673: $self->_write_models($models); 4674: $self->render(json => { ok => 1 }); 4675: } 4676: 4677: sub groups_delete ($self) { ●4678 → 4686 → 4693 4678: my $spec = $self->param('l') // ''; 4679: my $col = $self->param('col') // '';
Mutants (Total: 2, Killed: 2, Survived: 0)
4680: my $group_name = $self->param('group') // ''; 4681: 4682: return $self->render(json => { error => 'l= required' }, status => 400) 4683: unless length $spec; 4684: 4685: my $models = $self->_read_models; 4686: if (length $col && length $group_name) { 4687: delete $models->{groups}{$spec}{$col}{$group_name};
Mutants (Total: 2, Killed: 2, Survived: 0)
4688: } elsif (length $col) { 4689: delete $models->{groups}{$spec}{$col}; 4690: } else { 4691: delete $models->{groups}{$spec}; 4692: } 4693: $self->_write_models($models);
Mutants (Total: 3, Killed: 3, Survived: 0)
4694: $self->render(json => { ok => 1 });
Mutants (Total: 3, Killed: 3, Survived: 0)
4695: } 4696: 4697: sub groups_list ($self) { 4698: my $spec = $self->param('l') // ''; 4699: return $self->render(json => { error => 'l= required' }, status => 400) 4700: unless length $spec; 4701: 4702: my $models = $self->_read_models; 4703: $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: sub dates_save ($self) { 4714: my $spec = $self->param('l') // ''; 4715: my $col = $self->param('col') // ''; 4716: my $pattern = $self->param('pattern') // ''; 4717: 4718: return $self->render(json => { error => 'l= required' }, status => 400) 4719: unless length $spec; 4720: 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: ) unless $ALLOWED_DATE_PATTERNS{$pattern}; 4726: 4727: my $models = $self->_read_models; 4728: $models->{date_patterns}{$spec}{$col} = $pattern; 4729: $self->_write_models($models); 4730: $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: sub dates_delete ($self) { ●4736 → 4743 → 4748 4736: my $spec = $self->param('l') // ''; 4737: my $col = $self->param('col') // ''; 4738: 4739: return $self->render(json => { error => 'l= required' }, status => 400) 4740: unless length $spec; 4741: 4742: my $models = $self->_read_models; 4743: if (length $col) { 4744: delete $models->{date_patterns}{$spec}{$col}; 4745: } else { 4746: delete $models->{date_patterns}{$spec}; 4747: } 4748: $self->_write_models($models); 4749: $self->render(json => { ok => 1 }); 4750: } 4751: 4752: # dates_list: GET /dates/list?l=<spec> 4753: # Returns { patterns: { col: pattern, ... } } for $spec. 4754: sub dates_list ($self) { 4755: my $spec = $self->param('l') // ''; 4756: return $self->render(json => { error => 'l= required' }, status => 400) 4757: unless length $spec; 4758: 4759: my $models = $self->_read_models; 4760: $self->render(json => { patterns => $models->{date_patterns}{$spec} // {} }); 4761: } 4762: 4763: # --------------------------------------------------------------------------- 4764: # Scatter chart (GET /scatter) 4765: # --------------------------------------------------------------------------- 4766: 4767: sub scatter_view ($self) { ●4768 → 4781 → 4783 4768: my $x_col = $self->param('x') // ''; 4769: my $y_col = $self->param('y') // ''; 4770: my $back = _safe_back_url($self->param('back')) // '/'; 4771: my $back2 = _safe_back_url($self->param('back2')); 4772: my $back2_lbl = $self->param('back2_label') // ''; 4773: 4774: return $self->render(text => 'Missing x= parameter', status => 400) unless length $x_col; 4775: return $self->render(text => 'Missing y= parameter', status => 400) unless length $y_col; 4776: 4777: my ($src, $records, $columns) = $self->_run_pipeline_source; 4778: return $self->render(text => 'Could not open data source', status => 404) unless defined $records; 4779: 4780: eval { ($records, $columns) = $self->_apply_calc_fields($records, $columns) }; 4781: if ($@) { (my $e = $@) =~ s/ at \S+ line \d+\.?\n?$//; return $self->render(text => $e, status => 400) } 4782: ●4783 → 4783 → 4787 4783: for my $s (@{ $self->every_param('f') }) { 4784: $records = _apply_filter_spec($records, $s); 4785: } 4786: ●4787 → 4792 → 4801 4787: my %col_set = map { $_ => 1 } @{$columns}; 4788: return $self->render(text => "Column not found: $x_col", status => 400) unless $col_set{$x_col}; 4789: return $self->render(text => "Column not found: $y_col", status => 400) unless $col_set{$y_col}; 4790: 4791: my @points; 4792: for my $row (@$records) { 4793: my $xv = _numeric_cell($row->{$x_col} // ''); 4794: my $yv = _numeric_cell($row->{$y_col} // ''); 4795: next unless defined $xv && defined $yv; 4796: my %extra = map { $_ => _decode_cell($row->{$_} // '') } 4797: grep { $_ ne $x_col && $_ ne $y_col } @$columns; 4798: push @points, [$xv, $yv, \%extra]; 4799: } 4800: 4801: 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: my ($source_url, $source_accessed) = $self->_url_attribution; 4807: 4808: require HTML::D3; 4809: my $title = "$y_col vs $x_col"; 4810: 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: my $scatter_html = $snippet->{html}; 4818: utf8::decode($scatter_html) unless utf8::is_utf8($scatter_html); 4819: 4820: my ($platform, $language) = $self->_resolve_template; 4821: $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: sub stacked_view ($self) { ●4843 → 4858 → 4860 4843: my $cat_col = $self->param('cat') // ''; 4844: my $seg_col = $self->param('seg') // ''; 4845: my $val_col = $self->param('val') // ''; 4846: my $orient = $self->param('orient') // 'v'; 4847: my $back = _safe_back_url($self->param('back')) // '/'; 4848: my $back2 = _safe_back_url($self->param('back2')); 4849: my $back2_lbl = $self->param('back2_label') // ''; 4850: 4851: return $self->render(text => 'Missing cat= parameter', status => 400) unless length $cat_col; 4852: return $self->render(text => 'Missing seg= parameter', status => 400) unless length $seg_col; 4853: 4854: my ($src, $records, $columns) = $self->_run_pipeline_source; 4855: return $self->render(text => 'Could not open data source', status => 404) unless defined $records; 4856: 4857: eval { ($records, $columns) = $self->_apply_calc_fields($records, $columns) }; 4858: if ($@) { (my $e = $@) =~ s/ at \S+ line \d+\.?\n?$//; return $self->render(text => $e, status => 400) } 4859: ●4860 → 4860 → 4864 4860: for my $s (@{ $self->every_param('f') }) { 4861: $records = _apply_filter_spec($records, $s); 4862: } 4863: ●4864 → 4874 → 4888 4864: my %col_set = map { $_ => 1 } @{$columns}; 4865: return $self->render(text => "Column not found: $cat_col", status => 400) unless $col_set{$cat_col}; 4866: return $self->render(text => "Column not found: $seg_col", status => 400) unless $col_set{$seg_col}; 4867: 4868: my $count_mode = (!length $val_col || $val_col eq '__count__'); 4869: return $self->render(text => "Column not found: $val_col", status => 400) 4870: unless $count_mode || $col_set{$val_col}; 4871: 4872: # Build [{cat=>, seg=>, val=>N}] via Perl fold. 4873: my (%totals, %cat_seen, %seg_seen, @cat_order); 4874: for my $row (@$records) { 4875: my $cat = _decode_cell($row->{$cat_col} // ''); 4876: my $seg = _decode_cell($row->{$seg_col} // ''); 4877: next unless length $cat && length $seg; 4878: push @cat_order, $cat unless $cat_seen{$cat}++; 4879: $seg_seen{$seg} = 1; 4880: if ($count_mode) { 4881: $totals{$cat}{$seg}++; 4882: } else { 4883: my $v = _numeric_cell($row->{$val_col} // ''); 4884: $totals{$cat}{$seg} += ($v // 0) if defined $v; 4885: } 4886: } 4887: ●4888 → 4889 → 4895 4888: my @data; 4889: for my $cat (@cat_order) { 4890: for my $seg (sort keys %seg_seen) { 4891: push @data, { cat => $cat, seg => $seg, val => $totals{$cat}{$seg} // 0 }; 4892: } 4893: } 4894: 4895: 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: my ($source_url, $source_accessed) = $self->_url_attribution; 4901: 4902: require HTML::D3; 4903: my $title = $count_mode ? "Count by $cat_col and $seg_col" 4904: : "$val_col by $cat_col and $seg_col"; 4905: 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: my $stacked_html = $snippet->{html}; 4912: utf8::decode($stacked_html) unless utf8::is_utf8($stacked_html); 4913: 4914: my ($platform, $language) = $self->_resolve_template; 4915: $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: sub combo_view ($self) { ●4935 → 4952 → 4954 4935: my $x_col = $self->param('x') // ''; 4936: my $bar_col = $self->param('bar') // ''; 4937: my $line_col = $self->param('line') // ''; 4938: my $bar_label = $self->param('bar_label') // ''; 4939: my $line_label = $self->param('line_label') // ''; 4940: my $back = _safe_back_url($self->param('back')) // '/'; 4941: my $back2 = _safe_back_url($self->param('back2')); 4942: my $back2_lbl = $self->param('back2_label') // ''; 4943: 4944: return $self->render(text => 'Missing x= parameter', status => 400) unless length $x_col; 4945: return $self->render(text => 'Missing bar= parameter', status => 400) unless length $bar_col; 4946: return $self->render(text => 'Missing line= parameter', status => 400) unless length $line_col; 4947: 4948: my ($src, $records, $columns) = $self->_run_pipeline_source; 4949: return $self->render(text => 'Could not open data source', status => 404) unless defined $records; 4950: 4951: eval { ($records, $columns) = $self->_apply_calc_fields($records, $columns) }; 4952: if ($@) { (my $e = $@) =~ s/ at \S+ line \d+\.?\n?$//; return $self->render(text => $e, status => 400) } 4953: ●4954 → 4954 → 4958 4954: for my $s (@{ $self->every_param('f') }) { 4955: $records = _apply_filter_spec($records, $s); 4956: } 4957: ●4958 → 4965 → 4975 4958: my %col_set = map { $_ => 1 } @{$columns}; 4959: return $self->render(text => "Column not found: $x_col", status => 400) unless $col_set{$x_col}; 4960: return $self->render(text => "Column not found: $bar_col", status => 400) unless $col_set{$bar_col}; 4961: 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: my (%bar_sum, %line_sum, @x_order, %x_seen); 4965: for my $row (@$records) { 4966: my $xv = _decode_cell($row->{$x_col} // ''); 4967: next unless length $xv; 4968: push @x_order, $xv unless $x_seen{$xv}++; 4969: my $bv = _numeric_cell($row->{$bar_col} // ''); 4970: my $lv = _numeric_cell($row->{$line_col} // ''); 4971: $bar_sum{$xv} += ($bv // 0); 4972: $line_sum{$xv} += ($lv // 0); 4973: } 4974: 4975: my @data = map { { 4976: x => $_, 4977: bar_val => $bar_sum{$_} // 0, 4978: line_val => $line_sum{$_} // 0, 4979: } } @x_order; 4980: 4981: 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: my ($source_url, $source_accessed) = $self->_url_attribution; 4987: 4988: require HTML::D3; 4989: my $eff_bar_lbl = $bar_label || $bar_col; 4990: my $eff_line_lbl = $line_label || $line_col; 4991: my $title = "$eff_bar_lbl and $eff_line_lbl by $x_col"; 4992: 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: my $combo_html = $snippet->{html}; 4999: utf8::decode($combo_html) unless utf8::is_utf8($combo_html); 5000: 5001: my ($platform, $language) = $self->_resolve_template; 5002: $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: sub treemap_view ($self) { ●5022 → 5035 → 5037 5022: my $cat_col = $self->param('cat') // ''; 5023: my $val_col = $self->param('val') // ''; 5024: my $scheme = $self->param('scheme') // 'tableau10'; 5025: my $back = _safe_back_url($self->param('back')) // '/'; 5026: my $back2 = _safe_back_url($self->param('back2')); 5027: my $back2_lbl = $self->param('back2_label') // ''; 5028: 5029: return $self->render(text => 'Missing cat= parameter', status => 400) unless length $cat_col; 5030: 5031: my ($src, $records, $columns) = $self->_run_pipeline_source; 5032: return $self->render(text => 'Could not open data source', status => 404) unless defined $records; 5033: 5034: eval { ($records, $columns) = $self->_apply_calc_fields($records, $columns) }; 5035: if ($@) { (my $e = $@) =~ s/ at \S+ line \d+\.?\n?$//; return $self->render(text => $e, status => 400) } 5036: ●5037 → 5037 → 5041 5037: for my $s (@{ $self->every_param('f') }) { 5038: $records = _apply_filter_spec($records, $s); 5039: } 5040: ●5041 → 5060 → 5079 5041: my %col_set = map { $_ => 1 } @{$columns}; 5042: return $self->render(text => "Column not found: $cat_col", status => 400) unless $col_set{$cat_col}; 5043: 5044: my $count_mode = (!length $val_col || $val_col eq '__count__'); 5045: return $self->render(text => "Column not found: $val_col", status => 400) 5046: unless $count_mode || $col_set{$val_col}; 5047: 5048: 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: my $topn_n = int($self->param('topn') // 0); 5060: if ($topn_n > 0 && @$agg_rows > $topn_n) { 5061: my @sorted = sort { ($b->{value} // 0) <=> ($a->{value} // 0) } @$agg_rows; 5062: my @top_agg = @sorted[0 .. $topn_n - 1]; 5063: my %top_cats = map { ($_->{$cat_col} // '') => 1 } @top_agg; 5064: my $other_rec = [ 5065: grep { !$top_cats{$_->{$cat_col} // ''} } @$records 5066: ]; 5067: if (@$other_rec) { 5068: 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: if @$other && defined $other->[0]{value}; 5075: } 5076: $agg_rows = \@top_agg; 5077: } 5078: 5079: 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: { path => 'Root/' . _decode_cell($_->{$cat_col}), value => $_->{value} } 5086: } @$agg_rows; 5087: 5088: my ($source_url, $source_accessed) = $self->_url_attribution; 5089: 5090: require HTML::D3; 5091: my $title = $count_mode ? "Treemap of $cat_col by count" : "Treemap of $cat_col by $val_col"; 5092: my $snippet = HTML::D3->new(title => $title, width => 800, height => 500, responsive => 1) 5093: ->render_treemap_snippet(\@data, { 5094: scheme => $scheme, 5095: }); 5096: 5097: my $treemap_html = $snippet->{html}; 5098: utf8::decode($treemap_html) unless utf8::is_utf8($treemap_html); 5099: 5100: my ($platform, $language) = $self->_resolve_template; 5101: $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: sub histogram_view ($self) { ●5123 → 5135 → 5137 5123: my $col = $self->param('col') // ''; 5124: my $bins = $self->param('bins') // 20; 5125: my $back = _safe_back_url($self->param('back')) // '/'; 5126: my $back2 = _safe_back_url($self->param('back2')); 5127: my $back2_lbl = $self->param('back2_label') // ''; 5128: 5129: return $self->render(text => 'Missing col= parameter', status => 400) unless length $col; 5130: 5131: my ($src, $records, $columns) = $self->_run_pipeline_source; 5132: return $self->render(text => 'Could not open data source', status => 404) unless defined $records; 5133: 5134: eval { ($records, $columns) = $self->_apply_calc_fields($records, $columns) }; 5135: if ($@) { (my $e = $@) =~ s/ at \S+ line \d+\.?\n?$//; return $self->render(text => $e, status => 400) } 5136: ●5137 → 5137 → 5141 5137: for my $s (@{ $self->every_param('f') }) { 5138: $records = _apply_filter_spec($records, $s); 5139: } 5140: ●5141 → 5145 → 5150 5141: my %col_set = map { $_ => 1 } @{$columns}; 5142: return $self->render(text => "Column not found: $col", status => 400) unless $col_set{$col}; 5143: 5144: my @values; 5145: for my $row (@$records) { 5146: my $v = _numeric_cell($row->{$col} // ''); 5147: push @values, $v if defined $v; 5148: } 5149: 5150: 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: $bins = int($bins); 5156: $bins = 1 if $bins < 1; 5157: $bins = 200 if $bins > 200; 5158: 5159: my ($source_url, $source_accessed) = $self->_url_attribution; 5160: 5161: require HTML::D3; 5162: my $title = "Distribution of $col"; 5163: 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: my $histogram_html = $snippet->{html}; 5170: utf8::decode($histogram_html) unless utf8::is_utf8($histogram_html); 5171: 5172: my ($platform, $language) = $self->_resolve_template; 5173: $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: 5191: __END__ 5192: 5193: =head1 NAME 5194: 5195: Database::BI::Controller::Dashboard - Home picker, filesystem browser, table 5196: viewer, left-join engine, result filter, export, and file upload 5197: 5198: =head1 SYNOPSIS 5199: 5200: All routes in C<Database::BI> are handled by this controller. You do not 5201: call its methods directly -- Mojolicious dispatches HTTP requests to them 5202: automatically. The examples below show browser URLs and their curl 5203: equivalents. 5204: 5205: B<Open the home page and see all tables in the data directory:> 5206: 5207: # Browser 5208: http://localhost:3000/ 5209: 5210: # curl 5211: curl http://localhost:3000/ 5212: 5213: B<View a single table (file: data/sales.csv):> 5214: 5215: # Browser 5216: http://localhost:3000/view/sales 5217: 5218: # curl 5219: curl http://localhost:3000/view/sales 5220: 5221: B<Filter rows -- show only rows where region equals "North":> 5222: 5223: # Browser (add ?f=col:op:val to any view URL) 5224: http://localhost:3000/view/sales?f=region:eq:North 5225: 5226: # Multiple filters -- "North" AND amount greater than 100: 5227: http://localhost:3000/view/sales?f=region:eq:North&f=amount:gt:100 5228: 5229: # curl 5230: curl 'http://localhost:3000/view/sales?f=region:eq:North' 5231: 5232: B<Join two tables -- left-join sales with products on the product column:> 5233: 5234: # Browser 5235: http://localhost:3000/join?l=table:sales&j=table:products|product|name 5236: 5237: # The j= parameter is: right-table-spec | left-key | right-key 5238: # You can chain multiple joins: 5239: http://localhost:3000/join?l=table:sales&j=table:products|product|name&j=table:regions|region|id 5240: 5241: B<Open a file anywhere on the filesystem (not just in data/):> 5242: 5243: http://localhost:3000/open?path=/home/user/reports/q3.csv 5244: 5245: B<Download the current view as a CSV file:> 5246: 5247: # Uses the same l=, j=, f= parameters as /join 5248: http://localhost:3000/export?l=table:sales&format=csv 5249: 5250: # Download as a SQLite database file instead: 5251: http://localhost:3000/export?l=table:sales&format=sqlite 5252: 5253: # Download a filtered + joined result: 5254: http://localhost:3000/export?l=table:sales&j=table:products|product|name&f=region:eq:North&format=csv 5255: 5256: B<Save the current view to a file on the server (instead of downloading):> 5257: 5258: # POST with form fields; format is inferred from the filename extension 5259: curl -X POST http://localhost:3000/export \ 5260: -F l=table:sales \ 5261: -F dir=/home/user/exports \ 5262: -F filename=report.csv 5263: 5264: # Save as SQLite: 5265: curl -X POST http://localhost:3000/export \ 5266: -F l=table:sales \ 5267: -F dir=/home/user/exports \ 5268: -F filename=report.sql 5269: 5270: B<Get the column list for a table (used by the join UI):> 5271: 5272: curl http://localhost:3000/api/columns?table=sales 5273: # Returns: {"columns":["product","region","amount","date"]} 5274: 5275: B<Check when a file was last modified (used by the tooltip on the home page):> 5276: 5277: curl 'http://localhost:3000/api/stat?path=/data/sales.csv' 5278: # Returns: {"exists":true,"path":"/data/sales.csv","mtime":1700000000,"size":1234} 5279: 5280: B<Browse the filesystem to find a data file:> 5281: 5282: http://localhost:3000/browse 5283: http://localhost:3000/browse?path=/home/user/data 5284: 5285: B<Upload a data file by dropping it onto the page (multipart form POST):> 5286: 5287: curl -X POST http://localhost:3000/upload \ 5288: -F file=@/home/user/data/sales.csv 5289: # Returns: {"url":"/open?path=/.../.uploads/.../sales.csv","path":"/.../.uploads/.../sales.csv"} 5290: 5291: =head2 graph_view 5292: 5293: C<GET /graph> -- Render a D3.js v7 line chart from the current data pipeline. 5294: 5295: Accepts the same pipeline parameters as L</join_tables> (C<l=>, C<j=>, 5296: C<c=>, C<f=>, C<d=>) plus: 5297: 5298: =over 4 5299: 5300: =item C<x=E<lt>colE<gt>> 5301: 5302: Column name to use as the X axis (required). Any data type is accepted; 5303: values are displayed as categorical labels. 5304: 5305: =item C<y=E<lt>colE<gt>> 5306: 5307: Column name to use as the Y axis (required). Non-numeric characters 5308: (currency symbols, commas, etc.) are stripped before comparison; rows 5309: where the value is still non-numeric after stripping are silently skipped. 5310: 5311: =item C<back=E<lt>urlE<gt>> 5312: 5313: URL for the "Back to table" link rendered in the graph toolbar. Defaults 5314: to C</> when absent. The dashboard JS sets this to the current page URL 5315: before navigating. 5316: 5317: =back 5318: 5319: =head3 API SPECIFICATION 5320: 5321: =head4 INPUT 5322: 5323: l=<spec> string Left-table spec (required). Same syntax as /join. 5324: x=<col> string X-axis column name (required). 5325: y=<col> string Y-axis column name (required; must be numeric). 5326: back=<url> string Back-link URL (optional; default "/"). 5327: j=, c=, f=, d= Pipeline params -- see L</join_tables>. 5328: 5329: =head4 OUTPUT 5330: 5331: 200 text/html TT-rendered graph page. The HTML::D3 snippet embeds a 5332: C<const data = [...]> JSON array where each element has: 5333: { label: <x-value>, value: <y-value>, 5334: extra: { <col>: <val>, ... } } 5335: C<extra> contains every column not used as X or Y, so 5336: the hover tooltip shows the complete row for each point. 5337: The chart supports brush-to-zoom; a "Reset zoom" button 5338: appears after a brush selection. The toolbar shows the 5339: count of plotted data points. 5340: 5341: 400 text/plain C<x=> or C<y=> absent, or named column not found. 5342: 404 text/plain Data source could not be opened. 5343: 5344: =head3 MESSAGES 5345: 5346: Missing x or y column parameter C<x=> or C<y=> query param absent. 5347: Column not found: <name> Named column absent from result set. 5348: Could not open data source Left-table spec unresolvable or 404. 5349: No plottable data: no rows have valid ... All rows lack a numeric Y value. 5350: 5351: =head3 EXAMPLE 5352: 5353: GET /graph?l=table:sales&x=product&y=amount 5354: 5355: Renders a line chart of C<amount> (Y) against C<product> (X). Mousing over 5356: a dot shows a tooltip with the product name, the amount, and every other 5357: column in that row (e.g. C<region>, C<date>). 5358: 5359: =head3 FORMAL SPECIFICATION 5360: 5361: graph_view : Controller × Params → HTML | Error 5362: 5363: let pipeline = run_export_pipeline(l, j, c, f, d) 5364: let pairs = [ [row[x], num(row[y]), row \ {x,y}] 5365: | row ∈ pipeline.records, num(row[y]) ≠⊥ ] 5366: 5367: pre x ∈ params ∧ y ∈ params else 400 5368: pre x ∈ pipeline.cols else 400 5369: pre y ∈ pipeline.cols else 400 5370: pre pairs ≠[] else 200 "No plottable data" 5371: post HTML::D3->render_line_chart_snippet(pairs) embedded in TT layout 5372: 5373: =cut 5374: 5375: =head2 pie_view 5376: 5377: C<GET /pie> -- Render a D3.js v7 animated pie chart from the current data 5378: pipeline. 5379: 5380: Each row's category value (C<cat=>) is used as a slice label; the numeric 5381: value column (C<val=>) is summed per category. Accounting-notation 5382: negatives such as C<(1,234.56)> are handled automatically. Slices are 5383: sorted by total descending; when there are more than 12 distinct categories 5384: the smallest ones are collapsed into a single "Other" slice. 5385: 5386: Clicking any slice or legend entry navigates back to the table view with 5387: an C<f=cat:eq:value> filter applied automatically, so the user can drill 5388: into the data behind a slice without leaving the application. 5389: 5390: =head3 API SPECIFICATION 5391: 5392: =head4 INPUT 5393: 5394: l=<spec> string Left-table spec (required). Same syntax as /join. 5395: cat=<col> string Category column name (required; used as slice labels). 5396: val=<col> string Numeric value column name (required; values are summed). 5397: donut=1 flag Render as a donut chart with a hole in the centre (optional). 5398: back=<url> string URL for the "Back to table" breadcrumb link (optional; default "/"). 5399: f=<spec> string Result filter (repeatable; same syntax as /join). 5400: 5401: =head4 OUTPUT 5402: 5403: 200 text/html TT-rendered pie chart page containing: 5404: - Two-level breadcrumb (Home > Back to table). 5405: - Export buttons for SVG and PNG (legend is composited in). 5406: - An animated D3.js pie or donut chart with a colour-coded 5407: legend. Each slice and legend entry is clickable and 5408: navigates to the filtered table view. 5409: - Slice count (e.g. "7 slices"). 5410: 5411: 200 text/plain "No plottable data" when every row has a non-numeric or 5412: missing value column (HTTP 200, not 4xx, so the page can 5413: render a friendly message). 5414: 5415: 400 text/plain C<cat=> or C<val=> absent, or named column not found. 5416: 404 text/plain Data source could not be opened. 5417: 5418: =head4 DOMAIN CONSTRAINTS 5419: 5420: cat= Any column name that exists in the result set. Cell values are 5421: used verbatim as slice labels. Empty-string cells are skipped. 5422: 5423: val= Must be a column whose cells contain numbers (after stripping 5424: currency symbols, commas, and handling accounting-notation negatives). 5425: Rows where the value is still non-numeric after stripping are skipped. 5426: Negative totals are included in the chart (slice values may be negative 5427: if the source data contains credits or reversals). 5428: 5429: donut= Any truthy value (e.g. "1") enables the donut hole. Absent or 5430: "0" renders a solid pie. 5431: 5432: =head3 MESSAGES 5433: 5434: Missing cat or val column parameter C<cat=> or C<val=> query param absent. 5435: Column not found: <name> Named column absent from the result set. 5436: Could not open data source Left-table spec unresolvable or 404. 5437: No plottable data: ... All rows lack a valid numeric value. 5438: 5439: =head3 EXAMPLE 5440: 5441: GET /pie?l=table:sales&cat=region&val=amount&back=/view/sales 5442: 5443: Renders a pie chart of total C<amount> per C<region>. Clicking the 5444: "North" slice navigates to C</view/sales?f=region:eq:North>. 5445: 5446: With a donut hole: 5447: 5448: GET /pie?l=table:sales&cat=region&val=amount&donut=1 5449: 5450: =head3 FORMAL SPECIFICATION 5451: 5452: pie_view : Controller x Params -> HTML | Error 5453: 5454: let pipeline = run_export_pipeline(l, j, f, d) 5455: let totals = { cat => sum { val(row) | row in pipeline.records, 5456: cat(row) != '', num(val(row)) != bot } 5457: | cat in range(cat_col) } 5458: 5459: pre cat in params /\ val in params else 400 5460: pre cat in pipeline.cols else 400 5461: pre val in pipeline.cols else 400 5462: pre totals != {} else 200 "No plottable data" 5463: post HTML::D3->render_pie_chart_snippet(slices) embedded in TT layout 5464: where slices = sort_desc { |s.value| | s in totals } 5465: 5466: =cut 5467: 5468: =head2 clear_uploads 5469: 5470: C<POST /uploads/clear> -- Delete every file from the C<.uploads/> staging 5471: directory and return the total disk space recovered. 5472: 5473: The C<.uploads/> directory accumulates files from drag-and-drop uploads. 5474: It grows indefinitely; this action lets users reclaim that space without 5475: needing shell access. 5476: 5477: =head3 API SPECIFICATION 5478: 5479: =head4 INPUT 5480: 5481: No parameters. The C<.uploads/> path is always the one under C<app->home>. 5482: 5483: =head4 OUTPUT 5484: 5485: 200 application/json { "freed": <bytes>, "count": <n> } 5486: 5487: C<freed> is the total number of bytes removed. C<count> is the number of 5488: files deleted. Both are 0 when the directory is absent or already empty. 5489: 5490: =cut 5491: 5492: =head1 DESCRIPTION 5493: 5494: All user-facing routes in C<Database::BI> are handled by this controller. 5495: See the individual action POD above for per-endpoint documentation. 5496: 5497: =head2 Filter operators and the quick-filter bar 5498: 5499: Filters are expressed as C<f=col:op:val> query parameters and are applied 5500: server-side after all joins. Multiple C<f=> params are applied in order 5501: (AND semantics). 5502: 5503: The colon separator is split with a limit of 3, so values may themselves 5504: contain colons (e.g. C<f=sale_date:eq:2025-01-15>, or a time value like 5505: C<f=start_time:eq:14:30:00>). 5506: 5507: B<Supported operators:> 5508: 5509: eq case-insensitive string equality 5510: ne case-insensitive string inequality 5511: contains case-insensitive substring match 5512: starts case-insensitive prefix match 5513: lt numeric less-than 5514: le numeric less-than-or-equal 5515: gt numeric greater-than 5516: ge numeric greater-than-or-equal 5517: empty cell is undef or empty string (val ignored) 5518: notempty cell is defined and non-empty (val ignored) 5519: 5520: B<Quick-filter bar (table view):> 5521: 5522: A filter row below the toolbar lets the user pick a column, operator, and 5523: value and press "Apply filter" (or Enter) to add a condition without 5524: opening any panel. The current URL is updated with the new C<f=> param 5525: and the page reloads; all other URL parameters (joins, dedup, etc.) are 5526: preserved automatically via the browser C<URL> API. 5527: 5528: Active filter chips appear in the toolbar. Each chip has an individual 5529: x-button to remove just that condition. The "x Clear filters" link 5530: removes all C<f=> params at once. 5531: 5532: B<Drill-down from pie chart:> 5533: 5534: Clicking a pie slice or legend entry on C</pie> navigates to the table 5535: view with C<f=cat_col:eq:label> appended, so the user can inspect the 5536: rows behind any slice without manually typing a filter. 5537: 5538: =head1 COMMON PITFALLS 5539: 5540: These are the most common mistakes when working with this controller. 5541: 5542: =over 4 5543: 5544: =item B<SQLite files must use the .sql extension, not .sqlite> 5545: 5546: C<Database::Abstraction> (the data-reading library) probes for a file called 5547: C<tablename.sql> when it wants to open a SQLite database. It does B<not> 5548: look for C<.sqlite> or C<.db3>. If your file is called C<inventory.sqlite>, 5549: rename it to C<inventory.sql> or it will not appear in the file browser and 5550: will return 404 when opened. 5551: 5552: =item B<Filter values that contain a colon still work> 5553: 5554: A date like C<2025-01-15> contains hyphens, not colons, so it is fine. But 5555: if your value itself contains a colon (for example, a time like C<14:30:00>), 5556: the filter still works because the C<col:op:val> spec is split on the B<first 5557: two> colons only -- the rest of the string becomes the value. 5558: 5559: # This correctly matches "14:30:00" in the start_time column: 5560: ?f=start_time:eq:14:30:00 5561: 5562: =item B<Left join keeps only the FIRST matching right-table row> 5563: 5564: When the right table has two rows with the same join key, only the first one 5565: (in file order) is used. The second is silently ignored. If you need all 5566: matches, consider pre-processing your data so join keys are unique. 5567: 5568: =item B<Export format comes from the filename extension, not a Content-Type header> 5569: 5570: When using C<POST /export> to save a file to disk, the format (CSV or SQLite) 5571: is determined by the extension of the C<filename> parameter. C<.csv> produces 5572: a CSV file; C<.sql> produces a SQLite database. Any other extension returns 5573: HTTP 415 (Unsupported Media Type). The C<Content-Type> request header is 5574: ignored entirely. 5575: 5576: =item B<Template Toolkit variables starting with underscore are silently dropped> 5577: 5578: If you add a stash variable with a name starting with C<_> (for example, 5579: C<_tmp> or C<_result>), Template Toolkit will silently produce an empty string 5580: when the template tries to read it. This is a TT quirk when C<TRIM =E<gt> 1> 5581: is active. Always use names that start with a letter. 5582: 5583: =item B<_apply_filter_spec always passes all records through for unknown operators> 5584: 5585: If you pass an operator that is not in the supported list (for example C<regex> 5586: or C<like>), the filter is treated as a no-op and B<all rows are returned>. No 5587: error is produced. This is intentional so that future operators can be added 5588: without breaking existing clients that read a wider response. 5589: 5590: =item B<Uploaded files are evicted automatically, but not immediately> 5591: 5592: Files uploaded via C<POST /upload> are stored in C<.uploads/> under the 5593: application home directory. C<Database::BI> evicts upload subdirectories 5594: whose modification time is older than 24 hours B<on every server startup>. 5595: Between restarts, files accumulate. For an immediate full purge (regardless 5596: of age), post to C<POST /uploads/clear> or click the "Clear upload cache" 5597: button in the UI. 5598: 5599: =item B<Open C<data/> tables by name; open other files by absolute path> 5600: 5601: The C<view> action (C<GET /view/:table>) only looks inside C<data_dir>. 5602: To open a file from anywhere else on the filesystem, use C<open_file> 5603: (C<GET /open?path=/abs/path>). The two routes use different URL schemes and 5604: are not interchangeable. 5605: 5606: =back 5607: 5608: =head1 LIMITATIONS 5609: 5610: =over 4 5611: 5612: =item * 5613: 5614: Multi-table joins are delegated to C<Database::Join> with C<backend =E<gt> 'auto'>. 5615: For datasets up to C<join_max_rows> combined rows (default 10,000; configurable 5616: in C<database_bi.conf>) the join runs in Perl memory; larger datasets spill to 5617: a temporary SQLite database so peak RAM is bounded by the result set rather than 5618: the sum of all source tables. 5619: 5620: =item * 5621: 5622: C<_resolve_language> extracts only the primary language subtag from the first 5623: C<Accept-Language> tag (e.g. C<de> from C<de-DE,de;q=0.9,en;q=0.8>). 5624: Quality weights and multiple alternatives are not ranked. 5625: 5626: =item * 5627: 5628: No GeoIP-based language resolution is implemented. The language is resolved 5629: from the HTTP C<Accept-Language> header only. 5630: 5631: =item * 5632: 5633: C<Sub::Protected> enforcement requires the CHECK compilation phase; when modules 5634: are loaded dynamically at test time the "Too late to run CHECK block" warning 5635: is emitted and the restriction is not enforced in that context. 5636: 5637: =back 5638: 5639: =head1 AUTHOR 5640: 5641: Nigel Horne C<< <njh@nigelhorne.com> >> 5642: 5643: =head1 LICENCE AND COPYRIGHT 5644: 5645: Copyright 2026 Nigel Horne. 5646: 5647: Usage is subject to the GPL2 licence terms. 5648: If you use it, 5649: please let me know. 5650: 5651: =cut