1#!./perl -w 2 3use strict ; 4 5BEGIN { 6 unless(grep /blib/, @INC) { 7 chdir 't' if -d 't'; 8 @INC = '../lib' if -d '../lib'; 9 } 10} 11 12use lib 't'; 13use BerkeleyDB; 14use Test::More; 15use util; 16 17plan tests => 7; 18 19my $Dfile = "dbhash.tmp"; 20my $Dfile2 = "dbhash2.tmp"; 21my $Dfile3 = "dbhash3.tmp"; 22unlink $Dfile; 23 24umask(0) ; 25 26my $redirect = "xyzt" ; 27 28 29{ 30my $x = $BerkeleyDB::Error; 31my $redirect = "xyzt" ; 32 { 33 my $redirectObj = new Redirect $redirect ; 34 35## BEGIN simpleHash 36 use strict ; 37 use BerkeleyDB ; 38 use vars qw( %h $k $v ) ; 39 40 my $filename = "fruit" ; 41 unlink $filename ; 42 tie %h, "BerkeleyDB::Hash", 43 -Filename => $filename, 44 -Flags => DB_CREATE 45 or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ; 46 47 # Add a few key/value pairs to the file 48 $h{"apple"} = "red" ; 49 $h{"orange"} = "orange" ; 50 $h{"banana"} = "yellow" ; 51 $h{"tomato"} = "red" ; 52 53 # Check for existence of a key 54 print "Banana Exists\n\n" if $h{"banana"} ; 55 56 # Delete a key/value pair. 57 delete $h{"apple"} ; 58 59 # print the contents of the file 60 while (($k, $v) = each %h) 61 { print "$k -> $v\n" } 62 63 untie %h ; 64## END simpleHash 65 unlink $filename ; 66 } 67 68 #print "[" . docat($redirect) . "]" ; 69 is(docat_del($redirect), <<'EOM') ; 70Banana Exists 71 72orange -> orange 73tomato -> red 74banana -> yellow 75EOM 76 77 78} 79 80{ 81my $redirect = "xyzt" ; 82 { 83 84 my $redirectObj = new Redirect $redirect ; 85 86## BEGIN simpleHash2 87 use strict ; 88 use BerkeleyDB ; 89 90 my $filename = "fruit" ; 91 unlink $filename ; 92 my $db = new BerkeleyDB::Hash 93 -Filename => $filename, 94 -Flags => DB_CREATE 95 or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ; 96 97 # Add a few key/value pairs to the file 98 $db->db_put("apple", "red") ; 99 $db->db_put("orange", "orange") ; 100 $db->db_put("banana", "yellow") ; 101 $db->db_put("tomato", "red") ; 102 103 # Check for existence of a key 104 print "Banana Exists\n\n" if $db->db_get("banana", $v) == 0; 105 106 # Delete a key/value pair. 107 $db->db_del("apple") ; 108 109 # print the contents of the file 110 my ($k, $v) = ("", "") ; 111 my $cursor = $db->db_cursor() ; 112 while ($cursor->c_get($k, $v, DB_NEXT) == 0) 113 { print "$k -> $v\n" } 114 115 undef $cursor ; 116 undef $db ; 117## END simpleHash2 118 unlink $filename ; 119 } 120 121 #print "[" . docat($redirect) . "]" ; 122 is(docat_del($redirect), <<'EOM') ; 123Banana Exists 124 125orange -> orange 126tomato -> red 127banana -> yellow 128EOM 129 130} 131 132{ 133my $redirect = "xyzt" ; 134 { 135 136 my $redirectObj = new Redirect $redirect ; 137 138## BEGIN btreeSimple 139 use strict ; 140 use BerkeleyDB ; 141 142 my $filename = "tree" ; 143 unlink $filename ; 144 my %h ; 145 tie %h, 'BerkeleyDB::Btree', 146 -Filename => $filename, 147 -Flags => DB_CREATE 148 or die "Cannot open $filename: $! $BerkeleyDB::Error\n" ; 149 150 # Add a key/value pair to the file 151 $h{'Wall'} = 'Larry' ; 152 $h{'Smith'} = 'John' ; 153 $h{'mouse'} = 'mickey' ; 154 $h{'duck'} = 'donald' ; 155 156 # Delete 157 delete $h{"duck"} ; 158 159 # Cycle through the keys printing them in order. 160 # Note it is not necessary to sort the keys as 161 # the btree will have kept them in order automatically. 162 foreach (keys %h) 163 { print "$_\n" } 164 165 untie %h ; 166## END btreeSimple 167 unlink $filename ; 168 } 169 170 #print "[" . docat($redirect) . "]\n" ; 171 is(docat_del($redirect), <<'EOM') ; 172Smith 173Wall 174mouse 175EOM 176 177} 178 179{ 180my $redirect = "xyzt" ; 181 { 182 183 my $redirectObj = new Redirect $redirect ; 184 185## BEGIN btreeSortOrder 186 use strict ; 187 use BerkeleyDB ; 188 189 my $filename = "tree" ; 190 unlink $filename ; 191 my %h ; 192 tie %h, 'BerkeleyDB::Btree', 193 -Filename => $filename, 194 -Flags => DB_CREATE, 195 -Compare => sub { lc $_[0] cmp lc $_[1] } 196 or die "Cannot open $filename: $!\n" ; 197 198 # Add a key/value pair to the file 199 $h{'Wall'} = 'Larry' ; 200 $h{'Smith'} = 'John' ; 201 $h{'mouse'} = 'mickey' ; 202 $h{'duck'} = 'donald' ; 203 204 # Delete 205 delete $h{"duck"} ; 206 207 # Cycle through the keys printing them in order. 208 # Note it is not necessary to sort the keys as 209 # the btree will have kept them in order automatically. 210 foreach (keys %h) 211 { print "$_\n" } 212 213 untie %h ; 214## END btreeSortOrder 215 unlink $filename ; 216 } 217 218 #print "[" . docat($redirect) . "]\n" ; 219 is(docat_del($redirect), <<'EOM') ; 220mouse 221Smith 222Wall 223EOM 224 225} 226 227{ 228my $redirect = "xyzt" ; 229 { 230 231 my $redirectObj = new Redirect $redirect ; 232 233## BEGIN nullFilter 234 use strict ; 235 use BerkeleyDB ; 236 237 my %hash ; 238 my $filename = "filt.db" ; 239 unlink $filename ; 240 241 my $db = tie %hash, 'BerkeleyDB::Hash', 242 -Filename => $filename, 243 -Flags => DB_CREATE 244 or die "Cannot open $filename: $!\n" ; 245 246 # Install DBM Filters 247 $db->filter_fetch_key ( sub { s/\0$// } ) ; 248 $db->filter_store_key ( sub { $_ .= "\0" } ) ; 249 $db->filter_fetch_value( sub { s/\0$// } ) ; 250 $db->filter_store_value( sub { $_ .= "\0" } ) ; 251 252 $hash{"abc"} = "def" ; 253 my $a = $hash{"ABC"} ; 254 # ... 255 undef $db ; 256 untie %hash ; 257## END nullFilter 258 $db = tie %hash, 'BerkeleyDB::Hash', 259 -Filename => $filename, 260 -Flags => DB_CREATE 261 or die "Cannot open $filename: $!\n" ; 262 while (($k, $v) = each %hash) 263 { print "$k -> $v\n" } 264 undef $db ; 265 untie %hash ; 266 267 unlink $filename ; 268 } 269 270 #print "[" . docat($redirect) . "]\n" ; 271 is(docat_del($redirect), <<"EOM") ; 272abc\x00 -> def\x00 273EOM 274 275} 276 277{ 278my $redirect = "xyzt" ; 279 { 280 281 my $redirectObj = new Redirect $redirect ; 282 283## BEGIN intFilter 284 use strict ; 285 use BerkeleyDB ; 286 my %hash ; 287 my $filename = "filt.db" ; 288 unlink $filename ; 289 290 291 my $db = tie %hash, 'BerkeleyDB::Btree', 292 -Filename => $filename, 293 -Flags => DB_CREATE 294 or die "Cannot open $filename: $!\n" ; 295 296 $db->filter_fetch_key ( sub { $_ = unpack("i", $_) } ) ; 297 $db->filter_store_key ( sub { $_ = pack ("i", $_) } ) ; 298 $hash{123} = "def" ; 299 # ... 300 undef $db ; 301 untie %hash ; 302## END intFilter 303 $db = tie %hash, 'BerkeleyDB::Btree', 304 -Filename => $filename, 305 -Flags => DB_CREATE 306 or die "Cannot Open $filename: $!\n" ; 307 while (($k, $v) = each %hash) 308 { print "$k -> $v\n" } 309 undef $db ; 310 untie %hash ; 311 312 unlink $filename ; 313 } 314 315 my $val = pack("i", 123) ; 316 #print "[" . docat($redirect) . "]\n" ; 317 is(docat_del($redirect), <<"EOM") ; 318$val -> def 319EOM 320 321} 322 323{ 324my $redirect = "xyzt" ; 325 { 326 327 my $redirectObj = new Redirect $redirect ; 328 329 if ($FA) { 330## BEGIN simpleRecno 331 use strict ; 332 use BerkeleyDB ; 333 334 my $filename = "text" ; 335 unlink $filename ; 336 337 my @h ; 338 tie @h, 'BerkeleyDB::Recno', 339 -Filename => $filename, 340 -Flags => DB_CREATE, 341 -Property => DB_RENUMBER 342 or die "Cannot open $filename: $!\n" ; 343 344 # Add a few key/value pairs to the file 345 $h[0] = "orange" ; 346 $h[1] = "blue" ; 347 $h[2] = "yellow" ; 348 349 push @h, "green", "black" ; 350 351 my $elements = scalar @h ; 352 print "The array contains $elements entries\n" ; 353 354 my $last = pop @h ; 355 print "popped $last\n" ; 356 357 unshift @h, "white" ; 358 my $first = shift @h ; 359 print "shifted $first\n" ; 360 361 # Check for existence of a key 362 print "Element 1 Exists with value $h[1]\n" if $h[1] ; 363 364 untie @h ; 365## END simpleRecno 366 unlink $filename ; 367 } else { 368 use strict ; 369 use BerkeleyDB ; 370 371 my $filename = "text" ; 372 unlink $filename ; 373 374 my @h ; 375 my $db = tie @h, 'BerkeleyDB::Recno', 376 -Filename => $filename, 377 -Flags => DB_CREATE, 378 -Property => DB_RENUMBER 379 or die "Cannot open $filename: $!\n" ; 380 381 # Add a few key/value pairs to the file 382 $h[0] = "orange" ; 383 $h[1] = "blue" ; 384 $h[2] = "yellow" ; 385 386 $db->push("green", "black") ; 387 388 my $elements = $db->length() ; 389 print "The array contains $elements entries\n" ; 390 391 my $last = $db->pop ; 392 print "popped $last\n" ; 393 394 $db->unshift("white") ; 395 my $first = $db->shift ; 396 print "shifted $first\n" ; 397 398 # Check for existence of a key 399 print "Element 1 Exists with value $h[1]\n" if $h[1] ; 400 401 undef $db ; 402 untie @h ; 403 unlink $filename ; 404 } 405 406 } 407 408 #print "[" . docat($redirect) . "]\n" ; 409 is(docat_del($redirect), <<"EOM") ; 410The array contains 5 entries 411popped black 412shifted white 413Element 1 Exists with value blue 414EOM 415 416} 417 418