--- /dev/null
+blib*
+pm_to_blib*
+
+Makefile{,.old}
+Build
+_build*
+
+*.tar.gz
+with-*
+
+core.*
+*.{c,o,so,bs,out,def,exp}
+
+cover_db
+*.{gcda,gcov,gcno}
+
--- /dev/null
+Revision history for with
+
+0.01 2008-05-08 22:35 UTC
+ First version, released on an unsuspecting world.
+
--- /dev/null
+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)
--- /dev/null
+--- #YAML:1.0
+name: with
+version: 0.01
+abstract: Lexically call methods with a default object.
+license: perl
+author:
+ - Vincent Pit <perl@profvince.com>
+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
--- /dev/null
+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 <perl@profvince.com>',
+ 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' },
+);
--- /dev/null
+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, "<perl at profvince.com>", <http://www.profvince.com>.
+
+ 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
+ <http://rt.cpan.org/NoAuth/ReportBug.html?Queue=with>. 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.
+
--- /dev/null
+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<use with \$obj> idiom (note that you must pass a reference to the object). If you C<use with> 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/(?<![\$\@%])#.*/ },
+ { 'with::PODDATA' => $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<use with \$obj> statement stores an address to the variable C<$obj> in the C<with> field of the hints hash C<%^H>. It also starts a source filter that replaces function calls with calls to C<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 C<with> namespace. Some keywords that couldn't possibly be replaced are also completely skipped. C<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 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 C<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.
+
+=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<use with \$obj> or C<no with>.
+
+=head1 DEPENDENCIES
+
+L<perl> 5.9.4.
+
+L<Carp> (core module since perl 5).
+
+L<Filter::Util::Call>, L<Scalar::Util> and L<Text::Balanced> (core since 5.7.3).
+
+L<Sub::Prototype::Util> 0.08.
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+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<bug-with at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=with>. 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<Filter::Simple> (especially C<FILTER_ONLY>), 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
--- /dev/null
+#!/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;
--- /dev/null
+#!/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
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 1;
+
+BEGIN {
+ use_ok( 'with' );
+}
+
+diag( "Testing with $with::VERSION, Perl $], $^X" );
--- /dev/null
+#!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');
--- /dev/null
+#!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 = <<HEREDOC;
+wrong('heredoc');
+HEREDOC
+right qq[after heredoc];
+test $y, "wrong('heredoc');\n", 'heredoc is preserved';
+my $d = <DATA>;
+test $d, "wrong '__DATA__';\n", 'data is preserved';
+__DATA__
+wrong '__DATA__';
--- /dev/null
+#!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;
--- /dev/null
+#!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 }
--- /dev/null
+#!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');
--- /dev/null
+#!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();
--- /dev/null
+#!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/ ] }
+);
--- /dev/null
+#!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();
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+eval { require Test::Kwalitee; Test::Kwalitee->import() };
+plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@;
--- /dev/null
+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;
projects / perl / modules / with.git / commitdiff