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