/usr/share/perl5/IO/All/DBM.pm is in libio-all-perl 0.87-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 | use strict; use warnings;
package IO::All::DBM;
use IO::All::File -base;
use Fcntl;
field _dbm_list => [];
field '_dbm_class';
field _dbm_extra => [];
sub dbm {
my $self = shift;
bless $self, __PACKAGE__;
$self->_dbm_list([@_]);
return $self;
}
sub _assert_open {
my $self = shift;
return $self->tied_file
if $self->tied_file;
$self->open;
}
sub assert_filepath {
my $self = shift;
$self->SUPER::assert_filepath(@_);
if ($self->_rdonly and not -e $self->pathname) {
my $rdwr = $self->_rdwr;
$self->assert(0)->rdwr(1)->rdonly(0)->open;
$self->close;
$self->assert(1)->rdwr($rdwr)->rdonly(1);
}
}
sub open {
my $self = shift;
$self->is_open(1);
return $self->tied_file if $self->tied_file;
$self->assert_filepath if $self->_assert;
my $dbm_list = $self->_dbm_list;
my @dbm_list = @$dbm_list ? @$dbm_list :
(qw(DB_File GDBM_File NDBM_File ODBM_File SDBM_File));
my $dbm_class;
for my $module (@dbm_list) {
(my $file = "$module.pm") =~ s{::}{/}g;
if (defined $INC{$file} || eval "eval 'use $module; 1'") {
$self->_dbm_class($module);
last;
}
}
$self->throw("No module available for IO::All DBM operation")
unless defined $self->_dbm_class;
my $mode = $self->_rdonly ? O_RDONLY : O_RDWR;
if ($self->_dbm_class eq 'DB_File::Lock') {
$self->_dbm_class->import;
my $type = eval '$DB_HASH'; die $@ if $@;
# XXX Not sure about this warning
warn "Using DB_File::Lock in IO::All without the rdonly or rdwr method\n"
if not ($self->_rdwr or $self->_rdonly);
my $flag = $self->_rdwr ? 'write' : 'read';
$mode = $self->_rdwr ? O_RDWR : O_RDONLY;
$self->_dbm_extra([$type, $flag]);
}
$mode |= O_CREAT if $mode & O_RDWR;
$self->mode($mode);
$self->perms(0666) unless defined $self->perms;
return $self->tie_dbm;
}
sub tie_dbm {
my $self = shift;
my $hash;
my $filename = $self->name;
my $db = tie %$hash, $self->_dbm_class, $filename, $self->mode, $self->perms,
@{$self->_dbm_extra}
or $self->throw("Can't open '$filename' as DBM file:\n$!");
$self->add_utf8_dbm_filter($db)
if $self->_has_utf8;
$self->tied_file($hash);
}
sub add_utf8_dbm_filter {
my $self = shift;
my $db = shift;
$db->filter_store_key(sub { utf8::encode($_) });
$db->filter_store_value(sub { utf8::encode($_) });
$db->filter_fetch_key(sub { utf8::decode($_) });
$db->filter_fetch_value(sub { utf8::decode($_) });
}
1;
|