/usr/share/perl5/DBM/Deep/Sector/File/Scalar.pm is in libdbm-deep-perl 2.0002-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 | package DBM::Deep::Sector::File::Scalar;
use 5.008_004;
use strict;
use warnings FATAL => 'all';
no warnings 'recursion';
use base qw( DBM::Deep::Sector::File::Data );
my $STALE_SIZE = 2;
# Please refer to the pack() documentation for further information
my %StP = (
1 => 'C', # Unsigned char value (no order needed as it's just one byte)
2 => 'n', # Unsigned short in "network" (big-endian) order
4 => 'N', # Unsigned long in "network" (big-endian) order
8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent)
);
sub free {
my $self = shift;
my $chain_loc = $self->chain_loc;
$self->SUPER::free();
if ( $chain_loc ) {
$self->engine->load_sector( $chain_loc )->free;
}
return;
}
sub _init {
my $self = shift;
my $engine = $self->engine;
unless ( $self->offset ) {
my $data_section = $self->size - $self->base_size - $engine->byte_size - 1;
$self->{offset} = $engine->_request_data_sector( $self->size );
my $data = delete $self->{data};
my $utf8 = do { no warnings 'utf8'; $data !~ /^[\0-\xff]*\z/ };
if($utf8){
if($engine->{v} < 4) {
DBM::Deep->_throw_error(
"This database format version is too old for Unicode"
);
}
utf8::encode $data;
$self->{type} = $engine->SIG_UNIDATA;
}
else { $self->{type} = $engine->SIG_DATA; }
my $dlen = length $data;
my $continue = 1;
my $curr_offset = $self->offset;
while ( $continue ) {
my $next_offset = 0;
my ($leftover, $this_len, $chunk);
if ( $dlen > $data_section ) {
$leftover = 0;
$this_len = $data_section;
$chunk = substr( $data, 0, $this_len );
$dlen -= $data_section;
$next_offset = $engine->_request_data_sector( $self->size );
$data = substr( $data, $this_len );
}
else {
$leftover = $data_section - $dlen;
$this_len = $dlen;
$chunk = $data;
$continue = 0;
}
$engine->storage->print_at( $curr_offset, $self->type ); # Sector type
# Skip staleness
$engine->storage->print_at( $curr_offset + $self->base_size,
pack( $StP{$engine->byte_size}, $next_offset ), # Chain loc
pack( $StP{1}, $this_len ), # Data length
$chunk, # Data to be stored in this sector
chr(0) x $leftover, # Zero-fill the rest
);
$curr_offset = $next_offset;
}
return;
}
}
sub data_length {
my $self = shift;
my $buffer = $self->engine->storage->read_at(
$self->offset + $self->base_size + $self->engine->byte_size, 1
);
return unpack( $StP{1}, $buffer );
}
sub chain_loc {
my $self = shift;
return unpack(
$StP{$self->engine->byte_size},
$self->engine->storage->read_at(
$self->offset + $self->base_size,
$self->engine->byte_size,
),
);
}
sub data {
my $self = shift;
my $engine = $self->engine;
my $data;
while ( 1 ) {
my $chain_loc = $self->chain_loc;
$data .= $engine->storage->read_at(
$self->offset + $self->base_size + $engine->byte_size + 1, $self->data_length,
);
last unless $chain_loc;
$self = $engine->load_sector( $chain_loc );
}
utf8::decode $data if $self->type eq $engine->SIG_UNIDATA;
return $data;
}
1;
__END__
|