From: Vincent Pit Date: Wed, 27 Aug 2008 21:20:04 +0000 (+0200) Subject: This is 0.01 X-Git-Tag: v0.01^0 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=8d9466619cdc7aaf876803a49d8857ce55e114d0;p=perl%2Fmodules%2Fsubs-auto.git This is 0.01 --- 8d9466619cdc7aaf876803a49d8857ce55e114d0 diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..0d48f1a --- /dev/null +++ b/.gitignore @@ -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 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 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 index 0000000..162da65 --- /dev/null +++ b/Makefile.PL @@ -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 ', + 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/; + <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, "", . + + 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 + . 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 + . + +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 index 0000000..13568ac --- /dev/null +++ b/lib/subs/auto.pm @@ -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 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, which is ultimately why you use this pragma, right ?). + +=head1 DEPENDENCIES + +L 5.10.0. + +L (standard since perl 5), L (since 5.002). + +L with C magic enabled (this should be assured by the required perl version). + +=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 subs::auto + +Tests code coverage report is available at L. + +=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 index 0000000..ef74a92 --- /dev/null +++ b/t/00-load.t @@ -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 index 0000000..12e758e --- /dev/null +++ b/t/10-base.t @@ -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 index 0000000..0c375df --- /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/subs/auto.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..a63d2f4 --- /dev/null +++ b/t/92-pod-coverage.t @@ -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 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 $@;