AmberDB
view release on metacpan or search on metacpan
lib/AmberDB/Base.pm view on Meta::CPAN
# $data = $adb->set_charset($from, $to, $data);
# Converts between character encoding tables...
# ------------------------------------------------
sub set_charset {
my ( $self, $from, $to, $data ) = @_;
( $from && $to && $data ) or return;
return $data if ( $to eq "utf8" && utf8::is_utf8($data) );
return encode( $to, decode( $from, $data ) );
}
# Extracts search words from string...
# my %words = $self->get_words($string);
# my %words = $self->get_words($string, $write, $table);
# ------------------------------------------------
sub get_words {
my ( $self, $string, $action, $table ) = @_;
$string or return;
$string = $self->utf_decode($string);
if ( ref($string) eq 'ARRAY' ) {
$string = join " ", @$string;
}
my $is_write = ( $action && ( $action eq "write" || $action eq "1" ) ) ? 1 : 0;
my ( $minchar, %jump, %words );
# Get stop_word and min_char settings if table provided
if ( $table ) {
my $table_info = $self->table_info($table);
if ( $table_info->{stop_word} ) {
my $stop_word = $table_info->{stop_word};
$stop_word = $self->to_ascii($stop_word);
$stop_word = $self->trim_space($stop_word);
$stop_word = lc($stop_word);
%jump = map { $_ => 1 } split /\s+/, $stop_word;
}
$minchar = $table_info->{min_char} || 2;
}
foreach my $str ( split /\s+/, $string ) {
next if !$str;
my $str_val = $self->normalize_word( $str, $is_write );
foreach my $w ( split /\s+/, $str_val ) {
next if !$w;
next if ( $minchar && length($w) < $minchar );
next if $jump{$w};
$words{$w} = $w;
}
}
return %words;
}
# Normalizes and validates field values according to schema block definitions prior to encoding/writing.
# Usage:
# my @clean_fields = $adb->enc_validate($tableid, \@fields, $has_id);
# ------------------------------------------------
sub enc_validate {
my ( $self, $tableid, $fields_ref, $has_id ) = @_;
return wantarray ? () : [] unless defined $fields_ref;
my @fields = ( ref($fields_ref) eq 'ARRAY' ) ? @$fields_ref : ($fields_ref);
return wantarray ? @fields : \@fields unless @fields;
# Bypass in simple mode or when no tableid is given
return wantarray ? @fields : \@fields
if $self->config('simple') || !defined $tableid || $tableid eq '';
my $table_info = $self->table_info($tableid);
return wantarray ? @fields : \@fields
unless $table_info && ref($table_info->{blocks}) eq 'ARRAY' && @{ $table_info->{blocks} };
my @blocks = @{ $table_info->{blocks} };
my @cleaned;
for ( my $i = 0 ; $i < @fields ; $i++ ) {
my $blk_idx = $has_id ? $i : ( $i + 1 );
my $blk = $blocks[$blk_idx];
if ( !$blk && $table_info->{repeat_start} && $blk_idx >= $table_info->{repeat_start} ) {
$blk = $blocks[ $table_info->{repeat_start} ] // $blocks[-1];
}
my $val = $fields[$i];
if ( $blk && ref($blk) eq 'HASH' ) {
my $type = lc( $blk->{type} // 'text' );
my $valid = lc( $blk->{valid} // '' );
# 1. Type: number / num (integer, float, negative support)
if ( $type eq 'num' || $type eq 'number' || $type eq 'numeric' || $type eq 'int' || $type eq 'float' || $type eq 'decimal' ) {
if ( defined $val && length("$val") ) {
( my $trimmed = "$val" ) =~ s/^\s+|\s+$//g;
if ( $trimmed =~ /^[+-]?[0-9]+(?:\.[0-9]+)?$/ ) {
$val = 0 + $trimmed;
}
else {
$val = 0;
}
}
else {
$val = 0;
}
}
# 2. Type: ascii
elsif ( $type eq 'ascii' ) {
if ( defined $val && length("$val") ) {
$val = $self->to_ascii("$val");
}
else {
$val = '';
}
}
# 3. Type: date
elsif ( $type eq 'date' || $type eq 'datetime' || $type eq 'date_short' || $type eq 'date_long' ) {
if ( ( !defined $val || $val eq '' ) && $valid =~ /auto_date/ ) {
my $y = $self->{date}->{year} // ( 1900 + (localtime)[5] );
my $m = $self->{date}->{month} // sprintf( "%02d", (localtime)[4] + 1 );
my $d = $self->{date}->{day} // sprintf( "%02d", (localtime)[3] );
$val = "$y-$m-$d";
}
else {
$val //= '';
}
}
# 4. Type: array / repeat / loop
elsif ( $type eq 'array' || $type eq 'list' || $type eq 'repeat' || $type eq 'repeats' || $type eq 'loop' ) {
if ( defined $val ) {
if ( ref($val) eq 'ARRAY' ) {
# ok
}
elsif ( ref($val) ) {
$val = [$val];
}
elsif ( length("$val") ) {
$val = [ split /[,|]/, "$val" ];
}
else {
$val = [];
}
}
else {
$val = [];
}
}
# 5. Type: hash
elsif ( $type eq 'hash' || $type eq 'dict' || $type eq 'json' ) {
if ( defined $val && ref($val) eq 'HASH' ) {
# ok
}
else {
$val = {};
}
}
# 6. Type: text / string
elsif ( $type eq 'text' || $type eq 'string' || $type eq 'tinytext' || $type eq 'html' ) {
$val //= '';
}
# 7. Type: binary / base64
elsif ( $type eq 'binary' || $type eq 'base64' ) {
$val //= '';
}
# 8. Type: auto_id
elsif ( $type eq 'auto_id' || $type eq 'autoid' ) {
# auto_id is handled by table_autoid
}
}
push @cleaned, $val;
}
return wantarray ? @cleaned : \@cleaned;
}
# Normalizes and casts field values according to schema block definitions upon decoding/reading.
# Usage:
# my @decoded_fields = $adb->dec_validate($tableid, \@fields, $has_id);
# ------------------------------------------------
sub dec_validate {
my ( $self, $tableid, $fields_ref, $has_id ) = @_;
return wantarray ? () : [] unless defined $fields_ref;
my @fields = ( ref($fields_ref) eq 'ARRAY' ) ? @$fields_ref : ($fields_ref);
return wantarray ? @fields : \@fields unless @fields;
# Bypass in simple mode or when no tableid is given
return wantarray ? @fields : \@fields
if $self->config('simple') || !defined $tableid || $tableid eq '';
my $table_info = $self->table_info($tableid);
return wantarray ? @fields : \@fields
unless $table_info && ref($table_info->{blocks}) eq 'ARRAY' && @{ $table_info->{blocks} };
my @blocks = @{ $table_info->{blocks} };
my @cleaned;
for ( my $i = 0 ; $i < @fields ; $i++ ) {
my $blk_idx = $has_id ? $i : ( $i + 1 );
my $blk = $blocks[$blk_idx];
if ( !$blk && $table_info->{repeat_start} && $blk_idx >= $table_info->{repeat_start} ) {
$blk = $blocks[ $table_info->{repeat_start} ] // $blocks[-1];
}
my $val = $fields[$i];
if ( $blk && ref($blk) eq 'HASH' ) {
my $type = lc( $blk->{type} // 'text' );
# 1. Type: number / num -> Ensure numeric scalar (0 + $val)
if ( $type eq 'num' || $type eq 'number' || $type eq 'numeric' || $type eq 'int' || $type eq 'float' || $type eq 'decimal' ) {
if ( defined $val && length("$val") ) {
( my $trimmed = "$val" ) =~ s/^\s+|\s+$//g;
if ( $trimmed =~ /^[+-]?[0-9]+(?:\.[0-9]+)?$/ ) {
$val = 0 + $trimmed;
}
else {
$val = 0;
}
}
else {
$val = 0;
}
}
# 2. Type: array / repeat / loop -> Ensure ARRAY ref
elsif ( $type eq 'array' || $type eq 'list' || $type eq 'repeat' || $type eq 'repeats' || $type eq 'loop' ) {
if ( !defined $val ) {
$val = [];
}
elsif ( ref($val) ne 'ARRAY' ) {
$val = length("$val") ? [ split /[,|]/, "$val" ] : [];
}
}
# 3. Type: hash -> Ensure HASH ref
elsif ( $type eq 'hash' || $type eq 'dict' || $type eq 'json' ) {
if ( !defined $val || ref($val) ne 'HASH' ) {
$val = {};
}
}
# 4. Text / ASCII / Date / Binary
else {
lib/AmberDB/Base.pm view on Meta::CPAN
if ( defined $dbase_dir && $dbase_dir ne "." && $dbase_dir ne "" ) {
require File::Path;
for my $dir (
$self->{_path}->{dbase_dir},
$self->{_path}->{table_dir},
$self->{_path}->{schema_dir},
$self->{_path}->{backup_dir},
$self->{_path}->{buffer_dir},
$self->{_path}->{cache_dir},
$self->{_path}->{table_cache},
$self->{_path}->{schema_cache},
$self->{_path}->{lock_cache},
$self->{_path}->{txn_dir},
) {
if ( defined $dir && length($dir) && !$self->dir_exist($dir) ) {
eval { File::Path::make_path($dir) };
}
}
}
}
return 1;
}
# my $cfg_val = $adb->config("language");
# my $all_cfg = $adb->config();
# $adb->config(language => "en", no_write => 1);
# $adb->config({ language => "en", no_write => 1 });
# ------------------------------------------------
sub config {
my ( $self, @args ) = @_;
# 1. No arguments: return shallow copy of all configuration
if ( !@args ) {
return { %{ $self->{_cfg} || {} } };
}
# 2. Single scalar argument: getter -> $adb->config('language')
if ( @args == 1 && !ref( $args[0] ) ) {
return $self->{_cfg}->{ $args[0] };
}
# 3. Setter: key-value list or hashref
my %pairs = ( @args == 1 && ref( $args[0] ) eq 'HASH' ) ? %{ $args[0] } : @args;
# Internal dispatch table for side-effects
my $hooks = {
language => sub {
my $val = shift;
$self->{_cfg}->{language} = $val;
$self->_load_locale($val) if $self->can('_load_locale');
},
db_ext => sub {
my $val = shift;
$self->{_cfg}->{db_ext} = $val;
$self->{db_ext} = $val;
if ( defined $val && $val ne "db" ) {
$self->{_cfg}->{simple} = 1;
}
$self->_invalidate_table_paths();
},
simple => sub {
my $val = shift;
$self->{_cfg}->{simple} = $val ? 1 : 0;
$self->_invalidate_table_paths();
},
};
while ( my ( $key, $val ) = each %pairs ) {
if ( exists $hooks->{$key} ) {
$hooks->{$key}->($val);
}
else {
$self->{_cfg}->{$key} = $val;
}
}
return $self;
}
# my $dbase_dir = $adb->path("dbase_dir");
# my $paths_hash = $adb->path();
# $adb->path(schema_dir => "/custom/schema");
# ------------------------------------------------
sub path {
my ( $self, @args ) = @_;
# 1. No arguments: return shallow copy of all path mappings
if ( !@args ) {
return { %{ $self->{_path} || {} } };
}
# 2. Single scalar argument: getter -> $adb->path('dbase_dir')
if ( @args == 1 && !ref( $args[0] ) ) {
return $self->{_path}->{ $args[0] };
}
# 3. Setter: key-value list or hashref
my %pairs = ( @args == 1 && ref( $args[0] ) eq 'HASH' ) ? %{ $args[0] } : @args;
for my $key ( keys %pairs ) {
$self->{_path}->{$key} = $pairs{$key};
}
$self->_invalidate_table_paths();
return $self;
}
# Invalidate cached table paths if global path-affecting configurations change
# ------------------------------------------------
sub _invalidate_table_paths {
my ($self) = @_;
if ( $self->{_table} && ref( $self->{_table} ) eq 'HASH' ) {
for my $tbl ( keys %{ $self->{_table} } ) {
delete $self->{_table}->{$tbl}->{_path}
if ref( $self->{_table}->{$tbl} ) eq 'HASH';
}
}
}
# field_to_list and repeat_fields have been moved to AmberDB::Index.
# Index routines (facet_*, match_*, search_*, records_*, slug)
# have been moved to AmberDB::Index.
# my ($count, @records) = $adb->recs_cutting($start, $limit, @records);
# ------------------------------------------------
sub recs_cutting {
my ( $self, $start, $limit, @records ) = @_;
$start ||= 0;
$limit ||= 0;
$start = 0 if $start < 0;
my $count = scalar @records;
return ( $count, @records ) unless $limit;
my $end = ( $start + $limit ) > $count ? $count : ( $start + $limit );
@records = @records[ $start .. ( $end - 1 ) ];
return ( $count, @records );
}
# Minimal date helper without external dependencies.
# Populates $self->{date}: year, day_id, minute_id, second_id, str
# ------------------------------------------------
sub init_date {
my ($self) = @_;
if ( $self->can('get_date') ) {
$self->{date} = $self->get_date();
}
else {
my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime(time);
$year += 1900;
$mon += 1;
my $month = sprintf "%02d", $mon;
my $day = sprintf "%02d", $mday;
my $hr = sprintf "%02d", $hour;
my $mn = sprintf "%02d", $min;
my $sc = sprintf "%02d", $sec;
$self->{date} = {
year => $year,
day_id => "${year}${month}${day}",
minute_id => "${year}${month}${day}${hr}${mn}",
lib/AmberDB/Base.pm view on Meta::CPAN
=head1 TABLE NAMING CONVENTIONS
AmberDB enforces a strict, deterministic table naming convention:
=over 4
=item * B<Format:> All table identifiers must be lowercase alphanumeric characters using snake_case, formatted as C<E<lt>databaseE<gt>_E<lt>table_nameE<gt>> (e.g. C<catalog_product>, C<member_address>, C<orders_item>).
=item * B<Database Prefix:> The prefix prior to the first underscore (C<_>) represents the logical database/group schema name (mapped to C<E<lt>databaseE<gt>.dbase>).
=item * B<Schema Mapping:> A table named C<catalog_product> maps to schema file C<catalog_product.table> and database group configuration C<catalog.dbase>.
=item * B<Constraint:> Uppercase characters or mixed-case identifiers (such as C<Catalog_Product>) are not supported and will fail database group extraction.
=back
=head1 METHODS
=head2 db_encode(@fields)
Serializes a list of Perl values (scalars, array references, or hash references) into a tab-delimited flat-file line. Nested structures are encoded using internal prefixes (C<ARRAY:>, C<HASH:>) and escaped safely.
my $encoded = $adb->db_encode("101", "Product Name", [ "red", "blue" ], { stock => 5 });
=head2 db_decode($record)
Deserializes a tab-delimited flat-file line back into its native Perl data types. In list context, returns a list of fields; in scalar context, returns an array reference (or single field if only one column exists).
my @fields = $adb->db_decode($encoded);
=head2 char_escape($str) / char_unescape($str)
Escapes and unescapes structural control characters (tabs, newlines, pipes, equals signs, ampersands, record separators) into safe entity representations.
=head2 uri_encode($str) / uri_decode($str)
Percent-encodes and decodes strings for safe inclusion in URLs or HTTP query strings.
my $encoded_url = $adb->uri_encode("search query & params");
=head2 key_encode($key)
Transliterates non-alphanumeric characters into clean ASCII characters, stripping illegal symbols to produce safe disk filenames and index keys.
=head2 set_charset($from_encoding, $to_encoding, $data)
Transcodes text data between character encodings (e.g. C<'iso-8859-9'> to C<'utf8'>).
=head2 get_words($string, [$action], [$table])
Tokenizes C<$string> into search index keywords, stripping punctuation, applying language-specific stopwords, and normalizing casing.
my %words = $adb->get_words("Kablosuz Kulaklık & Aksesuarlar");
=head2 bin_encode(\@record_ids, [$id_type])
Packs a list of record IDs into a compact, fixed 8-byte binary buffer:
=over 4
=item * Numeric IDs (C<id_type =E<gt> 'num'>): Packed as 64-bit unsigned Big-Endian integers (C<QE<gt>>).
=item * ASCII IDs (C<id_type =E<gt> 'ascii'>): Packed as fixed 8-byte ASCII strings (C<a8>), strictly validated against 8-byte limits.
=back
my $packed_buffer = $adb->bin_encode([ 1, 2, 3 ], 'num');
=head2 bin_decode($binary_buffer, [$start], [$limit], [$direction], [$id_type])
Decodes an 8-byte binary buffer using O(1) C<substr> byte-offset slicing without unpacking the entire buffer into memory. Returns C<($total_count, @slice_ids)>.
=over 4
=item * C<$start>: 0-based record offset.
=item * C<$limit>: Maximum number of records to return (0 for all remaining).
=item * C<$direction>: C<'asc'> (default) or C<'desc'> (slices from the end).
=item * C<$id_type>: Optional C<'num'> or C<'ascii'> (auto-detected if omitted).
=back
my ($total, @page_ids) = $adb->bin_decode($packed_buffer, 0, 20, 'desc');
=head2 table_info($table_id)
Loads and returns the metadata schema hash for the specified table (e.g. C<catalog_product>). Automatically caches loaded schemas in memory.
my $schema = $adb->table_info("catalog_product");
=head2 dbase_info($dbase_name)
Loads and returns configuration settings for a logical database group (e.g. C<catalog>).
my $db_cfg = $adb->dbase_info("catalog");
=head2 table_path($table_id)
Resolves and returns the full absolute file system path (without file extension) for the target table based on its schema partition rules (dbase, year, section, language).
my $path_prefix = $adb->table_path("catalog_product");
=head2 flock_open($table_id, [$mode], [$record_id])
Acquires a file lock on a table or individual record. C<$mode> can be C<'write'> (exclusive C<LOCK_EX>, default) or C<'read'> (shared C<LOCK_SH>). Non-blocking; retries with exponential backoff.
$adb->flock_open("catalog_product", "write", 101);
=head2 flock_close($table_id, [$record_id])
Releases a table-level or record-level lock previously acquired by C<flock_open()>.
$adb->flock_close("catalog_product", 101);
=head2 Low-Level Database Accessors
=over 4
=item * C<recs_get($file_path, @keys)> — Fetches raw serialized values for given keys from an open C<DB_File> handle.
=item * C<recs_put($file_path, @records)> — Bulk writes C<[ $key, $val ]> pairs into an open C<DB_File> handle.
=item * C<recs_del($file_path, @keys)> — Deletes keys from an open C<DB_File> handle.
=item * C<recs_keys($file_path)> — Retrieves all keys sequentially from an open C<DB_File> handle using C-level cursor iterations.
=item * C<recs_scan($file_path, $mode_or_callback)> — Scans all entries in sequential order.
( run in 0.717 second using v1.01-cache-2.11-cpan-d01c6094234 )