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