1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
$|++;
use strict;
use warnings FATAL => 'all';
use Test::More;
use Test::Exception;
use Test::Warn;
use t::common qw( new_fh );
use_ok( 'DBM::Deep' );
# test a corrupted file
{
my ($fh, $filename) = new_fh();
open FH, ">$filename";
print FH 'DPDB';
close FH;
throws_ok {
DBM::Deep->new( $filename );
} qr/DBM::Deep: Pre-1.00 file version found/, "Fail if there's a bad header";
}
{
my ($fh, $filename) = new_fh();
my %hash;
tie %hash, 'DBM::Deep', $filename;
undef %hash;
my @array;
throws_ok {
tie @array, 'DBM::Deep', $filename;
} qr/DBM::Deep: File type mismatch/, "Fail if we try and tie a hash file with an array";
throws_ok {
DBM::Deep->new( file => $filename, type => DBM::Deep->TYPE_ARRAY )
} qr/DBM::Deep: File type mismatch/, "Fail if we try and open a hash file with an array";
}
{
my ($fh, $filename) = new_fh();
my @array;
tie @array, 'DBM::Deep', $filename;
undef @array;
my %hash;
throws_ok {
tie %hash, 'DBM::Deep', $filename;
} qr/DBM::Deep: File type mismatch/, "Fail if we try and tie an array file with a hash";
throws_ok {
DBM::Deep->new( file => $filename, type => DBM::Deep->TYPE_HASH )
} qr/DBM::Deep: File type mismatch/, "Fail if we try and open an array file with a hash";
}
{
my %floors = (
max_buckets => 16,
num_txns => 1,
data_sector_size => 32,
);
while ( my ($attr, $floor) = each %floors ) {
{
my ($fh, $filename) = new_fh();
warning_like {
my $db = DBM::Deep->new(
file => $filename,
$attr => undef,
);
} qr{Floor of $attr is $floor\. Setting it to $floor from '\Q(undef)\E'},
"Warning for $attr => undef is correct";
}
{
my ($fh, $filename) = new_fh();
warning_like {
my $db = DBM::Deep->new(
file => $filename,
$attr => '',
);
} qr{Floor of $attr is $floor\. Setting it to $floor from ''},
"Warning for $attr => '' is correct";
}
{
my ($fh, $filename) = new_fh();
warning_like {
my $db = DBM::Deep->new(
file => $filename,
$attr => 'abcd',
);
} qr{Floor of $attr is $floor\. Setting it to $floor from 'abcd'},
"Warning for $attr => 'abcd' is correct";
}
{
my ($fh, $filename) = new_fh();
my $val = $floor - 1;
warning_like {
my $db = DBM::Deep->new(
file => $filename,
$attr => $val,
);
} qr{Floor of $attr is $floor\. Setting it to $floor from '$val'},
"Warning for $attr => $val is correct";
}
}
my %ceilings = (
max_buckets => 256,
num_txns => 255,
data_sector_size => 256,
);
while ( my ($attr, $ceiling) = each %ceilings ) {
my ($fh, $filename) = new_fh();
warning_like {
my $db = DBM::Deep->new(
file => $filename,
$attr => 1000,
);
} qr{Ceiling of $attr is $ceiling\. Setting it to $ceiling from '1000'},
"Warning for $attr => 1000 is correct";
}
}
{
throws_ok {
DBM::Deep->new( 't/etc/db-0-983' );
} qr/DBM::Deep: Pre-1.00 file version found/, "Fail if opening a pre-1.00 file";
}
{
throws_ok {
DBM::Deep->new( 't/etc/db-0-99_04' );
} qr/DBM::Deep: This file version is too old - 0\.99 - expected (?x:
)1\.0003 to \d/, "Fail if opening a file version 1";
}
{
# Make sure we get the right file name in the error message.
throws_ok {
eval "#line 1 gneen\nDBM::Deep->new( 't/etc/db-0-99_04' )"
or die $@
} qr/ at gneen line 1\b/, "File name in error message is correct";
}
{
# Too many transactions.
my ($fh, $filename) = new_fh();
throws_ok {
new DBM::Deep $filename =>-> begin_work;
} qr/^DBM::Deep: Cannot allocate transaction ID at/,
"Error when starting transaction in database with only 1 txn";
}
done_testing;
|
