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