AmberDB
view release on metacpan or search on metacpan
t/amberdb_array_sort.t
t/amberdb_backup.t
t/amberdb_bin_crop.t
t/amberdb_bin_ops.t
t/amberdb_cache.t
t/amberdb_cli.t
t/amberdb_connect_lifecycle.t
t/amberdb_date.t
t/amberdb_ecommerce_facet.t
t/amberdb_encapsulation.t
t/amberdb_escape_encode.t
t/amberdb_facet_columnar.t
t/amberdb_field_ops.t
t/amberdb_index.t
t/amberdb_inflate_deflate.t
t/amberdb_inmemory_cache.t
t/amberdb_journal.t
t/amberdb_junk_facet_integration.t
t/amberdb_junk_tiered.t
t/amberdb_lock.t
t/amberdb_match_unq.t
lib/AmberDB.pm view on Meta::CPAN
if ( $is_async_write && ( !$existing || !%$existing ) ) {
$existing = $self->recs_get( $file_path, @input_rids ) if -e $file_path;
}
my ( %statu, @pairs, @records_to_put );
foreach my $item (@valid_inputs) {
my ( $rid, @data ) = @$item;
my $old_raw = $existing->{$rid};
if ( !defined $old_raw ) {
my $rid_escape = $self->key_encode($rid);
if ( defined $rid_escape && $rid_escape ne $rid ) {
$old_raw = $existing->{$rid_escape};
}
if ( !defined $old_raw ) {
cluck "[DB_TIE] Not exist: $rid\n";
next;
}
}
@data = $self->enc_validate( $tableid, \@data );
if ($has_unique) {
lib/AmberDB.pm view on Meta::CPAN
or do { cluck "[DB_TIE] $tableid id and $file_path file path not exist\n"; return; };
my @fields;
if ( defined $clean_rid ) {
my $db = $self->{_db}->{$file_path} || $self->table_read($file_path);
if ($db) {
my $raw;
my $k = $self->utf_encode("$rid");
my $ret = $db->get( $k, $raw );
if ( $ret != 0 ) {
my $rid_escape = $self->key_encode($rid);
if ( defined $rid_escape && $rid_escape ne $rid ) {
my $k_esc = $self->utf_encode("$rid_escape");
$ret = $db->get( $k_esc, $raw );
}
}
if ( $ret == 0 && defined $raw ) {
@fields = ( $rid, $self->db_decode($raw) );
}
}
}
if ( $use_ramdisk == 3 && scalar @fields ) {
lib/AmberDB.pm view on Meta::CPAN
@records = @{ $records[0] };
}
my $links = {};
scalar @records or return $links;
my @lookup_keys;
my %esc_map;
foreach my $rid (@records) {
push @lookup_keys, $rid;
my $rid_escape = $self->key_encode($rid);
if ( defined $rid_escape && $rid_escape ne $rid ) {
push @lookup_keys, $rid_escape;
$esc_map{$rid} = $rid_escape;
}
}
my $lnk_path = "$table_path.lnk";
$self->table_read($lnk_path) or return $links;
my $recs_data = $self->recs_get( $lnk_path, @lookup_keys );
$self->table_close($lnk_path);
if ($recs_data) {
foreach my $rid (@records) {
my $rid_escape = $esc_map{$rid};
my $val = $recs_data->{$rid} // ( defined $rid_escape ? $recs_data->{$rid_escape} : undef );
if ( defined $val && $val ne '' ) {
$links->{$rid} = $val;
}
}
}
return $links;
}
# Returns first record by numerical order or specified sort block (alias to read_id with type => 'first').
# ------------------------------------------------
lib/AmberDB.pm view on Meta::CPAN
# ------------------------------------------------
sub table_readid {
my ( $self, $file_path, $rid ) = @_;
# Input validation
( $file_path and $rid ) or return;
return unless -e $file_path;
# Strip spaces and apply key encoding
my $rid_escape = $self->key_encode($rid);
my @lookup = ($rid);
push @lookup, $rid_escape if defined $rid_escape && $rid_escape ne $rid;
my $was_open = $self->{_db}->{$file_path} ? 1 : 0;
$self->table_read($file_path) or return;
my $res = $self->recs_get( $file_path, @lookup );
$self->table_close($file_path) unless $was_open;
my $fields = $res ? ( $res->{$rid} // ( defined $rid_escape ? $res->{$rid_escape} : undef ) ) : undef;
return $fields ? ( $rid, $self->db_decode($fields) ) : ();
}
# Checks presence of one or more keys in open DB_File table.
# Usage:
# my $exists = $adb->recs_exist($file_path, $rid); # Returns 1 or 0 (single key)
# my $map = $adb->recs_exist($file_path, @keys); # Returns { key1 => 1, key2 => 0, ... }
# ------------------------------------------------
sub recs_exist {
lib/AmberDB.pm view on Meta::CPAN
return unless -e "$table_path.aut";
return unless scalar @record_ids;
my $table_info = $self->table_info($tableid);
return unless $table_info->{log_owner};
my @lookup_keys;
my %esc_map;
foreach my $rid (@record_ids) {
$self->{_auth}->{$tableid}->{$rid} and next;
my $rid_escape = $self->key_encode($rid) // $rid;
push @lookup_keys, $rid_escape;
$esc_map{$rid} = $rid_escape;
}
return 1 unless @lookup_keys;
my $aut_path = "$table_path.aut";
$self->table_read($aut_path) or return 1;
my $res = $self->recs_get( $aut_path, @lookup_keys );
$self->table_close($aut_path);
if ($res) {
foreach my $rid (@record_ids) {
$self->{_auth}->{$tableid}->{$rid} and next;
my $rid_escape = $esc_map{$rid} // $rid;
my $val = $res->{$rid_escape} // $res->{$rid};
if ( defined $val && $val ne '' ) {
$self->{_auth}->{$tableid}->{$rid} = [ $self->db_decode($val) ];
}
}
}
return 1;
}
# Writes user/action audit to .aut file. Active when log_owner is enabled.
lib/AmberDB/Base/Encoder.pm view on Meta::CPAN
return $self->db_decode($record);
}
if ( $self && ref($self) ) {
$record = $self->utf_decode($record);
}
# drop line endings: chomp
$record =~ s/\R$//;
# FAST-PATH: Plain TSV record without escapes, entities, or nested tags
if ( index($record, "\\") == -1 && index($record, "<TAB") == -1 && index($record, "&#") == -1 && index($record, "ARRAY:") == -1 && index($record, "HASH:") == -1 ) {
my @fields = split( /\t/, $record, -1 );
return wantarray ? @fields : ( @fields == 1 ? $fields[0] : \@fields );
}
# 1. ERA 2019 - 2025: <TAB> Hierarchy (<TAB0>, <TAB1>, <TAB2>, <TAB3>)
if ( $record =~ /<TAB[0-9]+>/ ) {
my $white_decode = sub {
return map {
my $s = $_;
lib/AmberDB/Base/Encoder.pm view on Meta::CPAN
}
if ( defined $rid_prefix ) {
unshift @fields, $rid_prefix;
}
return wantarray ? @fields : ( @fields == 1 ? $fields[0] : \@fields );
}
# 2. ERA 2026: HTML entities (&, |, =) + ARRAY: / HASH:
if ( $record =~ /(?:ARRAY:|HASH:|&#(?:38|61|124|92|30);)/ ) {
my $unescape_chars = sub {
my ($str) = @_;
return "" unless defined $str;
$str =~ s/\\\\/\\/g;
$str =~ s/\\([nrt])/$1 eq 'n' ? "\n" : $1 eq 'r' ? "\r" : "\t"/eg;
$str =~ s/=/=/g;
$str =~ s/|/|/g;
$str =~ s//\x1e/g;
$str =~ s/\/\\/g;
$str =~ s/&/&/g;
return $str;
};
my $decode_node;
$decode_node = sub {
my ($field) = @_;
return "" unless defined $field;
if ( $field =~ /^ARRAY:(.*)/s ) {
my $payload = $1;
return [] if $payload eq "";
return [ map { $decode_node->( $unescape_chars->($_) ) } split( /\|/, $payload, -1 ) ];
}
elsif ( $field =~ /^HASH:(.*)/s ) {
my $payload = $1;
my %h;
if ( $payload ne "" ) {
for my $pair ( split( /\|/, $payload, -1 ) ) {
my ( $k, $v ) = split( /=/, $pair, 2 );
$h{ $unescape_chars->($k) } = $decode_node->( $unescape_chars->( $v // '' ) );
}
}
return \%h;
}
elsif ( $field =~ /\\T/ ) {
return [ map { $unescape_chars->($_) } split( /\\T/, $field, -1 ) ];
}
else {
return $unescape_chars->($field);
}
};
my @raw = split( /\t/, $record, -1 );
if ( @raw == 1 && $raw[0] =~ /^(?:ARRAY|HASH):/ ) {
my $res = $decode_node->( $raw[0] );
return wantarray ? ($res) : $res;
}
my @res = map { $decode_node->( $unescape_chars->($_) ) } @raw;
return wantarray ? @res : ( @res == 1 ? $res[0] : \@res );
}
# 3. ERA 2004 - 2006 & 2003: \t root, \T array delimiter, standard escapes
my $unescape_basic = sub {
my ($s) = @_;
return "" unless defined $s;
$s =~ s/\\(.)/$1 eq "t" ? "\t" : $1 eq "n" ? "\n" : $1 eq "r" ? "\r" : $1 eq "T" ? "\\T" : $1 eq "\\" ? "\\" : $1/eg;
return $s;
};
my @raw_fields = split( /\t/, $record, -1 );
@raw_fields = map { $unescape_basic->($_) } @raw_fields;
for my $line (@raw_fields) {
if ( defined $line && $line =~ /\\T/ ) {
my @parts = split( /\\T/, $line, -1 );
@parts = map { $unescape_basic->($_) } @parts;
$line = \@parts;
}
}
return wantarray ? @raw_fields : ( @raw_fields == 1 ? $raw_fields[0] : \@raw_fields );
}
# ------------------------------------------------
# tsv_encode: Legacy text encoder for CSV exports and text-mode pipelines
# ------------------------------------------------
sub tsv_encode {
my ( $self, @fields ) = @_;
return unless @fields;
my $encode_node;
$encode_node = sub {
my ($node) = @_;
if ( ref($node) eq "ARRAY" ) {
my @escaped = map { ref($_) ? $encode_node->($_) : $self->char_escape($_) } @$node;
return "ARRAY:" . join( "|", @escaped );
}
elsif ( ref($node) eq "HASH" ) {
my @escaped_pairs;
foreach my $k ( sort keys %$node ) {
my $safe_k = $self->char_escape($k);
my $safe_v = ref( $node->{$k} ) ? $encode_node->( $node->{$k} ) : $self->char_escape( $node->{$k} );
push @escaped_pairs, "$safe_k=$safe_v";
}
return "HASH:" . join( "|", @escaped_pairs );
}
else {
return $self->char_escape($node);
}
};
if ( @fields == 1 && ref( $fields[0] ) ) {
return $encode_node->( $fields[0] );
}
my @encoded = map { ref($_) ? $encode_node->($_) : $self->char_escape($_) } @fields;
return join( "\t", @encoded );
}
# ------------------------------------------------
sub char_escape {
my ( $self, $str ) = @_;
return "" unless defined $str;
# WARNING: Escape ampersand & first! (Double escaping logic)
$str =~ s/&/&/g; # ampersand
$str =~ s/\\/\/g; # backslash
$str =~ s/\|/|/g; # pipe (Array/Hash delimiter)
$str =~ s/=/=/g; # equals (Hash key-value delimiter)
$str =~ s/\x1e//g; # record separator (Transaction journal delimiter)
$str =~ s/\t/\\t/g; # tab
$str =~ s/\n/\\n/g; # newline
$str =~ s/\r/\\r/g; # carriage return
return $str;
}
# ------------------------------------------------
sub char_unescape {
my ( $self, $str ) = @_;
return "" unless defined $str;
$str =~ s{ (\\\\) | \\([nrt]) | &\#(92|61|124|38|30); }{
defined $1 ? "\\" :
defined $2 ? ( $2 eq 'n' ? "\n" : $2 eq 'r' ? "\r" : "\t" ) :
chr($3)
}gex;
return $str;
}
# encode like cgi escape
# my $sifresiz = $adb->uri_encode("sifreli");
# ------------------------------------------------
sub uri_encode {
my ( $self, $str ) = @_;
$str =~ s/([^A-Za-z0-9\-_.~])/sprintf("%%%02X", ord($1))/ge;
return $str;
}
# decode like cgi unescape
# my $sifresiz = $adb->uri_decode("sifresiz");
# ------------------------------------------------
sub uri_decode {
my ( $self, $str ) = @_;
$str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/ge;
return $str;
}
# my $key_escape = $adb->key_encode($key);
# ------------------------------------------------
sub key_encode {
my ( $self, $key ) = @_;
my $key_escape = "$key";
if ( $key_escape =~ /[^\w]/ ) {
if ( $self && ref($self) ) {
$key_escape = $self->to_ascii($key_escape);
}
$key_escape =~ s/[^\w]//g;
}
return $key_escape;
}
# =====================================================================
# FORMAT DETECTION & LEGACY DECODING (2003-2026 formats)
# =====================================================================
sub detect_record_format {
my ( $self, $record ) = @_;
return 'v5' if !defined $record || $record eq '';
t/amberdb_escape_encode.t view on Meta::CPAN
use File::Temp qw(tempdir);
use File::Spec;
use lib 'lib';
use AmberDB;
my $temp_dir = tempdir( CLEANUP => 1 );
my $adb = AmberDB->new( path => { dbase_dir => $temp_dir } );
isa_ok( $adb, 'AmberDB' );
# 1. char_escape & char_unescape unit tests
subtest 'char_escape and char_unescape roundtrip' => sub {
plan tests => 7;
# Test A: Windows path
my $win_path = 'C:\temp\notes\read.txt';
my $esc_win = $adb->char_escape($win_path);
is( $esc_win, 'C:\temp\notes\read.txt', 'Windows path escaped with \' );
my $unesc_win = $adb->char_unescape($esc_win);
is( $unesc_win, $win_path, 'Windows path unescaped correctly without TAB/LF corruption' );
# Test B: Literal TAB, LF, CR
my $ctrl_str = "Line1\nLine2\rLine3\tColumn";
my $esc_ctrl = $adb->char_escape($ctrl_str);
is( $esc_ctrl, "Line1\\nLine2\\rLine3\\tColumn", 'Control chars escaped as \n, \r, \t' );
my $unesc_ctrl = $adb->char_unescape($esc_ctrl);
is( $unesc_ctrl, $ctrl_str, 'Control chars unescaped correctly' );
# Test C: Delimiters and ampersand
my $delims = 'A & B | C = D \ End';
my $esc_delims = $adb->char_escape($delims);
is( $esc_delims, 'A & B | C = D &#92; End', 'Delimiters and & escaped' );
my $unesc_delims = $adb->char_unescape($esc_delims);
is( $unesc_delims, $delims, 'Delimiters unescaped correctly without double-decode' );
# Test D: Legacy \\ unescaping
my $legacy_str = 'C:\\\\temp\\\\notes';
my $unesc_legacy = $adb->char_unescape($legacy_str);
is( $unesc_legacy, 'C:\temp\notes', 'Legacy double-backslash unescaped correctly' );
};
# 2. db_encode & db_decode scalar roundtrip
subtest 'db_encode and db_decode scalar fields' => sub {
plan tests => 4;
my @orig_fields = (
101,
'C:\temp\app.log',
"Multi-line\ndescription\twith tab",
t/amberdb_security_paths.t view on Meta::CPAN
# ---------------------------------------------------------------------------
subtest '2. table_path resolution and subdirectory auto-creation' => sub {
plan tests => 3;
my $path1 = $adb->table_path("test_basic");
like( $path1, qr{test_basic$}, "Basic table path resolved" );
my $path2 = $adb->table_path("uyeler/bekleyen.uyeler");
like( $path2, qr{uyeler/bekleyen\.uyeler$}, "Subdirectory table path resolved" );
my $path3 = $adb->table_path("../../../escape_test");
unlike( $path3, qr{\.\.}, "Path traversal not present in resolved path" );
};
# ---------------------------------------------------------------------------
subtest '3. Simple Mode Arbitrary String ID Length' => sub {
plan tests => 4;
# Standard mode: only numeric positive integer allowed
$adb->config( simple => 0 );
$adb->table_attr( test_table => { use_simple => 0 } );
( run in 0.950 second using v1.01-cache-2.11-cpan-54e63673c56 )