File Coverage

File:blib/lib/Database/BI/Model/DataSource.pm
Coverage:97.4%

linestmtbrancondsubtimecode
1package Database::BI::Model::DataSource;
2
3
12
12
12
380376
12
123
use strict;
4
12
12
12
18
8
237
use warnings;
5
12
12
12
1907
61875
31
use autodie qw(:all);
6
7
12
12
12
73422
13
258
use Carp                qw(croak carp);
8
12
12
12
25
9
72
use File::Spec          ();
9
12
12
12
42
29
201
use Readonly;
10
12
12
12
19
10
162
use Scalar::Util        qw(blessed);
11
12
12
12
2502
232784
35
use Sub::Protected;
12
12
12
12
1176
13
261
use Params::Validate::Strict qw(validate_strict);
13
12
12
12
20
16
3272
use Params::Get         ();
14
15our $VERSION = '0.002.0';
16
17# ---------------------------------------------------------------------------
18# I18N message dictionary.
19# All user-visible strings and exception messages are keyed here.
20# To plug in a real i18n backend (e.g. Locale::Maketext), pass an object
21# that responds to maketext($key, @args) as the "i18n" constructor argument;
22# it will be called in preference to this table.
23# ---------------------------------------------------------------------------
24
25Readonly our %MESSAGES => (
26        error_directory_required        => 'DataSource: argument "directory" is required',
27        error_table_required            => 'DataSource: argument "table" is required',
28        error_directory_missing         => 'DataSource: directory "%s" does not exist or is not readable',
29        error_table_name_invalid        => 'DataSource: table name "%s" contains illegal characters (alphanumeric and underscore only)',
30        error_backend_init              => 'DataSource: failed to initialise database backend for table "%s": %s',
31        error_fetch_failed              => 'DataSource: fetch_all failed for table "%s": %s',
32        error_url_invalid               => 'DataSource: URL "%s" must begin with http:// or https://',
33        error_url_fetch                 => 'DataSource: failed to open HTML table at "%s": %s',
34        warn_empty_result               => 'DataSource: fetch_all returned no records for table "%s"',
35        warn_data_normalised            => 'DataSource: result from backend was a hashref; converted to arrayref for table "%s"',
36);
37
38# A table name is a bare SQL-safe identifier: starts with a letter or
39# underscore, followed by zero or more alphanumeric/underscore characters.
40Readonly my $TABLE_NAME_RE => qr/\A[A-Za-z_][A-Za-z0-9_]*\z/;
41
42# ---------------------------------------------------------------------------
43# Protected helpers
44# ---------------------------------------------------------------------------
45
46# _url_label( $url ) -> $string
47#
48# Derive a safe, lowercase identifier from a URL for use as the table label.
49# Takes the last non-empty path component, strips the extension, then replaces
50# non-alphanumeric characters with underscores.  Falls back to the hostname
51# when the path component is absent or starts with a digit.
52sub _url_label {
53
25
16941
        my ($url) = @_;
54
25
101
        my ($path) = $url =~ m{https?://[^/?#]+(.*)}i;
55
25
47
88
50
        my @parts  = grep { length } split m{/}, ($path // '');
56
25
43
        my $last   = @parts ? $parts[-1] : '';
57        # /s: . must cross \n in case a percent-decoded newline hides inside the URL.
58
25
36
        $last =~ s/[?#].*//s;           # strip query / fragment
59
25
42
        $last =~ s/\.[^.]+\z//; # strip file extension (\z: no trailing-\n loophole)
60
25
34
        $last =~ s/[^A-Za-z0-9_]/_/g;   # sanitize
61
25
71
        unless (length $last && $last =~ /\A[A-Za-z_]/) {
62                # No usable path component -- fall back to hostname
63
9
23
                my ($host) = $url =~ m{https?://([^/:?#]+)};
64
9
8
8
12
19
10
                $last = defined $host ? do { (my $h = $host) =~ s/[^A-Za-z0-9_]/_/g; $h } : 'html';
65        }
66        # TODO: Unreachable code detected during path analysis. Investigate for removal.
67        # $last is always non-empty here: if the unless block did NOT fire, $last passed
68        # the "length $last && /\A[A-Za-z_]/" guard (non-empty by definition); if the
69        # unless block DID fire, $last was set to either the sanitized hostname (matched
70        # by [^/:?#]+, so >= 1 char, which stays >= 1 after s/[^A-Za-z0-9_]/_/g) or
71        # the literal 'html'.  Either way, $last is always truthy, so 'html_table' can
72        # never be selected.  The || fallback should be removed.
73
25
90
        return lc($last || 'html_table');
74}
75
76# _fmt( $key [, @sprintf_args] ) -> $string
77#
78# Package-level (not a method) i18n formatter. Looks up $key in %MESSAGES and
79# applies sprintf if positional arguments are supplied. This function is used
80# in new() before the object exists; instance methods should use _msg() instead
81# so that a caller-supplied i18n object can override the built-in strings.
82sub _fmt :Protected {
83
69
9216
        my ($key, @args) = @_;
84
69
196
        my $tmpl = $MESSAGES{$key} // "Internal error: unknown message key '$key'";
85
69
1150
        return @args ? sprintf($tmpl, @args) : $tmpl;
86
12
12
12
40
14
183
}
87
88# _msg( $self, $key [, @sprintf_args] ) -> $string
89#
90# Instance-level i18n formatter. Delegates to the caller-supplied i18n object
91# (if any) before falling back to _fmt(). The i18n object must implement
92# maketext($key, @args).
93sub _msg :Protected {
94
27
3363
        my ($self, $key, @args) = @_;
95
27
54
        if (my $i18n = $self->{_i18n}) {
96
1
1
                return $i18n->maketext($key, @args);
97        }
98
26
57
        return _fmt($key, @args);
99
12
12
12
1661
9
87
}
100
101# ---------------------------------------------------------------------------
102# Constructor
103# ---------------------------------------------------------------------------
104
105 - 171
=head1 CONSTRUCTOR

=head2 new

Creates and returns a new C<Database::BI::Model::DataSource> instance.

=head3 API SPECIFICATION

=head4 INPUT

        {
            directory => 'string',           # required; path to the data directory
            table     => 'string',           # required; bare table/file name (no extension)
            i18n      => { type => 'object', optional => 1, can => 'maketext' } # must implement maketext($key, @args)
        }

Accepts a flat key/value list, a hashref, or positional arguments via
C<Params::Get>.

=head4 DOMAIN CONSTRAINTS

=over 4

=item C<directory>

Must satisfy C<-d $directory> (must exist and be a directory).  An empty
string, a non-existent path, or the path to a regular file all produce
C<error_directory_missing>.

  Valid partition:   any existing directory path
  Invalid partition: non-existent path, regular file path, empty string ""

=item C<table>

Must match C<TABLE_NAME_RE = \A[A-Za-z_][A-Za-z0-9_]*\z>.  The first
character must be a letter (A-Z, a-z) or underscore; subsequent
characters may also be digits.

  Valid partition:   "sales", "_tmp", "report_2024" (letter/underscore start)
  Invalid partition: "1sales" (digit-start), "my.data" (dot),
                     "my-data" (hyphen), "" (empty string)
  Boundary values:   "a" (length-1 letter, valid), "_" (length-1 underscore,
                     valid), "1" (length-1 digit, croaks error_table_name_invalid)

=back

=head4 OUTPUT

Returns C<$self> (a blessed hashref). Croaks on invalid arguments.

=head3 MESSAGES

  error_directory_required    -- "directory" argument was not supplied
  error_table_required        -- "table" argument was not supplied
  error_directory_missing     -- supplied directory does not exist / is unreadable
  error_table_name_invalid    -- table name fails the safe-identifier check
  error_backend_init          -- Database::Abstraction subclass could not be instantiated

=head3 FORMAL SPECIFICATION

  new == [directory : PATH; table : NAME; i18n? : I18N_OBJECT]
         pre  (directory in dom FILE_SYSTEM /\ is_dir directory)
              /\ table =~ TABLE_NAME_RE
         post result.class = DataSource
              /\ result._db.class = Database::Abstraction

=cut
172
173sub new {
174        # Strategy: normalise the argument list with Params::Get so callers may
175        # pass a hashref or a flat list interchangeably, then validate strictly
176        # with Params::Validate before touching any value.
177        # When a "url" key is present, dispatch to the URL/HTML-table path instead.
178
266
129372
        my $class = shift;
179
266
603
        my $raw   = Params::Get::get_params(undef, \@_) // {};
180
266
4516
        return $class->_new_from_url($raw) if exists $raw->{url};
181
182
256
1259
        my $args = validate_strict(
183                schema => {
184                        directory => { type => 'string' },
185                        table     => { type => 'string' },
186                        i18n      => { type => 'object', optional => 1, default => undef, can => 'maketext' },
187                },
188                input => $raw,
189        );
190
191        croak _fmt('error_directory_missing', $args->{directory})
192
252
25559
                unless -d $args->{directory};
193
194        croak _fmt('error_table_name_invalid', $args->{table})
195
239
561
                unless $args->{table} =~ $TABLE_NAME_RE;
196
197        my $self = bless {
198                _directory => $args->{directory},
199                _table     => lc $args->{table},
200                _i18n      => $args->{i18n},
201
219
1709
                _db        => undef,
202        }, $class;
203
204
219
419
        $self->_init_backend;
205
218
700
        return $self;
206
207}
208
209# _new_from_url( $class, \%raw_params ) -> $self
210#
211# Purpose: Alternate constructor path for URL-backed HTML tables.
212#          Validates the URL scheme, derives a display label from the URL path,
213#          then calls _init_url_backend to build the D::A in-memory table.
214# Entry:   $raw->{url} must be an http:// or https:// URL.
215#          $raw->{html_table_index} (optional, default 0): zero-based table index.
216#          $raw->{i18n} (optional): Locale::Maketext-compatible object.
217# Exit:    Returns $self.  Croaks on invalid URL scheme or backend init failure.
218# Side Effects: Issues an HTTP GET to the URL via LWP::UserAgent.
219sub _new_from_url :Protected {
220
10
70
        my ($class, $raw) = @_;
221
222
10
18
        my $url = $raw->{url} // croak _fmt('error_url_invalid', '');
223
10
29
        croak _fmt('error_url_invalid', $url)
224                unless $url =~ m{\Ahttps?://}i;
225
226        my $self = bless {
227                _url   => $url,
228                _table => _url_label($url),
229                _i18n  => $raw->{i18n},
230
6
15
                _id_col  => undef,
231                _columns => undef,
232                _db      => undef,
233        }, $class;
234
235
6
21
        $self->_init_url_backend($raw->{html_table_index} // 0);
236
6
18
        return $self;
237
12
12
12
3088
11
104
}
238
239# _init_url_backend( $self, $table_index ) -> void
240#
241# Purpose: Construct the Database::Abstraction backend for URL/HTML-table mode.
242#          D::A fetches the page via LWP::UserAgent, parses it with
243#          HTML::TableExtract, and stores all rows (including headers from row 0)
244#          as an in-memory arrayref.  Column order is not recoverable after
245#          construction (hash keys lose order), so _columns stays undef and
246#          _get_columns in the controller falls back to alphabetical sorting.
247# Entry:   $self->{_url} is a valid http(s) URL; $table_index is a non-negative int.
248# Exit:    Sets $self->{_db}.  Croaks on LWP or HTML::TableExtract failure.
249# Side Effects: Network I/O; may take up to LWP's default timeout.
250sub _init_url_backend :Protected {
251
6
8
        my ($self, $table_index) = @_;
252
6
7
        my $url = $self->{_url};
253
254
6
19
        require Database::Abstraction;
255
256        # Reuse a single generic package for all URL-backed instances.
257        # The package name is irrelevant for the URL code path -- D::A branches on
258        # the presence of $self->{'url'}, not on the class name.
259
6
6
        my $pkg = 'Database::BI::_DB::HtmlUrl';
260        {
261
12
12
12
6
1234
11
815
4
                no strict 'refs';
262
6
2
33
17
                push @{"${pkg}::ISA"}, 'Database::Abstraction'
263                        unless $pkg->isa('Database::Abstraction');
264        }
265
266
6
6
        my $db = eval {
267
6
42
                $pkg->new({
268                        url              => $url,
269                        html_table_index => $table_index,
270                        no_entry         => 1,
271                })
272        };
273
6
11176
        croak $self->_msg('error_url_fetch', $url, $@) if $@;
274
275
6
8
        $self->{_db} = $db;
276
6
7
        return;
277
12
12
12
23
13
85
}
278
279# ---------------------------------------------------------------------------
280# Protected initialisation
281# ---------------------------------------------------------------------------
282
283# _detect_file_info( $dir, $table ) -> \%info
284#
285# Peek at the first header line of a CSV or PSV file and return a hashref:
286#   sep_char => field separator character (',' or '|')
287#   id       => first column name (used as Database::Abstraction's id key)
288#   columns  => arrayref of all column names in file order
289#
290# Two non-obvious defaults in Database::Abstraction make this necessary:
291#   1. sep_char defaults to '!' — so a plain CSV is read as one giant field
292#      per row, producing a single comma-joined string instead of columns.
293#   2. id defaults to 'entry' — the slurp filter greps on that column; if it
294#      doesn't exist every row is silently discarded.
295# Returns an empty hashref for non-CSV/PSV formats (SQLite, XML, etc.).
296sub _detect_file_info :Protected {
297
250
26874
        my ($dir, $table) = @_;
298
250
359
        for my $ext (qw(csv psv)) {
299
309
1663
                my $path = File::Spec->catfile($dir, "$table.$ext");
300
309
1867
                next unless -r $path;
301                # "use autodie" makes open() die on failure, so "or next" would be dead
302                # code.  Disable autodie for this open so a vanishing file (race between
303                # the -r probe and the open) results in a clean skip rather than a croak.
304
218
188
                my $fh;
305
12
12
12
218
218
1327
10
44
172
3550
                { no autodie 'open'; open $fh, '<', $path or next }
306
218
1674
                my $line = <$fh>;
307
218
498
                close $fh;
308
218
12242
                next unless defined $line;
309
210
255
                chomp $line;
310
311
210
187
                my $sep;
312
210
353
                if ($ext eq 'psv') {
313
19
20
                        $sep = '|';
314                } else {
315                        # Sniff the separator: Database::Abstraction uses '!' natively and
316                        # sometimes stores those files with a .csv extension.  If splitting
317                        # on ',' yields a single field that itself contains '!', the real
318                        # separator is almost certainly '!'.
319
191
359
                        my @probe = split /,/, $line, -1;
320
191
630
                        $sep = (@probe == 1 && $line =~ /!/) ? '!' : ',';
321                }
322
323
210
716
                my @cols = split /\Q$sep\E/, $line;
324                # Two separate substitutions: the /g on an anchored alternation wastes
325                # O(N) engine cycles retrying \A (which can only match at position 0).
326
210
1064
1064
275
840
883
                for (@cols) { s/\A[\s"]+//; s/[\s"]+\z// }    # strip whitespace and quotes
327
210
1064
246
896
                @cols = grep { length } @cols;
328                return {
329
210
816
                        sep_char => $sep,
330                        id       => (@cols ? $cols[0] : undef),
331                        columns  => \@cols,
332                };
333        }
334
40
50
        return {};
335
12
12
12
3390
13
142
}
336
337# _init_backend( $self ) -> void
338#
339# Strategy: Database::Abstraction is designed as a base class where the
340# lowercased package name maps to the data file in the directory
341# (e.g. "Database::BI::_DB::Sales" -> data/sales.csv or data/sales.db).
342# We synthesise an ephemeral subclass at runtime so DataSource remains
343# fully table-agnostic and callers never need to touch Database::Abstraction
344# directly. In Phase 2, this method can be replaced with Database::Join
345# instantiation without any change to the public API.
346#
347# no_entry => 1: a BI viewer wants every row; we do not need O(1) keyed
348# lookups on a primary key.  This stores data as an arrayref instead of a
349# hashref, which the fast-track path in selectall_arrayref returns directly.
350sub _init_backend :Protected {
351
219
206
        my $self  = shift;
352
219
259
        my $table = $self->{_table};
353
219
206
        my $dir   = $self->{_directory};
354
355
219
4633
        require Database::Abstraction;
356
357
219
635507
        my $pkg = 'Database::BI::_DB::' . ucfirst($table);
358        {
359
12
12
12
219
1285
15
1277
209
                no strict 'refs';
360
219
53
1196
534
                push @{"${pkg}::ISA"}, 'Database::Abstraction'
361                        unless $pkg->isa('Database::Abstraction');
362        }
363
364
219
413
        my $info   = _detect_file_info($dir, $table);
365
219
474
        my $id_col = $info->{id} // 'entry';
366
219
343
        $self->{_id_col}  = $id_col;
367
219
310
        $self->{_columns} = $info->{columns};     # undef for SQLite/XML
368
369
219
167
        my $db = eval {
370                $pkg->new({
371                        directory => $dir,
372                        table     => $table,
373                        id        => $id_col,
374                        no_entry  => 1,
375
219
1161
                        defined($info->{sep_char}) ? (sep_char => $info->{sep_char}) : (),
376                });
377        };
378
219
638300
        if ($@) {
379
1
4
                croak $self->_msg('error_backend_init', $table, $@);
380        }
381
382
218
285
        $self->{_db} = $db;
383
218
364
        return;
384
12
12
12
24
10
96
}
385
386# ---------------------------------------------------------------------------
387# Public accessors
388# ---------------------------------------------------------------------------
389
390 - 414
=head1 ACCESSORS

=head2 table_name

Returns the (lowercased) table name this instance was opened against.

=head3 API SPECIFICATION

=head4 INPUT

None.

=head4 OUTPUT

Returns a C<SCALAR> string.

=head3 MESSAGES

None.

=head3 FORMAL SPECIFICATION

  table_name == lambda self . self._table

=cut
415
416sub table_name {
417
12
1029
        my $self = shift;
418
12
35
        return $self->{_table};
419}
420
421 - 426
=head2 columns

Returns an arrayref of column names in file order, or C<undef> when the
backend does not expose a fixed column order (e.g. SQLite, XML).

=cut
427
428sub columns {
429
192
898
        my $self = shift;
430
192
269
        return $self->{_columns};
431}
432
433 - 438
=head2 id_column

Returns the name of the column used as the primary key / slurp-filter anchor.
Returns C<undef> for URL/HTML-table backends (no primary-key concept applies).

=cut
439
440sub id_column {
441
25
845
        my $self = shift;
442
25
36
        return $self->{_id_col};
443}
444
445 - 450
=head2 source_url

Returns the source URL for URL/HTML-table-backed instances, or C<undef> for
file-backed instances.

=cut
451
452sub source_url {
453
2
6
        my $self = shift;
454
2
6
        return $self->{_url};
455}
456
457# ---------------------------------------------------------------------------
458# Public data-access methods
459# ---------------------------------------------------------------------------
460
461 - 497
=head1 METHODS

=head2 fetch_all

Returns every record in the table as an arrayref of hashrefs.

=head3 API SPECIFICATION

=head4 INPUT

None.  Filtering is performed at the controller layer (C<Dashboard::_apply_filter_spec>)
after C<fetch_all> returns, not inside C<DataSource>.

=head4 OUTPUT

        ARRAYREF of HASHREF   # one hashref per row, keys are column names
                              # returns [] when the table exists but is empty

Croaks if the backend raises an exception. Carps (non-fatal) when the result
set is empty so the caller can distinguish "open succeeded, no rows" from a
silent failure.

=head3 MESSAGES

  error_fetch_failed     -- backend threw an exception during retrieval
  warn_empty_result      -- query succeeded but returned zero records
  warn_data_normalised   -- backend returned a hashref; converted to arrayref

=head3 FORMAL SPECIFICATION

  fetch_all == lambda self .
    let rows = self._db.selectall_hashref() in
    pre  self._db /= undef
    post result : seq HASHREF
         /\ #result >= 0

=cut
498
499sub fetch_all {
500
206
15642
        my $self  = shift;
501
206
225
        my $table = $self->{_table};
502
503
206
206
176
526
        my $data = eval { $self->{_db}->selectall_hashref() };
504
206
1004571
        if ($@) {
505
16
85
                croak $self->_msg('error_fetch_failed', $table, $@);
506        }
507
508
190
302
        return [] unless defined $data;
509
510        # Strategy: Database::Abstraction can return either an arrayref (when the
511        # underlying driver iterates rows) or a hashref keyed by primary key (when
512        # it mirrors DBI's selectall_hashref semantics). We normalise to arrayref
513        # here so every caller above this layer sees a uniform structure.
514
185
300
        if (ref $data eq 'HASH') {
515
4
8
                carp $self->_msg('warn_data_normalised', $table);
516
4
4
380
7
                $data = [ values %{$data} ];
517        }
518
519
185
185
161
286
        if (!@{$data}) {
520
4
25
                carp $self->_msg('warn_empty_result', $table);
521        }
522
523
185
666
        return $data;
524}
525
5261;
527