t/06_error.t

   1 ##
   2 # DBM::Deep Test
   3 ##
   4 $|++;
   5 use strict;
   6 use Test::More tests => 23;
   7 use Test::Exception;
   8 use Test::Warn;
   9 use t::common qw( new_fh );
  10
  11 use_ok( 'DBM::Deep' );
  12
  13 ##
  14 # test a corrupted file
  15 ##
  16 {
  17     my ($fh, $filename) = new_fh();
  18
  19     open FH, ">$filename";
  20     print FH 'DPDB';
  21     close FH;
  22
  23     throws_ok {
  24         DBM::Deep->new( $filename );
  25     } qr/DBM::Deep: Pre-1.00 file version found/, "Fail if there's a bad header";
  26 }
  27
  28 {
  29     my ($fh, $filename) = new_fh();
  30     my %hash;
  31     tie %hash, 'DBM::Deep', $filename;
  32     undef %hash;
  33
  34     my @array;
  35     throws_ok {
  36         tie @array, 'DBM::Deep', $filename;
  37     } qr/DBM::Deep: File type mismatch/, "Fail if we try and tie a hash file with an array";
  38
  39     throws_ok {
  40         DBM::Deep->new( file => $filename, type => DBM::Deep->TYPE_ARRAY )
  41     } qr/DBM::Deep: File type mismatch/, "Fail if we try and open a hash file with an array";
  42 }
  43
  44 {
  45     my ($fh, $filename) = new_fh();
  46     my @array;
  47     tie @array, 'DBM::Deep', $filename;
  48     undef @array;
  49
  50     my %hash;
  51     throws_ok {
  52         tie %hash, 'DBM::Deep', $filename;
  53     } qr/DBM::Deep: File type mismatch/, "Fail if we try and tie an array file with a hash";
  54
  55     throws_ok {
  56         DBM::Deep->new( file => $filename, type => DBM::Deep->TYPE_HASH )
  57     } qr/DBM::Deep: File type mismatch/, "Fail if we try and open an array file with a hash";
  58 }
  59
  60 {
  61     my %floors = (
  62         max_buckets => 16,
  63         num_txns => 1,
  64         data_sector_size => 32,
  65     );
  66
  67     while ( my ($attr, $floor) = each %floors ) {
  68         {
  69             my ($fh, $filename) = new_fh();
  70             warning_like {
  71                 my $db = DBM::Deep->new(
  72                     file => $filename,
  73                     $attr => undef,
  74                 );
  75             } qr{Floor of $attr is $floor\. Setting it to $floor from '\Q(undef)\E'},
  76              "Warning for $attr => undef is correct";
  77         }
  78         {
  79             my ($fh, $filename) = new_fh();
  80             warning_like {
  81                 my $db = DBM::Deep->new(
  82                     file => $filename,
  83                     $attr => '',
  84                 );
  85             } qr{Floor of $attr is $floor\. Setting it to $floor from ''},
  86              "Warning for $attr => '' is correct";
  87         }
  88         {
  89             my ($fh, $filename) = new_fh();
  90             warning_like {
  91                 my $db = DBM::Deep->new(
  92                     file => $filename,
  93                     $attr => 'abcd',
  94                 );
  95             } qr{Floor of $attr is $floor\. Setting it to $floor from 'abcd'},
  96              "Warning for $attr => 'abcd' is correct";
  97         }
  98         {
  99             my ($fh, $filename) = new_fh();
 100             my $val = $floor - 1;
 101             warning_like {
 102                 my $db = DBM::Deep->new(
 103                     file => $filename,
 104                     $attr => $val,
 105                 );
 106             } qr{Floor of $attr is $floor\. Setting it to $floor from '$val'},
 107              "Warning for $attr => $val is correct";
 108         }
 109     }
 110
 111     my %ceilings = (
 112         max_buckets => 256,
 113         num_txns => 255,
 114         data_sector_size => 256,
 115     );
 116
 117     while ( my ($attr, $ceiling) = each %ceilings ) {
 118         my ($fh, $filename) = new_fh();
 119         warning_like {
 120             my $db = DBM::Deep->new(
 121                 file => $filename,
 122                 $attr => 1000,
 123             );
 124         } qr{Ceiling of $attr is $ceiling\. Setting it to $ceiling from '1000'},
 125           "Warning for $attr => 1000 is correct";
 126     }
 127 }
 128
 129 {
 130     throws_ok {
 131         DBM::Deep->new( 't/old_versions/db.0.983' );
 132     } qr/DBM::Deep: Pre-1.00 file version found/, "Fail if opening a pre-1.00 file";
 133 }
 134
 135 {
 136     throws_ok {
 137         DBM::Deep->new( 't/old_versions/db.0.99_04' );
 138     } qr/DBM::Deep: Wrong file version found - 1 - expected 2/, "Fail if opening a file version 1";
 139 }