t/lib/db-recno.t

   1 #!./perl -w
   2
   3 BEGIN {
   4     unshift @INC, '../lib' if -d '../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 $bad_ones $FA) ;
  16
  17 # full tied array support started in Perl 5.004_57
  18 # Double check to see if it is available.
  19
  20 {
  21     sub try::TIEARRAY { bless [], "try" }
  22     sub try::FETCHSIZE { $FA = 1 }
  23     $FA = 0 ;
  24     my @a ;
  25     tie @a, 'try' ;
  26     my $a = @a ;
  27 }
  28
  29
  30 sub ok
  31 {
  32     my $no = shift ;
  33     my $result = shift ;
  34
  35     print "not " unless $result ;
  36     print "ok $no\n" ;
  37
  38     return $result ;
  39 }
  40
  41 sub bad_one
  42 {
  43     print STDERR <<EOM unless $bad_ones++ ;
  44 #
  45 # Some older versions of Berkeley DB will fail tests 51, 53 and 55.
  46 #
  47 # You can safely ignore the errors if you're never going to use the
  48 # broken functionality (recno databases with a modified bval).
  49 # Otherwise you'll have to upgrade your DB library.
  50 #
  51 # If you want to upgrade Berkeley DB, the most recent version is 1.85.
  52 # Check out http://www.bostic.com/db for more details.
  53 #
  54 EOM
  55 }
  56
  57 print "1..78\n";
  58
  59 my $Dfile = "recno.tmp";
  60 unlink $Dfile ;
  61
  62 umask(0);
  63
  64 # Check the interface to RECNOINFO
  65
  66 my $dbh = new DB_File::RECNOINFO ;
  67 ok(1, ! defined $dbh->{bval}) ;
  68 ok(2, ! defined $dbh->{cachesize}) ;
  69 ok(3, ! defined $dbh->{psize}) ;
  70 ok(4, ! defined $dbh->{flags}) ;
  71 ok(5, ! defined $dbh->{lorder}) ;
  72 ok(6, ! defined $dbh->{reclen}) ;
  73 ok(7, ! defined $dbh->{bfname}) ;
  74
  75 $dbh->{bval} = 3000 ;
  76 ok(8, $dbh->{bval} == 3000 );
  77
  78 $dbh->{cachesize} = 9000 ;
  79 ok(9, $dbh->{cachesize} == 9000 );
  80
  81 $dbh->{psize} = 400 ;
  82 ok(10, $dbh->{psize} == 400 );
  83
  84 $dbh->{flags} = 65 ;
  85 ok(11, $dbh->{flags} == 65 );
  86
  87 $dbh->{lorder} = 123 ;
  88 ok(12, $dbh->{lorder} == 123 );
  89
  90 $dbh->{reclen} = 1234 ;
  91 ok(13, $dbh->{reclen} == 1234 );
  92
  93 $dbh->{bfname} = 1234 ;
  94 ok(14, $dbh->{bfname} == 1234 );
  95
  96
  97 # Check that an invalid entry is caught both for store & fetch
  98 eval '$dbh->{fred} = 1234' ;
  99 ok(15, $@ =~ /^DB_File::RECNOINFO::STORE - Unknown element 'fred' at/ );
 100 eval 'my $q = $dbh->{fred}' ;
 101 ok(16, $@ =~ /^DB_File::RECNOINFO::FETCH - Unknown element 'fred' at/ );
 102
 103 # Now check the interface to RECNOINFO
 104
 105 my $X  ;
 106 my @h ;
 107 ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ;
 108
 109 ok(18, ((stat($Dfile))[2] & 0777) == ($^O eq 'os2' ? 0666 : 0640)
 110         ||  $^O eq 'MSWin32' || $^O eq 'amigaos') ;
 111
 112 #my $l = @h ;
 113 my $l = $X->length ;
 114 ok(19, ($FA ? @h == 0 : !$l) );
 115
 116 my @data = qw( a b c d ever f g h  i j k longername m n o p) ;
 117
 118 $h[0] = shift @data ;
 119 ok(20, $h[0] eq 'a' );
 120
 121 my $ i;
 122 foreach (@data)
 123   { $h[++$i] = $_ }
 124
 125 unshift (@data, 'a') ;
 126
 127 ok(21, defined $h[1] );
 128 ok(22, ! defined $h[16] );
 129 ok(23, $FA ? @h == @data : $X->length == @data );
 130
 131
 132 # Overwrite an entry & check fetch it
 133 $h[3] = 'replaced' ;
 134 $data[3] = 'replaced' ;
 135 ok(24, $h[3] eq 'replaced' );
 136
 137 #PUSH
 138 my @push_data = qw(added to the end) ;
 139 ($FA ? push(@h, @push_data) : $X->push(@push_data)) ;
 140 push (@data, @push_data) ;
 141 ok(25, $h[++$i] eq 'added' );
 142 ok(26, $h[++$i] eq 'to' );
 143 ok(27, $h[++$i] eq 'the' );
 144 ok(28, $h[++$i] eq 'end' );
 145
 146 # POP
 147 my $popped = pop (@data) ;
 148 my $value = ($FA ? pop @h : $X->pop) ;
 149 ok(29, $value eq $popped) ;
 150
 151 # SHIFT
 152 $value = ($FA ? shift @h : $X->shift) ;
 153 my $shifted = shift @data ;
 154 ok(30, $value eq $shifted );
 155
 156 # UNSHIFT
 157
 158 # empty list
 159 ($FA ? unshift @h : $X->unshift) ;
 160 ok(31, ($FA ? @h == @data : $X->length == @data ));
 161
 162 my @new_data = qw(add this to the start of the array) ;
 163 $FA ? unshift (@h, @new_data) : $X->unshift (@new_data) ;
 164 unshift (@data, @new_data) ;
 165 ok(32, $FA ? @h == @data : $X->length == @data );
 166 ok(33, $h[0] eq "add") ;
 167 ok(34, $h[1] eq "this") ;
 168 ok(35, $h[2] eq "to") ;
 169 ok(36, $h[3] eq "the") ;
 170 ok(37, $h[4] eq "start") ;
 171 ok(38, $h[5] eq "of") ;
 172 ok(39, $h[6] eq "the") ;
 173 ok(40, $h[7] eq "array") ;
 174 ok(41, $h[8] eq $data[8]) ;
 175
 176 # SPLICE
 177
 178 # Now both arrays should be identical
 179
 180 my $ok = 1 ;
 181 my $j = 0 ;
 182 foreach (@data)
 183 {
 184    $ok = 0, last if $_ ne $h[$j ++] ;
 185 }
 186 ok(42, $ok );
 187
 188 # Neagtive subscripts
 189
 190 # get the last element of the array
 191 ok(43, $h[-1] eq $data[-1] );
 192 ok(44, $h[-1] eq $h[ ($FA ? @h : $X->length) -1] );
 193
 194 # get the first element using a negative subscript
 195 eval '$h[ - ( $FA ? @h : $X->length)] = "abcd"' ;
 196 ok(45, $@ eq "" );
 197 ok(46, $h[0] eq "abcd" );
 198
 199 # now try to read before the start of the array
 200 eval '$h[ - (1 + ($FA ? @h : $X->length))] = 1234' ;
 201 ok(47, $@ =~ '^Modification of non-creatable array value attempted' );
 202
 203 # IMPORTANT - $X must be undefined before the untie otherwise the
 204 #             underlying DB close routine will not get called.
 205 undef $X ;
 206 untie(@h);
 207
 208 unlink $Dfile;
 209
 210 sub docat
 211 {
 212     my $file = shift;
 213     local $/ = undef;
 214     open(CAT,$file) || die "Cannot open $file:$!";
 215     my $result = <CAT>;
 216     close(CAT);
 217     return $result;
 218 }
 219
 220
 221 {
 222     # Check bval defaults to \n
 223
 224     my @h = () ;
 225     my $dbh = new DB_File::RECNOINFO ;
 226     ok(48, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
 227     $h[0] = "abc" ;
 228     $h[1] = "def" ;
 229     $h[3] = "ghi" ;
 230     untie @h ;
 231     my $x = docat($Dfile) ;
 232     unlink $Dfile;
 233     ok(49, $x eq "abc\ndef\n\nghi\n") ;
 234 }
 235
 236 {
 237     # Change bval
 238
 239     my @h = () ;
 240     my $dbh = new DB_File::RECNOINFO ;
 241     $dbh->{bval} = "-" ;
 242     ok(50, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
 243     $h[0] = "abc" ;
 244     $h[1] = "def" ;
 245     $h[3] = "ghi" ;
 246     untie @h ;
 247     my $x = docat($Dfile) ;
 248     unlink $Dfile;
 249     my $ok = ($x eq "abc-def--ghi-") ;
 250     bad_one() unless $ok ;
 251     ok(51, $ok) ;
 252 }
 253
 254 {
 255     # Check R_FIXEDLEN with default bval (space)
 256
 257     my @h = () ;
 258     my $dbh = new DB_File::RECNOINFO ;
 259     $dbh->{flags} = R_FIXEDLEN ;
 260     $dbh->{reclen} = 5 ;
 261     ok(52, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
 262     $h[0] = "abc" ;
 263     $h[1] = "def" ;
 264     $h[3] = "ghi" ;
 265     untie @h ;
 266     my $x = docat($Dfile) ;
 267     unlink $Dfile;
 268     my $ok = ($x eq "abc  def       ghi  ") ;
 269     bad_one() unless $ok ;
 270     ok(53, $ok) ;
 271 }
 272
 273 {
 274     # Check R_FIXEDLEN with user-defined bval
 275
 276     my @h = () ;
 277     my $dbh = new DB_File::RECNOINFO ;
 278     $dbh->{flags} = R_FIXEDLEN ;
 279     $dbh->{bval} = "-" ;
 280     $dbh->{reclen} = 5 ;
 281     ok(54, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
 282     $h[0] = "abc" ;
 283     $h[1] = "def" ;
 284     $h[3] = "ghi" ;
 285     untie @h ;
 286     my $x = docat($Dfile) ;
 287     unlink $Dfile;
 288     my $ok = ($x eq "abc--def-------ghi--") ;
 289     bad_one() unless $ok ;
 290     ok(55, $ok) ;
 291 }
 292
 293 {
 294     # check that attempting to tie an associative array to a DB_RECNO will fail
 295
 296     my $filename = "xyz" ;
 297     my %x ;
 298     eval { tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO ; } ;
 299     ok(56, $@ =~ /^DB_File can only tie an array to a DB_RECNO database/) ;
 300     unlink $filename ;
 301 }
 302
 303 {
 304    # sub-class test
 305
 306    package Another ;
 307
 308    use strict ;
 309
 310    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
 311    print FILE <<'EOM' ;
 312
 313    package SubDB ;
 314
 315    use strict ;
 316    use vars qw( @ISA @EXPORT) ;
 317
 318    require Exporter ;
 319    use DB_File;
 320    @ISA=qw(DB_File);
 321    @EXPORT = @DB_File::EXPORT ;
 322
 323    sub STORE {
 324         my $self = shift ;
 325         my $key = shift ;
 326         my $value = shift ;
 327         $self->SUPER::STORE($key, $value * 2) ;
 328    }
 329
 330    sub FETCH {
 331         my $self = shift ;
 332         my $key = shift ;
 333         $self->SUPER::FETCH($key) - 1 ;
 334    }
 335
 336    sub put {
 337         my $self = shift ;
 338         my $key = shift ;
 339         my $value = shift ;
 340         $self->SUPER::put($key, $value * 3) ;
 341    }
 342
 343    sub get {
 344         my $self = shift ;
 345         $self->SUPER::get($_[0], $_[1]) ;
 346         $_[1] -= 2 ;
 347    }
 348
 349    sub A_new_method
 350    {
 351         my $self = shift ;
 352         my $key = shift ;
 353         my $value = $self->FETCH($key) ;
 354         return "[[$value]]" ;
 355    }
 356
 357    1 ;
 358 EOM
 359
 360     close FILE ;
 361
 362     BEGIN { push @INC, '.'; }
 363     eval 'use SubDB ; ';
 364     main::ok(57, $@ eq "") ;
 365     my @h ;
 366     my $X ;
 367     eval '
 368         $X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO );
 369         ' ;
 370
 371     main::ok(58, $@ eq "") ;
 372
 373     my $ret = eval '$h[3] = 3 ; return $h[3] ' ;
 374     main::ok(59, $@ eq "") ;
 375     main::ok(60, $ret == 5) ;
 376
 377     my $value = 0;
 378     $ret = eval '$X->put(1, 4) ; $X->get(1, $value) ; return $value' ;
 379     main::ok(61, $@ eq "") ;
 380     main::ok(62, $ret == 10) ;
 381
 382     $ret = eval ' R_NEXT eq main::R_NEXT ' ;
 383     main::ok(63, $@ eq "" ) ;
 384     main::ok(64, $ret == 1) ;
 385
 386     $ret = eval '$X->A_new_method(1) ' ;
 387     main::ok(65, $@ eq "") ;
 388     main::ok(66, $ret eq "[[11]]") ;
 389
 390     undef $X;
 391     untie(@h);
 392     unlink "SubDB.pm", "recno.tmp" ;
 393
 394 }
 395
 396 {
 397
 398     # test $#
 399     my $self ;
 400     unlink $Dfile;
 401     ok(67, $self = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ;
 402     $h[0] = "abc" ;
 403     $h[1] = "def" ;
 404     $h[2] = "ghi" ;
 405     $h[3] = "jkl" ;
 406     ok(68, $FA ? $#h == 3 : $self->length() == 4) ;
 407     undef $self ;
 408     untie @h ;
 409     my $x = docat($Dfile) ;
 410     ok(69, $x eq "abc\ndef\nghi\njkl\n") ;
 411
 412     # $# sets array to same length
 413     ok(70, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
 414     if ($FA)
 415       { $#h = 3 }
 416     else
 417       { $self->STORESIZE(4) }
 418     ok(71, $FA ? $#h == 3 : $self->length() == 4) ;
 419     undef $self ;
 420     untie @h ;
 421     $x = docat($Dfile) ;
 422     ok(72, $x eq "abc\ndef\nghi\njkl\n") ;
 423
 424     # $# sets array to bigger
 425     ok(73, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
 426     if ($FA)
 427       { $#h = 6 }
 428     else
 429       { $self->STORESIZE(7) }
 430     ok(74, $FA ? $#h == 6 : $self->length() == 7) ;
 431     undef $self ;
 432     untie @h ;
 433     $x = docat($Dfile) ;
 434     ok(75, $x eq "abc\ndef\nghi\njkl\n\n\n\n") ;
 435
 436     # $# sets array smaller
 437     ok(76, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
 438     if ($FA)
 439       { $#h = 2 }
 440     else
 441       { $self->STORESIZE(3) }
 442     ok(77, $FA ? $#h == 2 : $self->length() == 3) ;
 443     undef $self ;
 444     untie @h ;
 445     $x = docat($Dfile) ;
 446     ok(78, $x eq "abc\ndef\nghi\n") ;
 447
 448     unlink $Dfile;
 449
 450
 451 }
 452
 453 exit ;