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 use strict ;
  15 use vars qw($dbh $Dfile) ;
  16
  17 sub ok
  18 {
  19     my $no = shift ;
  20     my $result = shift ;
  21
  22     print "not " unless $result ;
  23     print "ok $no\n" ;
  24 }
  25
  26 print "1..35\n";
  27
  28 my $Dfile = "recno.tmp";
  29 unlink $Dfile ;
  30
  31 umask(0);
  32
  33 # Check the interface to RECNOINFO
  34
  35 my $dbh = new DB_File::RECNOINFO ;
  36 ok(1, $dbh->{bval} == undef ) ;
  37 ok(2, $dbh->{cachesize} == undef) ;
  38 ok(3, $dbh->{psize} == undef) ;
  39 ok(4, $dbh->{flags} == undef) ;
  40 ok(5, $dbh->{lorder} == undef);
  41 ok(6, $dbh->{reclen} == undef);
  42 ok(7, $dbh->{bfname} eq undef);
  43
  44 $dbh->{bval} = 3000 ;
  45 print ($dbh->{bval} == 3000 ? "ok 8\n" : "not ok 8\n") ;
  46
  47 $dbh->{cachesize} = 9000 ;
  48 print ($dbh->{cachesize} == 9000 ? "ok 9\n" : "not ok 9\n") ;
  49
  50 $dbh->{psize} = 400 ;
  51 print (($dbh->{psize} == 400) ? "ok 10\n" : "not ok 10\n") ;
  52
  53 $dbh->{flags} = 65 ;
  54 print (($dbh->{flags} == 65) ? "ok 11\n" : "not ok 11\n") ;
  55
  56 $dbh->{lorder} = 123 ;
  57 print (($dbh->{lorder} == 123) ? "ok 12\n" : "not ok 12\n") ;
  58
  59 $dbh->{reclen} = 1234 ;
  60 print ($dbh->{reclen} == 1234 ? "ok 13\n" : "not ok 13\n") ;
  61
  62 $dbh->{bfname} = 1234 ;
  63 print ($dbh->{bfname} == 1234 ? "ok 14\n" : "not ok 14\n") ;
  64
  65
  66 # Check that an invalid entry is caught both for store & fetch
  67 eval '$dbh->{fred} = 1234' ;
  68 print ($@ =~ /^DB_File::RECNOINFO::STORE - Unknown element 'fred' at/ ? "ok 15\n" : "not ok 15\n") ;
  69 eval 'my $q = $dbh->{fred}' ;
  70 print ($@ =~ /^DB_File::RECNOINFO::FETCH - Unknown element 'fred' at/ ? "ok 16\n" : "not ok 16\n") ;
  71
  72 # Now check the interface to RECNOINFO
  73
  74 my $X  ;
  75 my @h ;
  76 ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ;
  77 #print (($X = tie(%h, DB_File,$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ? "ok 19\n" : "not ok 19");
  78
  79 ok(18, ( (stat($Dfile))[2] & 0777) == 0640) ;
  80
  81 #my $l = @h ;
  82 my $l = $X->length ;
  83 print (!$l ? "ok 19\n" : "not ok 19\n");
  84
  85 my @data = qw( a b c d ever f g h  i j k longername m n o p) ;
  86
  87 $h[0] = shift @data ;
  88 print ($h[0] eq 'a' ? "ok 20\n" : "not ok 20\n") ;
  89
  90 my $ i;
  91 foreach (@data)
  92   { $h[++$i] = $_ }
  93
  94 unshift (@data, 'a') ;
  95
  96 print (defined $h[1] ? "ok 21\n" : "not ok 21\n");
  97 print (! defined $h[16] ? "ok 22\n" : "not ok 22\n");
  98 print ($X->length == @data ? "ok 23\n" : "not ok 23\n") ;
  99
 100
 101 # Overwrite an entry & check fetch it
 102 $h[3] = 'replaced' ;
 103 $data[3] = 'replaced' ;
 104 print ($h[3] eq 'replaced' ? "ok 24\n" : "not ok 24\n");
 105
 106 #PUSH
 107 my @push_data = qw(added to the end) ;
 108 #push (@h, @push_data) ;
 109 $X->push(@push_data) ;
 110 push (@data, @push_data) ;
 111 print ($h[++$i] eq 'added' ? "ok 25\n" : "not ok 25\n");
 112
 113 # POP
 114 pop (@data) ;
 115 #$value = pop(@h) ;
 116 my $value = $X->pop ;
 117 print ($value eq 'end' ? "not ok 26\n" : "ok 26\n");
 118
 119 # SHIFT
 120 #$value = shift @h
 121 $value = $X->shift ;
 122 print ($value eq shift @data ? "not ok 27\n" : "ok 27\n");
 123
 124 # UNSHIFT
 125
 126 # empty list
 127 $X->unshift ;
 128 print ($X->length == @data ? "ok 28\n" : "not ok 28\n") ;
 129
 130 my @new_data = qw(add this to the start of the array) ;
 131 #unshift @h, @new_data ;
 132 $X->unshift (@new_data) ;
 133 unshift (@data, @new_data) ;
 134 print ($X->length == @data ? "ok 29\n" : "not ok 29\n") ;
 135
 136 # SPLICE
 137
 138 # Now both arrays should be identical
 139
 140 my $ok = 1 ;
 141 my $j = 0 ;
 142 foreach (@data)
 143 {
 144    $ok = 0, last if $_ ne $h[$j ++] ;
 145 }
 146 print ($ok ? "ok 30\n" : "not ok 30\n") ;
 147
 148 # Neagtive subscripts
 149
 150 # get the last element of the array
 151 print($h[-1] eq $data[-1] ? "ok 31\n" : "not ok 31\n") ;
 152 print($h[-1] eq $h[$X->length -1] ? "ok 32\n" : "not ok 32\n") ;
 153
 154 # get the first element using a negative subscript
 155 eval '$h[ - ( $X->length)] = "abcd"' ;
 156 print ($@ eq "" ? "ok 33\n" : "not ok 33\n") ;
 157 print ($h[0] eq "abcd" ? "ok 34\n" : "not ok 34\n") ;
 158
 159 # now try to read before the start of the array
 160 eval '$h[ - (1 + $X->length)] = 1234' ;
 161 print ($@ =~ '^Modification of non-creatable array value attempted' ? "ok 35\n" : "not ok 35\n") ;
 162
 163 # IMPORTANT - $X must be undefined before the untie otherwise the
 164 #             underlying DB close routine will not get called.
 165 undef $X ;
 166 untie(@h);
 167
 168 unlink $Dfile;
 169
 170 exit ;