| File: | blib/lib/Database/BI/Model/DataSource.pm |
| Coverage: | 97.4% |
| line | stmt | bran | cond | sub | time | code |
|---|---|---|---|---|---|---|
| 1 | package 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 | ||||||
| 15 | our $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 | ||||||
| 25 | Readonly 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. | |||||
| 40 | Readonly 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. | |||||
| 52 | sub _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. | |||||
| 82 | sub _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). | |||||
| 93 | sub _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 | ||||||
| 173 | sub 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. | |||||
| 219 | sub _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. | |||||
| 250 | sub _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.). | |||||
| 296 | sub _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. | |||||
| 350 | sub _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 | ||||||
| 416 | sub 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 | ||||||
| 428 | sub 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 | ||||||
| 440 | sub 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 | ||||||
| 452 | sub 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 | ||||||
| 499 | sub 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 | ||||||
| 526 | 1; | |||||
| 527 | ||||||