t/lib/db-recno.t

   1 #!./perl
   2
   3 BEGIN {
   4     @INC = '../lib';
   5     require Config; import Config;
   6     if ($Config{'extensions'} !~ /\bDB_File\b/) {
   7         print "1..0\n";
   8         exit 0;
   9     }
  10 }
  11
  12 use DB_File;
  13 use Fcntl;
  14
  15 print "1..30\n";
  16
  17 $Dfile = "Op.db-recno";
  18 unlink $Dfile;
  19
  20 umask(0);
  21
  22 # Check the interface to RECNOINFO
  23
  24 $dbh = TIEHASH DB_File::RECNOINFO ;
  25 print (($dbh->{bval} == undef) ? "ok 1\n" : "not ok 1\n") ;
  26 print (($dbh->{cachesize} == undef) ? "ok 2\n" : "not ok 2\n") ;
  27 print (($dbh->{psize} == undef) ? "ok 3\n" : "not ok 3\n") ;
  28 print (($dbh->{flags} == undef) ? "ok 4\n" : "not ok 4\n") ;
  29 print (($dbh->{lorder} == undef) ? "ok 5\n" : "not ok 5\n") ;
  30 print (($dbh->{reclen} == undef) ? "ok 6\n" : "not ok 6\n") ;
  31 print (($dbh->{bfname} == undef) ? "ok 7\n" : "not ok 7\n") ;
  32
  33 $dbh->{bval} = 3000 ;
  34 print ($dbh->{bval} == 3000 ? "ok 8\n" : "not ok 8\n") ;
  35
  36 $dbh->{cachesize} = 9000 ;
  37 print ($dbh->{cachesize} == 9000 ? "ok 9\n" : "not ok 9\n") ;
  38
  39 $dbh->{psize} = 400 ;
  40 print (($dbh->{psize} == 400) ? "ok 10\n" : "not ok 10\n") ;
  41
  42 $dbh->{flags} = 65 ;
  43 print (($dbh->{flags} == 65) ? "ok 11\n" : "not ok 11\n") ;
  44
  45 $dbh->{lorder} = 123 ;
  46 print (($dbh->{lorder} == 123) ? "ok 12\n" : "not ok 12\n") ;
  47
  48 $dbh->{reclen} = 1234 ;
  49 print ($dbh->{reclen} == 1234 ? "ok 13\n" : "not ok 13\n") ;
  50
  51 $dbh->{bfname} = 1234 ;
  52 print ($dbh->{bfname} == 1234 ? "ok 14\n" : "not ok 14\n") ;
  53
  54
  55 # Check that an invalid entry is caught both for store & fetch
  56 eval '$dbh->{fred} = 1234' ;
  57 print ($@ eq '' ? "ok 15\n" : "not ok 15\n") ;
  58 eval '$q = $dbh->{fred}' ;
  59 print ($@ eq '' ? "ok 16\n" : "not ok 16\n") ;
  60
  61 # Now check the interface to RECNOINFO
  62
  63 print (($X = tie(@h, DB_File,$Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO )) ? "ok 17\n" : "not ok 17");
  64
  65 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  66    $blksize,$blocks) = stat($Dfile);
  67 print (($mode & 0777) == 0640 ? "ok 18\n" : "not ok 18\n");
  68
  69 #$l = @h ;
  70 $l = $X->length ;
  71 print (!$l ? "ok 19\n" : "not ok 19\n");
  72
  73 @data = qw( a b c d ever f g h  i j k longername m n o p) ;
  74
  75 $h[0] = shift @data ;
  76 print ($h[0] eq 'a' ? "ok 20\n" : "not ok 20\n") ;
  77
  78 foreach (@data)
  79   { $h[++$i] = $_ }
  80
  81 unshift (@data, 'a') ;
  82
  83 print (defined $h[1] ? "ok 21\n" : "not ok 21\n");
  84 print (! defined $h[16] ? "ok 22\n" : "not ok 22\n");
  85 print ($X->length == @data ? "ok 23\n" : "not ok 23\n") ;
  86
  87
  88 # Overwrite an entry & check fetch it
  89 $h[3] = 'replaced' ;
  90 $data[3] = 'replaced' ;
  91 print ($h[3] eq 'replaced' ? "ok 24\n" : "not ok 24\n");
  92
  93 #PUSH
  94 @push_data = qw(added to the end) ;
  95 #push (@h, @push_data) ;
  96 $X->push(@push_data) ;
  97 push (@data, @push_data) ;
  98 print ($h[++$i] eq 'added' ? "ok 25\n" : "not ok 25\n");
  99
 100 # POP
 101 pop (@data) ;
 102 #$value = pop(@h) ;
 103 $value = $X->pop ;
 104 print ($value eq 'end' ? "not ok 26\n" : "ok 26\n");
 105
 106 # SHIFT
 107 #$value = shift @h
 108 $value = $X->shift ;
 109 print ($value eq shift @data ? "not ok 27\n" : "ok 27\n");
 110
 111 # UNSHIFT
 112
 113 # empty list
 114 $X->unshift ;
 115 print ($X->length == @data ? "ok 28\n" : "not ok 28\n") ;
 116
 117 @new_data = qw(add this to the start of the array) ;
 118 #unshift @h, @new_data ;
 119 $X->unshift (@new_data) ;
 120 unshift (@data, @new_data) ;
 121 print ($X->length == @data ? "ok 29\n" : "not ok 29\n") ;
 122
 123 # SPLICE
 124
 125 # Now both arrays should be identical
 126
 127 $ok = 1 ;
 128 $j = 0 ;
 129 foreach (@data)
 130 {
 131    $ok = 0, last if $_ ne $h[$j ++] ;
 132 }
 133 print ($ok ? "ok 30\n" : "not ok 30\n") ;
 134
 135 # IMPORTANT - $X must be undefined before the untie otherwise the
 136 #             underlying DB close routine will not get called.
 137 undef $X ;
 138 untie(@h);
 139
 140 unlink $Dfile;
 141
 142 exit ;