Test-Base-0.60/0000755000175000017500000000000011546276243011736 5ustar ingyingyTest-Base-0.60/META.yml0000644000175000017500000000111711546276227013211 0ustar ingyingy--- abstract: 'A Data Driven Testing Framework' author: - 'Ingy döt Net ' build_requires: ExtUtils::MakeMaker: 6.42 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 1.00' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Test-Base no_index: directory: - inc - t recommends: Test::Deep: 0 requires: Filter::Util::Call: 0 Spiffy: 0.30 Test::More: 0.62 perl: 5.6.1 resources: license: http://dev.perl.org/licenses/ version: 0.60 Test-Base-0.60/t/0000755000175000017500000000000011546276243012201 5ustar ingyingyTest-Base-0.60/t/xxx.t0000644000175000017500000000052111545127523013206 0ustar ingyingyuse Test::Base; plan eval { require YAML; 1 } ? (tests => 1 * blocks) : skip_all => 'Requires YAML'; my ($block) = blocks; eval { XXX($block->text) }; my $error = "$@"; $error =~ s/\\/\//g; is $error, $block->xxx, $block->name; __DATA__ === XXX Test --- text eval +{ foo => 'bar' } --- xxx --- foo: bar ... at t/xxx.t line 9 Test-Base-0.60/t/escape.t0000644000175000017500000000031611545127523013621 0ustar ingyingyuse Test::Base tests => 2; is next_block->escaped, "line1\nline2"; is next_block->escaped, " foo\n bar\n"; __END__ === --- escaped escape chomp line1\nline2 === --- escaped escape \tfoo \t\tbar Test-Base-0.60/t/internals.t0000644000175000017500000000561011545127523014362 0ustar ingyingy# Each filter should have access to blocks/block internals. use Test::Base tests => 20 * 2; run {}; package Test::Base::Filter; use Test::More; sub foo { my $self = shift; my $value = shift; # Test access to Test::Base::Filter object. ok ref($self), '$self is an object'; is ref($self), 'Test::Base::Filter', '$self is a Test:Base::Filter object'; like $value, qr/^This is some .*text.\z/, 'Filter value is correct'; # Test access to Test::Base::Block object. my $block = $self->current_block; is ref($block), 'Test::Base::Block', 'Have a reference to our block object'; ok not($block->is_filtered), 'Block is not completely filtered yet'; my $name = shift || 'One'; is $block->name, $name, 'name is correct'; my $description = shift || 'One'; is $block->description, $description, 'description is correct'; my $original = shift || "This is some text."; is $block->original_values->{xxx}, $original, 'Access to the original value'; my $seq_num = shift || 1; cmp_ok $block->seq_num, '==', $seq_num, 'Sequence number (seq_num) is correct'; my $array_xxx = shift || ["This is some text."]; is_deeply $block->{xxx}, $array_xxx, 'Test raw content of $block->{xxx}'; my $method_xxx = shift || "This is some text."; is $block->xxx, $method_xxx, 'Test method content of $block->xxx'; # Test access to Test::Base object. my $blocks = $block->blocks_object; my $block_list = $blocks->block_list; is ref($block_list), 'ARRAY', 'Have an array of all blocks'; is scalar(@$block_list), '2', 'Is there 2 blocks?'; is $blocks->block_class, "Test::Base::Block", 'block class'; is $blocks->filter_class, "Test::Base::Filter", 'filter class'; is_deeply $blocks->{_filters}, [qw(norm trim)], 'default filters are ok'; is $blocks->block_delim, '===', 'block delimiter'; is $blocks->data_delim, '---', 'data delimiter'; my $spec = <spec, $spec, 'spec is ok'; is $block_list->[$seq_num - 1], $block, 'test block ref in list'; } sub bar { my $self = shift; my $value = shift; $self->foo($value, 'Two', "This is the 2nd description.\nRight here.", "This is some more text.\n\n", 2, ["This is some more text."], "This is some more text.", ); } __END__ === One --- xxx foo: This is some text. === Two This is the 2nd description. Right here. --- xxx chomp bar This is some more text. Test-Base-0.60/t/eval_stdout.t0000644000175000017500000000031211545127523014706 0ustar ingyingyuse Test::Base tests => 1; is next_block->perl, <<'...'; You are a foo! You are 1 2. ... __DATA__ === --- perl eval_stdout print "You are a foo!\n"; my $foo = 2; print "You are 1 $foo.\n"; return 42; Test-Base-0.60/t/prototypes.t0000644000175000017500000000023011545127523014604 0ustar ingyingyuse Test::Base tests => 1; is foo(), 'scalar_context', 'testing force scalar context'; sub foo { wantarray ? 'list_context' : 'scalar_context'; } Test-Base-0.60/t/delimiters.t0000644000175000017500000000022611545127523014522 0ustar ingyingyuse Test::Base tests => 2; delimiters qw($$$ ***); run { ok(shift); }; __END__ $$$ *** foo this *** bar that $$$ *** foo hola *** bar latre Test-Base-0.60/t/main_filters.t0000644000175000017500000000127211545127523015037 0ustar ingyingyuse Test::Base tests => 6; is next_block->xxx, "I lmike mike\n"; is next_block->xxx, "I like mikey"; is next_block->xxx, "123\n"; is next_block->xxx, "I like MIKEY"; is next_block->xxx, "I like ike\n"; run_is xxx => 'yyy'; sub mike1 { s/ike/mike/g; }; sub mike2 { $_ = 'I like mikey'; return 123; }; sub mike3 { s/ike/heck/; return "123\n"; } sub mike4 { $_ = 'I like MIKEY'; return; } sub mike5 { return 200; } sub yyy { s/x/y/g } __DATA__ === --- xxx mike1 I like ike === --- xxx mike2 I like ike === --- xxx mike3 I like ike === --- xxx mike4 I like ike === --- xxx mike5 I like ike === --- xxx lines yyy xxx xxx xxx xxx --- yyy yyy yyy yyy yyy Test-Base-0.60/t/strict-warnings.test0000644000175000017500000000005011545127523016226 0ustar ingyingyuse Test::Base; $global_variable = 42; Test-Base-0.60/t/run_unlike.t0000644000175000017500000000123111546275211014530 0ustar ingyingyuse Test::Base tests => 2; sub perl514 { skip "perl-5.14 regexp stringification is different", shift || 1 if $] > 5.013; } run_unlike('html', 're1'); SKIP: { perl514; run_is 're1' => 're2'; } __END__ === Unlike Test --- html --- re1 regexp=i software error --- re2 chomp (?i-xsm:software error) Test-Base-0.60/t/read_file.t0000644000175000017500000000041211545127523014270 0ustar ingyingyuse Test::Base; __END__ === Filename is chomped automatically --- file read_file t/sample-file.txt --- content A sample of some text in a sample file! === Filename is inline --- file read_file: t/sample-file.txt --- content A sample of some text in a sample file! Test-Base-0.60/t/name.t0000644000175000017500000000040111545127523013274 0ustar ingyingyuse Test::Base; plan tests => 1 * blocks; my @blocks = blocks; is $blocks[0]->name, 'One Time'; is $blocks[1]->name, 'Two Toes'; is $blocks[2]->name, ''; is $blocks[3]->name, 'Three Tips'; __END__ === One Time === Two Toes --- foo === === Three Tips Test-Base-0.60/t/export.t0000644000175000017500000000166511545127523013712 0ustar ingyingyuse Test::Base; plan tests => 41; ok(defined &plan); ok(defined &ok); ok(defined &is); ok(defined &isnt); ok(defined &like); ok(defined &unlike); ok(defined &is_deeply); ok(defined &cmp_ok); ok(defined &skip); ok(defined &todo_skip); ok(defined &pass); ok(defined &fail); ok(defined &eq_array); ok(defined &eq_hash); ok(defined &eq_set); ok(defined &can_ok); ok(defined &isa_ok); ok(defined &diag); ok(defined &use_ok); ok(defined &blocks); ok(defined &next_block); ok(defined &delimiters); ok(defined &spec_file); ok(defined &spec_string); ok(defined &filters); ok(not defined &filters_map); ok(defined &filters_delay); ok(defined &run); ok(defined &run_is); ok(defined &run_like); ok(defined &run_unlike); ok(defined &run_compare); ok(not defined &diff_is); ok(defined &default_object); ok(defined &WWW); ok(defined &XXX); ok(defined &YYY); ok(defined &ZZZ); ok(defined &croak); ok(defined &carp); # ok(defined &cluck); ok(defined &confess); Test-Base-0.60/t/reverse.t0000644000175000017500000000027411545127523014037 0ustar ingyingyuse Test::Base; __DATA__ === --- (a) split reverse join=\s: this and that --- (b) : that and this === --- (a) lines reverse join This And That --- (b) That And This Test-Base-0.60/t/repeated-filters.t0000644000175000017500000000015311545127523015617 0ustar ingyingyuse Test::Base; __DATA__ === --- (foo) lines reverse reverse join one two three --- (bar) one two three Test-Base-0.60/t/TestA.pm0000644000175000017500000000005011545127523013545 0ustar ingyingypackage t::TestA; use Test::Base -Base; Test-Base-0.60/t/preserve-order.t0000644000175000017500000000053211545127523015325 0ustar ingyingyuse Test::Base tests => 10; run {}; my $count = 0; sub test { my $num = shift; chomp $num; is $num, ++$count; return; } __END__ === One --- grape test 1 --- iceberg_lettuce test 2 --- fig test 3 --- eggplant test 4 --- jalepeno test 5 --- banana test 6 --- apple test 7 --- carrot test 8 --- hot_pepper test 9 --- date test 10 Test-Base-0.60/t/filters-append.t0000644000175000017500000000046111545127523015277 0ustar ingyingyuse Test::Base tests => 2; filters qw(chomp +bar foo); is next_block->text, "this,foo,that,bar"; # 2nd test is needed is next_block->text, "this,foo,that,bar"; sub foo { $_[0] . ",foo" } sub bar { $_[0] . ",bar" } sub that { $_[0] . ",that" } __DATA__ === --- text that this === --- text that this Test-Base-0.60/t/next.t0000644000175000017500000000043611545127523013342 0ustar ingyingyuse Test::Base tests => 10; for (1..2) { is next_block->foo, 'This is foo'; is next_block->bar, 'This is bar'; while (my $block = next_block) { pass; } } __DATA__ === One --- foo chomp This is foo === Two --- bar chomp This is bar === Three === Four === Five Test-Base-0.60/t/compile.t0000644000175000017500000000007011545127523014006 0ustar ingyingyuse Test::Base tests => 1; pass 'Test::Base compiles'; Test-Base-0.60/t/run_is.t0000644000175000017500000000075611545127523013670 0ustar ingyingyuse Test::Base; plan tests => 7 * blocks; run_is 'foo', 'bar'; run_is 'bar', 'baz'; run_is 'baz', 'foo'; for my $block (blocks) { is $block->foo, $block->bar, $block->name; is $block->bar, $block->baz, $block->name; is $block->baz, $block->foo, $block->name; } my @blocks = blocks; is $blocks[0]->foo, "Hey Now\n"; is $blocks[1]->foo, "Holy Cow\n"; __END__ === One --- foo Hey Now --- bar Hey Now --- baz Hey Now === Two --- baz Holy Cow --- bar Holy Cow --- foo Holy Cow Test-Base-0.60/t/run_compare.t0000644000175000017500000000042711545127523014676 0ustar ingyingyuse Test::Base tests => 3; run_compare in => 'out'; __DATA__ === Compare strings --- in split sort join=\s: ccc bbb aaa --- out: aaa bbb ccc === Compare deeply --- in eval: [1, 2, 3] --- out eval Reverse: [3, 2, 1] === Compare like --- in: You are here --- out regexp: ere$ Test-Base-0.60/t/TestC.pm0000644000175000017500000000004611545127523013554 0ustar ingyingypackage t::TestC; use t::TestB -Base; Test-Base-0.60/t/undef.t0000644000175000017500000000067011545127523013465 0ustar ingyingyuse Test::Base tests => 2; filters { perl => ['eval', 'bang'], value => 'chomp', perl2 => 'eval', dummy => 'uuu', }; run_is perl => 'value'; run_is dummy => 'perl2'; sub bang { return defined($_) ? ':-(' : '!!!'; } sub uuu { undef($_); return undef; } __DATA__ === No warnings for sending undef to filter --- perl undef --- value !!! === No warnings returning undef from filter --- dummy --- perl2 undef Test-Base-0.60/t/deep.t0000644000175000017500000000101011545127523013266 0ustar ingyingyBEGIN { eval("use Test::Tester") } use Test::Base; BEGIN { skip_all_unless_require('Test::Tester'); skip_all_unless_require('Test::Deep'); } plan tests => 2; my $a = {}; my $b = bless {}, 'Foo'; my $name = "is_deep works on non vs blessed hashes"; my ($dummy, @results) = Test::Tester::run_tests( sub { is_deep($a, $b, $name); }, { ok => 0, name => $name, }, ); is($results[0]->{ok}, 0, "Test did not match"); is($results[0]->{name}, $name, "Test name is correct"); Test-Base-0.60/t/simple.t0000644000175000017500000000060111545127523013647 0ustar ingyingyuse Test::Base; plan tests => 1 * blocks; # A silly test instead of pod2html for my $block (blocks) { is( uc($block->pod), $block->upper, $block->name, ); } __END__ === Header 1 Test --- pod =head1 The Main Event --- upper =HEAD1 THE MAIN EVENT === List Test --- pod =over =item * one =item * two =back --- upper =OVER =ITEM * ONE =ITEM * TWO =BACK Test-Base-0.60/t/dumper.t0000644000175000017500000000070111545127523013653 0ustar ingyingyuse Test::Base; plan tests => 3 * blocks; run_is perl => 'dumper'; run_is dumper => 'perl'; run_is dumper => 'dumper'; __DATA__ === Dumper Test --- perl eval dumper [ 1..5, { 'a' .. 'p' }] --- dumper [ 1, 2, 3, 4, 5, { 'a' => 'b', 'c' => 'd', 'e' => 'f', 'g' => 'h', 'i' => 'j', 'k' => 'l', 'm' => 'n', 'o' => 'p' } ] === Another Dumper Test --- perl eval dumper "i like ike" --- dumper 'i like ike' Test-Base-0.60/t/trim.t0000644000175000017500000000050611545127523013335 0ustar ingyingyuse Test::Base tests => 4; my ($block1, $block2) = blocks; is $block1->foo, "line 1\nline 2\n"; is $block1->bar, "line1\nline2\n"; is $block2->foo, "aaa\n\nbbb\n"; is $block2->bar, "\nxxxx\n\nyyyy\n\n"; __END__ === One --- foo line 1 line 2 --- bar line1 line2 === Two --- bar -trim xxxx yyyy --- foo aaa bbb Test-Base-0.60/t/filter_delay.t0000644000175000017500000000107011545127523015022 0ustar ingyingy# Each filter should have access to blocks/block internals. use Test::Base; filters qw(chomp lower); filters_delay; plan tests => 8 * blocks; for my $block (blocks) { ok not($block->is_filtered); unlike $block->section, qr/[a-z]/; like $block->section, qr/^I L/; like $block->section, qr/\n/; $block->run_filters; ok $block->is_filtered; like $block->section, qr/[a-z]/; like $block->section, qr/^i l/; unlike $block->section, qr/\n/; } sub lower { lc } __DATA__ === One --- section I LIKE IKE === One --- section I LOVE LUCY Test-Base-0.60/t/TestBass.pm0000644000175000017500000000074611545127523014271 0ustar ingyingypackage TestBass; use Test::Base -Base; # const block_class => 'TestBass::Block'; # const filter_class => 'TestBass::Filter'; our @EXPORT = qw(run_like_hell); sub run_like_hell() { (my ($self), @_) = find_my_self(@_); $self->run_like(@_); } package TestBass::Block; use base 'Test::Base::Block'; sub el_nombre { $self->name(@_) } block_accessor 'feedle'; package TestBass::Filter; use base 'Test::Base::Filter'; sub foo_it { map { "foo - $_"; } @_; } Test-Base-0.60/t/spec20000644000175000017500000000006011545127523013127 0ustar ingyingy=== --- foo 1 --- bar 2 === --- foo 3 --- bar 4 Test-Base-0.60/t/base64.t0000644000175000017500000000103711545127523013446 0ustar ingyingyuse Test::Base; plan tests => ~~blocks; run_is; __END__ === Test One --- encoded base64_decode SSBMb3ZlIEx1Y3kK --- decoded I Love Lucy === Test Two --- encoded c3ViIHJ1bigmKSB7CiAgICBteSAkc2VsZiA9ICRkZWZhdWx0X29iamVjdDsKICAgIG15ICRjYWxs YmFjayA9IHNoaWZ0OwogICAgZm9yIG15ICRibG9jayAoJHNlbGYtPmJsb2NrcykgewogICAgICAg ICZ7JGNhbGxiYWNrfSgkYmxvY2spOwogICAgfQp9Cg== --- decoded base64_encode sub run(&) { my $self = $default_object; my $callback = shift; for my $block ($self->blocks) { &{$callback}($block); } } Test-Base-0.60/t/first_block.t0000644000175000017500000000044011545127523014660 0ustar ingyingyuse Test::Base tests => 7; filters 'chomp'; is next_block->test, '1'; is next_block->test, '2'; is first_block->test, '1'; is first_block->test, '1'; is next_block->test, '2'; is next_block->test, '3'; ok not defined next_block; __DATA__ === --- test 1 === --- test 2 === --- test 3 Test-Base-0.60/t/filters_map.t0000644000175000017500000000114411545127523014666 0ustar ingyingyuse Test::Base tests => 7; eval { filters_map { perl => ['eval'], text => ['chomp', 'lines', 'array'], }; }; like $@, qr{Can't locate object method "filters_map"}; filters { perl => ['eval'], text => ['chomp', 'lines', 'array'], }; run { my $block = shift; is ref($block->perl), 'ARRAY'; is ref($block->text), 'ARRAY'; is_deeply $block->perl, $block->text; }; __DATA__ === One --- perl [ "One\n", "2nd line\n", "\n", "Third time's a charm", ] --- text One 2nd line Third time's a charm === Two --- text tic tac toe --- perl [ 'tic tac toe' ] Test-Base-0.60/t/spec_file.t0000644000175000017500000000042311545127523014311 0ustar ingyingyuse Test::Base; filters 'chomp'; spec_file 't/spec2'; plan tests => 3 * blocks; run { my $block = shift; is ref($block), 'Test::Base::Block'; }; my @blocks = blocks; is($blocks[0]->foo, 1); is($blocks[0]->bar, 2); is($blocks[1]->foo, 3); is($blocks[1]->bar, 4); Test-Base-0.60/t/sort.t0000644000175000017500000000031211545127523013344 0ustar ingyingyuse Test::Base; __DATA__ === Can sort a list --- (in) split sort join=-: foo bar baz --- out: bar-baz-foo === Can sort backwards --- (in) split sort reverse join=-: foo bar baz --- out: foo-baz-bar Test-Base-0.60/t/last.t0000644000175000017500000000063611545127523013331 0ustar ingyingyuse Test::Base tests => 4; is scalar(blocks), 3, 'Does LAST limit tests to 3?'; run { is(shift()->test, 'all work and no play'); } __DATA__ === --- test: all work and no play === --- test: all work and no play === --- LAST --- test: all work and no play === --- test: all work and no play === --- test: all work and no play === --- test: all work and no play === --- test: all work and no play Test-Base-0.60/t/slice.t0000644000175000017500000000035511545127523013463 0ustar ingyingyuse Test::Base; __DATA__ === --- in lines slice=0,2 join one two three four five --- out one two three === --- in lines slice=2,3 join one two three four five --- out three four === --- in lines slice=1 join one two three --- out two Test-Base-0.60/t/diff_is.t0000644000175000017500000000342111545127523013764 0ustar ingyingyuse Test::Base tests => 3; SKIP: { if ($^O eq 'MSWin32') { skip 'Win32 doesn\'t have /tmp', 3; } unless (Test::Base->have_text_diff) { skip 'The autodiffing feature of Test::Base (which rocketh) requires Text-Diff-0.35 and Algorithm-Diff-1.15 (or greater).', 3; } filters { test => [qw(exec_perl_stdout smooth_output)], expected => 'smooth_output', }; run_is; sub smooth_output { s/test-blocks-\d+/test-blocks-321/; s/at line \d+\)/at line 000)/; s/in (.*) at line (\d+)/at $1 line $2/; # for Test::Simple 0.65 s/^\n//gm; } } __DATA__ === little diff --- test use lib 'lib'; use Test::Base tests => 1; is('a b c', 'a b x', 'little diff'); --- expected 1..1 not ok 1 - little diff # Failed test 'little diff' # in /tmp/test-blocks-321 at line 3. # got: 'a b c' # expected: 'a b x' # Looks like you failed 1 test of 1. === big diff --- test use lib 'lib'; use Test::Base tests => 1; is(< 1; is(< 18; for my $word (qw( BEGIN DESTROY EXPORT ISA block_accessor blocks_object description is_filtered name new run_filters seq_num set_value )) { my $blocks = my_blocks($word); eval {$blocks->blocks}; like $@, qr{'$word' is a reserved name}, "$word is a bad name"; } for my $word (qw( field const stub super )) { my $blocks = my_blocks($word); my @blocks = $blocks->blocks; eval {$blocks->blocks}; is "$@", '', "$word is a good name"; } sub my_blocks { my $word = shift; Test::Base->new->spec_string(<<"..."); === Fail test --- $word This is a test --- foo This is a test ... } my $blocks = Test::Base->new->spec_string(<<'...'); === Fail test --- bar This is a test --- foo This is a test ... eval {$blocks->blocks}; is "$@", ''; Test-Base-0.60/t/BaseTest.pm0000644000175000017500000000013411545127523014242 0ustar ingyingypackage t::BaseTest; use Test::Base -Base; use File::Path qw(rmtree); rmtree('t/output'); Test-Base-0.60/t/array.t0000644000175000017500000000023711545127523013501 0ustar ingyingyuse Test::Base tests => 1; is_deeply first_block->foo, [qw(one two three)]; __DATA__ === Create an array reference --- foo lines chomp array one two three Test-Base-0.60/t/run_is_deep.t0000644000175000017500000000046311545127523014660 0ustar ingyingyuse Test::Base; BEGIN { skip_all_unless_require('Test::Deep'); } plan tests => 3; filters 'eval'; run_is_deep qw(foo bar); run { my $block = shift; ok ref $block->foo; ok ref $block->bar; }; __DATA__ === Test is_deeply --- foo { foo => 22, bar => 33 } --- bar { bar => 33, foo => 22 } Test-Base-0.60/t/hash.t0000644000175000017500000000023211545127523013301 0ustar ingyingyuse Test::Base; __DATA__ === --- words lines chomp hash foo 42 bar 44 baz because --- hash eval +{ foo => 42, bar => 44, baz => 'because', } Test-Base-0.60/t/zero-blocks.t0000644000175000017500000000020111545127523014604 0ustar ingyingyuse Test::Base; plan tests => 1; ok(blocks == 0, 'Ok to have zero blocks'); __DATA__ There really is nothing here to test... Test-Base-0.60/t/sample-file.txt0000644000175000017500000000005011545127523015126 0ustar ingyingyA sample of some text in a sample file! Test-Base-0.60/t/filters.t0000644000175000017500000000050011545127523014024 0ustar ingyingyuse Test::Base; filters 'upper'; plan tests => 2; run { my $block = shift; is($block->one, $block->two); }; my ($block) = blocks; is($block->one, "HEY NOW HEY NOW\n"); sub Test::Base::Filter::upper { my $self = shift; return uc(shift); } __END__ === --- one Hey now Hey Now --- two hEY NoW hEY NoW Test-Base-0.60/t/tie_output.t0000644000175000017500000000061211545127523014561 0ustar ingyingyuse Test::Base tests => 3; my $out = "Stuff\n"; my $err = ''; tie_output(*STDOUT, $out); tie_output(*STDERR, $err); warn "Keep out!\n"; print "The eagle has landed\n"; is $out, "Stuff\nThe eagle has landed\n"; print "This bird had flown\n"; is $out, "Stuff\nThe eagle has landed\nThis bird had flown\n"; print STDERR "You 'lil rascal...\n"; is $err, "Keep out!\nYou 'lil rascal...\n"; Test-Base-0.60/t/autoload.t0000644000175000017500000000062511545127523014174 0ustar ingyingyuse Test::Base tests => 4; my $block = first_block; ok((not defined &Test::Base::Block::bogus_method), "Method doesn't exist"); ok((not exists $block->{bogus_method}), "Slot really doesn't exist"); ok((not defined $block->bogus_method), "Method is callable"); my @list_context = $block->bogus_method; ok @list_context == 0, "Returns nothing in list context"; __DATA__ === One --- xyz Flavor Test-Base-0.60/t/lines.t0000644000175000017500000000067611545127523013504 0ustar ingyingyuse Test::Base tests => 6; my @lines1 = [blocks]->[0]->text1; ok @lines1 == 3; is_deeply \@lines1, [ "One\n", "Two\n", "Three \n", ]; my @lines2 = [blocks]->[0]->text2; ok @lines2 == 3; is_deeply \@lines2, [ "Three", "Two", "One", ]; is ref([blocks]->[0]->text3), 'ARRAY'; is scalar(@{[blocks]->[0]->text3}), 0; __END__ === One --- text1 lines One Two Three --- text2 lines chomp Three Two One --- text3 lines array Test-Base-0.60/t/jit-run.t0000644000175000017500000000051011545127523013745 0ustar ingyingy# Don't filter until just before dispatch in run() use Test::Base tests => 4; eval { run { pass }; }; like "$@", qr/Can't find a function or method for/, 'expect an error'; __END__ === One --- foo xxx === Two --- foo xxx === Three --- foo xxx === Bad --- foo filter_doesnt_exist_vsdyufbkhdkbjagyewkjbc xxx Test-Base-0.60/t/late.t0000644000175000017500000000067211545127523013313 0ustar ingyingyuse Test::Base tests => 5; run {}; eval { filters 'blah', 'blam'; }; is "$@", ""; eval { filters {foo => 'grate'}; }; is "$@", ""; eval { delimiters '***', '&&&'; }; like "$@", qr{^Too late to call delimiters\(\)}; eval { spec_file 'foo.txt'; }; like "$@", qr{^Too late to call spec_file\(\)}; eval { spec_string "my spec\n"; }; like "$@", qr{^Too late to call spec_string\(\)}; __DATA__ === Dummy --- foo --- bar Test-Base-0.60/t/blocks-scalar.t0000644000175000017500000000047211545127523015104 0ustar ingyingyuse Test::Base; plan tests => 1 * blocks() + 1; for (1..blocks) { ok 1, 'Jusk checking my blocking'; } is scalar(blocks), 2, 'correct number of blocks'; sub this_filter_fails { confess "Should never get here"; } __DATA__ this === --- foo this_filter_fails xxxx === --- foo this_filter_fails yyyy Test-Base-0.60/t/lazy-filters.t0000644000175000017500000000042211545127523015004 0ustar ingyingyuse Test::Base tests => 2; no_diag_on_only; sub shouldnt_be_run { fail "shouldnt_be_run was run"; } run_is foo => 'bar'; my ($block) = blocks; is($block->foo, "1234"); __DATA__ === --- foo shouldnt_be_run --- bar === --- ONLY --- foo chomp 1234 --- bar chomp 1234 Test-Base-0.60/t/list.t0000644000175000017500000000131211545127523013331 0ustar ingyingyuse Test::Base tests => 5; my $block1 = [blocks]->[0]; my @values = $block1->grocery; is scalar(@values), 3, 'check list context'; is_deeply \@values, ['apples', 'oranges', 'beef jerky'], 'list context content'; my $block2 = [blocks]->[1]; is_deeply $block2->todo, [ 'Fix YAML', 'Fix Inline', 'Fix Test::Base', ], 'deep block from index'; my $block3 = [blocks]->[2]; is $block3->perl, 'xxx', 'scalar context'; is_deeply [$block3->perl], ['xxx', 'yyy', 'zzz'], 'deep list compare'; __END__ === One --- grocery lines chomp apples oranges beef jerky === Two --- todo lines chomp array Fix YAML Fix Inline Fix Test::Base === Three --- perl eval return qw( xxx yyy zzz ) Test-Base-0.60/t/eval_all.t0000644000175000017500000000050511545127523014140 0ustar ingyingyuse Test::Base tests => 2; filters { in => [qw(eval_all array)], out => 'eval', }; run_is_deeply in => 'out'; __DATA__ === --- (in) print "hi"; warn "hello\n"; print "bye"; print STDERR "baby"; die "darn\n"; --- (out) [undef, "darn\n", "hibye", "hello\nbaby"] === --- (in) [1..3]; --- (out) [[1,2,3], '', '', ''] Test-Base-0.60/t/parentheses.t0000644000175000017500000000066711545127523014713 0ustar ingyingyuse Test::Base tests => 17; sub some_text { 'This is some text' }; my $b = first_block; is $b->foo, $b->bar, $b->name; is $b->foo, some_text(); run { my $b = shift; ok defined $b->foo; is @{[$b->foo]}, 1; ok length $b->foo; }; __DATA__ === Parens clarify section --- (foo) some_text --- (bar) some_text === --- (foo: some text === --- foo) some text === --- (foo): some text === --- (foo) split join: some text Test-Base-0.60/t/run_is_deeply.t0000644000175000017500000000037011545127523015222 0ustar ingyingyuse Test::Base tests => 3; filters 'eval'; run_is_deeply qw(foo bar); run { my $block = shift; ok ref $block->foo; ok ref $block->bar; }; __DATA__ === Test is_deeply --- foo { foo => 22, bar => 33 } --- bar { bar => 33, foo => 22 } Test-Base-0.60/t/reverse-deep.t0000644000175000017500000000073611545127523014755 0ustar ingyingyuse Test::Base; __DATA__ === --- xxx) eval Reverse array [qw(a b c)], [qw(d e f)], [qw(g h i j)] --- yyy) eval [ [qw(c b a)], [qw(f e d)], [qw(j i h g)] ] === --- xxx) eval Reverse array [ [qw(a b c)], [qw(d e f)], [qw(g h i j)] ], [ [qw(a b c)], [qw(d e f)], [qw(g h i j)] ], --- yyy) eval [ [ [qw(c b a)], [qw(f e d)], [qw(j i h g)] ], [ [qw(c b a)], [qw(f e d)], [qw(j i h g)] ] ] Test-Base-0.60/t/blocks_grep.t0000644000175000017500000000066111545127523014656 0ustar ingyingyuse Test::Base; my $plan = 1 * blocks('foo') + 3; plan tests => $plan; is $plan, 5, 'Make sure plan adds up'; for my $block (blocks('foo')) { is $block->foo, exists($block->{bar}) ? $block->bar : 'no bar'; } eval { blocks(foo => 'bar') }; like "$@", qr{^Invalid arguments passed to 'blocks'}; run_is foo => 'bar'; __DATA__ === --- bar excluded === --- foo included --- bar included === --- foo chomp no bar Test-Base-0.60/t/eval.t0000644000175000017500000000052611545127523013313 0ustar ingyingyuse Test::Base tests => 4; filters 'eval'; my $block = first_block; is ref($block->hash), 'HASH'; is ref($block->array), 'ARRAY'; is scalar(@{$block->array}), 11; is $block->factorial, '362880'; __END__ === Test --- hash { foo => 'bar', bar => 'hihi', } --- array [ 10 .. 20 ] --- factorial my $x = 1; $x *= $_ for (1 .. 9); $x; Test-Base-0.60/t/oo_run.t0000644000175000017500000000054311545127523013664 0ustar ingyingyuse Test::Base; my $blocks = Test::Base->new; $blocks->delimiters(qw(%%% ***))->filters('lower'); plan tests => 3 * $blocks->blocks; $blocks->run(sub { my $block = shift; is $block->foo, $block->bar, $block->name; }); $blocks->run_is('foo', 'bar'); $blocks->run_like('foo', qr{x}); sub lower { lc } __DATA__ %%% Test *** foo xyz *** bar XYZ Test-Base-0.60/t/spec10000644000175000017500000000011411545127523013126 0ustar ingyingy=== Test one --- foo 42 --- bar 44 === Test two --- xxx 123 --- yyy 321 Test-Base-0.60/t/skip.t0000644000175000017500000000036111545127523013327 0ustar ingyingyuse Test::Base tests => 5; run { pass }; is scalar(blocks), 2; my @block = blocks; is $block[0]->foo, "2\n"; is $block[1]->foo, "3\n"; __DATA__ === One --- SKIP --- foo 1 === Two --- foo 2 === Three --- foo 3 === Four --- SKIP --- foo 4 Test-Base-0.60/t/subclass.t0000644000175000017500000000104111545127523014174 0ustar ingyingyuse lib 't'; use TestBass tests => 7; eval "use Test::Base"; is "$@", '', 'ok to import parent class *after* subclass'; my @blocks = blocks; is ref(default_object), 'TestBass'; is $blocks[0]->el_nombre, 'Test One'; ok $blocks[0]->can('feedle'), 'Does feedle method exist?'; run_is xxx => 'yyy'; run_like_hell 'thunk', qr(thunk,.*ile.*unk); __DATA__ === Test One --- xxx lines foo_it join a lion a tiger a liger --- yyy foo - a lion foo - a tiger foo - a liger === --- thunk A thunk, a pile of junk === --- thunk A thunk, a jile of punk Test-Base-0.60/t/join.t0000644000175000017500000000045711545127523013326 0ustar ingyingyuse Test::Base tests => 3; is next_block->input, 'onetwothree'; is next_block->input, 'one=two=three'; is next_block->input, "one\n\ntwo\n\nthree"; __DATA__ === --- input lines chomp join one two three === --- input lines chomp join== one two three === --- input lines chomp join=\n\n one two three Test-Base-0.60/t/Test-Less/0000755000175000017500000000000011546276243014024 5ustar ingyingyTest-Base-0.60/t/Test-Less/index.txt0000644000175000017500000000123611545127523015671 0ustar ingyingy# This file is an index for the `test-less` facility. # # More information can be found at: # http://search.cpan.org/search?query=Test-Less;mode=dist # filter t/append.t Jun 6 00:32:41 2005 GMT -- ingy filter t/array.t Jun 6 00:32:41 2005 GMT -- ingy filter t/base64.t Jun 6 00:32:41 2005 GMT -- ingy filter t/chomp.t Jun 6 00:32:42 2005 GMT -- ingy filter t/chop.t Jun 6 00:35:08 2005 GMT -- ingy filter t/dumper.t Jun 6 00:35:08 2005 GMT -- ingy filter t/eval.t Jun 6 00:35:08 2005 GMT -- ingy filter t/eval_all.t Jun 6 00:35:08 2005 GMT -- ingy filter t/eval_stderr.t Jun 6 00:35:08 2005 GMT -- ingy filter t/eval_stdout.t Jun 6 00:35:08 2005 GMT -- ingy Test-Base-0.60/t/Subclass.pm0000644000175000017500000000005311545127523014307 0ustar ingyingypackage t::Subclass; use Test::Base -Base; Test-Base-0.60/t/exported_func.t0000644000175000017500000000045311545127523015230 0ustar ingyingypackage Testfunc; use Test::Base -Base; BEGIN { our @EXPORT = qw(func_with_args); } sub func_with_args() { (my ($self), @_) = find_my_self(@_); return @_; } package main; BEGIN { Testfunc->import } plan tests => 1; my @ret = func_with_args(1, 2, 3); is_deeply \@ret, [ 1, 2, 3 ]; Test-Base-0.60/t/multi-level-inherit.t0000644000175000017500000000017711545127523016265 0ustar ingyingyuse t::TestC tests => 2; no_diff; pass 'It works'; run_is(); sub upper { uc } __DATA__ === First --- x upper foo --- y FOO Test-Base-0.60/t/head.t0000644000175000017500000000020611545127523013260 0ustar ingyingyuse Test::Base; __DATA__ === --- in lines head one two three --- out one === --- in lines head=2 join one two three --- out one two Test-Base-0.60/t/prepend.t0000644000175000017500000000055611545127523014024 0ustar ingyingyuse Test::Base; __DATA__ === Prepend lines before lines --- (in) lines prepend=---\n join one two three --- (out) --- one --- two --- three === Prepend chars before lines --- (in) lines chomp prepend=--- join=\n one two three --- (out) chomp ---one ---two ---three === Prepend to a multline string --- (in) prepend=--- one two three --- (out) ---one two three Test-Base-0.60/t/only.t0000644000175000017500000000032711545127523013344 0ustar ingyingyuse Test::Base tests => 3; no_diag_on_only; run { pass }; is scalar(blocks), 1; is first_block->foo, "2"; __DATA__ === One --- foo: 1 === Two --- ONLY --- foo: 2 === Three --- foo: 3 --- ONLY === Four --- foo: 4 Test-Base-0.60/t/only-with-implicit.t0000644000175000017500000000020411545127523016117 0ustar ingyingyuse Test::Base tests => 1; no_diag_on_only; run_is; __END__ === --- ONLY --- foo: xxx --- bar: xxx === --- foo: xxx --- bar: yyy Test-Base-0.60/t/subclass_late.t0000644000175000017500000000054711545127523015213 0ustar ingyingyuse lib 't'; use Test::Base tests => 1; # I can't remember why I added this but it was preventing multiple # levels of inheritance which I needed for the YAML and YAML-Syck # projects. And is also just damn useful in general. SKIP: { skip("yagni For now...", 1); eval "use TestBass"; like "$@", qr{Can't use TestBass after using Test::Base}; } Test-Base-0.60/t/strict-warnings.t0000644000175000017500000000025311545127523015517 0ustar ingyingyuse Test::Base tests => 1; use lib 't'; eval "require 'strict-warnings.test'"; like "$@", qr{\QGlobal symbol "\E.\Qglobal_variable" requires explicit package name\E}; Test-Base-0.60/t/embed_perl.t0000644000175000017500000000063011545127523014456 0ustar ingyingy# This feature allows you to put a Perl section at the top of your # specification, between <<< and >>>. Not making this an official # feature yet, until I decide whether I like it. use Test::Base tests => 2; run_is; sub reverse { join '', reverse split '', shift } __DATA__ <<< delimiters '+++', '***'; filters 'chomp'; >>> +++ One *** x reverse 123* *** y *321 +++ Two *** x reverse abc *** y cba Test-Base-0.60/t/chop.t0000644000175000017500000000052311545127523013312 0ustar ingyingyuse Test::Base; filters qw(norm trim chomp); plan tests => 1 * blocks; my $c = next_block; is_deeply $c->input, $c->output; $c = next_block; is $c->input, $c->output; __END__ === --- input lines chomp chop array one two three --- output eval [qw(on tw thre)] === --- input chomp chop one two three --- output eval "one\ntwo\nthre" Test-Base-0.60/t/quick-plan.t0000644000175000017500000000017711545127523014432 0ustar ingyingyuse Test::Base; run_is; __DATA__ === Foo --- a: foo --- b: foo === Bar --- a: bar --- b: bar === Baz --- a: baz --- b: baz Test-Base-0.60/t/strict.t0000644000175000017500000000016611545127523013674 0ustar ingyingyuse Test::Base; __DATA__ === Strict Test --- perl strict my $x = 5; --- strict use strict; use warnings; my $x = 5; Test-Base-0.60/t/run-args.t0000644000175000017500000000015411545127523014117 0ustar ingyingyuse Test::Base tests => 2; run_is; run_is_deeply; __END__ === --- foo: Coolness --- bar append=ness: Cool Test-Base-0.60/t/sort-deep.t0000644000175000017500000000025211545127523014262 0ustar ingyingyuse Test::Base; __END__ === Test deep sorting --- (a) eval Sort [ [ [qw(c d b a)], [qw(foo bar baz)], ] ] --- (b) eval Reverse [ [ [qw(d c b a)], [qw(foo baz bar)], ] ] Test-Base-0.60/t/split-regexp.t0000644000175000017500000000036311545127523015006 0ustar ingyingyuse Test::Base; __DATA__ === --- (xxx) chomp split=// reverse join one two --- (yyy) chomp owt eno === --- (xxx) split=/[XY]/ join=-: oneXtwoYthree --- (yyy): one-two-three === --- (xxx) split join=-: one two three --- (yyy): one-two-three Test-Base-0.60/t/dos_spec0000644000175000017500000000022011545127523013710 0ustar ingyingy=== Test One --- Foo Line 1 Line 2 --- Bar chomp Line 3 Line 4 === Test One --- Foo Line 5 Line 6 --- Bar chomp Line 7 Line 8 Test-Base-0.60/t/yaml.t0000644000175000017500000000101311545127523013316 0ustar ingyingyuse Test::Base; plan eval { require YAML; 1 } ? (tests => 1 * blocks) : skip_all => 'Requires YAML'; filters { data1 => 'yaml', data2 => 'eval', }; run_compare; __END__ === YAML Hashes --- data1 foo: xxx bar: [ 1, 2, 3] --- data2 +{ foo => 'xxx', bar => [1,2,3], } === YAML Arrays --- data1 - foo - bar - {x: y} --- data2 [ 'foo', 'bar', { x => 'y' }, ] === YAML Scalar --- data1 --- | sub foo { print "bar\n"; } --- data2 <<'END'; sub foo { print "bar\n"; } END Test-Base-0.60/t/compact.t0000644000175000017500000000146411545127523014014 0ustar ingyingyuse Test::Base; plan tests => 1 + 1 * blocks; filters { that => 'chomp' }; run_is this => 'that'; run sub { my $block = shift; my $value = $block->value or return; is $value, 'this', $block->name; }; my $bad_spec = <<'...'; === --- bad: real content bogus stuff --- xxx yyy ... my $tb = Test::Base->new->spec_string($bad_spec); eval { $tb->blocks }; like "$@", qr"Extra lines not allowed in 'bad' section", 'Bad spec fails'; sub upper { uc($_) } __DATA__ === Basic compact form --- (this): there is foo --- (that) there is foo === Filters work --- (this) upper: too high to die --- (that) TOO HIGH TO DIE === Can have no value --- (this): --- (that) === Can have ': ' in value --- (this) : foo: bar --- (that) chop foo: bart === Test trailing blank lines are ok --- (value): this Test-Base-0.60/t/use-test-more.t0000644000175000017500000000005511545127523015072 0ustar ingyingyuse Test::Base tests => 3; pass for 1 .. 3; Test-Base-0.60/t/split.t0000644000175000017500000000103511545127523013513 0ustar ingyingyuse Test::Base tests => 2; my $b = next_block; is $b->ok, "I am ok. Are you ok?"; $b = next_block; is_deeply [$b->words], [qw(foo bar baz)]; __DATA__ === Split a string of lines into words --- ok split join=\s I am ok. Are you ok? === Split on a string --- words split=x: fooxbarxbaz --- LAST The other tests don't work yet. === --- ok lines split I am ok. Are you ok? === --- test lines Split Reverse Join reverse join=\n I Like Ike Give Peace A Chance Love Is The Answer --- flip Answer The Is Love Chance A Peace Give Ike Like I Test-Base-0.60/t/unchomp.t0000644000175000017500000000024511545127523014033 0ustar ingyingyuse Test::Base tests => 1; filters qw(norm trim chomp); is next_block->input, "on\ntw\nthre\n"; __END__ === --- input lines chomp chop unchomp join one two three Test-Base-0.60/t/require.t0000644000175000017500000000026111545127523014034 0ustar ingyingy# This should not fail (used by Module::Install to check for dependency # presence, etc). require Test::Base; print "1..1\n"; print "ok 1 - Print ran. Code didn't blow up\n"; Test-Base-0.60/t/is.t0000644000175000017500000000007511545127523012776 0ustar ingyingyuse Test::Base tests => 1; is(<<_ , <<_); 1 2 3 _ 1 2 3 _ Test-Base-0.60/t/tail.t0000644000175000017500000000021211545127523013305 0ustar ingyingyuse Test::Base; __DATA__ === --- in lines tail one two three --- out three === --- in lines tail=2 join one two three --- out two three Test-Base-0.60/t/regexp.t0000644000175000017500000000054611545127523013660 0ustar ingyingyuse Test::Base; __DATA__ === --- text one fish two fish red fish blue fish --- re regexp= one fish two fish red fish blue fish === --- text One Fish Two Fish Red Fish Blue Fish --- re regexp=im ^one fish ^two fish ^red fish ^blue fish === --- text One Fish Two Fish Red Fish Blue Fish --- re regexp \A^one\ fish\n ^two\ fish. ^red\ fish. ^blue\ fish\n\z Test-Base-0.60/t/spec_string.t0000644000175000017500000000050311545127523014677 0ustar ingyingyuse Test::Base; filters 'chomp'; spec_string <<'...'; === --- foo 1 --- bar 2 === --- foo 3 --- bar 4 ... plan tests => 3 * blocks; run { my $block = shift; is ref($block), 'Test::Base::Block'; }; my @blocks = blocks; is $blocks[0]->foo, 1; is $blocks[0]->bar, 2; is $blocks[1]->foo, 3; is $blocks[1]->bar, 4; Test-Base-0.60/t/normalize.t0000644000175000017500000000035311545127523014362 0ustar ingyingyuse Test::Base tests => 4; spec_file 't/dos_spec'; my @blocks = blocks; is $blocks[0]->Foo, "Line 1\n\nLine 2\n"; is $blocks[0]->Bar, "Line 3\nLine 4"; is $blocks[1]->Foo, "Line 5\n\nLine 6\n"; is $blocks[1]->Bar, "Line 7\nLine 8"; Test-Base-0.60/t/filter_arguments.t0000644000175000017500000000041711545127523015735 0ustar ingyingyuse Test::Base tests => 3; run {}; sub foo { is filter_arguments, '123,456'; return; } sub bar { is filter_arguments, '---holy-crow+++'; is $_, "one\n two\n"; return; } __DATA__ === --- xxx foo=123,456 === --- xxx bar=---holy-crow+++ one two Test-Base-0.60/t/no_plan.t0000644000175000017500000000005011545127523014002 0ustar ingyingyuse Test::Base; plan 'no_plan'; pass; Test-Base-0.60/t/filter_functions.t0000644000175000017500000000062511545127523015741 0ustar ingyingyuse Test::Base tests => 2; filters { foo => 'upper', bar => 'lower', }; run_is 'foo', 'upper'; run_is 'bar', 'lower'; sub upper { uc(shift) } sub Test::Base::Filter::lower { shift; lc(shift) } __END__ === --- foo So long, and thanks for all the fish! --- bar So long, and thanks for all the fish! --- upper SO LONG, AND THANKS FOR ALL THE FISH! --- lower so long, and thanks for all the fish! Test-Base-0.60/t/description.t0000644000175000017500000000076511545127523014714 0ustar ingyingyuse Test::Base tests => 6; my @blocks = blocks; is $blocks[0]->description, 'One Time'; is $blocks[1]->description, "This is the real description\nof the test."; is $blocks[2]->description, ''; is $blocks[3]->description, ''; is $blocks[4]->description, 'Three Tips'; is $blocks[5]->description, 'Description goes here.'; __END__ === One Time === Two Toes This is the real description of the test. --- foo bar === === === Three Tips --- beezle blob === Description goes here. --- data Some data Test-Base-0.60/t/run_like.t0000644000175000017500000000106011545127523014166 0ustar ingyingyuse Test::Base tests => 3; run_like('html', 're1'); run_like 'html', 're2'; run_like html => qr{stylesheet}; __END__ === Like Test --- html --- re1 regexp=xis 4; my $file = 't/output/foo.txt'; ok not(-e $file), "$file doesn't already exist"; first_block; ok -e $file, "$file exists"; open my $fh, $file or die "Can't open '$file' for input:\n$!"; is join('', <$fh>), "One two\nBuckle my shoe\n", '$file content is right'; is first_block->poem, $file, 'Returns file name'; __END__ === --- poem write_file=t/output/foo.txt One two Buckle my shoe Test-Base-0.60/t/append.t0000644000175000017500000000041711545127523013632 0ustar ingyingyuse Test::Base; __DATA__ === --- in) lines append=---\n join one two three --- out) one --- two --- three --- === --- in) lines chomp append=---\n join one two three --- out one--- two--- three--- === --- in) chomp append=---\n one two three --- out one two three--- Test-Base-0.60/t/quick_test.t0000644000175000017500000000036211545127523014535 0ustar ingyingyuse Test::Base; __DATA__ === Compare strings --- in split sort join=\s: ccc bbb aaa --- out: aaa bbb ccc === Compare deeply --- in eval: [1, 2, 3] --- out eval Reverse: [3, 2, 1] === Compare like --- in: You are here --- out regexp: ere$ Test-Base-0.60/t/TestB.pm0000644000175000017500000000004611545127523013553 0ustar ingyingypackage t::TestB; use t::TestA -Base; Test-Base-0.60/t/arguments.t0000644000175000017500000000066611545127523014376 0ustar ingyingyuse Test::Base tests => 3; run {}; sub Test::Base::Filter::something { my $self = shift; my $value = shift; my $arguments = $self->current_arguments; is $value, "candle\n", 'value is ok'; is $arguments, "wicked", 'arguments is ok'; is $Test::Base::Filter::arguments, "wicked", '$arguments global variable is ok'; } __END__ === One --- foo something=wicked candle Test-Base-0.60/t/subclass-import.t0000644000175000017500000000012311545127523015504 0ustar ingyingy# Make sure a subclass passes along inport args use t::Subclass tests => 1; pass; Test-Base-0.60/t/subclass-autoclass.t0000644000175000017500000000077311545127523016203 0ustar ingyingypackage Testorama; use Test::Base -Base; BEGIN { our @EXPORT = qw(run_orama); } sub run_orama { pass 'Testorama EXPORT ok'; } package Test::Base::Block; sub foofoo { Test::More::pass 'Test::Base::Block ok'; } package Testorama::Filter; use base 'Test::Base::Filter'; sub rama_rama { Test::More::pass 'Testorama::Filter ok'; } package main; # use Testorama; BEGIN { Testorama->import } plan tests => 3; run_orama; [blocks]->[0]->foofoo; __DATA__ === --- stuff chomp rama_rama che! Test-Base-0.60/t/chomp.t0000644000175000017500000000047011545127523013470 0ustar ingyingyuse Test::Base; filters qw(norm trim chomp); plan tests => 1 * blocks; my @blocks = blocks; is $blocks[0]->input, "I am the foo"; is $blocks[1]->input, "One\n\nTwo\n\nThree"; is $blocks[2]->input, "Che!\n"; __END__ === --- input I am the foo === --- input One Two Three === --- input chomp -chomp Che! Test-Base-0.60/t/eval_stderr.t0000644000175000017500000000032011545127523014666 0ustar ingyingyuse Test::Base tests => 1; is next_block->perl, <<'...'; You are a foo! You are 1 2. ... __DATA__ === --- perl eval_stderr warn "You are a foo!\n"; my $foo = 2; print STDERR "You are 1 $foo.\n"; return 42; Test-Base-0.60/t/expected-zero.t0000644000175000017500000000024411545127523015137 0ustar ingyingyuse Test::Base; plan tests => 1*blocks; run { my $block = shift; is 0, $block->expected; } __END__ === ok --- expected chomp 0 === oops --- expected: 0 Test-Base-0.60/t/split-deep.t0000644000175000017500000000037011545127523014427 0ustar ingyingyuse Test::Base; __DATA__ === Complex generic manipulation --- (test) lines chomp Split Reverse Join=\s reverse join=\n Hey I Like Ike Give Peace A Chance Love Is The Answer --- (flipper) chomp Answer The Is Love Chance A Peace Give Ike Like I Hey Test-Base-0.60/t/flatten.t0000644000175000017500000000113211545127523014013 0ustar ingyingyuse Test::Base tests => 4; run_is_deeply in => 'out'; filters_delay; my ($b3, $b4) = blocks('bad'); eval { $b3->run_filters }; like "$@", qr"Input to the 'flatten' filter must be a scalar"; eval { $b4->run_filters }; like "$@", qr"Can only flatten a hash or array ref"; __END__ === --- in eval flatten array { one => 'won', two => 'too', three => 'thrice', } --- out lines chomp array one won three thrice two too === --- in eval flatten array [qw(one two three four)] --- out lines chomp array one two three four === --- bad lines flatten one two === --- bad flatten: foo bar baz Test-Base-0.60/t/no_diff.t0000644000175000017500000000014511545127523013765 0ustar ingyingyuse Test::Base tests => 1; no_diff; is "xxx\nyyy\n", "xxx\nyyy\n", 'This test is really weak.'; Test-Base-0.60/t/get_url.t0000644000175000017500000000035311545127523014023 0ustar ingyingyuse Test::Base; plan skip_all => "Need to figure out network testing"; # plan tests => 1; run_like html => 'match'; __DATA__ === Test kwiki.org --- (html) get_url: http://www.kwiki.org --- (match) regexp The Official Kwiki Web Site Test-Base-0.60/t/oo.t0000644000175000017500000000076611545127523013007 0ustar ingyingyuse Test::Base tests => 8; my $test = Test::Base->new; my @blocks = $test->filters('chomp')->spec_file('t/spec1')->blocks; is $blocks[0]->foo, '42'; is $blocks[0]->bar, '44'; is $blocks[1]->xxx, '123'; is $blocks[1]->yyy, '321'; @blocks = Test::Base->new->delimiters('^^^', '###')->blocks; is $blocks[0]->foo, "42\n"; is $blocks[0]->bar, "44\n"; is $blocks[1]->xxx, "123\n"; is $blocks[1]->yyy, "321\n"; __END__ ^^^ Test one ### foo 42 ### bar 44 ^^^ Test two ### xxx 123 ### yyy 321 Test-Base-0.60/inc/0000755000175000017500000000000011546276243012507 5ustar ingyingyTest-Base-0.60/inc/Module/0000755000175000017500000000000011546276243013734 5ustar ingyingyTest-Base-0.60/inc/Module/Install.pm0000644000175000017500000003013511546276226015703 0ustar ingyingy#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.00'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[0]) <=> _version($_[1]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2010 Adam Kennedy. Test-Base-0.60/inc/Module/Install/0000755000175000017500000000000011546276243015342 5ustar ingyingyTest-Base-0.60/inc/Module/Install/Fetch.pm0000644000175000017500000000462711546276226016743 0ustar ingyingy#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Test-Base-0.60/inc/Module/Install/Win32.pm0000644000175000017500000000340311546276226016603 0ustar ingyingy#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; Test-Base-0.60/inc/Module/Install/ReadmeFromPod.pm0000644000175000017500000000162411546276226020370 0ustar ingyingy#line 1 package Module::Install::ReadmeFromPod; use 5.006; use strict; use warnings; use base qw(Module::Install::Base); use vars qw($VERSION); $VERSION = '0.12'; sub readme_from { my $self = shift; return unless $self->is_admin; my $file = shift || $self->_all_from or die "Can't determine file to make readme_from"; my $clean = shift; print "Writing README from $file\n"; require Pod::Text; my $parser = Pod::Text->new(); open README, '> README' or die "$!\n"; $parser->output_fh( *README ); $parser->parse_file( $file ); if ($clean) { $self->clean_files('README'); } return 1; } sub _all_from { my $self = shift; return unless $self->admin->{extensions}; my ($metadata) = grep { ref($_) eq 'Module::Install::Metadata'; } @{$self->admin->{extensions}}; return unless $metadata; return $metadata->{values}{all_from} || ''; } 'Readme!'; __END__ #line 112 Test-Base-0.60/inc/Module/Install/WriteAll.pm0000644000175000017500000000237611546276226017434 0ustar ingyingy#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; Test-Base-0.60/inc/Module/Install/Can.pm0000644000175000017500000000333311546276226016404 0ustar ingyingy#line 1 package Module::Install::Can; use strict; use Config (); use File::Spec (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 156 Test-Base-0.60/inc/Module/Install/VersionCheck.pm0000644000175000017500000000313711546276226020270 0ustar ingyingy#line 1 package Module::Install::VersionCheck; use strict; use warnings; use 5.008003; use Module::Install::Base; my $DEFAULT = '0.00'; use vars qw($VERSION @ISA); BEGIN { $VERSION = '0.11'; @ISA = 'Module::Install::Base'; } sub version_check { my $self = shift; return unless $self->is_admin; my $module_version = $self->_get_module_version(); my $changes_version = $self->_get_changes_version(); my $git_tag_version = $self->_get_git_tag_version(); $self->_report( $module_version, $changes_version, $git_tag_version, ); } sub _get_module_version { my $self = shift; return $DEFAULT unless $self->admin->{extensions}; my ($metadata) = grep { ref($_) eq 'Module::Install::Metadata'; } @{$self->admin->{extensions}}; return $DEFAULT unless $metadata; return $metadata->{values}{version} || $DEFAULT; } sub _get_changes_version { my $self = shift; return $DEFAULT unless -e 'Changes'; open IN, 'Changes' or die "Can't open 'Changes' for input: $!"; my $text = do {local $/; }; $text =~ /\b(\d\.\d\d)\b/ or return $DEFAULT; return $1; } sub _get_git_tag_version { my $self = shift; return $DEFAULT unless -e '.git'; require Capture::Tiny; my $text = Capture::Tiny::capture_merged(sub { system('git tag') }); my $version = $DEFAULT; for (split "\n", $text) { if (/\b(\d\.\d\d)\b/ and $1 > $version) { $version = $1; } } return $version; } sub _report { my $self = shift; print "version_check @_\n"; } 1; =encoding utf8 #line 107 Test-Base-0.60/inc/Module/Install/Metadata.pm0000644000175000017500000004302011546276226017420 0ustar ingyingy#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config\n"; return $self; } $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; return 1; } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the reall old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( \Qhttp://rt.cpan.org/\E[^>]+| \Qhttp://github.com/\E[\w_]+/[\w_]+/issues| \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Test-Base-0.60/inc/Module/Install/AckXXX.pm0000644000175000017500000000123211546276226017005 0ustar ingyingy#line 1 package Module::Install::AckXXX; use strict; use warnings; use 5.008003; use Module::Install::Base; use vars qw($VERSION @ISA); BEGIN { $VERSION = '0.11'; @ISA = 'Module::Install::Base'; } sub ack_xxx { my $self = shift; return unless $self->is_admin; require Capture::Tiny; sub ack { system "ack '^\\s*use XXX\\b'"; } my $output = Capture::Tiny::capture_merged(\&ack); $self->_report($output) if $output; } sub _report { my $self = shift; my $output = shift; chomp ($output); print <<"..."; *** AUTHOR WARNING *** *** Found usage of XXX.pm in this code: $output ... } 1; =encoding utf8 #line 82 Test-Base-0.60/inc/Module/Install/Makefile.pm0000644000175000017500000002703211546276226017422 0ustar ingyingy#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # MakeMaker can complain about module versions that include # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/; $self->build_requires( 'ExtUtils::MakeMaker' => $v ); $self->configure_requires( 'ExtUtils::MakeMaker' => $v ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT $DB::single = 1; if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 541 Test-Base-0.60/inc/Module/Install/ManifestSkip.pm0000644000175000017500000000242211546276226020276 0ustar ingyingy#line 1 package Module::Install::ManifestSkip; use strict; use warnings; use 5.008003; use Module::Install::Base; use vars qw($VERSION @ISA); BEGIN { $VERSION = '0.14'; @ISA = 'Module::Install::Base'; } my $skip_file = "MANIFEST.SKIP"; sub manifest_skip { my $self = shift; return unless $self->is_admin; print "manifest_skip\n"; my $keepers; if (-e $skip_file) { open IN, $skip_file or die "Can't open $skip_file for input: $!"; my $input = do {local $/; }; close IN; if ($input =~ s/(.*?\n)\s*\n.*/$1/s and $input =~ /\S/) { $keepers = $input; } } open OUT, '>', $skip_file or die "Can't open $skip_file for output: $!";; if ($keepers) { print OUT "$keepers\n"; } print OUT _skip_files(); close OUT; $self->clean_files('MANIFEST'); } sub _skip_files { return <<'...'; ^Makefile$ ^Makefile\.old$ ^pm_to_blib$ ^blib/ ^pod2htm.* ^MANIFEST\.SKIP$ ^MANIFEST\.bak$ ^\.git/ ^\.gitignore ^\.gitmodules /\.git/ \.svn/ ^\.vimrc$ \.sw[op]$ ^core$ ^out$ ^tmon.out$ ^\w$ ^foo.* ^notes ^todo ^ToDo$ ## avoid OS X finder files \.DS_Store$ ## skip komodo project files \.kpf$ ## ignore emacs and vim backup files ~$ ... } 1; =encoding utf8 #line 135 Test-Base-0.60/inc/Module/Install/Base.pm0000644000175000017500000000214711546276226016557 0ustar ingyingy#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.00'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 Test-Base-0.60/Changes0000644000175000017500000001751511546276030013234 0ustar ingyingy--- version: 0.60 date: Mon Apr 4 15:51:09 CST 2011 changes: - Applied patch by andk++ - Make regexp test skip on 5.14 for now. --- version: 0.59 date: Thu Aug 20 14:56:36 PDT 2009 changes: - Fixed test dep bug reported by Alias++. --- version: 0.58 date: Thu Mar 26 17:26:13 PDT 2009 changes: - Another undef filtering change. --- version: 0.57 date: Thu Mar 26 16:42:03 PDT 2009 changes: - Allow value of undef to be filtered without warnings. --- version: 0.56 date: Sat Mar 7 12:13:32 PST 2009 changes: - Add Test::Deep support with is_deep and run_is_deep --- version: 0.55 date: Thu Dec 4 01:10:11 PST 2008 changes: - Module::Install::TestBase::use_test_base require 'Filter::Util::Call' now. --- version: 0.54 date: Wed Nov 29 15:21:02 PST 2006 changes: - Make dependency on Filter::Util::Call explicit in Makefile.PL Thanks to Adriano Ferreira --- version: 0.53 date: Wed Nov 29 15:21:02 PST 2006 changes: - Changes from miyagawa and crew --- version: 0.52 date: Mon Jun 19 10:44:53 PDT 2006 changes: - Add use_ok to exports --- version: 0.51 date: Fri Jun 16 13:05:22 PDT 2006 changes: - Remove build-requires dep of Spiffy for Module::Install::TestBase - Add in a patch from the good folk at Socialtext. --- version: 0.50 date: Mon Jan 30 10:52:52 PST 2006 changes: - No change. 0.49 got borked on the way to CPAN --- version: 0.49 date: Mon Jan 30 10:52:48 PST 2006 changes: - Added Module::Install::TestBase --- version: 0.48 date: Sun Jan 29 10:19:46 PST 2006 changes: - Fixed test failures on windows --- version: 0.47 date: Thu Jan 19 10:59:37 PST 2006 changes: - Depend on newer Spiffy 0.29 --- version: 0.46 date: Sat Jan 14 05:46:31 PST 2006 changes: - Don't sign the distribution tarball - Don't require the diffing stuff --- version: 0.45 date: Mon Jan 9 20:58:04 PST 2006 changes: - Let multilevel inheritance work! - no_diff function turns off diffing. --- version: 0.44 date: Fri Jul 22 23:38:04 PDT 2005 changes: - Bug fix in is_diff from rking - Allow Test::Base to be required without trying to run tests - allow ONLY|LAST|SKIP with run_* implicit names. --- version: 0.43 date: Sun Jun 19 03:14:40 PDT 2005 changes: - change Test::Base::Filter::block to current_block. - change Test::Base::Filter::arguments to current_arguments. - add split and Split filters - add join and Join filters - add reverse and Reverse filters - add hash filter - allow (parens) around a data section name for readability. - allow regexps on split - allow for compact, one-line data sections - allow for repeated filters - detect sections names automatically - import XXX stuff into Filter class - add run_compare - automatically set no_plan sometimes - automatically run run_compare if no plan set at END - massive refactoring of all tests --- version: 0.42 date: Tue Jun 14 09:31:25 PDT 2005 changes: - Make any block method callable with a dummy AUTOLOAD --- version: 0.41 date: Sun Jun 12 15:49:15 PDT 2005 changes: - Add first_block() function - Split Test::Base::Filter into a separate module --- version: 0.40 date: Sat Jun 11 20:55:42 PDT 2005 changes: - Change name from Test::Chunks to more lofty Test::Base - Change concept of "chunks" to "blocks" --- version: 0.38 date: Wed Jun 8 00:33:00 PDT 2005 changes: - Allow simple substitutions on $_ in filters defined in `main::` - Add a filter_arguments() function - Fixed a undef warning in `is()` --- version: 0.37 date: Tue Jun 7 11:04:07 PDT 2005 changes: - Implement rking style diff_is - Add filters: exec_perl_stdout --- version: 0.36 date: Sun Jun 5 11:49:54 PDT 2005 changes: - add tie_output support - suppress warning in accessor - support backslash escapes in filter arguments - New filters: unchomp chop append eval_stdout eval_stderr eval_all - Add join string to join filter - Add a Test-Less index --- version: 0.35 date: Thu Jun 2 17:46:30 PDT 2005 changes: - Subtle filter bug fixed --- version: 0.34 date: Sat May 28 23:55:49 PDT 2005 changes: - Allow "late" call of `filters`. - Allow for appending filters that are predefined. --- version: 0.33 date: Sat May 28 23:55:41 PDT 2005 changes: - Support `next_chunk` iterator. --- version: 0.32 date: Tue May 24 08:03:57 PDT 2005 changes: - Add a method to access filter arguments - Curry `use` args to Test::More - Change base64 filter to base64_decode base64_encode - Apply filter just before dispatch in run() - Apply filters in order - Default to Test::Chunks inline classes for subclassing modules (for Filter and Chunks) --- version: 0.31 date: Mon May 23 20:48:28 PDT 2005 changes: - Guess names for chunk_class and filter_class. Easier subclassing. --- version: 0.30 date: Mon May 23 16:39:23 PDT 2005 changes: - Further delay filtering by no running filters when chunks is called in scalar context. --- version: 0.29 date: Sun May 22 21:30:02 PDT 2005 changes: - add filters_delay function - add run_filters method to Test::Chunks::Chunk - Refactor many methods into Test::Chunks::Chunk - Expose internals to the filter methods by providing a `chunk` method to the Filter object. --- version: 0.28 date: Wed May 11 17:13:19 PDT 2005 changes: - Make running of the filters be lazy to avoid undesired side effects when not running all tests. May want to be even lazier in the future... --- version: 0.27 date: Tue May 10 17:01:18 PDT 2005 changes: - Added run_unlike --- version: 0.26 date: Mon May 9 07:57:58 PDT 2005 changes: - Embed perl code in a test specification. This is still experimental and undocumented. --- version: 0.25 date: changes: - Add `LAST` special section name to stop at a certain test. - Add test for strict/warnings filter. - Change 'description' method to 'name'. - Add a description method for the multiline description. --- version: 0.24 date: Thu May 5 01:54:29 PDT 2005 changes: - Refactored delimiter default handling --- version: 0.23 date: Thu May 5 00:33:32 PDT 2005 changes: - Make Test::Chunks more subclassable - Add join filter - General Refactorings --- version: 0.22 date: Tue May 3 12:32:39 PDT 2005 changes: - Support a grepping feature for `chunks()` - Ignore chunks that don't contain a specified data section for `run_*` functions. --- version: 0.21 date: Mon May 2 12:29:48 PDT 2005 changes: - Deprecate filters_map and just use filters with a map. --- version: 0.20 date: Mon May 2 00:08:17 PDT 2005 changes: - Added list context to filters. Very powerful stuff. --- version: 0.19 date: Sat Apr 30 17:27:09 PDT 2005 changes: - Add regexp flag tests - Change -XXX to :XXX and use better Spiffy 0.24 --- version: 0.18 date: Sat Apr 30 17:27:09 PDT 2005 changes: - Support run_is_deeply --- version: 0.17 date: Sat Apr 30 12:16:03 PDT 2005 changes: - Allow user filters to be plain functions - Add run_like - Add regexp and get_url filters - Allow run* functions to work as methods - Remove diff_is() until implemented --- version: 0.16 date: Fri Apr 29 20:04:24 PDT 2005 changes: - added run_is for common equality tests - strict and dumper filters - Can't use `Spiffy -XXX` until Spiffy exporting is fixed. --- version: 0.15 date: Wed Apr 27 23:50:50 PDT 2005 changes: - export everything Test::More does. - croak if things get called in the wrong order. --- version: 0.14 date: Wed Apr 27 12:22:45 PDT 2005 changes: - Move filters into the Test::Chunks::Filter class --- version: 0.13 date: Mon Apr 25 11:14:27 PDT 2005 changes: - add eval, yaml, list and lines filters - support a filter_map for more flexibility --- version: 0.12 date: Fri Apr 22 00:12:21 PDT 2005 changes: - finished the tests - automagically add strict and warnings to every test script --- version: 0.11 date: Thu Apr 21 11:26:32 PDT 2005 changes: - added delimiters() spec_file() spec_string() filters() functions - implemented nice filters system - lots more tests - finished the doc --- version: 0.10 date: Wed Apr 20 18:05:42 PDT 2005 changes: - Initial version of Test::Chunks Test-Base-0.60/MANIFEST0000644000175000017500000000401411546276236013070 0ustar ingyingyChanges inc/Module/Install.pm inc/Module/Install/AckXXX.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/ManifestSkip.pm inc/Module/Install/Metadata.pm inc/Module/Install/ReadmeFromPod.pm inc/Module/Install/VersionCheck.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Module/Install/TestBase.pm lib/Test/Base.pm lib/Test/Base/Filter.pm Makefile.PL MANIFEST This list of files META.yml README t/append.t t/arguments.t t/array.t t/autoload.t t/base64.t t/BaseTest.pm t/blocks-scalar.t t/blocks_grep.t t/chomp.t t/chop.t t/compact.t t/compile.t t/deep.t t/delimiters.t t/description.t t/diff_is.t t/dos_spec t/dumper.t t/embed_perl.t t/escape.t t/eval.t t/eval_all.t t/eval_stderr.t t/eval_stdout.t t/expected-zero.t t/export.t t/exported_func.t t/filter_arguments.t t/filter_delay.t t/filter_functions.t t/filters-append.t t/filters.t t/filters_map.t t/first_block.t t/flatten.t t/get_url.t t/hash.t t/head.t t/internals.t t/is.t t/jit-run.t t/join-deep.t t/join.t t/last.t t/late.t t/lazy-filters.t t/lines.t t/list.t t/main_filters.t t/multi-level-inherit.t t/name.t t/next.t t/no_diff.t t/no_plan.t t/normalize.t t/only-with-implicit.t t/only.t t/oo.t t/oo_run.t t/parentheses.t t/prepend.t t/preserve-order.t t/prototypes.t t/quick-plan.t t/quick_test.t t/read_file.t t/regexp.t t/repeated-filters.t t/require.t t/reserved_names.t t/reverse-deep.t t/reverse.t t/run-args.t t/run_compare.t t/run_is.t t/run_is_deep.t t/run_is_deeply.t t/run_like.t t/run_unlike.t t/sample-file.txt t/simple.t t/skip.t t/slice.t t/sort-deep.t t/sort.t t/spec1 t/spec2 t/spec_file.t t/spec_string.t t/split-deep.t t/split-regexp.t t/split.t t/strict-warnings.t t/strict-warnings.test t/strict.t t/subclass-autoclass.t t/subclass-import.t t/Subclass.pm t/subclass.t t/subclass_late.t t/tail.t t/Test-Less/index.txt t/TestA.pm t/TestB.pm t/TestBass.pm t/TestC.pm t/tie_output.t t/trim.t t/unchomp.t t/undef.t t/use-test-more.t t/write_file.t t/xxx.t t/yaml.t t/zero-blocks.t Test-Base-0.60/README0000644000175000017500000005270111546276226012624 0ustar ingyingyNAME Test::Base - A Data Driven Testing Framework SYNOPSIS A new test module: # lib/MyProject/Test.pm package MyProject::Test; use Test::Base -Base; use MyProject; package MyProject::Test::Filter; use Test::Base::Filter -base; sub my_filter { return MyProject->do_something(shift); } A sample test: # t/sample.t use MyProject::Test; plan tests => 1 * blocks; run_is input => 'expected'; sub local_filter { s/my/your/; } __END__ === Test one (the name of the test) --- input my_filter local_filter my input lines --- expected expected output === Test two This is an optional description of this particular test. --- input my_filter other input lines --- expected other expected output DESCRIPTION Testing is usually the ugly part of Perl module authoring. Perl gives you a standard way to run tests with Test::Harness, and basic testing primitives with Test::More. After that you are pretty much on your own to develop a testing framework and philosophy. Test::More encourages you to make your own framework by subclassing Test::Builder, but that is not trivial. Test::Base gives you a way to write your own test framework base class that *is* trivial. In fact it is as simple as two lines: package MyTestFramework; use Test::Base -Base; A module called "MyTestFramework.pm" containing those two lines, will give all the power of Test::More and all the power of Test::Base to every test file that uses it. As you build up the capabilities of "MyTestFramework", your tests will have all of that power as well. "MyTestFramework" becomes a place for you to put all of your reusable testing bits. As you write tests, you will see patterns and duplication, and you can "upstream" them into "MyTestFramework". Of course, you don't have to subclass Test::Base at all. You can use it directly in many applications, including everywhere you would use Test::More. Test::Base concentrates on offering reusable data driven patterns, so that you can write tests with a minimum of code. At the heart of all testing you have inputs, processes and expected outputs. Test::Base provides some clean ways for you to express your input and expected output data, so you can spend your time focusing on that rather than your code scaffolding. EXPORTED FUNCTIONS Test::Base extends Test::More and exports all of its functions. So you can basically write your tests the same as Test::More. Test::Base also exports many functions of its own: is(actual, expected, [test-name]) This is the equivalent of Test::More's "is" function with one interesting twist. If your actual and expected results differ and the output is multi-line, this function will show you a unified diff format of output. Consider the benefit when looking for the one character that is different in hundreds of lines of output! Diff output requires the optional "Text::Diff" CPAN module. If you don't have this module, the "is()" function will simply give you normal Test::More output. To disable diffing altogether, set the "TEST_SHOW_NO_DIFFS" environment variable (or $ENV{TEST_SHOW_NO_DIFFS}) to a true value. You can also call the "no_diff" function as a shortcut. blocks( [data-section-name] ) The most important function is "blocks". In list context it returns a list of "Test::Base::Block" objects that are generated from the test specification in the "DATA" section of your test file. In scalar context it returns the number of objects. This is useful to calculate your Test::More plan. Each Test::Base::Block object has methods that correspond to the names of that object's data sections. There is also a "name" and a "description" method for accessing those parts of the block if they were specified. The "blocks" function can take an optional single argument, that indicates to only return the blocks that contain a particular named data section. Otherwise "blocks" returns all blocks. my @all_of_my_blocks = blocks; my @just_the_foo_blocks = blocks('foo'); next_block() You can use the next_block function to iterate over all the blocks. while (my $block = next_block) { ... } It returns undef after all blocks have been iterated over. It can then be called again to reiterate. first_block() Returns the first block or undef if there are none. It resets the iterator to the "next_block" function. run(&subroutine) There are many ways to write your tests. You can reference each block individually or you can loop over all the blocks and perform a common operation. The "run" function does the looping for you, so all you need to do is pass it a code block to execute for each block. The "run" function takes a subroutine as an argument, and calls the sub one time for each block in the specification. It passes the current block object to the subroutine. run { my $block = shift; is(process($block->foo), $block->bar, $block->name); }; run_is([data_name1, data_name2]) Many times you simply want to see if two data sections are equivalent in every block, probably after having been run through one or more filters. With the "run_is" function, you can just pass the names of any two data sections that exist in every block, and it will loop over every block comparing the two sections. run_is 'foo', 'bar'; If no data sections are given "run_is" will try to detect them automatically. NOTE: Test::Base will silently ignore any blocks that don't contain both sections. is_deep($data1, $data2, $test_name) Like Test::More's "is_deeply" but uses the more correct Test::Deep module. run_is_deeply([data_name1, data_name2]) Like "run_is_deeply" but uses "is_deep" which uses the more correct Test::Deep. run_is_deeply([data_name1, data_name2]) Like "run_is" but uses "is_deeply" for complex data structure comparison. run_is_deeply([data_name1, data_name2]) Like "run_is_deeply" but uses "is_deep" which uses the more correct Test::Deep. run_like([data_name, regexp | data_name]); The "run_like" function is similar to "run_is" except the second argument is a regular expression. The regexp can either be a "qr{}" object or a data section that has been filtered into a regular expression. run_like 'foo', qr{ [qw(chomp lines)], yyy => ['yaml'], zzz => 'eval', }; If a filters list has only one element, the array ref is optional. filters_delay( [1 | 0] ); By default Test::Base::Block objects are have all their filters run ahead of time. There are testing situations in which it is advantageous to delay the filtering. Calling this function with no arguments or a true value, causes the filtering to be delayed. use Test::Base; filters_delay; plan tests => 1 * blocks; for my $block (blocks) { ... $block->run_filters; ok($block->is_filtered); ... } In the code above, the filters are called manually, using the "run_filters" method of Test::Base::Block. In functions like "run_is", where the tests are run automatically, filtering is delayed until right before the test. filter_arguments() Return the arguments after the equals sign on a filter. sub my_filter { my $args = filter_arguments; # is($args, 'whazzup'); ... } __DATA__ === A test --- data my_filter=whazzup tie_output() You can capture STDOUT and STDERR for operations with this function: my $out = ''; tie_output(*STDOUT, $buffer); print "Hey!\n"; print "Che!\n"; untie *STDOUT; is($out, "Hey!\nChe!\n"); no_diff() Turn off diff support for is() in a test file. default_object() Returns the default Test::Base object. This is useful if you feel the need to do an OO operation in otherwise functional test code. See OO below. WWW() XXX() YYY() ZZZ() These debugging functions are exported from the Spiffy.pm module. See Spiffy for more info. croak() carp() cluck() confess() You can use the functions from the Carp module without needing to import them. Test::Base does it for you by default. TEST SPECIFICATION Test::Base allows you to specify your test data in an external file, the DATA section of your program or from a scalar variable containing all the text input. A *test specification* is a series of text lines. Each test (or block) is separated by a line containing the block delimiter and an optional test "name". Each block is further subdivided into named sections with a line containing the data delimiter and the data section name. A "description" of the test can go on lines after the block delimiter but before the first data section. Here is the basic layout of a specification: === --- --- --- === --- --- --- Here is a code example: use Test::Base; delimiters qw(### :::); # test code here __END__ ### Test One We want to see if foo and bar are really the same... ::: foo a foo line another foo line ::: bar a bar line another bar line ### Test Two ::: foo some foo line some other foo line ::: bar some bar line some other bar line ::: baz some baz line some other baz line This example specifies two blocks. They both have foo and bar data sections. The second block has a baz component. The block delimiter is "###" and the data delimiter is ":::". The default block delimiter is "===" and the default data delimiter is "---". There are some special data section names used for control purposes: --- SKIP --- ONLY --- LAST A block with a SKIP section causes that test to be ignored. This is useful to disable a test temporarily. A block with an ONLY section causes only that block to be used. This is useful when you are concentrating on getting a single test to pass. If there is more than one block with ONLY, the first one will be chosen. Because ONLY is very useful for debugging and sometimes you forgot to remove the ONLY flag before commiting to the VCS or uploading to CPAN, Test::Base by default gives you a diag message saying *I found ONLY ... maybe you're debugging?*. If you don't like it, use "no_diag_on_only". A block with a LAST section makes that block the last one in the specification. All following blocks will be ignored. FILTERS The real power in writing tests with Test::Base comes from its filtering capabilities. Test::Base comes with an ever growing set of useful generic filters than you can sequence and apply to various test blocks. That means you can specify the block serialization in the most readable format you can find, and let the filters translate it into what you really need for a test. It is easy to write your own filters as well. Test::Base allows you to specify a list of filters to each data section of each block. The default filters are "norm" and "trim". These filters will be applied (in order) to the data after it has been parsed from the specification and before it is set into its Test::Base::Block object. You can add to the default filter list with the "filters" function. You can specify additional filters to a specific block by listing them after the section name on a data section delimiter line. Example: use Test::Base; filters qw(foo bar); filters { perl => 'strict' }; sub upper { uc(shift) } __END__ === Test one --- foo trim chomp upper ... --- bar -norm ... --- perl eval dumper my @foo = map { - $_; } 1..10; \ @foo; Putting a "-" before a filter on a delimiter line, disables that filter. Scalar vs List Each filter can take either a scalar or a list as input, and will return either a scalar or a list. Since filters are chained together, it is important to learn which filters expect which kind of input and return which kind of output. For example, consider the following filter list: norm trim lines chomp array dumper eval The data always starts out as a single scalar string. "norm" takes a scalar and returns a scalar. "trim" takes a list and returns a list, but a scalar is a valid list. "lines" takes a scalar and returns a list. "chomp" takes a list and returns a list. "array" takes a list and returns a scalar (an anonymous array reference containing the list elements). "dumper" takes a list and returns a scalar. "eval" takes a scalar and creates a list. A list of exactly one element works fine as input to a filter requiring a scalar, but any other list will cause an exception. A scalar in list context is considered a list of one element. Data accessor methods for blocks will return a list of values when used in list context, and the first element of the list in scalar context. This is usually "the right thing", but be aware. The Stock Filters Test::Base comes with large set of stock filters. They are in the "Test::Base::Filter" module. See Test::Base::Filter for a listing and description of these filters. Rolling Your Own Filters Creating filter extensions is very simple. You can either write a *function* in the "main" namespace, or a *method* in the "Test::Base::Filter" namespace or a subclass of it. In either case the text and any extra arguments are passed in and you return whatever you want the new value to be. Here is a self explanatory example: use Test::Base; filters 'foo', 'bar=xyz'; sub foo { transform(shift); } sub Test::Base::Filter::bar { my $self = shift; # The Test::Base::Filter object my $data = shift; my $args = $self->current_arguments; my $current_block_object = $self->block; # transform $data in a barish manner return $data; } If you use the method interface for a filter, you can access the block internals by calling the "block" method on the filter object. Normally you'll probably just use the functional interface, although all the builtin filters are methods. Note that filters defined in the "main" namespace can look like: sub filter9 { s/foo/bar/; } since Test::Base automatically munges the input string into $_ variable and checks the return value of the function to see if it looks like a number. If you must define a filter that returns just a single number, do it in a different namespace as a method. These filters don't allow the simplistic $_ munging. OO Test::Base has a nice functional interface for simple usage. Under the hood everything is object oriented. A default Test::Base object is created and all the functions are really just method calls on it. This means if you need to get fancy, you can use all the object oriented stuff too. Just create new Test::Base objects and use the functions as methods. use Test::Base; my $blocks1 = Test::Base->new; my $blocks2 = Test::Base->new; $blocks1->delimiters(qw(!!! @@@))->spec_file('test1.txt'); $blocks2->delimiters(qw(### $$$))->spec_string($test_data); plan tests => $blocks1->blocks + $blocks2->blocks; # ... etc THE "Test::Base::Block" CLASS In Test::Base, blocks are exposed as Test::Base::Block objects. This section lists the methods that can be called on a Test::Base::Block object. Of course, each data section name is also available as a method. name() This is the optional short description of a block, that is specified on the block separator line. description() This is an optional long description of the block. It is the text taken from between the block separator and the first data section. seq_num() Returns a sequence number for this block. Sequence numbers begin with 1. blocks_object() Returns the Test::Base object that owns this block. run_filters() Run the filters on the data sections of the blocks. You don't need to use this method unless you also used the "filters_delay" function. is_filtered() Returns true if filters have already been run for this block. original_values() Returns a hash of the original, unfiltered values of each data section. SUBCLASSING One of the nicest things about Test::Base is that it is easy to subclass. This is very important, because in your personal project, you will likely want to extend Test::Base with your own filters and other reusable pieces of your test framework. Here is an example of a subclass: package MyTestStuff; use Test::Base -Base; our @EXPORT = qw(some_func); sub some_func { (my ($self), @_) = find_my_self(@_); ... } package MyTestStuff::Block; use base 'Test::Base::Block'; sub desc { $self->description(@_); } package MyTestStuff::Filter; use base 'Test::Base::Filter'; sub upper { $self->assert_scalar(@_); uc(shift); } Note that you don't have to re-Export all the functions from Test::Base. That happens automatically, due to the powers of Spiffy. The first line in "some_func" allows it to be called as either a function or a method in the test code. DISTRIBUTION SUPPORT You might be thinking that you do not want to use Test::Base in you modules, because it adds an installation dependency. Fear not. Module::Install takes care of that. Just write a Makefile.PL that looks something like this: use inc::Module::Install; name 'Foo'; all_from 'lib/Foo.pm'; use_test_base; WriteAll; The line with "use_test_base" will automatically bundle all the code the user needs to run Test::Base based tests. OTHER COOL FEATURES Test::Base automatically adds: use strict; use warnings; to all of your test scripts and Test::Base subclasses. A Spiffy feature indeed. HISTORY This module started its life with the horrible and ridicule inducing name "Test::Chunks". It was renamed to "Test::Base" with the hope that it would be seen for the very useful module that it has become. If you are switching from "Test::Chunks" to "Test::Base", simply substitute the concept and usage of "chunks" to "blocks". AUTHOR Ingy döt Net COPYRIGHT Copyright (c) 2006, 2008, 2009, 2011. Ingy döt Net. Copyright (c) 2005. Brian Ingerson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html Test-Base-0.60/lib/0000755000175000017500000000000011546276243012504 5ustar ingyingyTest-Base-0.60/lib/Module/0000755000175000017500000000000011546276243013731 5ustar ingyingyTest-Base-0.60/lib/Module/Install/0000755000175000017500000000000011546276243015337 5ustar ingyingyTest-Base-0.60/lib/Module/Install/TestBase.pm0000644000175000017500000000260411546274265017413 0ustar ingyingypackage Module::Install::TestBase; use strict; use warnings; use Module::Install::Base; use vars qw($VERSION @ISA); BEGIN { $VERSION = '0.60'; @ISA = 'Module::Install::Base'; } sub use_test_base { my $self = shift; $self->include('Test::Base'); $self->include('Test::Base::Filter'); $self->include('Spiffy'); $self->include('Test::More'); $self->include('Test::Builder'); $self->include('Test::Builder::Module'); $self->requires('Filter::Util::Call'); } 1; =encoding utf8 =head1 NAME Module::Install::TestBase - Module::Install Support for Test::Base =head1 SYNOPSIS use inc::Module::Install; name 'Foo'; all_from 'lib/Foo.pm'; use_test_base; WriteAll; =head1 DESCRIPTION This module adds the C directive to Module::Install. Now you can get full Test-Base support for you module with no external dependency on Test::Base. Just add this line to your Makefile.PL: use_test_base; That's it. Really. Now Test::Base is bundled into your module, so that it is no longer any burden on the person installing your module. =head1 AUTHOR Ingy döt Net =head1 COPYRIGHT Copyright (c) 2006, 2008, 2011. Ingy döt Net. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L =cut Test-Base-0.60/lib/Test/0000755000175000017500000000000011546276243013423 5ustar ingyingyTest-Base-0.60/lib/Test/Base/0000755000175000017500000000000011546276243014275 5ustar ingyingyTest-Base-0.60/lib/Test/Base/Filter.pm0000644000175000017500000003015411546274413016060 0ustar ingyingy#=============================================================================== # This is the default class for handling Test::Base data filtering. #=============================================================================== package Test::Base::Filter; use Spiffy -Base; use Spiffy ':XXX'; field 'current_block'; our $arguments; sub current_arguments { return undef unless defined $arguments; my $args = $arguments; $args =~ s/(\\s)/ /g; $args =~ s/(\\[a-z])/'"' . $1 . '"'/gee; return $args; } sub assert_scalar { return if @_ == 1; require Carp; my $filter = (caller(1))[3]; $filter =~ s/.*:://; Carp::croak "Input to the '$filter' filter must be a scalar, not a list"; } sub _apply_deepest { my $method = shift; return () unless @_; if (ref $_[0] eq 'ARRAY') { for my $aref (@_) { @$aref = $self->_apply_deepest($method, @$aref); } return @_; } $self->$method(@_); } sub _split_array { map { [$self->split($_)]; } @_; } sub _peel_deepest { return () unless @_; if (ref $_[0] eq 'ARRAY') { if (ref $_[0]->[0] eq 'ARRAY') { for my $aref (@_) { @$aref = $self->_peel_deepest(@$aref); } return @_; } return map { $_->[0] } @_; } return @_; } #=============================================================================== # these filters work on the leaves of nested arrays #=============================================================================== sub Join { $self->_peel_deepest($self->_apply_deepest(join => @_)) } sub Reverse { $self->_apply_deepest(reverse => @_) } sub Split { $self->_apply_deepest(_split_array => @_) } sub Sort { $self->_apply_deepest(sort => @_) } sub append { my $suffix = $self->current_arguments; map { $_ . $suffix } @_; } sub array { return [@_]; } sub base64_decode { $self->assert_scalar(@_); require MIME::Base64; MIME::Base64::decode_base64(shift); } sub base64_encode { $self->assert_scalar(@_); require MIME::Base64; MIME::Base64::encode_base64(shift); } sub chomp { map { CORE::chomp; $_ } @_; } sub chop { map { CORE::chop; $_ } @_; } sub dumper { no warnings 'once'; require Data::Dumper; local $Data::Dumper::Sortkeys = 1; local $Data::Dumper::Indent = 1; local $Data::Dumper::Terse = 1; Data::Dumper::Dumper(@_); } sub escape { $self->assert_scalar(@_); my $text = shift; $text =~ s/(\\.)/eval "qq{$1}"/ge; return $text; } sub eval { $self->assert_scalar(@_); my @return = CORE::eval(shift); return $@ if $@; return @return; } sub eval_all { $self->assert_scalar(@_); my $out = ''; my $err = ''; Test::Base::tie_output(*STDOUT, $out); Test::Base::tie_output(*STDERR, $err); my $return = CORE::eval(shift); no warnings; untie *STDOUT; untie *STDERR; return $return, $@, $out, $err; } sub eval_stderr { $self->assert_scalar(@_); my $output = ''; Test::Base::tie_output(*STDERR, $output); CORE::eval(shift); no warnings; untie *STDERR; return $output; } sub eval_stdout { $self->assert_scalar(@_); my $output = ''; Test::Base::tie_output(*STDOUT, $output); CORE::eval(shift); no warnings; untie *STDOUT; return $output; } sub exec_perl_stdout { my $tmpfile = "/tmp/test-blocks-$$"; $self->_write_to($tmpfile, @_); open my $execution, "$^X $tmpfile 2>&1 |" or die "Couldn't open subprocess: $!\n"; local $/; my $output = <$execution>; close $execution; unlink($tmpfile) or die "Couldn't unlink $tmpfile: $!\n"; return $output; } sub flatten { $self->assert_scalar(@_); my $ref = shift; if (ref($ref) eq 'HASH') { return map { ($_, $ref->{$_}); } sort keys %$ref; } if (ref($ref) eq 'ARRAY') { return @$ref; } die "Can only flatten a hash or array ref"; } sub get_url { $self->assert_scalar(@_); my $url = shift; CORE::chomp($url); require LWP::Simple; LWP::Simple::get($url); } sub hash { return +{ @_ }; } sub head { my $size = $self->current_arguments || 1; return splice(@_, 0, $size); } sub join { my $string = $self->current_arguments; $string = '' unless defined $string; CORE::join $string, @_; } sub lines { $self->assert_scalar(@_); my $text = shift; return () unless length $text; my @lines = ($text =~ /^(.*\n?)/gm); return @lines; } sub norm { $self->assert_scalar(@_); my $text = shift; $text = '' unless defined $text; $text =~ s/\015\012/\n/g; $text =~ s/\r/\n/g; return $text; } sub prepend { my $prefix = $self->current_arguments; map { $prefix . $_ } @_; } sub read_file { $self->assert_scalar(@_); my $file = shift; CORE::chomp $file; open my $fh, $file or die "Can't open '$file' for input:\n$!"; CORE::join '', <$fh>; } sub regexp { $self->assert_scalar(@_); my $text = shift; my $flags = $self->current_arguments; if ($text =~ /\n.*?\n/s) { $flags = 'xism' unless defined $flags; } else { CORE::chomp($text); } $flags ||= ''; my $regexp = eval "qr{$text}$flags"; die $@ if $@; return $regexp; } sub reverse { CORE::reverse(@_); } sub slice { die "Invalid args for slice" unless $self->current_arguments =~ /^(\d+)(?:,(\d))?$/; my ($x, $y) = ($1, $2); $y = $x if not defined $y; die "Invalid args for slice" if $x > $y; return splice(@_, $x, 1 + $y - $x); } sub sort { CORE::sort(@_); } sub split { $self->assert_scalar(@_); my $separator = $self->current_arguments; if (defined $separator and $separator =~ s{^/(.*)/$}{$1}) { my $regexp = $1; $separator = qr{$regexp}; } $separator = qr/\s+/ unless $separator; CORE::split $separator, shift; } sub strict { $self->assert_scalar(@_); <<'...' . shift; use strict; use warnings; ... } sub tail { my $size = $self->current_arguments || 1; return splice(@_, @_ - $size, $size); } sub trim { map { s/\A([ \t]*\n)+//; s/(?<=\n)\s*\z//g; $_; } @_; } sub unchomp { map { $_ . "\n" } @_; } sub write_file { my $file = $self->current_arguments or die "No file specified for write_file filter"; if ($file =~ /(.*)[\\\/]/) { my $dir = $1; if (not -e $dir) { require File::Path; File::Path::mkpath($dir) or die "Can't create $dir"; } } open my $fh, ">$file" or die "Can't open '$file' for output\n:$!"; print $fh @_; close $fh; return $file; } sub yaml { $self->assert_scalar(@_); require YAML; return YAML::Load(shift); } sub _write_to { my $filename = shift; open my $script, ">$filename" or die "Couldn't open $filename: $!\n"; print $script @_; close $script or die "Couldn't close $filename: $!\n"; } __DATA__ =head1 NAME Test::Base::Filter - Default Filter Class for Test::Base =head1 SYNOPSIS package MyTestSuite; use Test::Base -Base; ... reusable testing code ... package MyTestSuite::Filter; use Test::Base::Filter -Base; sub my_filter1 { ... } =head1 DESCRIPTION Filters are the key to writing effective data driven tests with Test::Base. Test::Base::Filter is a class containing a large default set of generic filters. You can easily subclass it to add/override functionality. =head1 FILTERS This is a list of the default stock filters (in alphabetic order): =head2 append list => list Append a string to each element of a list. --- numbers lines chomp append=-#\n join one two three =head2 array list => scalar Turn a list of values into an anonymous array reference. =head2 base64_decode scalar => scalar Decode base64 data. Useful for binary tests. =head2 base64_encode scalar => scalar Encode base64 data. Useful for binary tests. =head2 chomp list => list Remove the final newline from each string value in a list. =head2 chop list => list Remove the final char from each string value in a list. =head2 dumper scalar => list Take a data structure (presumably from another filter like eval) and use Data::Dumper to dump it in a canonical fashion. =head2 escape scalar => scalar Unescape all backslash escaped chars. =head2 eval scalar => list Run Perl's C command against the data and use the returned value as the data. =head2 eval_all scalar => list Run Perl's C command against the data and return a list of 4 values: 1) The return value 2) The error in $@ 3) Captured STDOUT 4) Captured STDERR =head2 eval_stderr scalar => scalar Run Perl's C command against the data and return the captured STDERR. =head2 eval_stdout scalar => scalar Run Perl's C command against the data and return the captured STDOUT. =head2 exec_perl_stdout list => scalar Input Perl code is written to a temp file and run. STDOUT is captured and returned. =head2 flatten scalar => list Takes a hash or array ref and flattens it to a list. =head2 get_url scalar => scalar The text is chomped and considered to be a url. Then LWP::Simple::get is used to fetch the contents of the url. =head2 hash list => scalar Turn a list of key/value pairs into an anonymous hash reference. =head2 head[=number] list => list Takes a list and returns a number of the elements from the front of it. The default number is one. =head2 join list => scalar Join a list of strings into a scalar. =head2 Join Join the list of strings inside a list of array refs and return the strings in place of the array refs. =head2 lines scalar => list Break the data into an anonymous array of lines. Each line (except possibly the last one if the C filter came first) will have a newline at the end. =head2 norm scalar => scalar Normalize the data. Change non-Unix line endings to Unix line endings. =head2 prepend=string list => list Prepend a string onto each of a list of strings. =head2 read_file scalar => scalar Read the file named by the current content and return the file's content. =head2 regexp[=xism] scalar => scalar The C filter will turn your data section into a regular expression object. You can pass in extra flags after an equals sign. If the text contains more than one line and no flags are specified, then the 'xism' flags are assumed. =head2 reverse list => list Reverse the elements of a list. =head2 Reverse list => list Reverse the list of strings inside a list of array refs. =head2 slice=x[,y] list => list Returns the element number x through element number y of a list. =head2 sort list => list Sorts the elements of a list in character sort order. =head2 Sort list => list Sort the list of strings inside a list of array refs. =head2 split[=string|pattern] scalar => list Split a string in into a list. Takes a optional string or regexp as a parameter. Defaults to /\s+/. Same as Perl C. =head2 Split[=string|pattern] list => list Split each of a list of strings and turn them into array refs. =head2 strict scalar => scalar Prepend the string: use strict; use warnings; to the block's text. =head2 tail[=number] list => list Return a number of elements from the end of a list. The default number is one. =head2 trim list => list Remove extra blank lines from the beginning and end of the data. This allows you to visually separate your test data with blank lines. =head2 unchomp list => list Add a newline to each string value in a list. =head2 write_file[=filename] scalar => scalar Write the content of the section to the named file. Return the filename. =head2 yaml scalar => list Apply the YAML::Load function to the data block and use the resultant structure. Requires YAML.pm. =head1 AUTHOR Ingy döt Net =head1 COPYRIGHT Copyright (c) 2006, 2011. Ingy döt Net. All rights reserved. Copyright (c) 2005. Brian Ingerson. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut Test-Base-0.60/lib/Test/Base.pm0000644000175000017500000011331211546274447014640 0ustar ingyingypackage Test::Base; use 5.006001; use Spiffy 0.30 -Base; use Spiffy ':XXX'; our $VERSION = '0.60'; my @test_more_exports; BEGIN { @test_more_exports = qw( ok isnt like unlike is_deeply cmp_ok skip todo_skip pass fail eq_array eq_hash eq_set plan can_ok isa_ok diag use_ok $TODO ); } use Test::More import => \@test_more_exports; use Carp; our @EXPORT = (@test_more_exports, qw( is no_diff blocks next_block first_block delimiters spec_file spec_string filters filters_delay filter_arguments run run_compare run_is run_is_deeply run_like run_unlike skip_all_unless_require is_deep run_is_deep WWW XXX YYY ZZZ tie_output no_diag_on_only find_my_self default_object croak carp cluck confess )); field '_spec_file'; field '_spec_string'; field _filters => [qw(norm trim)]; field _filters_map => {}; field spec => -init => '$self->_spec_init'; field block_list => -init => '$self->_block_list_init'; field _next_list => []; field block_delim => -init => '$self->block_delim_default'; field data_delim => -init => '$self->data_delim_default'; field _filters_delay => 0; field _no_diag_on_only => 0; field block_delim_default => '==='; field data_delim_default => '---'; my $default_class; my $default_object; my $reserved_section_names = {}; sub default_object { $default_object ||= $default_class->new; return $default_object; } my $import_called = 0; sub import() { $import_called = 1; my $class = (grep /^-base$/i, @_) ? scalar(caller) : $_[0]; if (not defined $default_class) { $default_class = $class; } # else { # croak "Can't use $class after using $default_class" # unless $default_class->isa($class); # } unless (grep /^-base$/i, @_) { my @args; for (my $ii = 1; $ii <= $#_; ++$ii) { if ($_[$ii] eq '-package') { ++$ii; } else { push @args, $_[$ii]; } } Test::More->import(import => \@test_more_exports, @args) if @args; } _strict_warnings(); goto &Spiffy::import; } # Wrap Test::Builder::plan my $plan_code = \&Test::Builder::plan; my $Have_Plan = 0; { no warnings 'redefine'; *Test::Builder::plan = sub { $Have_Plan = 1; goto &$plan_code; }; } my $DIED = 0; $SIG{__DIE__} = sub { $DIED = 1; die @_ }; sub block_class { $self->find_class('Block') } sub filter_class { $self->find_class('Filter') } sub find_class { my $suffix = shift; my $class = ref($self) . "::$suffix"; return $class if $class->can('new'); $class = __PACKAGE__ . "::$suffix"; return $class if $class->can('new'); eval "require $class"; return $class if $class->can('new'); die "Can't find a class for $suffix"; } sub check_late { if ($self->{block_list}) { my $caller = (caller(1))[3]; $caller =~ s/.*:://; croak "Too late to call $caller()" } } sub find_my_self() { my $self = ref($_[0]) eq $default_class ? splice(@_, 0, 1) : default_object(); return $self, @_; } sub blocks() { (my ($self), @_) = find_my_self(@_); croak "Invalid arguments passed to 'blocks'" if @_ > 1; croak sprintf("'%s' is invalid argument to blocks()", shift(@_)) if @_ && $_[0] !~ /^[a-zA-Z]\w*$/; my $blocks = $self->block_list; my $section_name = shift || ''; my @blocks = $section_name ? (grep { exists $_->{$section_name} } @$blocks) : (@$blocks); return scalar(@blocks) unless wantarray; return (@blocks) if $self->_filters_delay; for my $block (@blocks) { $block->run_filters unless $block->is_filtered; } return (@blocks); } sub next_block() { (my ($self), @_) = find_my_self(@_); my $list = $self->_next_list; if (@$list == 0) { $list = [@{$self->block_list}, undef]; $self->_next_list($list); } my $block = shift @$list; if (defined $block and not $block->is_filtered) { $block->run_filters; } return $block; } sub first_block() { (my ($self), @_) = find_my_self(@_); $self->_next_list([]); $self->next_block; } sub filters_delay() { (my ($self), @_) = find_my_self(@_); $self->_filters_delay(defined $_[0] ? shift : 1); } sub no_diag_on_only() { (my ($self), @_) = find_my_self(@_); $self->_no_diag_on_only(defined $_[0] ? shift : 1); } sub delimiters() { (my ($self), @_) = find_my_self(@_); $self->check_late; my ($block_delimiter, $data_delimiter) = @_; $block_delimiter ||= $self->block_delim_default; $data_delimiter ||= $self->data_delim_default; $self->block_delim($block_delimiter); $self->data_delim($data_delimiter); return $self; } sub spec_file() { (my ($self), @_) = find_my_self(@_); $self->check_late; $self->_spec_file(shift); return $self; } sub spec_string() { (my ($self), @_) = find_my_self(@_); $self->check_late; $self->_spec_string(shift); return $self; } sub filters() { (my ($self), @_) = find_my_self(@_); if (ref($_[0]) eq 'HASH') { $self->_filters_map(shift); } else { my $filters = $self->_filters; push @$filters, @_; } return $self; } sub filter_arguments() { $Test::Base::Filter::arguments; } sub have_text_diff { eval { require Text::Diff; 1 } && $Text::Diff::VERSION >= 0.35 && $Algorithm::Diff::VERSION >= 1.15; } sub is($$;$) { (my ($self), @_) = find_my_self(@_); my ($actual, $expected, $name) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; if ($ENV{TEST_SHOW_NO_DIFFS} or not defined $actual or not defined $expected or $actual eq $expected or not($self->have_text_diff) or $expected !~ /\n./s ) { Test::More::is($actual, $expected, $name); } else { $name = '' unless defined $name; ok $actual eq $expected, $name . "\n" . Text::Diff::diff(\$expected, \$actual); } } sub run(&;$) { (my ($self), @_) = find_my_self(@_); my $callback = shift; for my $block (@{$self->block_list}) { $block->run_filters unless $block->is_filtered; &{$callback}($block); } } my $name_error = "Can't determine section names"; sub _section_names { return @_ if @_ == 2; my $block = $self->first_block or croak $name_error; my @names = grep { $_ !~ /^(ONLY|LAST|SKIP)$/; } @{$block->{_section_order}[0] || []}; croak "$name_error. Need two sections in first block" unless @names == 2; return @names; } sub _assert_plan { plan('no_plan') unless $Have_Plan; } sub END { run_compare() unless $Have_Plan or $DIED or not $import_called; } sub run_compare() { (my ($self), @_) = find_my_self(@_); $self->_assert_plan; my ($x, $y) = $self->_section_names(@_); local $Test::Builder::Level = $Test::Builder::Level + 1; for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and exists($block->{$y}); $block->run_filters unless $block->is_filtered; if (ref $block->$x) { is_deeply($block->$x, $block->$y, $block->name ? $block->name : ()); } elsif (ref $block->$y eq 'Regexp') { my $regexp = ref $y ? $y : $block->$y; like($block->$x, $regexp, $block->name ? $block->name : ()); } else { is($block->$x, $block->$y, $block->name ? $block->name : ()); } } } sub run_is() { (my ($self), @_) = find_my_self(@_); $self->_assert_plan; my ($x, $y) = $self->_section_names(@_); local $Test::Builder::Level = $Test::Builder::Level + 1; for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and exists($block->{$y}); $block->run_filters unless $block->is_filtered; is($block->$x, $block->$y, $block->name ? $block->name : () ); } } sub run_is_deeply() { (my ($self), @_) = find_my_self(@_); $self->_assert_plan; my ($x, $y) = $self->_section_names(@_); for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and exists($block->{$y}); $block->run_filters unless $block->is_filtered; is_deeply($block->$x, $block->$y, $block->name ? $block->name : () ); } } sub run_like() { (my ($self), @_) = find_my_self(@_); $self->_assert_plan; my ($x, $y) = $self->_section_names(@_); for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and defined($y); $block->run_filters unless $block->is_filtered; my $regexp = ref $y ? $y : $block->$y; like($block->$x, $regexp, $block->name ? $block->name : () ); } } sub run_unlike() { (my ($self), @_) = find_my_self(@_); $self->_assert_plan; my ($x, $y) = $self->_section_names(@_); for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and defined($y); $block->run_filters unless $block->is_filtered; my $regexp = ref $y ? $y : $block->$y; unlike($block->$x, $regexp, $block->name ? $block->name : () ); } } sub skip_all_unless_require() { (my ($self), @_) = find_my_self(@_); my $module = shift; eval "require $module; 1" or Test::More::plan( skip_all => "$module failed to load" ); } sub is_deep() { (my ($self), @_) = find_my_self(@_); require Test::Deep; Test::Deep::cmp_deeply(@_); } sub run_is_deep() { (my ($self), @_) = find_my_self(@_); $self->_assert_plan; my ($x, $y) = $self->_section_names(@_); for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and exists($block->{$y}); $block->run_filters unless $block->is_filtered; is_deep($block->$x, $block->$y, $block->name ? $block->name : () ); } } sub _pre_eval { my $spec = shift; return $spec unless $spec =~ s/\A\s*<<<(.*?)>>>\s*$//sm; my $eval_code = $1; eval "package main; $eval_code"; croak $@ if $@; return $spec; } sub _block_list_init { my $spec = $self->spec; $spec = $self->_pre_eval($spec); my $cd = $self->block_delim; my @hunks = ($spec =~ /^(\Q${cd}\E.*?(?=^\Q${cd}\E|\z))/msg); my $blocks = $self->_choose_blocks(@hunks); $self->block_list($blocks); # Need to set early for possible filter use my $seq = 1; for my $block (@$blocks) { $block->blocks_object($self); $block->seq_num($seq++); } return $blocks; } sub _choose_blocks { my $blocks = []; for my $hunk (@_) { my $block = $self->_make_block($hunk); if (exists $block->{ONLY}) { diag "I found ONLY: maybe you're debugging?" unless $self->_no_diag_on_only; return [$block]; } next if exists $block->{SKIP}; push @$blocks, $block; if (exists $block->{LAST}) { return $blocks; } } return $blocks; } sub _check_reserved { my $id = shift; croak "'$id' is a reserved name. Use something else.\n" if $reserved_section_names->{$id} or $id =~ /^_/; } sub _make_block { my $hunk = shift; my $cd = $self->block_delim; my $dd = $self->data_delim; my $block = $self->block_class->new; $hunk =~ s/\A\Q${cd}\E[ \t]*(.*)\s+// or die; my $name = $1; my @parts = split /^\Q${dd}\E +\(?(\w+)\)? *(.*)?\n/m, $hunk; my $description = shift @parts; $description ||= ''; unless ($description =~ /\S/) { $description = $name; } $description =~ s/\s*\z//; $block->set_value(description => $description); my $section_map = {}; my $section_order = []; while (@parts) { my ($type, $filters, $value) = splice(@parts, 0, 3); $self->_check_reserved($type); $value = '' unless defined $value; $filters = '' unless defined $filters; if ($filters =~ /:(\s|\z)/) { croak "Extra lines not allowed in '$type' section" if $value =~ /\S/; ($filters, $value) = split /\s*:(?:\s+|\z)/, $filters, 2; $value = '' unless defined $value; $value =~ s/^\s*(.*?)\s*$/$1/; } $section_map->{$type} = { filters => $filters, }; push @$section_order, $type; $block->set_value($type, $value); } $block->set_value(name => $name); $block->set_value(_section_map => $section_map); $block->set_value(_section_order => $section_order); return $block; } sub _spec_init { return $self->_spec_string if $self->_spec_string; local $/; my $spec; if (my $spec_file = $self->_spec_file) { open FILE, $spec_file or die $!; $spec = ; close FILE; } else { $spec = do { package main; no warnings 'once'; ; }; } return $spec; } sub _strict_warnings() { require Filter::Util::Call; my $done = 0; Filter::Util::Call::filter_add( sub { return 0 if $done; my ($data, $end) = ('', ''); while (my $status = Filter::Util::Call::filter_read()) { return $status if $status < 0; if (/^__(?:END|DATA)__\r?$/) { $end = $_; last; } $data .= $_; $_ = ''; } $_ = "use strict;use warnings;$data$end"; $done = 1; } ); } sub tie_output() { my $handle = shift; die "No buffer to tie" unless @_; tie *$handle, 'Test::Base::Handle', $_[0]; } sub no_diff { $ENV{TEST_SHOW_NO_DIFFS} = 1; } package Test::Base::Handle; sub TIEHANDLE() { my $class = shift; bless \ $_[0], $class; } sub PRINT { $$self .= $_ for @_; } #=============================================================================== # Test::Base::Block # # This is the default class for accessing a Test::Base block object. #=============================================================================== package Test::Base::Block; our @ISA = qw(Spiffy); our @EXPORT = qw(block_accessor); sub AUTOLOAD { return; } sub block_accessor() { my $accessor = shift; no strict 'refs'; return if defined &$accessor; *$accessor = sub { my $self = shift; if (@_) { Carp::croak "Not allowed to set values for '$accessor'"; } my @list = @{$self->{$accessor} || []}; return wantarray ? (@list) : $list[0]; }; } block_accessor 'name'; block_accessor 'description'; Spiffy::field 'seq_num'; Spiffy::field 'is_filtered'; Spiffy::field 'blocks_object'; Spiffy::field 'original_values' => {}; sub set_value { no strict 'refs'; my $accessor = shift; block_accessor $accessor unless defined &$accessor; $self->{$accessor} = [@_]; } sub run_filters { my $map = $self->_section_map; my $order = $self->_section_order; Carp::croak "Attempt to filter a block twice" if $self->is_filtered; for my $type (@$order) { my $filters = $map->{$type}{filters}; my @value = $self->$type; $self->original_values->{$type} = $value[0]; for my $filter ($self->_get_filters($type, $filters)) { $Test::Base::Filter::arguments = $filter =~ s/=(.*)$// ? $1 : undef; my $function = "main::$filter"; no strict 'refs'; if (defined &$function) { local $_ = (@value == 1 and not defined($value[0])) ? undef : join '', @value; my $old = $_; @value = &$function(@value); if (not(@value) or @value == 1 and defined($value[0]) and $value[0] =~ /\A(\d+|)\z/ ) { if ($value[0] && $_ eq $old) { Test::Base::diag("Filters returning numbers are supposed to do munging \$_: your filter '$function' apparently doesn't."); } @value = ($_); } } else { my $filter_object = $self->blocks_object->filter_class->new; die "Can't find a function or method for '$filter' filter\n" unless $filter_object->can($filter); $filter_object->current_block($self); @value = $filter_object->$filter(@value); } # Set the value after each filter since other filters may be # introspecting. $self->set_value($type, @value); } } $self->is_filtered(1); } sub _get_filters { my $type = shift; my $string = shift || ''; $string =~ s/\s*(.*?)\s*/$1/; my @filters = (); my $map_filters = $self->blocks_object->_filters_map->{$type} || []; $map_filters = [ $map_filters ] unless ref $map_filters; my @append = (); for ( @{$self->blocks_object->_filters}, @$map_filters, split(/\s+/, $string), ) { my $filter = $_; last unless length $filter; if ($filter =~ s/^-//) { @filters = grep { $_ ne $filter } @filters; } elsif ($filter =~ s/^\+//) { push @append, $filter; } else { push @filters, $filter; } } return @filters, @append; } { %$reserved_section_names = map { ($_, 1); } keys(%Test::Base::Block::), qw( new DESTROY ); } __DATA__ =encoding utf8 =head1 NAME Test::Base - A Data Driven Testing Framework =head1 SYNOPSIS A new test module: # lib/MyProject/Test.pm package MyProject::Test; use Test::Base -Base; use MyProject; package MyProject::Test::Filter; use Test::Base::Filter -base; sub my_filter { return MyProject->do_something(shift); } A sample test: # t/sample.t use MyProject::Test; plan tests => 1 * blocks; run_is input => 'expected'; sub local_filter { s/my/your/; } __END__ === Test one (the name of the test) --- input my_filter local_filter my input lines --- expected expected output === Test two This is an optional description of this particular test. --- input my_filter other input lines --- expected other expected output =head1 DESCRIPTION Testing is usually the ugly part of Perl module authoring. Perl gives you a standard way to run tests with Test::Harness, and basic testing primitives with Test::More. After that you are pretty much on your own to develop a testing framework and philosophy. Test::More encourages you to make your own framework by subclassing Test::Builder, but that is not trivial. Test::Base gives you a way to write your own test framework base class that I trivial. In fact it is as simple as two lines: package MyTestFramework; use Test::Base -Base; A module called C containing those two lines, will give all the power of Test::More and all the power of Test::Base to every test file that uses it. As you build up the capabilities of C, your tests will have all of that power as well. C becomes a place for you to put all of your reusable testing bits. As you write tests, you will see patterns and duplication, and you can "upstream" them into C. Of course, you don't have to subclass Test::Base at all. You can use it directly in many applications, including everywhere you would use Test::More. Test::Base concentrates on offering reusable data driven patterns, so that you can write tests with a minimum of code. At the heart of all testing you have inputs, processes and expected outputs. Test::Base provides some clean ways for you to express your input and expected output data, so you can spend your time focusing on that rather than your code scaffolding. =head1 EXPORTED FUNCTIONS Test::Base extends Test::More and exports all of its functions. So you can basically write your tests the same as Test::More. Test::Base also exports many functions of its own: =head2 is(actual, expected, [test-name]) This is the equivalent of Test::More's C function with one interesting twist. If your actual and expected results differ and the output is multi-line, this function will show you a unified diff format of output. Consider the benefit when looking for the one character that is different in hundreds of lines of output! Diff output requires the optional C CPAN module. If you don't have this module, the C function will simply give you normal Test::More output. To disable diffing altogether, set the C environment variable (or C<$ENV{TEST_SHOW_NO_DIFFS}>) to a true value. You can also call the C function as a shortcut. =head2 blocks( [data-section-name] ) The most important function is C. In list context it returns a list of C objects that are generated from the test specification in the C section of your test file. In scalar context it returns the number of objects. This is useful to calculate your Test::More plan. Each Test::Base::Block object has methods that correspond to the names of that object's data sections. There is also a C and a C method for accessing those parts of the block if they were specified. The C function can take an optional single argument, that indicates to only return the blocks that contain a particular named data section. Otherwise C returns all blocks. my @all_of_my_blocks = blocks; my @just_the_foo_blocks = blocks('foo'); =head2 next_block() You can use the next_block function to iterate over all the blocks. while (my $block = next_block) { ... } It returns undef after all blocks have been iterated over. It can then be called again to reiterate. =head2 first_block() Returns the first block or undef if there are none. It resets the iterator to the C function. =head2 run(&subroutine) There are many ways to write your tests. You can reference each block individually or you can loop over all the blocks and perform a common operation. The C function does the looping for you, so all you need to do is pass it a code block to execute for each block. The C function takes a subroutine as an argument, and calls the sub one time for each block in the specification. It passes the current block object to the subroutine. run { my $block = shift; is(process($block->foo), $block->bar, $block->name); }; =head2 run_is([data_name1, data_name2]) Many times you simply want to see if two data sections are equivalent in every block, probably after having been run through one or more filters. With the C function, you can just pass the names of any two data sections that exist in every block, and it will loop over every block comparing the two sections. run_is 'foo', 'bar'; If no data sections are given C will try to detect them automatically. NOTE: Test::Base will silently ignore any blocks that don't contain both sections. =head2 is_deep($data1, $data2, $test_name) Like Test::More's C but uses the more correct Test::Deep module. =head2 run_is_deeply([data_name1, data_name2]) Like C but uses C which uses the more correct Test::Deep. =head2 run_is_deeply([data_name1, data_name2]) Like C but uses C for complex data structure comparison. =head2 run_is_deeply([data_name1, data_name2]) Like C but uses C which uses the more correct Test::Deep. =head2 run_like([data_name, regexp | data_name]); The C function is similar to C except the second argument is a regular expression. The regexp can either be a C object or a data section that has been filtered into a regular expression. run_like 'foo', qr{ function is similar to C, except the opposite. run_unlike 'foo', qr{ function is like the C, C and the C functions all rolled into one. It loops over each relevant block and determines what type of comparison to do. NOTE: If you do not specify either a plan, or run any tests, the C function will automatically be run. =head2 delimiters($block_delimiter, $data_delimiter) Override the default delimiters of C<===> and C<--->. =head2 spec_file($file_name) By default, Test::Base reads its input from the DATA section. This function tells it to get the spec from a file instead. =head2 spec_string($test_data) By default, Test::Base reads its input from the DATA section. This function tells it to get the spec from a string that has been prepared somehow. =head2 filters( @filters_list or $filters_hashref ) Specify a list of additional filters to be applied to all blocks. See L below. You can also specify a hash ref that maps data section names to an array ref of filters for that data type. filters { xxx => [qw(chomp lines)], yyy => ['yaml'], zzz => 'eval', }; If a filters list has only one element, the array ref is optional. =head2 filters_delay( [1 | 0] ); By default Test::Base::Block objects are have all their filters run ahead of time. There are testing situations in which it is advantageous to delay the filtering. Calling this function with no arguments or a true value, causes the filtering to be delayed. use Test::Base; filters_delay; plan tests => 1 * blocks; for my $block (blocks) { ... $block->run_filters; ok($block->is_filtered); ... } In the code above, the filters are called manually, using the C method of Test::Base::Block. In functions like C, where the tests are run automatically, filtering is delayed until right before the test. =head2 filter_arguments() Return the arguments after the equals sign on a filter. sub my_filter { my $args = filter_arguments; # is($args, 'whazzup'); ... } __DATA__ === A test --- data my_filter=whazzup =head2 tie_output() You can capture STDOUT and STDERR for operations with this function: my $out = ''; tie_output(*STDOUT, $buffer); print "Hey!\n"; print "Che!\n"; untie *STDOUT; is($out, "Hey!\nChe!\n"); =head2 no_diff() Turn off diff support for is() in a test file. =head2 default_object() Returns the default Test::Base object. This is useful if you feel the need to do an OO operation in otherwise functional test code. See L below. =head2 WWW() XXX() YYY() ZZZ() These debugging functions are exported from the Spiffy.pm module. See L for more info. =head2 croak() carp() cluck() confess() You can use the functions from the Carp module without needing to import them. Test::Base does it for you by default. =head1 TEST SPECIFICATION Test::Base allows you to specify your test data in an external file, the DATA section of your program or from a scalar variable containing all the text input. A I is a series of text lines. Each test (or block) is separated by a line containing the block delimiter and an optional test C. Each block is further subdivided into named sections with a line containing the data delimiter and the data section name. A C of the test can go on lines after the block delimiter but before the first data section. Here is the basic layout of a specification: === --- --- --- === --- --- --- Here is a code example: use Test::Base; delimiters qw(### :::); # test code here __END__ ### Test One We want to see if foo and bar are really the same... ::: foo a foo line another foo line ::: bar a bar line another bar line ### Test Two ::: foo some foo line some other foo line ::: bar some bar line some other bar line ::: baz some baz line some other baz line This example specifies two blocks. They both have foo and bar data sections. The second block has a baz component. The block delimiter is C<###> and the data delimiter is C<:::>. The default block delimiter is C<===> and the default data delimiter is C<--->. There are some special data section names used for control purposes: --- SKIP --- ONLY --- LAST A block with a SKIP section causes that test to be ignored. This is useful to disable a test temporarily. A block with an ONLY section causes only that block to be used. This is useful when you are concentrating on getting a single test to pass. If there is more than one block with ONLY, the first one will be chosen. Because ONLY is very useful for debugging and sometimes you forgot to remove the ONLY flag before commiting to the VCS or uploading to CPAN, Test::Base by default gives you a diag message saying I. If you don't like it, use C. A block with a LAST section makes that block the last one in the specification. All following blocks will be ignored. =head1 FILTERS The real power in writing tests with Test::Base comes from its filtering capabilities. Test::Base comes with an ever growing set of useful generic filters than you can sequence and apply to various test blocks. That means you can specify the block serialization in the most readable format you can find, and let the filters translate it into what you really need for a test. It is easy to write your own filters as well. Test::Base allows you to specify a list of filters to each data section of each block. The default filters are C and C. These filters will be applied (in order) to the data after it has been parsed from the specification and before it is set into its Test::Base::Block object. You can add to the default filter list with the C function. You can specify additional filters to a specific block by listing them after the section name on a data section delimiter line. Example: use Test::Base; filters qw(foo bar); filters { perl => 'strict' }; sub upper { uc(shift) } __END__ === Test one --- foo trim chomp upper ... --- bar -norm ... --- perl eval dumper my @foo = map { - $_; } 1..10; \ @foo; Putting a C<-> before a filter on a delimiter line, disables that filter. =head2 Scalar vs List Each filter can take either a scalar or a list as input, and will return either a scalar or a list. Since filters are chained together, it is important to learn which filters expect which kind of input and return which kind of output. For example, consider the following filter list: norm trim lines chomp array dumper eval The data always starts out as a single scalar string. C takes a scalar and returns a scalar. C takes a list and returns a list, but a scalar is a valid list. C takes a scalar and returns a list. C takes a list and returns a list. C takes a list and returns a scalar (an anonymous array reference containing the list elements). C takes a list and returns a scalar. C takes a scalar and creates a list. A list of exactly one element works fine as input to a filter requiring a scalar, but any other list will cause an exception. A scalar in list context is considered a list of one element. Data accessor methods for blocks will return a list of values when used in list context, and the first element of the list in scalar context. This is usually "the right thing", but be aware. =head2 The Stock Filters Test::Base comes with large set of stock filters. They are in the C module. See L for a listing and description of these filters. =head2 Rolling Your Own Filters Creating filter extensions is very simple. You can either write a I in the C
namespace, or a I in the C namespace or a subclass of it. In either case the text and any extra arguments are passed in and you return whatever you want the new value to be. Here is a self explanatory example: use Test::Base; filters 'foo', 'bar=xyz'; sub foo { transform(shift); } sub Test::Base::Filter::bar { my $self = shift; # The Test::Base::Filter object my $data = shift; my $args = $self->current_arguments; my $current_block_object = $self->block; # transform $data in a barish manner return $data; } If you use the method interface for a filter, you can access the block internals by calling the C method on the filter object. Normally you'll probably just use the functional interface, although all the builtin filters are methods. Note that filters defined in the C
namespace can look like: sub filter9 { s/foo/bar/; } since Test::Base automatically munges the input string into $_ variable and checks the return value of the function to see if it looks like a number. If you must define a filter that returns just a single number, do it in a different namespace as a method. These filters don't allow the simplistic $_ munging. =head1 OO Test::Base has a nice functional interface for simple usage. Under the hood everything is object oriented. A default Test::Base object is created and all the functions are really just method calls on it. This means if you need to get fancy, you can use all the object oriented stuff too. Just create new Test::Base objects and use the functions as methods. use Test::Base; my $blocks1 = Test::Base->new; my $blocks2 = Test::Base->new; $blocks1->delimiters(qw(!!! @@@))->spec_file('test1.txt'); $blocks2->delimiters(qw(### $$$))->spec_string($test_data); plan tests => $blocks1->blocks + $blocks2->blocks; # ... etc =head1 THE C CLASS In Test::Base, blocks are exposed as Test::Base::Block objects. This section lists the methods that can be called on a Test::Base::Block object. Of course, each data section name is also available as a method. =head2 name() This is the optional short description of a block, that is specified on the block separator line. =head2 description() This is an optional long description of the block. It is the text taken from between the block separator and the first data section. =head2 seq_num() Returns a sequence number for this block. Sequence numbers begin with 1. =head2 blocks_object() Returns the Test::Base object that owns this block. =head2 run_filters() Run the filters on the data sections of the blocks. You don't need to use this method unless you also used the C function. =head2 is_filtered() Returns true if filters have already been run for this block. =head2 original_values() Returns a hash of the original, unfiltered values of each data section. =head1 SUBCLASSING One of the nicest things about Test::Base is that it is easy to subclass. This is very important, because in your personal project, you will likely want to extend Test::Base with your own filters and other reusable pieces of your test framework. Here is an example of a subclass: package MyTestStuff; use Test::Base -Base; our @EXPORT = qw(some_func); sub some_func { (my ($self), @_) = find_my_self(@_); ... } package MyTestStuff::Block; use base 'Test::Base::Block'; sub desc { $self->description(@_); } package MyTestStuff::Filter; use base 'Test::Base::Filter'; sub upper { $self->assert_scalar(@_); uc(shift); } Note that you don't have to re-Export all the functions from Test::Base. That happens automatically, due to the powers of Spiffy. The first line in C allows it to be called as either a function or a method in the test code. =head1 DISTRIBUTION SUPPORT You might be thinking that you do not want to use Test::Base in you modules, because it adds an installation dependency. Fear not. Module::Install takes care of that. Just write a Makefile.PL that looks something like this: use inc::Module::Install; name 'Foo'; all_from 'lib/Foo.pm'; use_test_base; WriteAll; The line with C will automatically bundle all the code the user needs to run Test::Base based tests. =head1 OTHER COOL FEATURES Test::Base automatically adds: use strict; use warnings; to all of your test scripts and Test::Base subclasses. A Spiffy feature indeed. =head1 HISTORY This module started its life with the horrible and ridicule inducing name C. It was renamed to C with the hope that it would be seen for the very useful module that it has become. If you are switching from C to C, simply substitute the concept and usage of C to C. =head1 AUTHOR Ingy döt Net =head1 COPYRIGHT Copyright (c) 2006, 2008, 2009, 2011. Ingy döt Net. Copyright (c) 2005. Brian Ingerson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut Test-Base-0.60/Makefile.PL0000644000175000017500000000046511546275274013720 0ustar ingyingyuse inc::Module::Install; name 'Test-Base'; all_from 'lib/Test/Base.pm'; readme_from; manifest_skip; version_check; ack_xxx; requires 'Spiffy' => '0.30'; requires 'Test::More' => '0.62'; requires 'Filter::Util::Call' => '0'; recommends 'Test::Deep'; clean_files 't/output'; WriteAll;