| Commit | Line | Data |
|---|
| 0e9b1cbd |
1 | |
| 2 | use strict; |
| 3 | use warnings; |
| 4 | use Carp; |
| 5 | |
| 6 | my %files = (); |
| 7 | |
| 8 | use lib '.'; |
| 9 | |
| 10 | { |
| 11 | chdir 't' if -d 't'; |
| 12 | if ( ! -d 'DBM_Filter') |
| 13 | { |
| 14 | mkdir 'DBM_Filter', 0777 |
| 9aedf6d8 |
15 | or die "Cannot create directory 'DBM_Filter': $!\n" ; |
| 0e9b1cbd |
16 | } |
| 17 | } |
| 18 | |
| 9aedf6d8 |
19 | END { rmdir 'DBM_Filter' } |
| 0e9b1cbd |
20 | |
| 21 | sub writeFile |
| 22 | { |
| 23 | my $filename = shift ; |
| 24 | my $content = shift; |
| 9aedf6d8 |
25 | open F, ">DBM_Filter/$filename.pm" or croak "Cannot open $filename: $!" ; |
| 0e9b1cbd |
26 | print F $content ; |
| 27 | close F; |
| 28 | $files{"DBM_Filter/$filename.pm"} ++; |
| 29 | } |
| 30 | |
| 31 | END { unlink keys %files if keys %files } |
| 32 | |
| 33 | use Test::More tests => 189; |
| 34 | |
| 35 | BEGIN { use_ok('DBM_Filter') }; |
| 36 | BEGIN { use_ok('SDBM_File') }; |
| 37 | BEGIN { use_ok('Fcntl') }; |
| 38 | |
| 39 | unlink <Op_dbmx*>; |
| 40 | END { unlink <Op_dbmx*>; } |
| 41 | |
| 42 | writeFile('times_ten', <<'EOM'); |
| 43 | package DBM_Filter::times_ten; |
| 44 | sub Store { $_ *= 10 } |
| 45 | sub Fetch { $_ /= 10 } |
| 46 | 1; |
| 47 | EOM |
| 48 | |
| 49 | writeFile('append_A', <<'EOM'); |
| 50 | package DBM_Filter::append_A; |
| 51 | sub Store { $_ .= 'A' } |
| 52 | sub Fetch { s/A$// } |
| 53 | 1; |
| 54 | EOM |
| 55 | |
| 56 | writeFile('append_B', <<'EOM'); |
| 57 | package DBM_Filter::append_B; |
| 58 | sub Store { $_ .= 'B' } |
| 59 | sub Fetch { s/B$// } |
| 60 | 1; |
| 61 | EOM |
| 62 | |
| 63 | writeFile('append_C', <<'EOM'); |
| 64 | package DBM_Filter::append_C; |
| 65 | sub Store { $_ .= 'C' } |
| 66 | sub Fetch { s/C$// } |
| 67 | 1; |
| 68 | EOM |
| 69 | |
| 70 | writeFile('append_D', <<'EOM'); |
| 71 | package DBM_Filter::append_D; |
| 72 | sub Store { $_ .= 'D' } |
| 73 | sub Fetch { s/D$// } |
| 74 | 1; |
| 75 | EOM |
| 76 | |
| 77 | writeFile('append', <<'EOM'); |
| 78 | package DBM_Filter::append; |
| 79 | sub Filter |
| 80 | { |
| 81 | my $string = shift ; |
| 82 | return { |
| 83 | Store => sub { $_ .= $string }, |
| 84 | Fetch => sub { s/${string}$// } |
| 85 | } |
| 86 | } |
| 87 | 1; |
| 88 | EOM |
| 89 | |
| 90 | writeFile('double', <<'EOM'); |
| 91 | package DBM_Filter::double; |
| 92 | sub Store { $_ *= 2 } |
| 93 | sub Fetch { $_ /= 2 } |
| 94 | 1; |
| 95 | EOM |
| 96 | |
| 97 | writeFile('uc', <<'EOM'); |
| 98 | package DBM_Filter::uc; |
| 99 | sub Store { $_ = uc $_ } |
| 100 | sub Fetch { $_ = lc $_ } |
| 101 | 1; |
| 102 | EOM |
| 103 | |
| 104 | writeFile('reverse', <<'EOM'); |
| 105 | package DBM_Filter::reverse; |
| 106 | sub Store { $_ = reverse $_ } |
| 107 | sub Fetch { $_ = reverse $_ } |
| 108 | 1; |
| 109 | EOM |
| 110 | |
| 111 | |
| 112 | my %PreData = ( |
| 113 | 'abc' => 'def', |
| 114 | '123' => '456', |
| 115 | ); |
| 116 | |
| 117 | my %PostData = ( |
| 118 | 'alpha' => 'beta', |
| 119 | 'green' => 'blue', |
| 120 | ); |
| 121 | |
| 122 | sub doPreData |
| 123 | { |
| 124 | my $h = shift ; |
| 125 | |
| 126 | $$h{"abc"} = "def"; |
| 127 | $$h{"123"} = "456"; |
| 128 | ok $$h{"abc"} eq "def", "read eq written" ; |
| 129 | ok $$h{"123"} eq "456", "read eq written" ; |
| 130 | |
| 131 | } |
| 132 | |
| 133 | sub doPostData |
| 134 | { |
| 135 | my $h = shift ; |
| 136 | |
| 137 | no warnings 'uninitialized'; |
| 138 | $$h{undef()} = undef(); |
| 139 | $$h{"alpha"} = "beta"; |
| 140 | $$h{"green"} = "blue"; |
| 141 | ok $$h{""} eq "", "read eq written" ; |
| 142 | ok $$h{"green"} eq "blue", "read eq written" ; |
| 143 | ok $$h{"green"} eq "blue", "read eq written" ; |
| 144 | |
| 145 | } |
| 146 | |
| 147 | sub checkRaw |
| 148 | { |
| 149 | my $filename = shift ; |
| 150 | my %expected = @_ ; |
| 151 | my %h; |
| 152 | |
| 153 | # read the dbm file without the filter |
| 154 | ok tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640), "tied to SDBM_File"; |
| 155 | |
| 156 | my %bad = (); |
| 157 | while (my ($k, $v) = each %h) { |
| 158 | if ( defined $expected{$k} && $expected{$k} eq $v ) { |
| 159 | delete $expected{$k} ; |
| 160 | } |
| 161 | else |
| 162 | { $bad{$k} = $v } |
| 163 | } |
| 164 | |
| 165 | ok keys(%expected) + keys(%bad) == 0, "Raw hash is ok"; |
| 166 | |
| 167 | if ( keys(%expected) + keys(%bad) ) { |
| 168 | my $bad = "Expected does not match actual\nExpected:\n" ; |
| 169 | while (my ($k, $v) = each %expected) { |
| 170 | $bad .= "\t'$k' =>\t'$v'\n"; |
| 171 | } |
| 172 | $bad .= "\nGot:\n" ; |
| 173 | while (my ($k, $v) = each %bad) { |
| 174 | $bad .= "\t'$k' =>\t'$v'\n"; |
| 175 | } |
| 176 | diag $bad ; |
| 177 | } |
| 178 | |
| 179 | { |
| 180 | use warnings FATAL => 'untie'; |
| 181 | eval { untie %h }; |
| 182 | is $@, '', "untie without inner references" ; |
| 183 | } |
| 184 | unlink <Op_dbmx*>; |
| 185 | } |
| 186 | |
| 187 | { |
| 188 | #diag "Test Set: Key and Value Filter, no stacking, no closure"; |
| 189 | |
| 190 | my %h = () ; |
| 191 | my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ; |
| 192 | ok $db, "tied to SDBM_File"; |
| 193 | |
| 194 | doPreData(\%h); |
| 195 | |
| 196 | eval { $db->Filter_Push('append_A') }; |
| 197 | is $@, '', "push 'append_A' filter" ; |
| 198 | |
| 199 | doPostData(\%h); |
| 200 | |
| 201 | undef $db; |
| 202 | { |
| 203 | use warnings FATAL => 'untie'; |
| 204 | eval { untie %h }; |
| 205 | is $@, '', "untie without inner references" ; |
| 206 | } |
| 207 | |
| 208 | checkRaw 'Op_dbmx', |
| 209 | 'abc' => 'def', |
| 210 | '123' => '456', |
| 211 | 'A' => 'A', |
| 212 | 'alphaA' => 'betaA', |
| 213 | 'greenA' => 'blueA'; |
| 214 | |
| 215 | } |
| 216 | |
| 217 | { |
| 218 | #diag "Test Set: Key Only Filter, no stacking, no closure"; |
| 219 | |
| 220 | my %h = () ; |
| 221 | my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ; |
| 222 | ok $db, "tied to SDBM_File"; |
| 223 | |
| 224 | doPreData(\%h); |
| 225 | |
| 226 | eval { $db->Filter_Key_Push('append_A') }; |
| 227 | is $@, '', "push 'append_A' filter" ; |
| 228 | |
| 229 | doPostData(\%h); |
| 230 | |
| 231 | undef $db; |
| 232 | { |
| 233 | use warnings FATAL => 'untie'; |
| 234 | eval { untie %h }; |
| 235 | is $@, '', "untie without inner references" ; |
| 236 | } |
| 237 | |
| 238 | checkRaw 'Op_dbmx', |
| 239 | 'abc' => 'def', |
| 240 | '123' => '456', |
| 241 | 'A' => '', |
| 242 | 'alphaA' => 'beta', |
| 243 | 'greenA' => 'blue'; |
| 244 | |
| 245 | } |
| 246 | |
| 247 | { |
| 248 | #diag "Test Set: Value Only Filter, no stacking, no closure"; |
| 249 | |
| 250 | my %h = () ; |
| 251 | my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ; |
| 252 | ok $db, "tied to SDBM_File"; |
| 253 | |
| 254 | doPreData(\%h); |
| 255 | |
| 256 | eval { $db->Filter_Value_Push('append_A') }; |
| 257 | is $@, '', "push 'append_A' filter" ; |
| 258 | |
| 259 | doPostData(\%h); |
| 260 | |
| 261 | undef $db; |
| 262 | { |
| 263 | use warnings FATAL => 'untie'; |
| 264 | eval { untie %h }; |
| 265 | is $@, '', "untie without inner references" ; |
| 266 | } |
| 267 | |
| 268 | checkRaw 'Op_dbmx', |
| 269 | 'abc' => 'def', |
| 270 | '123' => '456', |
| 271 | '' => 'A', |
| 272 | 'alpha' => 'betaA', |
| 273 | 'green' => 'blueA'; |
| 274 | |
| 275 | } |
| 276 | |
| 277 | { |
| 278 | #diag "Test Set: Key and Value Filter, with stacking, no closure"; |
| 279 | |
| 280 | my %h = () ; |
| 281 | my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ; |
| 282 | ok $db, "tied to SDBM_File"; |
| 283 | |
| 284 | doPreData(\%h); |
| 285 | |
| 286 | eval { $db->Filter_Push('append_A') }; |
| 287 | is $@, '', "push 'append_A' filter" ; |
| 288 | |
| 289 | eval { $db->Filter_Push('append_B') }; |
| 290 | is $@, '', "push 'append_B' filter" ; |
| 291 | |
| 292 | doPostData(\%h); |
| 293 | |
| 294 | undef $db; |
| 295 | { |
| 296 | use warnings FATAL => 'untie'; |
| 297 | eval { untie %h }; |
| 298 | is $@, '', "untie without inner references" ; |
| 299 | } |
| 300 | |
| 301 | checkRaw 'Op_dbmx', |
| 302 | 'abc' => 'def', |
| 303 | '123' => '456', |
| 304 | 'AB' => 'AB', |
| 305 | 'alphaAB' => 'betaAB', |
| 306 | 'greenAB' => 'blueAB'; |
| 307 | |
| 308 | } |
| 309 | |
| 310 | { |
| 311 | #diag "Test Set: Key Filter != Value Filter, with stacking, no closure"; |
| 312 | |
| 313 | my %h = () ; |
| 314 | my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ; |
| 315 | ok $db, "tied to SDBM_File"; |
| 316 | |
| 317 | doPreData(\%h); |
| 318 | |
| 319 | eval { $db->Filter_Value_Push('append_A') }; |
| 320 | is $@, '', "push 'append_A' filter" ; |
| 321 | |
| 322 | eval { $db->Filter_Key_Push('append_B') }; |
| 323 | is $@, '', "push 'append_B' filter" ; |
| 324 | |
| 325 | eval { $db->Filter_Value_Push('append_C') }; |
| 326 | is $@, '', "push 'append_C' filter" ; |
| 327 | |
| 328 | eval { $db->Filter_Key_Push('append_D') }; |
| 329 | is $@, '', "push 'append_D' filter" ; |
| 330 | |
| 331 | doPostData(\%h); |
| 332 | |
| 333 | undef $db; |
| 334 | { |
| 335 | use warnings FATAL => 'untie'; |
| 336 | eval { untie %h }; |
| 337 | is $@, '', "untie without inner references" ; |
| 338 | } |
| 339 | |
| 340 | checkRaw 'Op_dbmx', |
| 341 | 'abc' => 'def', |
| 342 | '123' => '456', |
| 343 | 'BD' => 'AC', |
| 344 | 'alphaBD' => 'betaAC', |
| 345 | 'greenBD' => 'blueAC'; |
| 346 | |
| 347 | } |
| 348 | |
| 349 | { |
| 350 | #diag "Test Set: Key only Filter, with stacking, no closure"; |
| 351 | |
| 352 | my %h = () ; |
| 353 | my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ; |
| 354 | ok $db, "tied to SDBM_File"; |
| 355 | |
| 356 | doPreData(\%h); |
| 357 | |
| 358 | eval { $db->Filter_Key_Push('append_B') }; |
| 359 | is $@, '', "push 'append_B' filter" ; |
| 360 | |
| 361 | eval { $db->Filter_Key_Push('append_D') }; |
| 362 | is $@, '', "push 'append_D' filter" ; |
| 363 | |
| 364 | doPostData(\%h); |
| 365 | |
| 366 | undef $db; |
| 367 | { |
| 368 | use warnings FATAL => 'untie'; |
| 369 | eval { untie %h }; |
| 370 | is $@, '', "untie without inner references" ; |
| 371 | } |
| 372 | |
| 373 | checkRaw 'Op_dbmx', |
| 374 | 'abc' => 'def', |
| 375 | '123' => '456', |
| 376 | 'BD' => '', |
| 377 | 'alphaBD' => 'beta', |
| 378 | 'greenBD' => 'blue'; |
| 379 | |
| 380 | } |
| 381 | |
| 382 | { |
| 383 | #diag "Test Set: Value only Filter, with stacking, no closure"; |
| 384 | |
| 385 | my %h = () ; |
| 386 | my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ; |
| 387 | ok $db, "tied to SDBM_File"; |
| 388 | |
| 389 | doPreData(\%h); |
| 390 | |
| 391 | eval { $db->Filter_Value_Push('append_A') }; |
| 392 | is $@, '', "push 'append_A' filter" ; |
| 393 | |
| 394 | eval { $db->Filter_Value_Push('append_C') }; |
| 395 | is $@, '', "push 'append_C' filter" ; |
| 396 | |
| 397 | doPostData(\%h); |
| 398 | |
| 399 | undef $db; |
| 400 | { |
| 401 | use warnings FATAL => 'untie'; |
| 402 | eval { untie %h }; |
| 403 | is $@, '', "untie without inner references" ; |
| 404 | } |
| 405 | |
| 406 | checkRaw 'Op_dbmx', |
| 407 | 'abc' => 'def', |
| 408 | '123' => '456', |
| 409 | '' => 'AC', |
| 410 | 'alpha' => 'betaAC', |
| 411 | 'green' => 'blueAC'; |
| 412 | |
| 413 | } |
| 414 | |
| 415 | { |
| 416 | #diag "Test Set: Combination Key/Value + Key Filter != Value Filter, with stacking, no closure"; |
| 417 | |
| 418 | my %h = () ; |
| 419 | my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ; |
| 420 | ok $db, "tied to SDBM_File"; |
| 421 | |
| 422 | doPreData(\%h); |
| 423 | |
| 424 | eval { $db->Filter_Push('append_A') }; |
| 425 | is $@, '', "push 'append_A' filter" ; |
| 426 | |
| 427 | eval { $db->Filter_Value_Push('append_C') }; |
| 428 | is $@, '', "push 'append_C' filter" ; |
| 429 | |
| 430 | eval { $db->Filter_Key_Push('append_D') }; |
| 431 | is $@, '', "push 'append_D' filter" ; |
| 432 | |
| 433 | doPostData(\%h); |
| 434 | |
| 435 | undef $db; |
| 436 | { |
| 437 | use warnings FATAL => 'untie'; |
| 438 | eval { untie %h }; |
| 439 | is $@, '', "untie without inner references" ; |
| 440 | } |
| 441 | |
| 442 | checkRaw 'Op_dbmx', |
| 443 | 'abc' => 'def', |
| 444 | '123' => '456', |
| 445 | 'AD' => 'AC', |
| 446 | 'alphaAD' => 'betaAC', |
| 447 | 'greenAD' => 'blueAC'; |
| 448 | |
| 449 | } |
| 450 | |
| 451 | { |
| 452 | #diag "Test Set: Combination Key/Value + Key + Key/Value, no closure"; |
| 453 | |
| 454 | my %h = () ; |
| 455 | my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ; |
| 456 | ok $db, "tied to SDBM_File"; |
| 457 | |
| 458 | doPreData(\%h); |
| 459 | |
| 460 | eval { $db->Filter_Push('append_A') }; |
| 461 | is $@, '', "push 'append_A' filter" ; |
| 462 | |
| 463 | eval { $db->Filter_Key_Push('append_B') }; |
| 464 | is $@, '', "push 'append_B' filter" ; |
| 465 | |
| 466 | eval { $db->Filter_Push('append_C') }; |
| 467 | is $@, '', "push 'append_C' filter" ; |
| 468 | |
| 469 | doPostData(\%h); |
| 470 | |
| 471 | undef $db; |
| 472 | { |
| 473 | use warnings FATAL => 'untie'; |
| 474 | eval { untie %h }; |
| 475 | is $@, '', "untie without inner references" ; |
| 476 | } |
| 477 | |
| 478 | checkRaw 'Op_dbmx', |
| 479 | 'abc' => 'def', |
| 480 | '123' => '456', |
| 481 | 'ABC' => 'AC', |
| 482 | 'alphaABC' => 'betaAC', |
| 483 | 'greenABC' => 'blueAC'; |
| 484 | |
| 485 | } |
| 486 | |
| 487 | { |
| 488 | #diag "Test Set: Combination Key/Value + Key + Key/Value, with closure"; |
| 489 | |
| 490 | my %h = () ; |
| 491 | my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ; |
| 492 | ok $db, "tied to SDBM_File"; |
| 493 | |
| 494 | doPreData(\%h); |
| 495 | |
| 496 | eval { $db->Filter_Push('append' => 'A') }; |
| 497 | is $@, '', "push 'append_A' filter" ; |
| 498 | |
| 499 | eval { $db->Filter_Key_Push('append' => 'B') }; |
| 500 | is $@, '', "push 'append_B' filter" ; |
| 501 | |
| 502 | eval { $db->Filter_Push('append' => 'C') }; |
| 503 | is $@, '', "push 'append_C' filter" ; |
| 504 | |
| 505 | doPostData(\%h); |
| 506 | |
| 507 | undef $db; |
| 508 | { |
| 509 | use warnings FATAL => 'untie'; |
| 510 | eval { untie %h }; |
| 511 | is $@, '', "untie without inner references" ; |
| 512 | } |
| 513 | |
| 514 | checkRaw 'Op_dbmx', |
| 515 | 'abc' => 'def', |
| 516 | '123' => '456', |
| 517 | 'ABC' => 'AC', |
| 518 | 'alphaABC' => 'betaAC', |
| 519 | 'greenABC' => 'blueAC'; |
| 520 | |
| 521 | } |
| 522 | |
| 523 | { |
| 524 | #diag "Test Set: Combination Key/Value + Key + Key/Value, immediate"; |
| 525 | |
| 526 | my %h = () ; |
| 527 | my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ; |
| 528 | ok $db, "tied to SDBM_File"; |
| 529 | |
| 530 | doPreData(\%h); |
| 531 | |
| 532 | eval { |
| 533 | $db->Filter_Push( |
| 534 | Store => sub { $_ .= 'A' }, |
| 535 | Fetch => sub { s/A$// }) }; |
| 536 | is $@, '', "push 'append_A' filter" ; |
| 537 | |
| 538 | eval { |
| 539 | $db->Filter_Key_Push( |
| 540 | Store => sub { $_ .= 'B' }, |
| 541 | Fetch => sub { s/B$// }) }; |
| 542 | is $@, '', "push 'append_B' filter" ; |
| 543 | |
| 544 | eval { |
| 545 | $db->Filter_Push( |
| 546 | Store => sub { $_ .= 'C' }, |
| 547 | Fetch => sub { s/C$// }) }; |
| 548 | is $@, '', "push 'append_C' filter" ; |
| 549 | |
| 550 | doPostData(\%h); |
| 551 | |
| 552 | undef $db; |
| 553 | { |
| 554 | use warnings FATAL => 'untie'; |
| 555 | eval { untie %h }; |
| 556 | is $@, '', "untie without inner references" ; |
| 557 | } |
| 558 | |
| 559 | checkRaw 'Op_dbmx', |
| 560 | 'abc' => 'def', |
| 561 | '123' => '456', |
| 562 | 'ABC' => 'AC', |
| 563 | 'alphaABC' => 'betaAC', |
| 564 | 'greenABC' => 'blueAC'; |
| 565 | |
| 566 | } |
| 567 | |
| 568 | { |
| 569 | #diag "Test Set: Combination Key/Value + Key + Key/Value, immediate, closure"; |
| 570 | |
| 571 | my %h = () ; |
| 572 | my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ; |
| 573 | ok $db, "tied to SDBM_File"; |
| 574 | |
| 575 | doPreData(\%h); |
| 576 | |
| 577 | eval { |
| 578 | $db->Filter_Push( |
| 579 | Store => sub { $_ .= 'A' }, |
| 580 | Fetch => sub { s/A$// }) }; |
| 581 | is $@, '', "push 'append_A' filter" ; |
| 582 | |
| 583 | eval { $db->Filter_Key_Push('append_B') }; |
| 584 | is $@, '', "push 'append_B' filter" ; |
| 585 | |
| 586 | eval { $db->Filter_Push('append' => 'C') }; |
| 587 | is $@, '', "push 'append_C' filter" ; |
| 588 | |
| 589 | doPostData(\%h); |
| 590 | |
| 591 | undef $db; |
| 592 | { |
| 593 | use warnings FATAL => 'untie'; |
| 594 | eval { untie %h }; |
| 595 | is $@, '', "untie without inner references" ; |
| 596 | } |
| 597 | |
| 598 | checkRaw 'Op_dbmx', |
| 599 | 'abc' => 'def', |
| 600 | '123' => '456', |
| 601 | 'ABC' => 'AC', |
| 602 | 'alphaABC' => 'betaAC', |
| 603 | 'greenABC' => 'blueAC'; |
| 604 | |
| 605 | } |
| 606 | |
| 607 | { |
| 608 | #diag "Test Set: Filtered & Filter_Pop"; |
| 609 | |
| 610 | my %h = () ; |
| 611 | my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ; |
| 612 | ok $db, "tied to SDBM_File"; |
| 613 | |
| 614 | doPreData(\%h); |
| 615 | |
| 616 | ok ! $db->Filtered, "not filtered" ; |
| 617 | |
| 618 | eval { |
| 619 | $db->Filter_Push( |
| 620 | Store => sub { $_ .= 'A' }, |
| 621 | Fetch => sub { s/A$// }) }; |
| 622 | is $@, '', "push 'append_A' filter" ; |
| 623 | |
| 624 | ok $db->Filtered, "is filtered" ; |
| 625 | |
| 626 | eval { $db->Filter_Key_Push('append_B') }; |
| 627 | is $@, '', "push 'append_B' filter" ; |
| 628 | |
| 629 | ok $db->Filtered, "is filtered" ; |
| 630 | |
| 631 | eval { $db->Filter_Push('append' => 'C') }; |
| 632 | is $@, '', "push 'append_C' filter" ; |
| 633 | |
| 634 | ok $db->Filtered, "is filtered" ; |
| 635 | |
| 636 | doPostData(\%h); |
| 637 | |
| 638 | eval { $db->Filter_Pop() }; |
| 639 | is $@, '', "Filter_Pop"; |
| 640 | |
| 641 | ok $db->Filtered, "is filtered" ; |
| 642 | |
| 643 | $h{'after'} = 'noon'; |
| 644 | is $h{'after'}, 'noon', "read eq written"; |
| 645 | |
| 646 | eval { $db->Filter_Pop() }; |
| 647 | is $@, '', "Filter_Pop"; |
| 648 | |
| 649 | ok $db->Filtered, "is filtered" ; |
| 650 | |
| 651 | $h{'morning'} = 'after'; |
| 652 | is $h{'morning'}, 'after', "read eq written"; |
| 653 | |
| 654 | eval { $db->Filter_Pop() }; |
| 655 | is $@, '', "Filter_Pop"; |
| 656 | |
| 657 | ok ! $db->Filtered, "not filtered" ; |
| 658 | |
| 659 | $h{'and'} = 'finally'; |
| 660 | is $h{'and'}, 'finally', "read eq written"; |
| 661 | |
| 662 | eval { $db->Filter_Pop() }; |
| 663 | is $@, '', "Filter_Pop"; |
| 664 | |
| 665 | undef $db; |
| 666 | { |
| 667 | use warnings FATAL => 'untie'; |
| 668 | eval { untie %h }; |
| 669 | is $@, '', "untie without inner references" ; |
| 670 | } |
| 671 | |
| 672 | checkRaw 'Op_dbmx', |
| 673 | 'abc' => 'def', |
| 674 | '123' => '456', |
| 675 | 'ABC' => 'AC', |
| 676 | 'alphaABC' => 'betaAC', |
| 677 | 'greenABC' => 'blueAC', |
| 678 | 'afterAB' => 'noonA', |
| 679 | 'morningA' => 'afterA', |
| 680 | 'and' => 'finally'; |
| 681 | |
| 682 | } |
| 683 | |
| 684 | { |
| 685 | #diag "Test Set: define the filter package in-line"; |
| 686 | |
| 687 | { |
| 688 | package DBM_Filter::append_X; |
| 689 | |
| 690 | sub Store { $_ .= 'X' } |
| 691 | sub Fetch { s/X$// } |
| 692 | } |
| 693 | |
| 694 | my %h = () ; |
| 695 | my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ; |
| 696 | ok $db, "tied to SDBM_File"; |
| 697 | |
| 698 | doPreData(\%h); |
| 699 | |
| 700 | eval { $db->Filter_Push('append_X') }; |
| 701 | is $@, '', "push 'append_X' filter" ; |
| 702 | |
| 703 | doPostData(\%h); |
| 704 | |
| 705 | undef $db; |
| 706 | { |
| 707 | use warnings FATAL => 'untie'; |
| 708 | eval { untie %h }; |
| 709 | is $@, '', "untie without inner references" ; |
| 710 | } |
| 711 | |
| 712 | checkRaw 'Op_dbmx', |
| 713 | 'abc' => 'def', |
| 714 | '123' => '456', |
| 715 | 'X' => 'X', |
| 716 | 'alphaX' => 'betaX', |
| 717 | 'greenX' => 'blueX'; |
| 718 | |
| 719 | } |
| 720 | |
projects / p5sagit/p5-mst-13.2.git / blame