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 my $db_file;
  49 BEGIN {
  50     use Config;
  51     foreach (qw/ODBM_File SDBM_File NDBM_File GDBM_File DB_File/) {
  52         if ($Config{extensions} =~ /\b$_\b/) {
  53             $db_file = $_;
  54             last;
  55         }
  56     }
  57     use_ok($db_file);
  58 };
  59 BEGIN { use_ok('Fcntl') };
  60
  61 unlink <Op_dbmx*>;
  62 END { unlink <Op_dbmx*>; }
  63
  64 my %h1 = () ;
  65 my %h2 = () ;
  66 $db = tie(%h1, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
  67
  68 ok $db, "tied to $db_file ok";
  69
  70
  71 # Error cases
  72
  73 eval { $db->Filter_Push() ; };
  74 like $@, qr/^Filter_Push: no parameters present/,
  75         "croak if not parameters passed to Filter_Push";
  76
  77 eval { $db->Filter_Push("unknown_class") ; };
  78 like $@, qr/^Filter_Push: Cannot Load DBM Filter 'DBM_Filter::unknown_class'/,
  79         "croak on unknown class" ;
  80
  81 eval { $db->Filter_Push("Some::unknown_class") ; };
  82 like $@, qr/^Filter_Push: Cannot Load DBM Filter 'Some::unknown_class'/,
  83         "croak on unknown fully qualified class" ;
  84
  85 eval { $db->Filter_Push('Store') ; };
  86 like $@, qr/^Filter_Push: not even params/,
  87         "croak if not passing even number or params to Filter_Push";
  88
  89 runFilter('bad1', <<'EOM');
  90     package DBM_Filter::bad1 ;
  91     1;
  92 EOM
  93
  94 like $@, qr/^Filter_Push: No methods \(Filter, Fetch or Store\) found in class 'DBM_Filter::bad1'/,
  95         "croak if none of Filter/Fetch/Store in filter" ;
  96
  97
  98 runFilter('bad2', <<'EOM');
  99     package DBM_Filter::bad2 ;
 100
 101     sub Filter
 102     {
 103         return 2;
 104     }
 105
 106     1;
 107 EOM
 108
 109 like $@, qr/^Filter_Push: 'DBM_Filter::bad2::Filter' did not return a hash reference./,
 110         "croak if Filter doesn't return hash reference" ;
 111
 112 runFilter('bad3', <<'EOM');
 113     package DBM_Filter::bad3 ;
 114
 115     sub Filter
 116     {
 117         return { BadKey => sub { } } ;
 118
 119     }
 120
 121     1;
 122 EOM
 123
 124 like $@, qr/^Filter_Push: Unknown key 'BadKey'/,
 125         "croak if bad keyword returned from Filter";
 126
 127 runFilter('bad4', <<'EOM');
 128     package DBM_Filter::bad4 ;
 129
 130     sub Filter
 131     {
 132         return { Store => "abc" } ;
 133     }
 134
 135     1;
 136 EOM
 137
 138 like $@, qr/^Filter_Push: value associated with key 'Store' is not a code reference/,
 139         "croak if not a code reference";
 140
 141 runFilter('bad5', <<'EOM');
 142     package DBM_Filter::bad5 ;
 143
 144     sub Filter
 145     {
 146         return { } ;
 147     }
 148
 149     1;
 150 EOM
 151
 152 like $@, qr/^Filter_Push: expected both Store & Fetch - got neither/,
 153         "croak if neither fetch or store is present";
 154
 155 runFilter('bad6', <<'EOM');
 156     package DBM_Filter::bad6 ;
 157
 158     sub Filter
 159     {
 160         return { Store => sub {} } ;
 161     }
 162
 163     1;
 164 EOM
 165
 166 like $@, qr/^Filter_Push: expected both Store & Fetch - got Store/,
 167         "croak if store is present but fetch isn't";
 168
 169 runFilter('bad7', <<'EOM');
 170     package DBM_Filter::bad7 ;
 171
 172     sub Filter
 173     {
 174         return { Fetch => sub {} } ;
 175     }
 176
 177     1;
 178 EOM
 179
 180 like $@, qr/^Filter_Push: expected both Store & Fetch - got Fetch/,
 181         "croak if fetch is present but store isn't";
 182
 183 runFilter('bad8', <<'EOM');
 184     package DBM_Filter::bad8 ;
 185
 186     sub Filter {}
 187     sub Store {}
 188     sub Fetch {}
 189
 190     1;
 191 EOM
 192
 193 like $@, qr/^Filter_Push: Can't mix Filter with Store and Fetch in class 'DBM_Filter::bad8'/,
 194         "croak if Fetch, Store and Filter";
 195
 196 runFilter('bad9', <<'EOM');
 197     package DBM_Filter::bad9 ;
 198
 199     sub Filter {}
 200     sub Store {}
 201
 202     1;
 203 EOM
 204
 205 like $@, qr/^Filter_Push: Can't mix Filter with Store and Fetch in class 'DBM_Filter::bad9'/,
 206         "croak if Store and Filter";
 207
 208 runFilter('bad10', <<'EOM');
 209     package DBM_Filter::bad10 ;
 210
 211     sub Filter {}
 212     sub Fetch {}
 213
 214     1;
 215 EOM
 216
 217 like $@, qr/^Filter_Push: Can't mix Filter with Store and Fetch in class 'DBM_Filter::bad10'/,
 218         "croak if Fetch and Filter";
 219
 220 runFilter('bad11', <<'EOM');
 221     package DBM_Filter::bad11 ;
 222
 223     sub Fetch {}
 224
 225     1;
 226 EOM
 227
 228 like $@, qr/^Filter_Push: Missing method 'Store' in class 'DBM_Filter::bad11'/,
 229         "croak if Fetch but no Store";
 230
 231 runFilter('bad12', <<'EOM');
 232     package DBM_Filter::bad12 ;
 233
 234     sub Store {}
 235
 236     1;
 237 EOM
 238
 239 like $@, qr/^Filter_Push: Missing method 'Fetch' in class 'DBM_Filter::bad12'/,
 240         "croak if Store but no Fetch";
 241
 242 undef $db;
 243 {
 244     use warnings FATAL => 'untie';
 245     eval { untie %h1 };
 246     is $@, '', "untie without inner references" ;
 247 }
 248