1#!./perl -w 2use strict; 3 4use Test::More; 5use Config; 6use File::Temp 'tempdir'; 7use File::Spec; 8use Fcntl qw( :mode ); 9 10BEGIN { 11 plan(skip_all => "GDBM_File was not built") 12 unless $Config{extensions} =~ /\bGDBM_File\b/; 13 14 plan(tests => 18); 15 use_ok('GDBM_File'); 16} 17 18use constant { 19 DUMP_ASCII => 0, 20 DUMP_BIN => 1, 21 DUMP_UNKNOWN => -1 22}; 23 24sub dump_format { 25 my $file = shift; 26 if (open(my $fd, '<', $file)) { 27 $_ = <$fd>; 28 if (/^# GDBM dump file created by GDBM version/) { 29 return DUMP_ASCII; 30 } 31 if (/^!\r$/) { 32 $_ = <$fd>; 33 if (/^! GDBM FLAT FILE DUMP -- THIS IS NOT A TEXT FILE/) { 34 return DUMP_BIN; 35 } 36 } 37 } 38 return DUMP_UNKNOWN; 39} 40 41my $wd = tempdir(CLEANUP => 1); 42my $dbname = File::Spec->catfile($wd, 'Op_dbmx'); 43my %h; 44my $db = tie(%h, 'GDBM_File', $dbname, GDBM_WRCREAT, 0640); 45isa_ok($db, 'GDBM_File'); 46SKIP: { 47 skip 'GDBM_File::dump not available', 16 48 unless $db->can('dump'); 49 50 $h{one} = '1'; 51 $h{two} = '2'; 52 $h{three} = '3'; 53 54 my $dumpname = "$dbname.dump"; 55 is(eval { $db->dump($dumpname); 1 }, 1, "Create ASCII dump"); 56 is(dump_format($dumpname), DUMP_ASCII, "ASCII dump created"); 57 is(eval { $db->dump($dumpname); 1 }, undef, "Refuse to overwrite existing dump"); 58 is(eval { $db->dump($dumpname, overwrite => 1); 1 }, 1, "Working overwrite option"); 59 60 my $binname = "$dbname.bin"; 61 is(eval { $db->dump($binname, binary => 1); 1 }, 1, "Create binary dump"); 62 is(dump_format($binname), DUMP_BIN, "Binary dump created"); 63 is(eval { $db->dump($binname, binary => 1); 1 }, undef, "Refuse to overwrite existing binary dump"); 64 is(eval { $db->dump($binname, binary => 1, overwrite => 1); 1 }, 1, "Working overwrite option (binary format)"); 65 66 untie %h; 67 $db->close; 68 69 # 70 # Test loading the database 71 # 72 73 $db = tie(%h, 'GDBM_File', $dbname, GDBM_NEWDB, 0640); 74 isa_ok($db, 'GDBM_File'); 75 76 is(eval { $db->load($dumpname); 1 }, 1, "Loading from ascii dump"); 77 is_deeply({map { $_ => $h{$_} } sort keys %h}, 78 { one => 1, two => 2, three => 3 }, 79 "Restored database content"); 80 81 is(eval { $db->load($dumpname); 1 }, undef, "Refuse to replace existing keys"); 82 83 is(eval { $db->load($dumpname, replace => 1); 1 }, 1, "Replace existing keys"); 84 85 untie %h; 86 $db->close; 87 88 # 89 # Test loading the database from binary dump 90 # 91 $db = tie(%h, 'GDBM_File', $dbname, GDBM_NEWDB, 0640); 92 isa_ok($db, 'GDBM_File'); 93 94 is(eval { $db->load($binname); 1 }, 1, "Loading from binary dump"); 95 is_deeply({map { $_ => $h{$_} } sort keys %h}, 96 { one => 1, two => 2, three => 3 }, 97 "Restored database content"); 98 99} 100 101 102