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