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