1package Magic; 2#use strict; 3use Exporter; 4use vars qw( @ISA @EXPORT ); 5@ISA = qw( Exporter ); 6@EXPORT = qw( ok ); 7 8sub debug { $::D || 0 } 9 10sub import { 11 printf("1..%d\n", count($_[0])); 12 Magic->export_to_level(1,@_); 13} 14 15sub count { 16 my $package = shift; 17 local $/ = undef; 18 open(SCRIPT, $0); 19 my $code = <SCRIPT>; 20 $code =~ s/\n__(DATA|END)__\n.*//s; 21 $code =~ s/\n\n=pod\n\n.*?(\n\n=cut\n\n|$)//gs; 22 my (@count) = $code =~ /::ok/gs; 23 return (1 + scalar @count); 24} 25 26my $count = 2; 27my %history; 28 29sub ok(%) { 30 my %p = (@_); # code, expect, desc, version, need 31 my $ok = 0; 32 exists $p{'code'} or die "->ok(code => \\&) required!"; 33 $p{'desc'} ||= ''; 34 35 return printf("# skip %-2s %s (\$VERSION < %s)\n", 36 $count++, $p{'desc'}, $p{'version'}) 37 if (exists $p{'version'} and $Class::Contract::VERSION < $p{'version'}); 38 39 return printf("# skip %-2s %s\n (duplicate test description)\n", 40 $count++, $p{'desc'}) 41 if exists $history{$p{'desc'}}; 42 43 if (exists $p{'need'}) { 44 $p{'need'} = [$p{'need'}] unless (ref($p{'need'}) eq 'ARRAY'); 45 foreach my $test (@{$p{'need'}}) { 46 return printf("# skip %-2s (test requires: '%s')\n", $count++, $test) 47 unless $history{$test}; 48 } 49 } 50 51 undef $@; 52 my $val = eval qq{$p{'code'}}; 53 $@ and $val = $@; 54 55 if (exists $p{'expect'}) { 56 if (ref($p{'expect'}) eq 'Regexp') { 57 $ok = $val =~ /$p{'expect'}/; 58 print "\t$count regex match on [$val]\n" if debug; 59 } elsif ($@) { 60 $ok = 0; 61 print STDERR "\tunexpected exception:\n$@\n";# if debug; 62 } else { # Is it a number or a string 63 $ok = ($p{'expect'} =~ /^([+-]?)(?=\d|\.d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/) 64 ? ($val == $p{'expect'}) 65 : ($val eq $p{'expect'}); 66 print "\texpected=[$p{'expect'}]\n\tvalue=[$val]\n" if debug; 67 } 68 } else { 69 $ok = $val ? 1 : 0 70 } 71 72 $history{$p{'desc'}} = $ok; 73 74 print 'not ' unless $ok; 75 printf("ok %-6s %s\n", $count, $p{'desc'}); 76 $count++; 77 return $ok 78} 79 801; 81__END__ 82