AmberDB
view release on metacpan or search on metacpan
lib/AmberDB.pm view on Meta::CPAN
# Deflate if records contain hashrefs or if single arrayref of hashes or HoH
if ( @records == 1 && ref($records[0]) eq 'ARRAY' && @{$records[0]} && ref($records[0]->[0]) eq 'HASH' ) {
@records = $self->deflate( $tableid, @{ $records[0] } );
}
elsif ( @records == 1 && ref($records[0]) eq 'HASH' ) {
@records = $self->deflate( $tableid, $records[0] );
}
elsif ( grep { ref($_) eq 'HASH' } @records ) {
@records = $self->deflate( $tableid, @records );
}
# Write authority cancelled.
$self->config('no_write')
and do { cluck "[DB_TIE] No authority to write to the file.\n"; return; };
my $table_info = $self->table_info($tableid);
my $is_simple = $self->config('simple') || ( $table_info && $table_info->{use_simple} );
my $table_path = $self->table_path($tableid);
my $file_path = "$table_path.$self->{db_ext}";
my $use_ramdisk = $table_info ? ( $table_info->{use_ramdisk} // $table_info->{use_cache} // 0 ) : 0;
$use_ramdisk = $self->_normalize_ramdisk_tier($use_ramdisk);
my $ramdisk_path;
if ($use_ramdisk) {
$self->ramdisk_ensure($tableid);
$ramdisk_path = $self->ramdisk_path($tableid);
}
my $is_txn = ( $self->{_txn} && $self->{_txn}->{active} ) ? 1 : 0;
my $is_async_write = ( $use_ramdisk == 4 && !$is_txn );
my $ram_file = $ramdisk_path ? "$ramdisk_path.$self->{db_ext}" : undef;
my $target_file = ( $is_async_write && $ram_file ) ? $ram_file : $file_path;
my $has_unique = ( $table_info->{valid} && grep { /unique/i } values %{ $table_info->{valid} } ) ? 1 : 0;
my $has_repeat = ( $table_info->{repeat} && %{ $table_info->{repeat} } ) ? 1 : 0;
my ( @valid_inputs, @input_rids );
foreach my $record (@records) {
my ( $rid, @data ) = @$record;
next unless $rid;
push @valid_inputs, [ $rid, @data ];
push @input_rids, $rid;
}
return {} unless @valid_inputs;
# Phase 1: raw writings
$self->table_write($target_file) or return {};
my $existing = $self->recs_get( $target_file, @input_rids );
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) {
my ( $unq_ok, $unq_err ) = $self->unique_check( $table_path, $table_info, $rid, \@data );
if ( !$unq_ok ) {
cluck "[DB_UNIQUE] $unq_err\n";
next;
}
}
my $new_record = [ $rid, @data ];
if ($has_repeat) {
$new_record = [ $self->repeat_fields( $table_info, @$new_record ) ];
}
push @records_to_put, $new_record;
$self->clear_cache( $tableid, $rid );
$statu{$rid} = 1;
my @old_rec = $old_raw ? ( $rid, $self->db_decode($old_raw) ) : ($rid);
my @new_rec = @$new_record;
push @pairs, [ $rid, \@old_rec, \@new_rec ];
}
if (@records_to_put) {
$self->recs_put( [ $target_file, $tableid ], @records_to_put );
if ($is_async_write) {
foreach my $rec (@records_to_put) {
$self->ramdisk_mark_dirty( $file_path, $rec->[0], 2 );
}
}
elsif ( $use_ramdisk == 4 && $is_txn ) {
foreach my $rec (@records_to_put) {
$self->ramdisk_unmark_dirty( $file_path, $rec->[0] );
}
}
}
$self->table_close($file_path);
$self->table_close($ram_file) if $ram_file;
return \%statu unless @pairs;
return \%statu if $is_simple;
my $idx_path = ( $use_ramdisk && $ramdisk_path ) ? $ramdisk_path : $table_path;
# Phase 2: bulk index updates
# 1. Base stream unconditional index updates
$self->search_modify( $idx_path, $table_info, $tableid, \@pairs );
$self->match_modify( $idx_path, $table_info, \@pairs );
# 2. Tiered stream updates
if ( $table_info->{use_junk} ) {
$self->junk_transition( $idx_path, $table_info, $tableid, \@pairs );
lib/AmberDB.pm view on Meta::CPAN
}
}
else {
# Standard primary key ID fallback
if ( $type eq 'rand' || $type eq 'random' ) {
$rid = $all_keys[ int( rand(@all_keys) ) ];
}
elsif ($want_smallest) {
my @sorted = ( $all_keys[0] =~ /^\d+$/ )
? sort { $a <=> $b } @all_keys
: sort { $a cmp $b } @all_keys;
$rid = $sorted[0];
}
else {
my @sorted = ( $all_keys[0] =~ /^\d+$/ )
? sort { $b <=> $a } @all_keys
: sort { $b cmp $a } @all_keys;
$rid = $sorted[0];
}
}
}
}
}
return unless defined $rid && $rid ne '';
my $can_alias = ( $table_info && $table_info->{use_alias} )
|| ( $table_info && $table_info->{force} )
|| $opt_force
|| $opt_get_links;
my $raw_rid = $rid;
my $clean_rid = $self->id_check( $tableid, $rid );
if ( defined $clean_rid && $clean_rid ne '' ) {
$rid = $clean_rid;
}
elsif ( !$can_alias ) {
return;
}
my $data_path = ( $use_ramdisk == 2 || $use_ramdisk == 4 ) ? $self->ramdisk_path($tableid) : $table_path;
my $file_path = "$data_path.$self->{db_ext}";
if ( ( $use_ramdisk == 2 || $use_ramdisk == 4 ) && !-e $file_path ) {
$file_path = "$table_path.$self->{db_ext}";
}
if ( $use_ramdisk == 3 ) {
return unless $self->_check_ramdisk_ttl( $tableid, $file_path );
return unless -e $file_path;
}
-e $file_path
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 ) {
utime( undef, undef, $file_path );
}
# Read from alias file if use_alias is configured, links/alias is requested, or .lnk file exists
if ( !scalar @fields && ( $can_alias || -e "$table_path.lnk" ) ) {
my $link_path = "$table_path.lnk";
my @link = $self->table_readid( $link_path, defined $clean_rid ? $clean_rid : $raw_rid );
if ( $link[1] ) {
$rid = $self->id_check( $tableid, $link[1] ) // $link[1];
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 && defined $raw ) {
@fields = ( $rid, $self->db_decode($raw) );
}
}
}
}
# Read from nodelete archive if FORCE or deleted is enabled
if ( !scalar @fields ) {
my $can_del = ( $table_info && $table_info->{force} && $table_info->{keep_deleted} )
|| ( $opt_force && ( !$table_info || $table_info->{keep_deleted} ) )
|| $opt_get_deleted;
if ($can_del) {
my $del_path = "$table_path.del";
@fields = $self->table_readid( $del_path, $rid );
}
}
# Increment read counter if enabled
my $should_count = defined $opt_counter
? $opt_counter
: ( $table_info && $table_info->{use_counter} ? 1 : 0 );
if ( ( scalar @fields ) && $should_count ) {
my $cnt_path = "$table_path.cnt";
$self->table_write($cnt_path);
my $value = $self->recs_get( $cnt_path, $rid );
$self->recs_put( $cnt_path, [ $rid, ++$value->{$rid} ] );
$self->table_close($cnt_path);
}
# Load access logs only if table tracks log_owner
if ( $table_info && $table_info->{log_owner} ) {
$self->auth_read( $tableid, $table_path, $rid );
}
lib/AmberDB.pm view on Meta::CPAN
my $recs_data = $self->recs_get( $file_path, @lookup_keys );
$self->table_close($file_path);
if ($recs_data) {
foreach my $orig_id (@$ids) {
my $rid = $links->{$orig_id} || $orig_id;
next if $rec_by_id{$rid};
my $key_esc = $esc_map{$rid};
my $value = $recs_data->{$rid} // ( defined $key_esc ? $recs_data->{$key_esc} : undef );
next unless defined $value && $value ne '';
my @decoded = $self->db_decode($value);
@decoded = $self->dec_validate( $tableid, \@decoded );
$rec_by_id{$rid} = [ $rid, @decoded ];
}
}
if ( $use_ramdisk == 3 && %rec_by_id ) {
utime( undef, undef, $file_path );
}
$self->auth_read( $tableid, $table_path, @$ids );
# Preserve exact requested ID order
my @records;
foreach my $orig_id (@$ids) {
my $rid = $links->{$orig_id} || $orig_id;
if ( my $rec = $rec_by_id{$rid} ) {
push @records, $rec;
}
}
return @records;
}
# my @records = $adb->read_links($tableid, @rids);
# Returns rid -> canonical_rid mapping from .lnk file.
# ------------------------------------------------
sub read_links {
my ( $self, $tableid, @records ) = @_;
$tableid or return;
scalar @records or return;
my $table_path = $self->table_path($tableid);
return unless -e "$table_path.$self->{db_ext}";
return unless -e "$table_path.lnk";
if ( (scalar @records) == 1 && ref $records[0] eq "ARRAY" ) {
@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').
# ------------------------------------------------
sub read_firstid {
my ( $self, $tableid, @args ) = @_;
$tableid or return;
my $opts = ( @args == 1 && ref($args[0]) eq 'HASH' ) ? { %{ $args[0] } }
: ( @args >= 2 && ref($args[1]) eq 'HASH' ) ? { %{ $args[1] } }
: ( @args && ref($args[-1]) eq 'HASH' ) ? { %{ $args[-1] } }
: ( @args && !ref($args[-1]) && $args[-1] =~ /^(?:inflate|counter|no_counter|deleted|alias|links)$/i ) ? { $args[-1] => 1 }
: ( @args == 1 && !ref($args[0]) && $args[0] ne '' && $args[0] ne '0' ) ? { sort => $args[0] }
: ( @args >= 2 && !ref($args[1]) && $args[1] ne '' && $args[1] ne '0' ) ? { sort => $args[1] }
: {};
$opts->{type} = 'first';
return $self->read_id( $tableid, 0, $opts );
}
# Returns last record by numerical order or specified sort block (alias to read_id with type => 'last').
# ------------------------------------------------
sub read_lastid {
my ( $self, $tableid, @args ) = @_;
$tableid or return;
my $opts = ( @args == 1 && ref($args[0]) eq 'HASH' ) ? { %{ $args[0] } }
: ( @args >= 2 && ref($args[1]) eq 'HASH' ) ? { %{ $args[1] } }
: ( @args && ref($args[-1]) eq 'HASH' ) ? { %{ $args[-1] } }
: ( @args && !ref($args[-1]) && $args[-1] =~ /^(?:inflate|counter|no_counter|deleted|alias|links)$/i ) ? { $args[-1] => 1 }
: ( @args == 1 && !ref($args[0]) && $args[0] ne '' && $args[0] ne '0' ) ? { sort => $args[0] }
: ( @args >= 2 && !ref($args[1]) && $args[1] ne '' && $args[1] ne '0' ) ? { sort => $args[1] }
: {};
$opts->{type} = 'last';
return $self->read_id( $tableid, 0, $opts );
}
# Returns random record (alias to read_id with type => 'rand').
# ------------------------------------------------
sub read_randid {
my ( $self, $tableid, @args ) = @_;
$tableid or return;
my $opts = ( @args == 1 && ref($args[0]) eq 'HASH' ) ? { %{ $args[0] } }
: ( @args >= 2 && ref($args[1]) eq 'HASH' ) ? { %{ $args[1] } }
: ( @args && ref($args[-1]) eq 'HASH' ) ? { %{ $args[-1] } }
: ( @args && !ref($args[-1]) && $args[-1] =~ /^(?:inflate|counter|no_counter|deleted|alias|links)$/i ) ? { $args[-1] => 1 }
: {};
$opts->{type} = 'rand';
return $self->read_id( $tableid, 0, $opts );
}
lib/AmberDB.pm view on Meta::CPAN
? "${safe_tid}_${safe_rid}"
: "${safe_tid}";
if ( my $existing = $self->{_lock}->{$lock_name} ) {
return $existing;
}
my $lock_file = "$lock_dir/${lock_name}.lock";
open my $fh, ">>", $lock_file or do {
cluck "[DB_LOCK] Cannot open lock file: $lock_file ($!)\n";
return;
};
my $flags = ( $mode eq "read" ) ? LOCK_SH : LOCK_EX;
flock( $fh, $flags );
$self->{_lock}->{$lock_name} = $fh;
return $fh;
}
# Unlocks and closes lock file for record or table.
# $adb->flock_close($table_id, [$record_id]);
# ------------------------------------------------
sub flock_close {
my ( $self, $tableid, $record_id ) = @_;
$tableid or return;
my $safe_tid = $self->sanitize_table($tableid);
$safe_tid =~ s{/}{-}g;
my $safe_rid = defined($record_id) ? "$record_id" : "";
$safe_rid =~ s{[^\w.\-]+}{}g;
my $lock_name = ( $safe_rid ne "" )
? "${safe_tid}_${safe_rid}"
: "${safe_tid}";
if ( my $fh = delete $self->{_lock}->{$lock_name} ) {
flock( $fh, LOCK_UN );
close $fh;
}
return 1;
}
# Reads directly from DB_File for a single key; returns decoded (rid, @fields).
# Legacy helper - recs_get preferred for bulk reads.
# my @fields = $adb->table_readid("file_path", $id);
# ------------------------------------------------
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 {
my ( $self, $file_path, @records ) = @_;
return unless $file_path;
return unless scalar @records;
# if not opened, open the table
if ( !$self->{_db}->{$file_path} ) {
$self->table_read($file_path)
or do { cluck "[DB_TIE] $file_path can't open for get.\n"; return; };
}
my $db = $self->{_db}->{$file_path};
my %result = ();
foreach my $rid (@records) {
my $k = $self->utf_encode("$rid");
my $val;
my $ret = $db->get( $k, $val );
$result{$rid} = ( $ret == 0 && defined $val ) ? 1 : 0;
}
if ( scalar @records == 1 ) {
return $result{ $records[0] };
}
return \%result;
}
# Reads all keys from DB_File handle in sequential order using C-level seq.
# Usage:
# my @keys = $adb->recs_keys($file_path);
# ------------------------------------------------
sub recs_keys {
my ( $self, $file_path ) = @_;
return $self->recs_scan( $file_path, 'keys' );
}
# Scans key-value pairs sequentially using DB_File seq.
# Usage:
# $adb->recs_scan($file_path, sub { my ($key, $val) = @_; ... }); # Custom callback
# my $hash = $adb->recs_scan($file_path); # Default / 'hash': { key => raw_val }
# my $keys = $adb->recs_scan($file_path, 'keys'); # 'keys': [$k1, $k2, ...] or ($k1, $k2, ...)
# my $values = $adb->recs_scan($file_path, 'values'); # 'values' / 'value': [$v1, $v2, ...] or ($v1, $v2, ...)
# my $pairs = $adb->recs_scan($file_path, 'each'); # 'each' / 'pairs': [ [$k1, $v1], ... ]
# my $count = $adb->recs_scan($file_path, 'count'); # 'count': total record count (scalar)
# ------------------------------------------------
sub recs_scan {
my ( $self, $file_path, $mode ) = @_;
return unless $file_path;
lib/AmberDB.pm view on Meta::CPAN
foreach my $record (@records) {
ref($record) eq "ARRAY" or $record = [$record];
my $rid = $record->[0];
my $bac_val = $self->db_encode( @{$record}[ 1 .. $#$record ] );
print $YAZ "$time_str\t$user\t$action\t$tableid\t$rid\t$bac_val\n";
}
close $YAZ;
return 1;
}
# my $view_pre = $adb->auth_view($tableid, $rid);
# Returns add/edit/del audit history on record as HTML <pre>.
# ------------------------------------------------
sub auth_view {
my ( $self, $tableid, $rid ) = @_;
return unless $rid;
return unless $tableid;
return unless ref $self->{_auth}->{$tableid}->{$rid} eq "ARRAY";
my $string;
foreach my $line ( @{ $self->{_auth}->{$tableid}->{$rid} } ) {
if ( ref $line eq "ARRAY" ) {
my $date = $self->dateid2str( $line->[2] );
if ( $line->[1] ne "edit" ) { $line->[1] .= " " }
$string .= " $line->[1]\t$date\t$line->[0]\n";
}
else {
$string .= "--> $line\n";
$string .= "----------------\n";
}
}
return $string;
}
# Loads record ownership audit trail into memory (_auth) from .aut file.
# AUTH called internally only from read_list and read_id.
# my $ok = $adb->auth_read($tableid, $table_path, @record_ids);
# ------------------------------------------------
sub auth_read {
my ( $self, $tableid, $table_path, @record_ids ) = @_;
return unless $tableid;
return unless -e "$table_path.$self->{db_ext}";
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.
# my $ok = $adb->auth_write($tableid, $table_path, "add|edit|del", $rid);
# ------------------------------------------------
sub auth_write {
my ( $self, $tableid, $table_path, $action, $rid ) = @_;
return unless $tableid;
my $table_info = $self->table_info($tableid);
return
unless ( $rid
&& $action
&& $table_path
&& $table_info->{record_index}
&& $table_info->{log_owner}
&& $action =~ /^(add|edit|del)$/ );
return unless -e "$table_path.$self->{db_ext}";
my $file_path = "$table_path.aut";
$self->table_write($file_path)
or do { cluck "[DB_TIE] $tableid -> $action, Autority write error. Can't open.\n"; return; };
my $value = $self->recs_get( $file_path, $rid );
my @record = $self->db_decode( $value->{$rid} );
my $user = $self->config('user') || 'user_system';
if ( !scalar @record ) {
if ( $action ne "add" ) {
@record = (
"root", [ "root", "add", $self->{date}->{year} . "01010000" ]
);
}
else {
@record = ( $user );
}
}
push @record,
[ $user, $action, $self->{date}->{minute_id} ];
$self->recs_put( [ $file_path, $tableid ], [ $rid, @record ] );
$self->table_close($file_path);
return 1;
}
# Cache and buffer methods have been moved to AmberDB::Cache.
# Transaction methods have been moved to AmberDB::Transact.
1;
__END__
( run in 0.918 second using v1.01-cache-2.11-cpan-54e63673c56 )