lang/perl/BerkeleyDB/t/examples.t

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