1use strict; use warnings;
2package IO::All::DBM;
3
4use IO::All::File -base;
5use Fcntl;
6
7field _dbm_list => [];
8field '_dbm_class';
9field _dbm_extra => [];
10
11sub dbm {
12    my $self = shift;
13    bless $self, __PACKAGE__;
14    $self->_dbm_list([@_]);
15    return $self;
16}
17
18sub _assert_open {
19    my $self = shift;
20    return $self->tied_file
21      if $self->tied_file;
22    $self->open;
23}
24
25sub assert_filepath {
26    my $self = shift;
27    $self->SUPER::assert_filepath(@_);
28    if ($self->_rdonly and not -e $self->pathname) {
29        my $rdwr = $self->_rdwr;
30        $self->assert(0)->rdwr(1)->rdonly(0)->open;
31        $self->close;
32        $self->assert(1)->rdwr($rdwr)->rdonly(1);
33    }
34}
35
36sub open {
37    my $self = shift;
38    $self->is_open(1);
39    return $self->tied_file if $self->tied_file;
40    $self->assert_filepath if $self->_assert;
41    my $dbm_list = $self->_dbm_list;
42    my @dbm_list = @$dbm_list ? @$dbm_list :
43      (qw(DB_File GDBM_File NDBM_File ODBM_File SDBM_File));
44    my $dbm_class;
45    for my $module (@dbm_list) {
46        (my $file = "$module.pm") =~ s{::}{/}g;
47        if (defined $INC{$file} || eval "eval 'use $module; 1'") {
48            $self->_dbm_class($module);
49            last;
50        }
51    }
52    $self->throw("No module available for IO::All DBM operation")
53      unless defined $self->_dbm_class;
54    my $mode = $self->_rdonly ? O_RDONLY : O_RDWR;
55    if ($self->_dbm_class eq 'DB_File::Lock') {
56        $self->_dbm_class->import;
57        my $type = eval '$DB_HASH'; die $@ if $@;
58        # XXX Not sure about this warning
59        warn "Using DB_File::Lock in IO::All without the rdonly or rdwr method\n"
60          if not ($self->_rdwr or $self->_rdonly);
61        my $flag = $self->_rdwr ? 'write' : 'read';
62        $mode = $self->_rdwr ? O_RDWR : O_RDONLY;
63        $self->_dbm_extra([$type, $flag]);
64    }
65    $mode |= O_CREAT if $mode & O_RDWR;
66    $self->mode($mode);
67    $self->perms(0666) unless defined $self->perms;
68    return $self->tie_dbm;
69}
70
71sub tie_dbm {
72    my $self = shift;
73    my $hash;
74    my $filename = $self->name;
75    my $db = tie %$hash, $self->_dbm_class, $filename, $self->mode, $self->perms,
76        @{$self->_dbm_extra}
77      or $self->throw("Can't open '$filename' as DBM file:\n$!");
78    $self->add_utf8_dbm_filter($db)
79      if $self->_has_utf8;
80    $self->tied_file($hash);
81}
82
83sub add_utf8_dbm_filter {
84    my $self = shift;
85    my $db = shift;
86    $db->filter_store_key(sub { utf8::encode($_) });
87    $db->filter_store_value(sub { utf8::encode($_) });
88    $db->filter_fetch_key(sub { utf8::decode($_) });
89    $db->filter_fetch_value(sub { utf8::decode($_) });
90}
91
921;
93