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