1#line 1 2# TODO: 3# 4package Test::Base; 5use 5.006001; 6use Spiffy 0.30 -Base; 7use Spiffy ':XXX'; 8our $VERSION = '0.58'; 9 10my @test_more_exports; 11BEGIN { 12 @test_more_exports = qw( 13 ok isnt like unlike is_deeply cmp_ok 14 skip todo_skip pass fail 15 eq_array eq_hash eq_set 16 plan can_ok isa_ok diag 17 use_ok 18 $TODO 19 ); 20} 21 22use Test::More import => \@test_more_exports; 23use Carp; 24 25our @EXPORT = (@test_more_exports, qw( 26 is no_diff 27 28 blocks next_block first_block 29 delimiters spec_file spec_string 30 filters filters_delay filter_arguments 31 run run_compare run_is run_is_deeply run_like run_unlike 32 skip_all_unless_require is_deep run_is_deep 33 WWW XXX YYY ZZZ 34 tie_output no_diag_on_only 35 36 find_my_self default_object 37 38 croak carp cluck confess 39)); 40 41field '_spec_file'; 42field '_spec_string'; 43field _filters => [qw(norm trim)]; 44field _filters_map => {}; 45field spec => 46 -init => '$self->_spec_init'; 47field block_list => 48 -init => '$self->_block_list_init'; 49field _next_list => []; 50field block_delim => 51 -init => '$self->block_delim_default'; 52field data_delim => 53 -init => '$self->data_delim_default'; 54field _filters_delay => 0; 55field _no_diag_on_only => 0; 56 57field block_delim_default => '==='; 58field data_delim_default => '---'; 59 60my $default_class; 61my $default_object; 62my $reserved_section_names = {}; 63 64sub default_object { 65 $default_object ||= $default_class->new; 66 return $default_object; 67} 68 69my $import_called = 0; 70sub import() { 71 $import_called = 1; 72 my $class = (grep /^-base$/i, @_) 73 ? scalar(caller) 74 : $_[0]; 75 if (not defined $default_class) { 76 $default_class = $class; 77 } 78# else { 79# croak "Can't use $class after using $default_class" 80# unless $default_class->isa($class); 81# } 82 83 unless (grep /^-base$/i, @_) { 84 my @args; 85 for (my $ii = 1; $ii <= $#_; ++$ii) { 86 if ($_[$ii] eq '-package') { 87 ++$ii; 88 } else { 89 push @args, $_[$ii]; 90 } 91 } 92 Test::More->import(import => \@test_more_exports, @args) 93 if @args; 94 } 95 96 _strict_warnings(); 97 goto &Spiffy::import; 98} 99 100# Wrap Test::Builder::plan 101my $plan_code = \&Test::Builder::plan; 102my $Have_Plan = 0; 103{ 104 no warnings 'redefine'; 105 *Test::Builder::plan = sub { 106 $Have_Plan = 1; 107 goto &$plan_code; 108 }; 109} 110 111my $DIED = 0; 112$SIG{__DIE__} = sub { $DIED = 1; die @_ }; 113 114sub block_class { $self->find_class('Block') } 115sub filter_class { $self->find_class('Filter') } 116 117sub find_class { 118 my $suffix = shift; 119 my $class = ref($self) . "::$suffix"; 120 return $class if $class->can('new'); 121 $class = __PACKAGE__ . "::$suffix"; 122 return $class if $class->can('new'); 123 eval "require $class"; 124 return $class if $class->can('new'); 125 die "Can't find a class for $suffix"; 126} 127 128sub check_late { 129 if ($self->{block_list}) { 130 my $caller = (caller(1))[3]; 131 $caller =~ s/.*:://; 132 croak "Too late to call $caller()" 133 } 134} 135 136sub find_my_self() { 137 my $self = ref($_[0]) eq $default_class 138 ? splice(@_, 0, 1) 139 : default_object(); 140 return $self, @_; 141} 142 143sub blocks() { 144 (my ($self), @_) = find_my_self(@_); 145 146 croak "Invalid arguments passed to 'blocks'" 147 if @_ > 1; 148 croak sprintf("'%s' is invalid argument to blocks()", shift(@_)) 149 if @_ && $_[0] !~ /^[a-zA-Z]\w*$/; 150 151 my $blocks = $self->block_list; 152 153 my $section_name = shift || ''; 154 my @blocks = $section_name 155 ? (grep { exists $_->{$section_name} } @$blocks) 156 : (@$blocks); 157 158 return scalar(@blocks) unless wantarray; 159 160 return (@blocks) if $self->_filters_delay; 161 162 for my $block (@blocks) { 163 $block->run_filters 164 unless $block->is_filtered; 165 } 166 167 return (@blocks); 168} 169 170sub next_block() { 171 (my ($self), @_) = find_my_self(@_); 172 my $list = $self->_next_list; 173 if (@$list == 0) { 174 $list = [@{$self->block_list}, undef]; 175 $self->_next_list($list); 176 } 177 my $block = shift @$list; 178 if (defined $block and not $block->is_filtered) { 179 $block->run_filters; 180 } 181 return $block; 182} 183 184sub first_block() { 185 (my ($self), @_) = find_my_self(@_); 186 $self->_next_list([]); 187 $self->next_block; 188} 189 190sub filters_delay() { 191 (my ($self), @_) = find_my_self(@_); 192 $self->_filters_delay(defined $_[0] ? shift : 1); 193} 194 195sub no_diag_on_only() { 196 (my ($self), @_) = find_my_self(@_); 197 $self->_no_diag_on_only(defined $_[0] ? shift : 1); 198} 199 200sub delimiters() { 201 (my ($self), @_) = find_my_self(@_); 202 $self->check_late; 203 my ($block_delimiter, $data_delimiter) = @_; 204 $block_delimiter ||= $self->block_delim_default; 205 $data_delimiter ||= $self->data_delim_default; 206 $self->block_delim($block_delimiter); 207 $self->data_delim($data_delimiter); 208 return $self; 209} 210 211sub spec_file() { 212 (my ($self), @_) = find_my_self(@_); 213 $self->check_late; 214 $self->_spec_file(shift); 215 return $self; 216} 217 218sub spec_string() { 219 (my ($self), @_) = find_my_self(@_); 220 $self->check_late; 221 $self->_spec_string(shift); 222 return $self; 223} 224 225sub filters() { 226 (my ($self), @_) = find_my_self(@_); 227 if (ref($_[0]) eq 'HASH') { 228 $self->_filters_map(shift); 229 } 230 else { 231 my $filters = $self->_filters; 232 push @$filters, @_; 233 } 234 return $self; 235} 236 237sub filter_arguments() { 238 $Test::Base::Filter::arguments; 239} 240 241sub have_text_diff { 242 eval { require Text::Diff; 1 } && 243 $Text::Diff::VERSION >= 0.35 && 244 $Algorithm::Diff::VERSION >= 1.15; 245} 246 247sub is($$;$) { 248 (my ($self), @_) = find_my_self(@_); 249 my ($actual, $expected, $name) = @_; 250 local $Test::Builder::Level = $Test::Builder::Level + 1; 251 if ($ENV{TEST_SHOW_NO_DIFFS} or 252 not defined $actual or 253 not defined $expected or 254 $actual eq $expected or 255 not($self->have_text_diff) or 256 $expected !~ /\n./s 257 ) { 258 Test::More::is($actual, $expected, $name); 259 } 260 else { 261 $name = '' unless defined $name; 262 ok $actual eq $expected, 263 $name . "\n" . Text::Diff::diff(\$expected, \$actual); 264 } 265} 266 267sub run(&;$) { 268 (my ($self), @_) = find_my_self(@_); 269 my $callback = shift; 270 for my $block (@{$self->block_list}) { 271 $block->run_filters unless $block->is_filtered; 272 &{$callback}($block); 273 } 274} 275 276my $name_error = "Can't determine section names"; 277sub _section_names { 278 return @_ if @_ == 2; 279 my $block = $self->first_block 280 or croak $name_error; 281 my @names = grep { 282 $_ !~ /^(ONLY|LAST|SKIP)$/; 283 } @{$block->{_section_order}[0] || []}; 284 croak "$name_error. Need two sections in first block" 285 unless @names == 2; 286 return @names; 287} 288 289sub _assert_plan { 290 plan('no_plan') unless $Have_Plan; 291} 292 293sub END { 294 run_compare() unless $Have_Plan or $DIED or not $import_called; 295} 296 297sub run_compare() { 298 (my ($self), @_) = find_my_self(@_); 299 $self->_assert_plan; 300 my ($x, $y) = $self->_section_names(@_); 301 local $Test::Builder::Level = $Test::Builder::Level + 1; 302 for my $block (@{$self->block_list}) { 303 next unless exists($block->{$x}) and exists($block->{$y}); 304 $block->run_filters unless $block->is_filtered; 305 if (ref $block->$x) { 306 is_deeply($block->$x, $block->$y, 307 $block->name ? $block->name : ()); 308 } 309 elsif (ref $block->$y eq 'Regexp') { 310 my $regexp = ref $y ? $y : $block->$y; 311 like($block->$x, $regexp, $block->name ? $block->name : ()); 312 } 313 else { 314 is($block->$x, $block->$y, $block->name ? $block->name : ()); 315 } 316 } 317} 318 319sub run_is() { 320 (my ($self), @_) = find_my_self(@_); 321 $self->_assert_plan; 322 my ($x, $y) = $self->_section_names(@_); 323 local $Test::Builder::Level = $Test::Builder::Level + 1; 324 for my $block (@{$self->block_list}) { 325 next unless exists($block->{$x}) and exists($block->{$y}); 326 $block->run_filters unless $block->is_filtered; 327 is($block->$x, $block->$y, 328 $block->name ? $block->name : () 329 ); 330 } 331} 332 333sub run_is_deeply() { 334 (my ($self), @_) = find_my_self(@_); 335 $self->_assert_plan; 336 my ($x, $y) = $self->_section_names(@_); 337 for my $block (@{$self->block_list}) { 338 next unless exists($block->{$x}) and exists($block->{$y}); 339 $block->run_filters unless $block->is_filtered; 340 is_deeply($block->$x, $block->$y, 341 $block->name ? $block->name : () 342 ); 343 } 344} 345 346sub run_like() { 347 (my ($self), @_) = find_my_self(@_); 348 $self->_assert_plan; 349 my ($x, $y) = $self->_section_names(@_); 350 for my $block (@{$self->block_list}) { 351 next unless exists($block->{$x}) and defined($y); 352 $block->run_filters unless $block->is_filtered; 353 my $regexp = ref $y ? $y : $block->$y; 354 like($block->$x, $regexp, 355 $block->name ? $block->name : () 356 ); 357 } 358} 359 360sub run_unlike() { 361 (my ($self), @_) = find_my_self(@_); 362 $self->_assert_plan; 363 my ($x, $y) = $self->_section_names(@_); 364 for my $block (@{$self->block_list}) { 365 next unless exists($block->{$x}) and defined($y); 366 $block->run_filters unless $block->is_filtered; 367 my $regexp = ref $y ? $y : $block->$y; 368 unlike($block->$x, $regexp, 369 $block->name ? $block->name : () 370 ); 371 } 372} 373 374sub skip_all_unless_require() { 375 (my ($self), @_) = find_my_self(@_); 376 my $module = shift; 377 eval "require $module; 1" 378 or Test::More::plan( 379 skip_all => "$module failed to load" 380 ); 381} 382 383sub is_deep() { 384 (my ($self), @_) = find_my_self(@_); 385 require Test::Deep; 386 Test::Deep::cmp_deeply(@_); 387} 388 389sub run_is_deep() { 390 (my ($self), @_) = find_my_self(@_); 391 $self->_assert_plan; 392 my ($x, $y) = $self->_section_names(@_); 393 for my $block (@{$self->block_list}) { 394 next unless exists($block->{$x}) and exists($block->{$y}); 395 $block->run_filters unless $block->is_filtered; 396 is_deep($block->$x, $block->$y, 397 $block->name ? $block->name : () 398 ); 399 } 400} 401 402sub _pre_eval { 403 my $spec = shift; 404 return $spec unless $spec =~ 405 s/\A\s*<<<(.*?)>>>\s*$//sm; 406 my $eval_code = $1; 407 eval "package main; $eval_code"; 408 croak $@ if $@; 409 return $spec; 410} 411 412sub _block_list_init { 413 my $spec = $self->spec; 414 $spec = $self->_pre_eval($spec); 415 my $cd = $self->block_delim; 416 my @hunks = ($spec =~ /^(\Q${cd}\E.*?(?=^\Q${cd}\E|\z))/msg); 417 my $blocks = $self->_choose_blocks(@hunks); 418 $self->block_list($blocks); # Need to set early for possible filter use 419 my $seq = 1; 420 for my $block (@$blocks) { 421 $block->blocks_object($self); 422 $block->seq_num($seq++); 423 } 424 return $blocks; 425} 426 427sub _choose_blocks { 428 my $blocks = []; 429 for my $hunk (@_) { 430 my $block = $self->_make_block($hunk); 431 if (exists $block->{ONLY}) { 432 diag "I found ONLY: maybe you're debugging?" 433 unless $self->_no_diag_on_only; 434 return [$block]; 435 } 436 next if exists $block->{SKIP}; 437 push @$blocks, $block; 438 if (exists $block->{LAST}) { 439 return $blocks; 440 } 441 } 442 return $blocks; 443} 444 445sub _check_reserved { 446 my $id = shift; 447 croak "'$id' is a reserved name. Use something else.\n" 448 if $reserved_section_names->{$id} or 449 $id =~ /^_/; 450} 451 452sub _make_block { 453 my $hunk = shift; 454 my $cd = $self->block_delim; 455 my $dd = $self->data_delim; 456 my $block = $self->block_class->new; 457 $hunk =~ s/\A\Q${cd}\E[ \t]*(.*)\s+// or die; 458 my $name = $1; 459 my @parts = split /^\Q${dd}\E +\(?(\w+)\)? *(.*)?\n/m, $hunk; 460 my $description = shift @parts; 461 $description ||= ''; 462 unless ($description =~ /\S/) { 463 $description = $name; 464 } 465 $description =~ s/\s*\z//; 466 $block->set_value(description => $description); 467 468 my $section_map = {}; 469 my $section_order = []; 470 while (@parts) { 471 my ($type, $filters, $value) = splice(@parts, 0, 3); 472 $self->_check_reserved($type); 473 $value = '' unless defined $value; 474 $filters = '' unless defined $filters; 475 if ($filters =~ /:(\s|\z)/) { 476 croak "Extra lines not allowed in '$type' section" 477 if $value =~ /\S/; 478 ($filters, $value) = split /\s*:(?:\s+|\z)/, $filters, 2; 479 $value = '' unless defined $value; 480 $value =~ s/^\s*(.*?)\s*$/$1/; 481 } 482 $section_map->{$type} = { 483 filters => $filters, 484 }; 485 push @$section_order, $type; 486 $block->set_value($type, $value); 487 } 488 $block->set_value(name => $name); 489 $block->set_value(_section_map => $section_map); 490 $block->set_value(_section_order => $section_order); 491 return $block; 492} 493 494sub _spec_init { 495 return $self->_spec_string 496 if $self->_spec_string; 497 local $/; 498 my $spec; 499 if (my $spec_file = $self->_spec_file) { 500 open FILE, $spec_file or die $!; 501 $spec = <FILE>; 502 close FILE; 503 } 504 else { 505 $spec = do { 506 package main; 507 no warnings 'once'; 508 <DATA>; 509 }; 510 } 511 return $spec; 512} 513 514sub _strict_warnings() { 515 require Filter::Util::Call; 516 my $done = 0; 517 Filter::Util::Call::filter_add( 518 sub { 519 return 0 if $done; 520 my ($data, $end) = ('', ''); 521 while (my $status = Filter::Util::Call::filter_read()) { 522 return $status if $status < 0; 523 if (/^__(?:END|DATA)__\r?$/) { 524 $end = $_; 525 last; 526 } 527 $data .= $_; 528 $_ = ''; 529 } 530 $_ = "use strict;use warnings;$data$end"; 531 $done = 1; 532 } 533 ); 534} 535 536sub tie_output() { 537 my $handle = shift; 538 die "No buffer to tie" unless @_; 539 tie $handle, 'Test::Base::Handle', $_[0]; 540} 541 542sub no_diff { 543 $ENV{TEST_SHOW_NO_DIFFS} = 1; 544} 545 546package Test::Base::Handle; 547 548sub TIEHANDLE() { 549 my $class = shift; 550 bless \ $_[0], $class; 551} 552 553sub PRINT { 554 $$self .= $_ for @_; 555} 556 557#=============================================================================== 558# Test::Base::Block 559# 560# This is the default class for accessing a Test::Base block object. 561#=============================================================================== 562package Test::Base::Block; 563our @ISA = qw(Spiffy); 564 565our @EXPORT = qw(block_accessor); 566 567sub AUTOLOAD { 568 return; 569} 570 571sub block_accessor() { 572 my $accessor = shift; 573 no strict 'refs'; 574 return if defined &$accessor; 575 *$accessor = sub { 576 my $self = shift; 577 if (@_) { 578 Carp::croak "Not allowed to set values for '$accessor'"; 579 } 580 my @list = @{$self->{$accessor} || []}; 581 return wantarray 582 ? (@list) 583 : $list[0]; 584 }; 585} 586 587block_accessor 'name'; 588block_accessor 'description'; 589Spiffy::field 'seq_num'; 590Spiffy::field 'is_filtered'; 591Spiffy::field 'blocks_object'; 592Spiffy::field 'original_values' => {}; 593 594sub set_value { 595 no strict 'refs'; 596 my $accessor = shift; 597 block_accessor $accessor 598 unless defined &$accessor; 599 $self->{$accessor} = [@_]; 600} 601 602sub run_filters { 603 my $map = $self->_section_map; 604 my $order = $self->_section_order; 605 Carp::croak "Attempt to filter a block twice" 606 if $self->is_filtered; 607 for my $type (@$order) { 608 my $filters = $map->{$type}{filters}; 609 my @value = $self->$type; 610 $self->original_values->{$type} = $value[0]; 611 for my $filter ($self->_get_filters($type, $filters)) { 612 $Test::Base::Filter::arguments = 613 $filter =~ s/=(.*)$// ? $1 : undef; 614 my $function = "main::$filter"; 615 no strict 'refs'; 616 if (defined &$function) { 617 local $_ = 618 (@value == 1 and not defined($value[0])) ? undef : 619 join '', @value; 620 my $old = $_; 621 @value = &$function(@value); 622 if (not(@value) or 623 @value == 1 and defined($value[0]) and $value[0] =~ /\A(\d+|)\z/ 624 ) { 625 if ($value[0] && $_ eq $old) { 626 Test::Base::diag("Filters returning numbers are supposed to do munging \$_: your filter '$function' apparently doesn't."); 627 } 628 @value = ($_); 629 } 630 } 631 else { 632 my $filter_object = $self->blocks_object->filter_class->new; 633 die "Can't find a function or method for '$filter' filter\n" 634 unless $filter_object->can($filter); 635 $filter_object->current_block($self); 636 @value = $filter_object->$filter(@value); 637 } 638 # Set the value after each filter since other filters may be 639 # introspecting. 640 $self->set_value($type, @value); 641 } 642 } 643 $self->is_filtered(1); 644} 645 646sub _get_filters { 647 my $type = shift; 648 my $string = shift || ''; 649 $string =~ s/\s*(.*?)\s*/$1/; 650 my @filters = (); 651 my $map_filters = $self->blocks_object->_filters_map->{$type} || []; 652 $map_filters = [ $map_filters ] unless ref $map_filters; 653 my @append = (); 654 for ( 655 @{$self->blocks_object->_filters}, 656 @$map_filters, 657 split(/\s+/, $string), 658 ) { 659 my $filter = $_; 660 last unless length $filter; 661 if ($filter =~ s/^-//) { 662 @filters = grep { $_ ne $filter } @filters; 663 } 664 elsif ($filter =~ s/^\+//) { 665 push @append, $filter; 666 } 667 else { 668 push @filters, $filter; 669 } 670 } 671 return @filters, @append; 672} 673 674{ 675 %$reserved_section_names = map { 676 ($_, 1); 677 } keys(%Test::Base::Block::), qw( new DESTROY ); 678} 679 680__DATA__ 681 682=encoding utf8 683 684#line 1376 685