]> git.vpit.fr Git - perl/modules/subs-auto.git/commitdiff
This is 0.01 v0.01
authorVincent Pit <vince@profvince.com>
Wed, 27 Aug 2008 21:20:04 +0000 (23:20 +0200)
committerVincent Pit <vince@profvince.com>
Wed, 27 Aug 2008 21:20:04 +0000 (23:20 +0200)
13 files changed:
.gitignore [new file with mode: 0644]
Changes [new file with mode: 0644]
MANIFEST [new file with mode: 0644]
Makefile.PL [new file with mode: 0644]
README [new file with mode: 0644]
lib/subs/auto.pm [new file with mode: 0644]
t/00-load.t [new file with mode: 0644]
t/10-base.t [new file with mode: 0644]
t/90-boilerplate.t [new file with mode: 0644]
t/91-pod.t [new file with mode: 0644]
t/92-pod-coverage.t [new file with mode: 0644]
t/95-portability-files.t [new file with mode: 0644]
t/99-kwalitee.t [new file with mode: 0644]

diff --git a/.gitignore b/.gitignore
new file mode 100644 (file)
index 0000000..0d48f1a
--- /dev/null
@@ -0,0 +1,25 @@
+blib*
+pm_to_blib*
+
+Makefile
+Makefile.old
+Build
+_build*
+
+*.tar.gz
+subs-auto-*
+
+core.*
+*.[co]
+*.so
+*.bs
+*.out
+*.def
+*.exp
+
+cover_db
+*.gcda
+*.gcov
+*.gcno
+
+Debian_CPANTS.txt
diff --git a/Changes b/Changes
new file mode 100644 (file)
index 0000000..5916ad6
--- /dev/null
+++ b/Changes
@@ -0,0 +1,5 @@
+Revision history for subs-auto
+
+0.01    2008-08-27 21:10 UTC
+        First version, released on an unsuspecting world.
+
diff --git a/MANIFEST b/MANIFEST
new file mode 100644 (file)
index 0000000..8ecef54
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,12 @@
+Changes
+MANIFEST
+Makefile.PL
+README
+lib/subs/auto.pm
+t/00-load.t
+t/10-base.t
+t/90-boilerplate.t
+t/91-pod.t
+t/92-pod-coverage.t
+t/95-portability-files.t
+t/99-kwalitee.t
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644 (file)
index 0000000..162da65
--- /dev/null
@@ -0,0 +1,53 @@
+use 5.010;
+
+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          => 'subs::auto',
+    AUTHOR        => 'Vincent Pit <perl@profvince.com>',
+    LICENSE       => 'perl',
+    VERSION_FROM  => 'lib/subs/auto.pm',
+    ABSTRACT_FROM => 'lib/subs/auto.pm',
+    PL_FILES      => {},
+    PREREQ_PM     => {
+        'Carp'            => 0,
+        'Symbol'          => 0,
+        'Variable::Magic' => 0.08
+    },
+    dist          => {
+        PREOP      => 'pod2text lib/subs/auto.pm > $(DISTVNAME)/README; '
+                      . build_req,
+        COMPRESS   => 'gzip -9f', SUFFIX => 'gz'
+    },
+    clean         => { FILES => 'subs-auto-* *.gcov *.gcda *.gcno cover_db' }
+);
+
+1;
+
+package MY;
+
+sub postamble {
+ my $cv = join ' -coverage ', 'cover',
+                            qw/statement branch condition path subroutine time/;
+ <<POSTAMBLE;
+cover test_cover:
+       $cv -test
+POSTAMBLE
+}
diff --git a/README b/README
new file mode 100644 (file)
index 0000000..674535c
--- /dev/null
+++ b/README
@@ -0,0 +1,81 @@
+NAME
+    subs::auto - Read barewords as subroutine names.
+
+VERSION
+    Version 0.01
+
+SYNOPSIS
+        {
+         use subs::auto;
+         foo;             # Compile to "foo()"     instead of "'foo'"
+                          #                        or croaking on strict subs
+         foo $x;          # Compile to "foo($x)"   instead of "$x->foo"
+         foo 1;           # Compile to "foo(1)"    instead of croaking
+         foo 1, 2;        # Compile to "foo(1, 2)" instead of croaking
+         foo(@a);         # Still ok
+         foo->meth;       # "'foo'->meth" if you have use'd foo somewhere,
+                          #  or "foo()->meth" otherwise
+         print foo 'wut'; # print to the filehandle foo if it's actually one,
+                          #  or "foo()->print('wut')" otherwise
+        } # ... but function calls will fail at run-time if you don't
+          # actually define foo somewhere
+    
+        foo; # BANG
+
+DESCRIPTION
+    This pragma lexically enables the parsing of any bareword as a
+    subroutine name, except those which corresponds to an entry in %INC
+    (expected to be class names) or whose symbol table entry has a IO slot
+    (expected to be filehandles).
+
+EXPORT
+    None.
+
+CAVEATS
+    "*{'::foo'}{CODE}" will appear as defined in a scope where the pragma is
+    enabled, "foo" is used as a bareword, but is never actually defined
+    afterwards. This may or may not be considered as Doing The Right Thing.
+    However, "*{'::foo'}{CODE}" will always return the right value if you
+    fetch it outside the pragma's scope. Actually, you can make it return
+    the right value even in the pragma's scope by reading "*{'::foo'}{CODE}"
+    outside (or by actually defining "foo", which is ultimately why you use
+    this pragma, right ?).
+
+DEPENDENCIES
+    perl 5.10.0.
+
+    Carp (standard since perl 5), Symbol (since 5.002).
+
+    Variable::Magic with "uvar" magic enabled (this should be assured by the
+    required perl version).
+
+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-subs-auto at
+    rt.cpan.org", or through the web interface at
+    <http://rt.cpan.org/NoAuth/ReportBug.html?Queue=subs-auto>. 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 subs::auto
+
+    Tests code coverage report is available at
+    <http://www.profvince.com/perl/cover/subs-auto>.
+
+ACKNOWLEDGEMENTS
+    Thanks to Sebastien Aperghis-Tramoni for helping to name this pragma.
+
+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/subs/auto.pm b/lib/subs/auto.pm
new file mode 100644 (file)
index 0000000..13568ac
--- /dev/null
@@ -0,0 +1,218 @@
+package subs::auto;
+
+use 5.010;
+
+use strict;
+use warnings;
+
+use Symbol qw/gensym/;
+
+use Variable::Magic qw/wizard cast dispell getdata/;
+
+=head1 NAME
+
+subs::auto - Read barewords as subroutine names.
+
+=head1 VERSION
+
+Version 0.01
+
+=cut
+
+our $VERSION = '0.01';
+
+=head1 SYNOPSIS
+
+    {
+     use subs::auto;
+     foo;             # Compile to "foo()"     instead of "'foo'"
+                      #                        or croaking on strict subs
+     foo $x;          # Compile to "foo($x)"   instead of "$x->foo"
+     foo 1;           # Compile to "foo(1)"    instead of croaking
+     foo 1, 2;        # Compile to "foo(1, 2)" instead of croaking
+     foo(@a);         # Still ok
+     foo->meth;       # "'foo'->meth" if you have use'd foo somewhere,
+                      #  or "foo()->meth" otherwise
+     print foo 'wut'; # print to the filehandle foo if it's actually one,
+                      #  or "foo()->print('wut')" otherwise
+    } # ... but function calls will fail at run-time if you don't
+      # actually define foo somewhere
+    
+    foo; # BANG
+
+=head1 DESCRIPTION
+
+This pragma lexically enables the parsing of any bareword as a subroutine name, except those which corresponds to an entry in C<%INC> (expected to be class names) or whose symbol table entry has a IO slot (expected to be filehandles).
+
+=cut
+
+BEGIN {
+ if (!Variable::Magic::VMG_UVAR) {
+  require Carp;
+  Carp::croak('uvar magic not available');
+ }
+}
+
+my @core = qw/abs accept alarm atan2 bind binmode bless break caller chdir
+              chmod chomp chop chown chr chroot close closedir connect
+              continue cos crypt dbmclose dbmopen default defined delete die
+              do dump each endgrent endhostent endnetent endprotoent endpwent
+              endservent eof eval exec exists exit exp fcntl fileno flock fork
+              format formline getc getgrent getgrgid getgrnam gethostbyaddr
+              gethostbyname gethostent getlogin getnetbyaddr getnetbyname
+              getnetent getpeername getpgrp getppid getpriority getprotobyname
+              getprotobynumber getprotoent getpwent getpwnam getpwuid
+              getservbyname getservbyport getservent getsockname getsockopt
+              given glob gmtime goto grep hex index int ioctl join keys kill
+              last lc lcfirst length link listen local localtime lock log
+              lstat map mkdir msgctl msgget msgrcv msgsnd my next no oct open
+              opendir ord our pack package pipe pop pos print printf prototype
+              push quotemeta rand read readdir readline readlink readpipe recv
+              redo ref rename require reset return reverse rewinddir rindex
+              rmdir say scalar seek seekdir select semctl semget semop send
+              setgrent sethostent setnetent setpgrp setpriority setprotoent
+              setpwent setservent setsockopt shift shmctl shmget shmread
+              shmwrite shutdown sin sleep socket socketpair sort splice split
+              sprintf sqrt srand stat state study sub substr symlink syscall
+              sysopen sysread sysseek system syswrite tell telldir tie tied
+              time times truncate uc ucfirst umask undef unlink unpack unshift
+              untie use utime values vec wait waitpid wantarray warn when
+              write/;
+push @core,qw/not/;
+
+my %core;
+@core{@core} = ();
+delete @core{qw/my local/};
+undef @core;
+
+my $tag = wizard data => sub { 1 };
+
+sub _reset {
+ my ($pkg, $func) = @_;
+ my $fqn = join '::', @_;
+ my $cb = do {
+  no strict 'refs';
+  no warnings 'once';
+  *$fqn{CODE};
+ };
+ if ($cb and getdata(&$cb, $tag)) {
+  no strict 'refs';
+  my $sym = gensym;
+  for (qw/SCALAR ARRAY HASH IO FORMAT/) {
+   no warnings 'once';
+   *$sym = *$fqn{$_} if defined *$fqn{$_}
+  }
+  undef *$fqn;
+  *$fqn = *$sym;
+ }
+}
+
+sub _fetch {
+ (undef, my $data, my $func) = @_;
+ return if $data->{guard};
+ return unless $func !~ /::/ and not exists $core{$func};
+ local $data->{guard} = 1;
+ my $hints = (caller 0)[10];
+ if ($hints and $hints->{bareword}) {
+  my $mod = $func . '.pm';
+  if (not exists $INC{$mod}) {
+   my $fqn = $data->{pkg} . '::' . $func;
+   if (do { no strict 'refs'; not *$fqn{CODE} and not *$fqn{IO}}) {
+    my $cb = sub {
+     my ($file, $line) = (caller 0)[1, 2];
+     ($file, $line) = ('(eval 0)', 0) unless $file && $line;
+     die "Undefined subroutine &$fqn called at $file line $line\n";
+    };
+    cast &$cb, $tag;
+    no strict 'refs';
+    *$fqn = $cb;
+   }
+  }
+ } else {
+  _reset($data->{pkg}, $func);
+ }
+ return;
+}
+
+sub _store {
+ (undef, my $data, my $func) = @_;
+ return if $data->{guard};
+ local $data->{guard} = 1;
+ _reset($data->{pkg}, $func);
+ return;
+}
+
+my $wiz = wizard data  => sub { +{ pkg => $_[1] } },
+                 fetch => \&_fetch,
+                 store => \&_store;
+
+my %pkgs;
+
+sub import {
+ my $pkg = caller 1;
+ $^H{bareword} = 1;
+ ++$pkgs{$pkg};
+ no strict 'refs';
+ cast %{$pkg . '::'}, $wiz, $pkg;
+}
+
+sub unimport {
+ $^H{bareword} = 0;
+}
+
+{
+ no warnings 'void';
+ CHECK {
+  no strict 'refs';
+  dispell %{$_ . '::'}, $wiz for keys %pkgs;
+ }
+}
+
+=head1 EXPORT
+
+None.
+
+=head1 CAVEATS
+
+C<*{'::foo'}{CODE}> will appear as defined in a scope where the pragma is enabled, C<foo> is used as a bareword, but is never actually defined afterwards. This may or may not be considered as Doing The Right Thing. However, C<*{'::foo'}{CODE}> will always return the right value if you fetch it outside the pragma's scope. Actually, you can make it return the right value even in the pragma's scope by reading C<*{'::foo'}{CODE}> outside (or by actually defining C<foo>, which is ultimately why you use this pragma, right ?).
+
+=head1 DEPENDENCIES
+
+L<perl> 5.10.0.
+
+L<Carp> (standard since perl 5), L<Symbol> (since 5.002).
+
+L<Variable::Magic> with C<uvar> magic enabled (this should be assured by the required perl version).
+
+=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-subs-auto at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=subs-auto>.  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 subs::auto
+
+Tests code coverage report is available at L<http://www.profvince.com/perl/cover/subs-auto>.
+
+=head1 ACKNOWLEDGEMENTS
+
+Thanks to Sebastien Aperghis-Tramoni for helping to name this pragma.
+
+=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 subs::auto
diff --git a/t/00-load.t b/t/00-load.t
new file mode 100644 (file)
index 0000000..ef74a92
--- /dev/null
@@ -0,0 +1,11 @@
+#!perl -T
+
+use strict;
+use warnings;
+use Test::More tests => 1;
+
+BEGIN {
+       use_ok( 'subs::auto' );
+}
+
+diag( "Testing subs::auto $subs::auto::VERSION, Perl $], $^X" );
diff --git a/t/10-base.t b/t/10-base.t
new file mode 100644 (file)
index 0000000..12e758e
--- /dev/null
@@ -0,0 +1,246 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 59;
+
+my %_re = (
+ bareword => sub { qr/^Bareword\s+['"]?\s*$_[0]\s*['"]?\s+not\s+allowed\s+while\s+["']?\s*strict\s+subs\s*['"]?\s+in\s+use\s+at\s+$_[1]\s+line\s+$_[2]/ },
+ undefined => sub { qr/^Undefined\s+subroutine\s+\&$_[0]\s+called\s+at\s+$_[1]\s+line\s+$_[2]/ },
+);
+
+sub _got_test {
+ my $sub  = shift;
+ my $line = shift;
+ my %args = @_;
+ my $msg  = delete $args{msg};
+ $msg     = join ' ', $args{name}, $sub, 'line', $line unless $msg;
+ my $file = $args{eval} ? '\\(eval\\s+\\d+\\)' : quotemeta $0;
+ my $re   = $_re{$args{name}}->($sub, $file, $line);
+ if ($args{todo}) {
+  TODO: {
+   local $TODO = $args{todo};
+   like($@, $re, $msg);
+  }
+ } else {
+  like($@, $re, $msg);
+ }
+}
+
+sub _got_bareword { _got_test(@_, name => 'bareword'); }
+
+sub _got_undefined {
+ my $sub = shift;
+ $sub = 'main::' . $sub if $sub !~ /::/;
+ _got_test($sub, @_, name => 'undefined');
+}
+
+sub _got_ok { is($@, '', $_[0]); }
+
+my $warn;
+
+my $bar;
+sub bar { $bar = 1 }
+
+eval "yay 11, 13"; # Defined on the other side of the scope
+_got_ok('compiling to yay(11,13)');
+our @yay;
+is_deeply(\@yay, [ 11, 13 ], 'yay really was executed');
+
+eval "flip"; # Not called in sub::auto zone, not declared, not defined
+_got_bareword('flip', 1, eval => 1);
+
+eval "flop"; # Not called in sub::auto zone, declared, not defined
+_got_undefined('flop', 1, eval => 1);
+
+my $qux;
+eval "qux"; # Called in sub::auto zone, not declared, not defined
+_got_bareword('qux', 1, eval => 1);
+
+my $blech;
+eval "blech"; # Called in sub::auto zone, declared, not defined
+_got_undefined('blech', 1, eval => 1);
+
+my $wut;
+eval "wut"; # Called in sub::auto zone, declared, defined
+_got_ok('compiling to wut()');
+
+# === Starting from here ======================================================
+use subs::auto;
+
+eval { onlycalledonce 1, 2 };
+_got_undefined('onlycalledonce', 72);
+
+eval { Test::More->import() };
+_got_ok('don\'t touch class names');
+
+my $strict;
+sub strict { $strict = 1; undef }
+eval { strict->import };
+is($strict, 1, 'the strict subroutine was called');
+
+my %h = (
+ a => 5,
+ b => 7,
+);
+
+my $foo;
+our @foo;
+
+my $y = eval {
+ foo 1, 2, \%h;
+};
+_got_ok('compiling to foo(1,2,\\\%h)');
+is($foo, 15, 'foo really was executed');
+
+eval {
+ wut 13, "what"
+};
+_got_ok('compiling to wut(13,"what")');
+is($wut, 17, 'wut really was executed');
+
+eval { qux };
+_got_undefined('qux', 103);
+
+{
+ no strict 'refs';
+ is(*{'::feh'}{CODE}, undef, 'feh isn\'t defined');
+ is(*{'::feh'}{CODE}, undef, 'feh isn\'t defined, really');
+ isnt(*{'::yay'}{CODE}, undef, 'yay is defined');
+ isnt(*{'::foo'}{CODE}, undef, 'foo is defined');
+ is(*{'::flip'}{CODE}, undef, 'flip isn\'t defined');
+ isnt(*{'::flop'}{CODE}, undef, 'flip is defined');
+ is(*{'::qux'}{CODE}, undef, 'qux isn\'t defined');
+ isnt(*{'::blech'}{CODE}, undef, 'blech is defined');
+ isnt(*{'::wut'}{CODE}, undef, 'wut is defined');
+}
+
+eval { no warnings; no strict; qux };
+_got_undefined('qux', 119);
+
+eval { no warnings; no strict; blech };
+_got_undefined('blech', 122);
+
+sub foo {
+ if ($_[2]) {
+  my %h = %{$_[2]};
+  $foo = $_[0] + $_[1] + (($h{a} || 0 == 5) ? 4 : 0)
+                       + (($h{b} || 0 == 7) ? 8 : 0);
+  undef;
+ } else {
+  $foo = '::foo'; # for symbol table tests later
+ }
+}
+
+eval {
+ foo 3, 4, { };
+};
+_got_ok('compiling to foo(3,4,{})');
+is($foo, 7, 'foo really was executed');
+
+$warn = undef;
+eval {
+ local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/ }; 
+ local *qux = sub { $qux = $_[0] };
+ qux 5;
+};
+_got_ok('compiling to qux(5)');
+is($qux, 5, 'qux really was executed');
+is($warn, undef, 'no redefine warning');
+
+$warn = undef;
+eval {
+ local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/ };
+ local *blech = sub { $blech = $_[0] };
+ blech 7;
+};
+_got_ok('compiling to blech(7)');
+is($blech, 7, 'blech really was executed');
+is($warn, undef, 'no redefine warning');
+
+eval { qux };
+_got_undefined('qux', 162);
+
+eval { blech };
+_got_undefined('blech', 165);
+
+# === Up to there =============================================================
+no subs::auto;
+
+my $b;
+my $cb = eval {
+ sub {
+  $b = do {
+   no strict;
+   no warnings 'reserved';
+   blech;
+  }  
+ }
+};
+_got_ok('compiling to bareword');
+$cb->();
+is($b, 'blech', 'bareword ok');
+
+$warn = undef;
+{
+ local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/; diag $_[0] };
+ local *qux = sub { $qux = 2 * $_[0] };
+ qux(3);
+}
+_got_ok('compiling to qux(3)');
+is($qux, 6, 'new qux really was executed');
+is($warn, undef, 'no redefine warning');
+
+$warn = undef;
+{
+ local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/ };
+ local *blech = sub { $blech = 2 * $_[0] };
+ blech(9);
+}
+_got_ok('compiling to blech(9)');
+is($blech, 18, 'new blech really was executed');
+is($warn, undef, 'no redefine warning');
+
+eval "qux";
+_got_bareword('qux', 1, eval => 1);
+
+eval "blech";
+_got_undefined('blech', 1, eval => 1);
+
+{
+ no strict qw/refs subs/;
+ is(*{::feh}{CODE}, undef, 'feh isn\'t defined');
+ is(*{::feh}{CODE}, undef, 'feh isn\'t defined, really');
+ isnt(*{::yay}{CODE}, undef, 'yay is defined');
+ isnt(*{::foo}{CODE}, undef, 'foo is defined'); # calls foo
+ is($foo, '::foo', 'foo was called');
+ is(*{::flip}{CODE}, undef, 'flip isn\'t defined');
+ isnt(*{::flop}{CODE}, undef, 'flip is defined');
+ is(*{::qux}{CODE}, undef, 'qux isn\'t defined');
+ isnt(*{::blech}{CODE}, undef, 'blech is defined');
+ isnt(*{::wut}{CODE}, undef, 'wut is defined');
+}
+
+sub blech;
+eval { blech };
+_got_undefined('blech', 226);
+
+sub flop;
+
+bar();
+is($bar, 1, 'bar ok');
+
+sub wut { $wut = ($_[0] || 0) + length($_[1] || ''); '::wut' }
+
+sub yay { @yay = @_; '::yay' }
+
+{
+ use subs::auto;
+ eval "no subs::auto; meh";
+ _got_bareword("meh", 1, eval => 1);
+# eval "use subs::auto; meh";
+# _got_undefined('meh', 1, eval => 1, todo => 'Fails because of some bug in perl or Variable::Magic');
+# eval "meh";
+# _got_undefined('meh', 1, eval => 1, todo => 'Fails because of some bug in perl or Variable::Magic');
+}
diff --git a/t/90-boilerplate.t b/t/90-boilerplate.t
new file mode 100644 (file)
index 0000000..0c375df
--- /dev/null
@@ -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/subs/auto.pm');
diff --git a/t/91-pod.t b/t/91-pod.t
new file mode 100644 (file)
index 0000000..ee8b18a
--- /dev/null
@@ -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 (file)
index 0000000..a63d2f4
--- /dev/null
@@ -0,0 +1,18 @@
+#!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 => [ qw/unimport/ ] });
diff --git a/t/95-portability-files.t b/t/95-portability-files.t
new file mode 100644 (file)
index 0000000..ab541f3
--- /dev/null
@@ -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 (file)
index 0000000..7775e60
--- /dev/null
@@ -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 $@;