lib/DBM_Filter/t/01error.t

   1
   2 use strict;
   3 use warnings;
   4 use Carp;
   5
   6 use lib '.';
   7 our $db ;
   8
   9 {
  10     chdir 't' if -d 't';
  11     if ( ! -d 'DBM_Filter')
  12     {
  13         mkdir 'DBM_Filter', 0777
  14             or die "Cannot create directory 'DBM_Filter': $!\n" ;
  15     }
  16 }
  17
  18 END { rmdir 'DBM_Filter' }
  19
  20 sub writeFile
  21 {
  22     my $filename = shift ;
  23     my $content = shift;
  24     open F, ">$filename" or croak "Cannot open $filename: $!" ;
  25     print F $content ;
  26     close F;
  27 }
  28
  29 sub runFilter
  30 {
  31     my $name = shift ;
  32     my $filter = shift ;
  33
  34 print "# runFilter $name\n" ;
  35     my $filename = "DBM_Filter/$name.pm";
  36     $filter = "package DBM_Filter::$name ;\n$filter"
  37         unless $filter =~ /^\s*package/ ;
  38
  39     writeFile($filename, $filter);
  40     eval { $db->Filter_Push($name) };
  41     unlink $filename;
  42     return $@;
  43 }
  44
  45 use Test::More tests => 21;
  46
  47 BEGIN { use_ok('DBM_Filter') };
  48 BEGIN { use_ok('SDBM_File') };
  49 BEGIN { use_ok('Fcntl') };
  50
  51 unlink <Op_dbmx*>;
  52 END { unlink <Op_dbmx*>; }
  53
  54 my %h1 = () ;
  55 my %h2 = () ;
  56 $db = tie(%h1, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
  57
  58 ok $db, "tied to SDBM_File ok";
  59
  60
  61 # Error cases
  62
  63 eval { $db->Filter_Push() ; };
  64 like $@, qr/^Filter_Push: no parameters present/,
  65         "croak if not parameters passed to Filter_Push";
  66
  67 eval { $db->Filter_Push("unknown_class") ; };
  68 like $@, qr/^Filter_Push: Cannot Load DBM Filter 'DBM_Filter::unknown_class'/,
  69         "croak on unknown class" ;
  70
  71 eval { $db->Filter_Push("Some::unknown_class") ; };
  72 like $@, qr/^Filter_Push: Cannot Load DBM Filter 'Some::unknown_class'/,
  73         "croak on unknown fully qualified class" ;
  74
  75 eval { $db->Filter_Push('Store') ; };
  76 like $@, qr/^Filter_Push: not even params/,
  77         "croak if not passing even number or params to Filter_Push";
  78
  79 runFilter('bad1', <<'EOM');
  80     package DBM_Filter::bad1 ;
  81     1;
  82 EOM
  83
  84 like $@, qr/^Filter_Push: No methods \(Filter, Fetch or Store\) found in class 'DBM_Filter::bad1'/,
  85         "croak if none of Filter/Fetch/Store in filter" ;
  86
  87
  88 runFilter('bad2', <<'EOM');
  89     package DBM_Filter::bad2 ;
  90
  91     sub Filter
  92     {
  93         return 2;
  94     }
  95
  96     1;
  97 EOM
  98
  99 like $@, qr/^Filter_Push: 'DBM_Filter::bad2::Filter' did not return a hash reference./,
 100         "croak if Filter doesn't return hash reference" ;
 101
 102 runFilter('bad3', <<'EOM');
 103     package DBM_Filter::bad3 ;
 104
 105     sub Filter
 106     {
 107         return { BadKey => sub { } } ;
 108
 109     }
 110
 111     1;
 112 EOM
 113
 114 like $@, qr/^Filter_Push: Unknown key 'BadKey'/,
 115         "croak if bad keyword returned from Filter";
 116
 117 runFilter('bad4', <<'EOM');
 118     package DBM_Filter::bad4 ;
 119
 120     sub Filter
 121     {
 122         return { Store => "abc" } ;
 123     }
 124
 125     1;
 126 EOM
 127
 128 like $@, qr/^Filter_Push: value associated with key 'Store' is not a code reference/,
 129         "croak if not a code reference";
 130
 131 runFilter('bad5', <<'EOM');
 132     package DBM_Filter::bad5 ;
 133
 134     sub Filter
 135     {
 136         return { } ;
 137     }
 138
 139     1;
 140 EOM
 141
 142 like $@, qr/^Filter_Push: expected both Store & Fetch - got neither/,
 143         "croak if neither fetch or store is present";
 144
 145 runFilter('bad6', <<'EOM');
 146     package DBM_Filter::bad6 ;
 147
 148     sub Filter
 149     {
 150         return { Store => sub {} } ;
 151     }
 152
 153     1;
 154 EOM
 155
 156 like $@, qr/^Filter_Push: expected both Store & Fetch - got Store/,
 157         "croak if store is present but fetch isn't";
 158
 159 runFilter('bad7', <<'EOM');
 160     package DBM_Filter::bad7 ;
 161
 162     sub Filter
 163     {
 164         return { Fetch => sub {} } ;
 165     }
 166
 167     1;
 168 EOM
 169
 170 like $@, qr/^Filter_Push: expected both Store & Fetch - got Fetch/,
 171         "croak if fetch is present but store isn't";
 172
 173 runFilter('bad8', <<'EOM');
 174     package DBM_Filter::bad8 ;
 175
 176     sub Filter {}
 177     sub Store {}
 178     sub Fetch {}
 179
 180     1;
 181 EOM
 182
 183 like $@, qr/^Filter_Push: Can't mix Filter with Store and Fetch in class 'DBM_Filter::bad8'/,
 184         "croak if Fetch, Store and Filter";
 185
 186 runFilter('bad9', <<'EOM');
 187     package DBM_Filter::bad9 ;
 188
 189     sub Filter {}
 190     sub Store {}
 191
 192     1;
 193 EOM
 194
 195 like $@, qr/^Filter_Push: Can't mix Filter with Store and Fetch in class 'DBM_Filter::bad9'/,
 196         "croak if Store and Filter";
 197
 198 runFilter('bad10', <<'EOM');
 199     package DBM_Filter::bad10 ;
 200
 201     sub Filter {}
 202     sub Fetch {}
 203
 204     1;
 205 EOM
 206
 207 like $@, qr/^Filter_Push: Can't mix Filter with Store and Fetch in class 'DBM_Filter::bad10'/,
 208         "croak if Fetch and Filter";
 209
 210 runFilter('bad11', <<'EOM');
 211     package DBM_Filter::bad11 ;
 212
 213     sub Fetch {}
 214
 215     1;
 216 EOM
 217
 218 like $@, qr/^Filter_Push: Missing method 'Store' in class 'DBM_Filter::bad11'/,
 219         "croak if Fetch but no Store";
 220
 221 runFilter('bad12', <<'EOM');
 222     package DBM_Filter::bad12 ;
 223
 224     sub Store {}
 225
 226     1;
 227 EOM
 228
 229 like $@, qr/^Filter_Push: Missing method 'Fetch' in class 'DBM_Filter::bad12'/,
 230         "croak if Store but no Fetch";
 231
 232 undef $db;
 233 {
 234     use warnings FATAL => 'untie';
 235     eval { untie %h1 };
 236     is $@, '', "untie without inner references" ;
 237 }
 238