From: Vincent Pit Date: Sun, 29 Jun 2008 16:49:57 +0000 (+0200) Subject: Importing with-0.01 X-Git-Tag: v0.01 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=fd599f0e0bd12f2c8704e21b072a755fcb5934c8;p=perl%2Fmodules%2Fwith.git Importing with-0.01 --- 7d694e6f49e219b9c5f62d323666ca2854d51f50 diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..b4cce30 --- /dev/null +++ b/.gitignore @@ -0,0 +1,16 @@ +blib* +pm_to_blib* + +Makefile{,.old} +Build +_build* + +*.tar.gz +with-* + +core.* +*.{c,o,so,bs,out,def,exp} + +cover_db +*.{gcda,gcov,gcno} + diff --git a/Changes b/Changes new file mode 100644 index 0000000..770f607 --- /dev/null +++ b/Changes @@ -0,0 +1,5 @@ +Revision history for with + +0.01 2008-05-08 22:35 UTC + First version, released on an unsuspecting world. + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..7aca9a6 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,19 @@ +Changes +MANIFEST +Makefile.PL +README +lib/with.pm +samples/funcs.pl +samples/with.pl +t/00-load.t +t/10-with.t +t/11-skip.t +t/12-keywords.t +t/13-scope.t +t/90-boilerplate.t +t/91-pod.t +t/92-pod-coverage.t +t/95-portability-files.t +t/99-kwalitee.t +t/lib/with/TestClass.pm +META.yml Module meta-data (added by MakeMaker) diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..aa8ddee --- /dev/null +++ b/META.yml @@ -0,0 +1,22 @@ +--- #YAML:1.0 +name: with +version: 0.01 +abstract: Lexically call methods with a default object. +license: perl +author: + - Vincent Pit +generated_by: ExtUtils::MakeMaker version 6.42 +distribution_type: module +requires: + Carp: 0 + Filter::Util::Call: 0 + Scalar::Util: 0 + Sub::Prototype::Util: 0.08 + Test::More: 0 + Text::Balanced: 0 +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.3.html + version: 1.3 +build_requires: + ExtUtils::MakeMaker: 0 + Test::More: 0 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..af17077 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,43 @@ +use 5.009004; + +use strict; +use warnings; +use ExtUtils::MakeMaker; + +my $BUILD_REQUIRES = { + 'ExtUtils::MakeMaker' => 0, + 'Test::More' => 0, +}; + +sub build_req { + my $tometa = ' >> $(DISTVNAME)/META.yml;'; + my $build_req = 'echo "build_requires:" ' . $tometa; + foreach my $mod ( sort { lc $a cmp lc $b } keys %$BUILD_REQUIRES ) { + my $ver = $BUILD_REQUIRES->{$mod}; + $build_req .= sprintf 'echo " %-30s %s" %s', "$mod:", $ver, $tometa; + } + return $build_req; +} + +WriteMakefile( + NAME => 'with', + AUTHOR => 'Vincent Pit ', + LICENSE => 'perl', + VERSION_FROM => 'lib/with.pm', + ABSTRACT_FROM => 'lib/with.pm', + PL_FILES => {}, + PREREQ_PM => { + 'Carp' => 0, + 'Filter::Util::Call' => 0, + 'Scalar::Util' => 0, + 'Sub::Prototype::Util' => 0.08, + 'Text::Balanced' => 0, + 'Test::More' => 0, + }, + dist => { + PREOP => 'pod2text lib/with.pm > $(DISTVNAME)/README; ' + . build_req, + COMPRESS => 'gzip -9f', SUFFIX => 'gz' + }, + clean => { FILES => 'with-* *.gcov *.gcda *.gcno cover_db' }, +); diff --git a/README b/README new file mode 100644 index 0000000..b90723b --- /dev/null +++ b/README @@ -0,0 +1,130 @@ +NAME + with - Lexically call methods with a default object. + +VERSION + Version 0.01 + +SYNOPSIS + package Deuce; + + sub new { my $class = shift; bless { id = > shift }, $class } + + sub hlagh { my $self = shift; print "Deuce::hlagh $self->{id}\n" } + + package Pants; + + sub hlagh { print "Pants::hlagh\n" } + + our @ISA; + push @ISA, 'Deuce'; + my $deuce = new Deuce 1; + + hlagh; # Pants::hlagh + + { + use with \$deuce; + hlagh; # Deuce::hlagh 1 + Pants::hlagh; # Pants::hlagh + + { + use with \Deuce->new(2); + hlagh; # Deuce::hlagh 2 + } + + hlagh; # Deuce::hlagh 1 + + no with; + hlagh; # Pants::hlagh + } + + hlagh; # Pants::hlagh + +DESCRIPTION + This pragma lets you define a default object against with methods will + be called in the current scope when possible. It is enabled by the "use + with \$obj" idiom (note that you must pass a reference to the object). + If you "use with" several times in the current scope, the default object + will be the last specified one. + +HOW DOES IT WORK + The main problem to address is that lexical scope and source + modifications can only occur at compile time, while object creation and + method resolution happen at run-time. + + The "use with \$obj" statement stores an address to the variable $obj in + the "with" field of the hints hash "%^H". It also starts a source filter + that replaces function calls with calls to "with::defer", passing the + name of the original function as the first argument. When the replaced + function is part of Perl core, the call is deferred to a corresponding + wrapper generated in the "with" namespace. Some keywords that couldn't + possibly be replaced are also completely skipped. "no with" undefines + the hint and deletes the source filter, stopping any subsequent + modification in the current scope. + + When the script is executed, deferred calls first fetch the default + object back from the address stored into the hint. If the object "->can" + the original function name, a method call is issued. If not, the calling + namespace is inspected for a subroutine with the proper name, and if + it's present the program "goto"s into it. If that fails too, the core + function with the same name is recalled if possible, or an "Undefined + subroutine" warning is thrown. + +IGNORED KEYWORDS + A call will never dispatch to methods whose name is part of : + + my our local sub do eval goto return + if else elsif unless given when or and + while until for foreach next redo last continue + eq ne lt gt le ge + map grep system exec sort print say + new + STDIN STDOUT STDERR + +EXPORT + No function or constant is exported by this pragma. + +CAVEATS + Most likely slow. Almost surely non thread-safe. Contains source + filters, hence brittle. Messes with the dreadful prototypes. Crazy. Will + have bugs. + + Don't put anything on the same line of "use with \$obj" or "no with". + +DEPENDENCIES + perl 5.9.4. + + Carp (core module since perl 5). + + Filter::Util::Call, Scalar::Util and Text::Balanced (core since 5.7.3). + + Sub::Prototype::Util 0.08. + +AUTHOR + Vincent Pit, "", . + + You can contact me by mail or on #perl @ FreeNode (vincent or + Prof_Vince). + +BUGS + Please report any bugs or feature requests to "bug-with at rt.cpan.org", + or through the web interface at + . I will be + notified, and then you'll automatically be notified of progress on your + bug as I make changes. + +SUPPORT + You can find documentation for this module with the perldoc command. + + perldoc with + +ACKNOWLEDGEMENTS + A fair part of this module is widely inspired from Filter::Simple + (especially "FILTER_ONLY"), but a complete integration was needed in + order to add hints support and more placeholder patterns. + +COPYRIGHT & LICENSE + Copyright 2008 Vincent Pit, all rights reserved. + + This program is free software; you can redistribute it and/or modify it + under the same terms as Perl itself. + diff --git a/lib/with.pm b/lib/with.pm new file mode 100644 index 0000000..11bf4aa --- /dev/null +++ b/lib/with.pm @@ -0,0 +1,370 @@ +package with; + +use 5.009004; + +use strict; +use warnings; + +use Carp qw/croak/; +use Filter::Util::Call; +use Text::Balanced qw/extract_variable extract_quotelike extract_multiple/; +use Scalar::Util qw/refaddr set_prototype/; + +use Sub::Prototype::Util qw/flatten recall wrap/; + +=head1 NAME + +with - Lexically call methods with a default object. + +=head1 VERSION + +Version 0.01 + +=cut + +our $VERSION = '0.01'; + +=head1 SYNOPSIS + + package Deuce; + + sub new { my $class = shift; bless { id = > shift }, $class } + + sub hlagh { my $self = shift; print "Deuce::hlagh $self->{id}\n" } + + + package Pants; + + sub hlagh { print "Pants::hlagh\n" } + + our @ISA; + push @ISA, 'Deuce'; + my $deuce = new Deuce 1; + + hlagh; # Pants::hlagh + + { + use with \$deuce; + hlagh; # Deuce::hlagh 1 + Pants::hlagh; # Pants::hlagh + + { + use with \Deuce->new(2); + hlagh; # Deuce::hlagh 2 + } + + hlagh; # Deuce::hlagh 1 + + no with; + hlagh; # Pants::hlagh + } + + hlagh; # Pants::hlagh + +=head1 DESCRIPTION + +This pragma lets you define a default object against with methods will be called in the current scope when possible. It is enabled by the C idiom (note that you must pass a reference to the object). If you C several times in the current scope, the default object will be the last specified one. + +=cut + +my $EOP = qr/\n+|\Z/; +my $CUT = qr/\n=cut.*$EOP/; +my $pod_or_DATA = qr/ + ^=(?:head[1-4]|item) .*? $CUT + | ^=pod .*? $CUT + | ^=for .*? $EOP + | ^=begin \s* (\S+) .*? \n=end \s* \1 .*? $EOP + | ^__(DATA|END)__\r?\n.* + /smx; + +my $extractor = [ + { 'with::COMMENT' => qr/(? $pod_or_DATA }, + { 'with::QUOTELIKE' => sub { + extract_quotelike $_[0], qr/(?=(?:['"]|\bq.|<<\w+))/ + } }, + { 'with::VARIABLE' => sub { + extract_variable $_[0], qr/(?=\\?[\$\@\%\&\*])/ + } }, + { 'with::HASHKEY' => qr/\w+\s*=>/ }, + { 'with::QUALIFIED' => qr/\w+(?:::\w+)+(?:::)?/ }, + { 'with::SUB' => qr/sub\s+\w+(?:::\w+)*/ }, + { 'with::FILEHANDLE' => qr/<[\$\*]?[^\W>]*>/ }, + { 'with::USE' => qr/(?:use|no)\s+\S+/ }, +]; + +my %skip; +$skip{$_} = 1 for qw/my our local sub do eval goto return + if else elsif unless given when or and + while until for foreach next redo last continue + eq ne lt gt le ge + map grep system exec sort print say + new + STDIN STDOUT STDERR/; + +my @core = qw/abs accept alarm atan2 bind binmode bless caller chdir chmod + chop chown chr chroot close closedir connect cos crypt dbmclose + defined delete die do dump each endgrent endhostent endnetent + endpwent endservent eof eval exec exists exit exp fcntl fileno + fork format formline getc getgrent getgrgid getgrnam + gethostbyname gethostent getlogin getnetbyaddr getnetbyname + getpeername getpgrp getppid getpriority getprotobyname + getprotoent getpwent getpwnam getpwuid getservbyname + getservent getsockname getsockopt glob gmtime goto grep hex + int ioctl join keys kill last lc lcfirst length link listen + localtime lock log lstat map mkdir msgctl msgget msgrcv msgsnd + next no oct open opendir ord our pack package pipe pop pos print + prototype push quotemeta rand read readdir readline readlink + redo ref rename require reset return reverse rewinddir rindex + scalar seek seekdir select semctl semget semop send setgrent + setnetent setpgrp setpriority setprotoent setpwent setservent + shift shmctl shmget shmread shmwrite shutdown sin sleep socket + sort splice split sprintf sqrt srand stat study sub substr + syscall sysopen sysread sysseek system syswrite tell telldir tie + time times truncate uc ucfirst umask undef unlink unpack unshift + use utime values vec wait waitpid wantarray warn write/; +my %core; +$core{$_} = prototype "CORE::$_" for @core; +undef @core; +# Fake prototypes +$core{'not'} = '$'; +$core{'defined'} = '_'; +$core{'undef'} = ';\[$@%&*]'; + +my %hints; + +sub code { + no strict 'refs'; + my $name = @_ > 1 ? join '::', @_ + : $_[0]; + return *{$name}{CODE}; +} + +sub corewrap { + my ($name, $par) = @_; + return '' unless $name; + my $wrap = 'with::core::' . $name; + if (not code $wrap) { + my $proto = $core{$name}; + my $func = wrap { 'CORE::' . $name => $proto }, compile => 1; + my $code = set_prototype sub { + my ($caller, $H) = (caller 0)[0, 10]; + my $id = ($H || {})->{with}; + my $obj; + # Try method call. + if ($id and $obj = $hints{$id}) { + if (my $meth = $$obj->can($name)) { + @_ = flatten $proto, @_ if defined $proto; + unshift @_, $$obj; + goto &$meth; + } + } + # Try function call in caller namescape. + $name = $caller . '::' . $name; + if (code $name) { + @_ = flatten $proto, @_ if defined $proto; + goto &$name; + } + # Try core function call. + my @ret = eval { $func->(@_) }; + if ($@) { + # Produce a correct error in regard of the caller. + my $msg = $@; + $msg =~ s/(called)\s+at.*/$1/s; + croak $msg; + } + return wantarray ? @ret : $ret[0]; + }, $proto; + { + no strict 'refs'; + *$wrap = $code; + } + } + return $wrap . ' ' . $par; +} + +sub subwrap { + my ($name, $par, $proto) = @_; + return '' unless $name; + return "with::defer $par'$name'," unless defined $proto; + my $wrap = 'with::sub::' . $name; + if (not code $wrap) { + my $code = set_prototype sub { + my ($caller, $H) = (caller 0)[0, 10]; + my $id = ($H || {})->{with}; + my $obj; + # Try method call. + if ($id and $obj = $hints{$id}) { + if (my $meth = $$obj->can($name)) { + @_ = flatten $proto, @_; + unshift @_, $$obj; + goto &$meth; + } + } + # Try function call in caller namescape. + $name = $caller . '::' . $name; + goto &$name if code $name; + # This call won't succeed, but it'll throw an exception we should propagate. + eval { $name->(@_) }; + if ($@) { + # Produce a correct 'Undefined subroutine' error in regard of the caller. + my $msg = $@; + $msg =~ s/(called)\s+at.*/$1/s; + croak $msg; + } + croak "$name didn't exist and yet the call succeeded\n"; + }, $proto; + { + no strict 'refs'; + *$wrap = $code; + } + } + return $wrap . ' '. $par; +} + +sub defer { + my $name = shift; + my ($caller, $H) = (caller 0)[0, 10]; + my $id = ($H || {})->{with}; + my $obj; + # Try method call. + if ($id and $obj = $hints{$id}) { + if (my $meth = $$obj->can($name)) { + unshift @_, $$obj; + goto &$meth; + } + } + # Try function call in caller namescape. + $name = $caller . '::' . $name; + goto &$name if code $name; + # This call won't succeed, but it'll throw an exception we should propagate. + eval { $name->(@_) }; + if ($@) { + # Produce a correct 'Undefined subroutine' error in regard of the caller. + my $msg = $@; + $msg =~ s/(called)\s+at.*/$1/s; + croak $msg; + } + croak "$name didn't exist and yet the call succeeded\n"; +} + +sub import { + return unless defined $_[1] and ref $_[1]; + my $caller = (caller 0)[0]; + my $id = refaddr $_[1]; + $hints{$^H{with} = $id} = $_[1]; + filter_add sub { + my ($status, $lastline); + my ($data, $count) = ('', 0); + while ($status = filter_read) { + return $status if $status < 0; + return $status unless defined $^H{with} && $^H{with} == $id; + if (/^__(?:DATA)__\r?$/ || /\b(?:use|no)\s+with\b/) { + $lastline = $_; + last; + } + $data .= $_; + ++$count; + $_ = ''; + } + return $count if not $count; + my $instr; + my @components; + for (extract_multiple($data, $extractor)) { + if (ref) { push @components, $_; $instr = 0 } + elsif ($instr) { $components[-1] .= $_ } + else { push @components, $_; $instr = 1 } + } + my $i = 0; + $_ = join '', + map { (ref) ? $; . pack('N', $i++) . $; : $_ } + @components; + @components = grep ref, @components; + s/ + \b &? ([^\W\d]\w+) \s* (?!=>) (\(?) + / + $skip{$1} ? "$1 $2" + : exists $core{$1} ? corewrap $1, $2 + : subwrap $1, $2, prototype($caller.'::'.$1) + /sexg; + s/\Q$;\E(\C{4})\Q$;\E/${$components[unpack('N',$1)]}/g; + $_ .= $lastline if defined $lastline; + return $count; + } +} + +sub unimport { + $^H{with} = undef; + filter_del; +} + +=head1 HOW DOES IT WORK + +The main problem to address is that lexical scope and source modifications can only occur at compile time, while object creation and method resolution happen at run-time. + +The C statement stores an address to the variable C<$obj> in the C field of the hints hash C<%^H>. It also starts a source filter that replaces function calls with calls to C, passing the name of the original function as the first argument. When the replaced function is part of Perl core, the call is deferred to a corresponding wrapper generated in the C namespace. Some keywords that couldn't possibly be replaced are also completely skipped. C undefines the hint and deletes the source filter, stopping any subsequent modification in the current scope. + +When the script is executed, deferred calls first fetch the default object back from the address stored into the hint. If the object C<< ->can >> the original function name, a method call is issued. If not, the calling namespace is inspected for a subroutine with the proper name, and if it's present the program Cs into it. If that fails too, the core function with the same name is recalled if possible, or an "Undefined subroutine" warning is thrown. + +=head1 IGNORED KEYWORDS + +A call will never dispatch to methods whose name is part of : + + my our local sub do eval goto return + if else elsif unless given when or and + while until for foreach next redo last continue + eq ne lt gt le ge + map grep system exec sort print say + new + STDIN STDOUT STDERR + +=head1 EXPORT + +No function or constant is exported by this pragma. + +=head1 CAVEATS + +Most likely slow. Almost surely non thread-safe. Contains source filters, hence brittle. Messes with the dreadful prototypes. Crazy. Will have bugs. + +Don't put anything on the same line of C or C. + +=head1 DEPENDENCIES + +L 5.9.4. + +L (core module since perl 5). + +L, L and L (core since 5.7.3). + +L 0.08. + +=head1 AUTHOR + +Vincent Pit, C<< >>, L. + +You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince). + +=head1 BUGS + +Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. + +=head1 SUPPORT + +You can find documentation for this module with the perldoc command. + + perldoc with + +=head1 ACKNOWLEDGEMENTS + +A fair part of this module is widely inspired from L (especially C), but a complete integration was needed in order to add hints support and more placeholder patterns. + +=head1 COPYRIGHT & LICENSE + +Copyright 2008 Vincent Pit, all rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut + +1; # End of with diff --git a/samples/funcs.pl b/samples/funcs.pl new file mode 100755 index 0000000..5bcfeb9 --- /dev/null +++ b/samples/funcs.pl @@ -0,0 +1,37 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +my $pod = $ARGV[0] || './perlfunc.pod'; +open my $p, '<', $pod or die "open($pod): $!"; +my $d = do { local $/; <$p> }; +my ($f) = $d =~ /=over[^\n]*\n(.*?)=back/s; +die "no functions" unless $f; +my @f = $f =~ /C<([^<>]+)>/g; +my %dup; +@f = sort + grep { eval { () = prototype "CORE::$_" }; !$@ } + grep !$dup{$_}++, @f; +my $c = 10; +my $base = "my \@core = qw/"; +my $out = $base; +my $l = length $base; +my $first = 1; +for (@f) { + if ($l + (1 - $first) + length() <= 78) { + if ($first) { + $first = 0; + } else { + $l++; + $out .= ' '; + } + $l += length; + $out .= $_; + } else { + $l = length($base) - 1; + $out .= "\n" . (' ' x $l); + } +} +$out .= "/;\n"; +print $out; diff --git a/samples/with.pl b/samples/with.pl new file mode 100755 index 0000000..045783b --- /dev/null +++ b/samples/with.pl @@ -0,0 +1,45 @@ +#!/usr/bin/env perl + +package Deuce; + +use strict; +use warnings; + +sub new { my $class = shift; bless { id => shift }, $class } + +sub hlagh { my $self = shift; print "Deuce::hlagh $self->{id}\n" } + + +package main; + +use strict; +use warnings; + +use lib 'blib/lib'; + +sub hlagh { print "Pants::hlagh\n" } + +our @ISA; +push @ISA, 'Deuce'; +my $deuce = new Deuce 1; +my $d = new Deuce 3; + +hlagh; # Pants::hlagh + +{ + use with \$deuce; + hlagh; # Deuce::hlagh 1 + main::hlagh; # Pants::hlagh + + { + use with \Deuce->new(2); # Constant blessed reference + hlagh; # Deuce::hlagh 2 + } + + hlagh; # Deuce::hlagh 1 + + no with; + hlagh; # Pants::hlagh +} + +hlagh; # Pants::hlagh diff --git a/t/00-load.t b/t/00-load.t new file mode 100644 index 0000000..cf812f7 --- /dev/null +++ b/t/00-load.t @@ -0,0 +1,12 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 1; + +BEGIN { + use_ok( 'with' ); +} + +diag( "Testing with $with::VERSION, Perl $], $^X" ); diff --git a/t/10-with.t b/t/10-with.t new file mode 100644 index 0000000..4f6e34c --- /dev/null +++ b/t/10-with.t @@ -0,0 +1,60 @@ +#!perl -T + +package main; + +use strict; +use warnings; + +use Test::More 'no_plan'; + +use lib 't/lib'; +use with::TestClass; + +my $tc; +BEGIN { $tc = 'with::TestClass' } + +sub foo { is($_[0], __PACKAGE__, __PACKAGE__ . '::foo was called'); } +sub baz { is($_[0], __PACKAGE__, __PACKAGE__ . '::baz was called'); } + +my %cbs; +# "use with \with::TestClass->new(id => 2, %cbs)" forces the evaluation of %cbs +# at compile time for constant folding, so we must define it in a BEGIN block. +BEGIN { %cbs = (is => \&Test::More::is); } + +my $o1 = new with::TestClass id => 1, %cbs; + + +foo 'main', 0; +{ + use with \$o1; + foo $tc, 1; + bar($tc, 1); + { + foo $tc, 1; + use with \with::TestClass->new(id => 2, %cbs); + + foo + $tc, + "2"; + bar $tc, 2; + main::foo 'main', 2; + my $ref = \&foo; + $ref->('main', 2); + + no with; + foo 'main', 0; + } + + + + foo $tc, q{1};bar $tc, + '1'; + + + + baz 'main', 1; + +} +foo 'main', 0; +eval { bar 'main', 0 }; +ok($@, 'wrong call croaks'); diff --git a/t/11-skip.t b/t/11-skip.t new file mode 100644 index 0000000..fae6ba0 --- /dev/null +++ b/t/11-skip.t @@ -0,0 +1,37 @@ +#!perl -T + +package main; + +use strict; +use warnings; + +use Test::More 'no_plan'; + +sub with::Mock::right { pass $_[1] } +sub with::Mock::wrong { fail $_[1] } +sub with::Mock::test { is $_[1], $_[2], $_[3] } + +use with \bless {}, 'with::Mock'; + +right 'normal'; +my $s = q{wrong 'string'}; +test $s, q{wrong 'string'}, 'string is preserved'; +# no with; +right + 'after string'; +# wrong('comments'); +right 'after comment'; +=pod +wrong('POD'); +=cut +right q/after POD/; +my $x = "heredoc"; right "before $x"; +my $y = <; +test $d, "wrong '__DATA__';\n", 'data is preserved'; +__DATA__ +wrong '__DATA__'; diff --git a/t/12-keywords.t b/t/12-keywords.t new file mode 100644 index 0000000..f2daaff --- /dev/null +++ b/t/12-keywords.t @@ -0,0 +1,53 @@ +#!perl -T + +package main; + +use strict; +use warnings; + +use Test::More 'no_plan'; + +sub with::Mock::right { pass $_[1] } +sub with::Mock::wrong { fail $_[1] } +sub with::Mock::test { is_deeply $_[1], $_[2], $_[3] } + +use with \bless {}, 'with::Mock'; + +my $c = 0; +++$c for 1 .. 10; +test $c, 10, 'for'; + +$c = 0; +while ($c < 5) { ++$c; } +test $c, 5, 'while'; + +$c = undef; +test !defined($c), 1, 'undef, defined'; + +my @a = (1, 2); + +my $x = pop @a; +my $y = shift @a; +push @a, $y; +unshift @a, $x; +test \@a, [ 2, 1 ], 'pop/shift/push/unshift'; + +@a = reverse @a; +test \@a, [ 1, 2 ], 'reverse'; + +open my $fh, '<', $0 or die "$!"; +my $d = do { local $/; <$fh> }; +$d =~ s/^(\S+).*/$1/s; +test $d, '#!perl', 'open/do/local'; + +@a = map { $_ + 1 } 0 .. 5; +test \@a, [ 1 .. 6 ], 'map'; + +@a = grep { $_ > 2 } 0 .. 5; +test \@a, [ 3 .. 5 ], 'grep'; + +my %h = (foo => 1, bar => 2); +@a = sort { $h{$a} <=> $h{$b} } keys %h; +test \@a, [ 'foo', 'bar' ], 'sort/keys'; + +print STDERR "# boo" if 0; diff --git a/t/13-scope.t b/t/13-scope.t new file mode 100644 index 0000000..8a9b4c8 --- /dev/null +++ b/t/13-scope.t @@ -0,0 +1,24 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More 'no_plan'; + +sub bait { ok !$_[0], 'object shouldn\'t be called' } +sub with::Mock::bait { ok $_[1], 'object should be called' } + +my $obj = bless {}, 'with::Mock'; + +sub alpha { + use with \$obj; + bait 1; +} + +bait 0; + +sub beta { + bait 0; +} + +sub main::gamma { bait 0 } diff --git a/t/90-boilerplate.t b/t/90-boilerplate.t new file mode 100644 index 0000000..42ca678 --- /dev/null +++ b/t/90-boilerplate.t @@ -0,0 +1,48 @@ +#!perl -T + +use strict; +use warnings; +use Test::More tests => 3; + +sub not_in_file_ok { + my ($filename, %regex) = @_; + open( my $fh, '<', $filename ) + or die "couldn't open $filename for reading: $!"; + + my %violated; + + while (my $line = <$fh>) { + while (my ($desc, $regex) = each %regex) { + if ($line =~ $regex) { + push @{$violated{$desc}||=[]}, $.; + } + } + } + + if (%violated) { + fail("$filename contains boilerplate text"); + diag "$_ appears on lines @{$violated{$_}}" for keys %violated; + } else { + pass("$filename contains no boilerplate text"); + } +} + +sub module_boilerplate_ok { + my ($module) = @_; + not_in_file_ok($module => + 'the great new $MODULENAME' => qr/ - The great new /, + 'boilerplate description' => qr/Quick summary of what the module/, + 'stub function definition' => qr/function[12]/, + ); +} + +not_in_file_ok(README => + "The README is used..." => qr/The README is used/, + "'version information here'" => qr/to provide version information/, +); + +not_in_file_ok(Changes => + "placeholder date/time" => qr(Date/time) +); + +module_boilerplate_ok('lib/with.pm'); diff --git a/t/91-pod.t b/t/91-pod.t new file mode 100644 index 0000000..ee8b18a --- /dev/null +++ b/t/91-pod.t @@ -0,0 +1,12 @@ +#!perl -T + +use strict; +use warnings; +use Test::More; + +# Ensure a recent version of Test::Pod +my $min_tp = 1.22; +eval "use Test::Pod $min_tp"; +plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; + +all_pod_files_ok(); diff --git a/t/92-pod-coverage.t b/t/92-pod-coverage.t new file mode 100644 index 0000000..4cd3e2f --- /dev/null +++ b/t/92-pod-coverage.t @@ -0,0 +1,20 @@ +#!perl -T + +use strict; +use warnings; +use Test::More; + +# Ensure a recent version of Test::Pod::Coverage +my $min_tpc = 1.08; +eval "use Test::Pod::Coverage $min_tpc"; +plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@; + +# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, +# but older versions don't recognize some common documentation styles +my $min_pc = 0.18; +eval "use Pod::Coverage $min_pc"; +plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@; + +all_pod_coverage_ok( + { also_private => [ qr/import$/, qw/code corewrap subwrap defer/ ] } +); diff --git a/t/95-portability-files.t b/t/95-portability-files.t new file mode 100644 index 0000000..ab541f3 --- /dev/null +++ b/t/95-portability-files.t @@ -0,0 +1,10 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More; + +eval "use Test::Portability::Files"; +plan skip_all => "Test::Portability::Files required for testing filenames portability" if $@; +run_tests(); diff --git a/t/99-kwalitee.t b/t/99-kwalitee.t new file mode 100644 index 0000000..7775e60 --- /dev/null +++ b/t/99-kwalitee.t @@ -0,0 +1,9 @@ +#!perl + +use strict; +use warnings; + +use Test::More; + +eval { require Test::Kwalitee; Test::Kwalitee->import() }; +plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@; diff --git a/t/lib/with/TestClass.pm b/t/lib/with/TestClass.pm new file mode 100644 index 0000000..a3c1724 --- /dev/null +++ b/t/lib/with/TestClass.pm @@ -0,0 +1,25 @@ +package with::TestClass; + +use strict; +use warnings; + +sub new { + my $class = shift; + my %args = @_; + $class = ref $class || $class || return; + bless { id => $args{id}, is => $args{is} }, $class; +} + +sub foo { + my $self = shift; + $self->{is}->($_[0], __PACKAGE__, __PACKAGE__ . '::foo was called'); + $self->{is}->($_[1], $self->{id}, 'id in foo is correct'); +} + +sub bar { + my $self = shift; + $self->{is}->($_[0], __PACKAGE__, __PACKAGE__ . '::bar was called'); + $self->{is}->($_[1], $self->{id}, 'id in bar is correct'); +} + +1;