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