Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

import true 0.11 from CPAN

git-cpan-module:   true
git-cpan-version:  0.11
git-cpan-authorid: CHOCOLATE
git-cpan-file:     authors/id/C/CH/CHOCOLATE/true-0.11.tar.gz
  • Loading branch information...
commit 13eb26ab64909ec56c5ec05f4f0ffa450930307c 1 parent b6328e1
@chocolateboy authored
View
7 Changes
@@ -1,5 +1,12 @@
Revision history for Perl extension true.
+0.11 Tue Aug 17 16:08:23 2010
+ - add missing dependency
+ - add support/documentation for unimport
+ - add unimport.t
+ - add leak.t
+ - doc tweakage
+
0.10 Tue Aug 17 04:18:42 2010
- rm caveats
- more tests
View
18 MANIFEST
@@ -6,24 +6,34 @@ META.yml
ppport.h
README
t/01_compile.t
-t/02_use.t
-t/03_require.t
-t/04_use_subclass.t
-t/05_require_subclass.t
+t/leak.t
t/lib/bad.pl
t/lib/Bad.pm
t/lib/Contemporary/Perl.pm
t/lib/Contemporary/Perl/Subclass.pm
t/lib/Contemporary/Perl/Subclass/Subclass.pm
+t/lib/DirectNestedUnimport.pm
+t/lib/DirectTopLevelUnimport.pm
+t/lib/DirectTrueLoadUntrue.pm
t/lib/good.pl
t/lib/Good.pm
t/lib/good_with_sub_subclass.pl
t/lib/good_with_subclass.pl
t/lib/GoodWithSubclass.pm
t/lib/GoodWithSubSubclass.pm
+t/lib/IndirectNestedUnimport.pm
+t/lib/IndirectTopLevelUnimport.pm
+t/lib/IndirectTrueLoadUntrue.pm
t/lib/TestSubclass.pm
t/lib/Ugly.pm
t/lib/UglyWithSubclass.pm
t/lib/UglyWithSubSubclass.pm
+t/lib/Untrue1.pm
+t/lib/Untrue2.pm
t/pod.t
+t/require.t
+t/require_subclass.t
+t/unimport.t
+t/use.t
+t/use_subclass.t
true.xs
View
3  META.yml
@@ -1,6 +1,6 @@
--- #YAML:1.0
name: true
-version: 0.10
+version: 0.11
abstract: automatically return a true value when a file is required
author:
- chocolateboy <chocolate@cpan.org>
@@ -16,6 +16,7 @@ build_requires:
requires:
B::Hooks::OP::Annotation: 0.43
B::Hooks::OP::Check: 0.18
+ Devel::StackTrace: 1.22
no_index:
directory:
- t
View
3  Makefile.PL
@@ -29,7 +29,8 @@ WriteMakefile(
NAME => 'true',
VERSION_FROM => 'lib/true.pm',
PREREQ_PM => {
- %XS_PREREQUISITES
+ %XS_PREREQUISITES,
+ 'Devel::StackTrace' => '1.22',
},
ABSTRACT_FROM => 'lib/true.pm',
AUTHOR => 'chocolateboy <chocolate@cpan.org>',
View
9 README
@@ -1,4 +1,4 @@
-true version 0.10
+true version 0.11
==============================
automatically return a true value when a file is required
@@ -16,9 +16,10 @@ DEPENDENCIES
This module requires these other modules and libraries:
- B::Hooks::OP::Annotation: 0.43
- B::Hooks::OP::Check: 0.18
- ExtUtils::Depends: 0.302
+ B::Hooks::OP::Annotation
+ B::Hooks::OP::Check
+ Devel::StackTrace
+ ExtUtils::Depends
COPYRIGHT AND LICENCE
View
36 lib/true.pm
@@ -8,7 +8,7 @@ use B::Hooks::OP::Check;
use Devel::StackTrace;
use XSLoader;
-our $VERSION = '0.10';
+our $VERSION = '0.11';
our %TRUE;
XSLoader::load(__PACKAGE__, $VERSION);
@@ -26,20 +26,31 @@ sub ccfile() {
last;
}
+ if (defined($ccfile) && not(length($ccfile))) {
+ ($ccfile, $ccline) = (undef, undef);
+ }
+
return wantarray ? ($ccfile, $ccline) : $ccfile;
}
sub import {
- my $ccfile = ccfile();
+ my ($ccfile, $ccline) = ccfile();
- if ($ccfile && not($TRUE{$ccfile})) {
+ if (defined($ccfile) && not($TRUE{$ccfile})) {
$TRUE{$ccfile} = 1;
+ # warn "enabling true for $ccfile at line $ccline: ", pp(\%TRUE), $/;
xs_enter();
}
}
sub unimport {
- die "not implemented!";
+ my ($ccfile, $ccline) = ccfile();
+
+ if (defined($ccfile) && $TRUE{$ccfile}) {
+ # warn "disabling true for $ccfile at line $ccline: ", pp(\%TRUE), $/;
+ delete $TRUE{$ccfile};
+ xs_leave() unless (%TRUE);
+ }
}
1;
@@ -87,12 +98,19 @@ or even:
1; # Must end with this, because Perl is bogus.
This module packages this "return true" behaviour so that it need not be written explicitly.
-It shouldn't be used directly, except, perhaps, for pedagogical purposes. Rather it is intended
-to be invoked from the C<import> method of a L<Modern::Perl|Modern::Perl>-style module that
-enables modern Perl features and conveniences and cleans up legacy Perl warts.
+It can be used directly, but it is intended to be invoked from the C<import> method of a
+L<Modern::Perl|Modern::Perl>-style module that enables modern Perl features and conveniences
+and cleans up legacy Perl warts.
=head2 METHODS
+C<true> is file-scoped rather than lexically-scoped. Importing it anywhere in a
+file (e.g. at the top-level or in a nested scope) causes that file to return true,
+and unimporting it anywhere in a file restores the default behaviour. Duplicate imports/unimports
+are ignored.
+
+Note also that these methods are only useful at compile-time.
+
=head3 import
This method, which takes no arguments, should be invoked from the C<import> method of a module that
@@ -118,6 +136,10 @@ explicitly return a true value:
# no need to return true
+=head3 unimport
+
+This method disables the "automatically return true" behaviour for the current file.
+
=head2 EXPORT
None by default.
View
28 t/leak.t
@@ -0,0 +1,28 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+
+use File::Spec;
+use FindBin qw($Bin);
+use Test::More tests => 6;
+
+use lib (File::Spec->catdir($Bin, 'lib'));
+
+# pre-leak sanity-check
+eval 'use Good';
+is $@, '', 'use: Good using true';
+is Good::Good(), 'Good', 'use: Good loaded OK';
+
+eval 'use DirectTrueLoadUntrue';
+like $@, qr{Untrue1.pm did not return a true value\b},
+ "leak (direct): true doesn't leak into a module that doesn't use it";
+
+eval 'use IndirectTrueLoadUntrue';
+like $@, qr{Untrue2.pm did not return a true value\b},
+ "leak (indirect): true doesn't leak into a module that doesn't use it";
+
+# post-leak sanity-check
+eval 'use Ugly';
+is $@, '', 'use: Ugly using true';
+is Ugly::Ugly(), 'Ugly', 'use: Ugly loaded OK';
View
4 t/lib/Contemporary/Perl.pm
@@ -10,4 +10,8 @@ sub import {
true->import();
}
+sub unimport {
+ true->unimport();
+}
+
1;
View
5 t/lib/Contemporary/Perl/Subclass.pm
@@ -9,3 +9,8 @@ sub import {
my $class = shift;
$class->SUPER::import(@_);
}
+
+sub unimport {
+ my $class = shift;
+ $class->SUPER::unimport(@_);
+}
View
5 t/lib/Contemporary/Perl/Subclass/Subclass.pm
@@ -9,3 +9,8 @@ sub import {
my $class = shift;
$class->SUPER::import(@_);
}
+
+sub unimport {
+ my $class = shift;
+ $class->SUPER::unimport(@_);
+}
View
12 t/lib/DirectNestedUnimport.pm
@@ -0,0 +1,12 @@
+package DirectNestedUnimport;
+
+use strict;
+use warnings;
+
+use true;
+use true;
+
+{
+ no true;
+ no true;
+}
View
10 t/lib/DirectTopLevelUnimport.pm
@@ -0,0 +1,10 @@
+package DirectTopLevelUnimport;
+
+use strict;
+use warnings;
+
+use true;
+use true;
+
+no true;
+no true; # test duplicate unimport
View
9 t/lib/DirectTrueLoadUntrue.pm
@@ -0,0 +1,9 @@
+package DirectTrueLoadUntrue;
+
+use strict;
+use warnings;
+use true;
+
+use Untrue1;
+
+sub whatever { 'whatever' }
View
12 t/lib/IndirectNestedUnimport.pm
@@ -0,0 +1,12 @@
+package IndirectNestedUnimport;
+
+use strict;
+use warnings;
+
+use Contemporary::Perl::Subclass::Subclass;
+use Contemporary::Perl::Subclass::Subclass;
+
+{
+ no Contemporary::Perl::Subclass::Subclass;
+ no Contemporary::Perl::Subclass::Subclass;
+}
View
10 t/lib/IndirectTopLevelUnimport.pm
@@ -0,0 +1,10 @@
+package IndirectTopLevelUnimport;
+
+use strict;
+use warnings;
+
+use Contemporary::Perl::Subclass::Subclass;
+use Contemporary::Perl::Subclass::Subclass;
+
+no Contemporary::Perl::Subclass::Subclass;
+no Contemporary::Perl::Subclass::Subclass;
View
9 t/lib/IndirectTrueLoadUntrue.pm
@@ -0,0 +1,9 @@
+package IndirectTrueLoadUntrue;
+
+use strict;
+use warnings;
+
+use Contemporary::Perl::Subclass::Subclass;
+use Untrue2;
+
+sub whatever { 'whatever' }
View
6 t/lib/Untrue1.pm
@@ -0,0 +1,6 @@
+package Untrue1;
+
+use strict;
+use warnings;
+
+sub whatever { 'whatever' }
View
6 t/lib/Untrue2.pm
@@ -0,0 +1,6 @@
+package Untrue2;
+
+use strict;
+use warnings;
+
+sub whatever { 'whatever' }
View
0  t/03_require.t → t/require.t
File renamed without changes
View
0  t/05_require_subclass.t → t/require_subclass.t
File renamed without changes
View
32 t/unimport.t
@@ -0,0 +1,32 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+
+use File::Spec;
+use FindBin qw($Bin);
+use Test::More tests => 8;
+
+use lib (File::Spec->catdir($Bin, 'lib'));
+
+# pre-unimport sanity-check
+eval 'use Good';
+is $@, '', 'use: Good using true';
+is Good::Good(), 'Good', 'use: Good loaded OK';
+
+eval 'use DirectTopLevelUnimport';
+like $@, qr{DirectTopLevelUnimport.pm did not return a true value\b}, 'use: direct top-level unimport works';
+
+eval 'use DirectNestedUnimport';
+like $@, qr{DirectNestedUnimport.pm did not return a true value\b}, 'use: direct nested unimport works';
+
+eval 'use IndirectTopLevelUnimport';
+like $@, qr{IndirectTopLevelUnimport.pm did not return a true value\b}, 'use: indirect top-level unimport works';
+
+eval 'use IndirectNestedUnimport';
+like $@, qr{IndirectNestedUnimport.pm did not return a true value\b}, 'use: indirect nested unimport works';
+
+# post-unimport sanity-check
+eval 'use Ugly';
+is $@, '', 'use: Ugly using true';
+is Ugly::Ugly(), 'Ugly', 'use: Ugly loaded OK';
View
0  t/02_use.t → t/use.t
File renamed without changes
View
0  t/04_use_subclass.t → t/use_subclass.t
File renamed without changes
View
20 true.xs
@@ -14,7 +14,7 @@
#define CxOLD_OP_TYPE(cx) (cx->blk_eval.old_op_type)
#endif
-STATIC char * currently_compiling_file(pTHX);
+STATIC char * true_ccfile(pTHX);
STATIC hook_op_check_id TRUE_CHECK_LEAVEEVAL_ID = 0;
STATIC HV * TRUE_HASH = NULL;
STATIC OPAnnotationGroup TRUE_ANNOTATIONS = NULL;
@@ -25,7 +25,7 @@ STATIC U32 true_enabled(pTHX_ const char *filename);
STATIC void true_leave(pTHX);
STATIC void true_unregister(pTHX_ const char *filename);
-STATIC char * currently_compiling_file(pTHX) {
+STATIC char * true_ccfile(pTHX) {
return CopFILE(&PL_compiling);
}
@@ -45,15 +45,17 @@ STATIC U32 true_enabled(pTHX_ const char * const filename) {
}
STATIC void true_unregister(pTHX_ const char *filename) {
+ /* warn("deleting %s\n", filename); */
(void)hv_delete(TRUE_HASH, filename, (I32)strlen(filename), G_DISCARD);
if (HvKEYS(TRUE_HASH) == 0) {
+ /* warn("hash is empty: disabling true\n"); */
true_leave(aTHX);
}
}
STATIC OP * true_check_leaveeval(pTHX_ OP * o, void * user_data) {
- char * ccfile = currently_compiling_file(aTHX);
+ char * ccfile = true_ccfile(aTHX);
PERL_UNUSED_VAR(user_data);
if (true_enabled(aTHX_ ccfile)) {
@@ -69,16 +71,19 @@ STATIC OP * true_leaveeval(pTHX) {
const PERL_CONTEXT * cx;
SV ** newsp;
OPAnnotation * annotation = op_annotation_get(TRUE_ANNOTATIONS, PL_op);
+ const char *filename = annotation->data;
cx = &cxstack[cxstack_ix];
newsp = PL_stack_base + cx->blk_oldsp;
- if (CxOLD_OP_TYPE(cx) == OP_REQUIRE) {
+ /* make sure it hasn't been unimported */
+ if ((CxOLD_OP_TYPE(cx) == OP_REQUIRE) && true_enabled(aTHX_ filename)) {
if (!(cx->blk_gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp)) {
XPUSHs(&PL_sv_yes);
PUTBACK;
}
- true_unregister(aTHX_ annotation->data);
+ /* warn("executed leaveeval for %s\n", filename); */
+ true_unregister(aTHX_ filename);
}
return CALL_FPTR(annotation->op_ppaddr)(aTHX);
@@ -104,9 +109,8 @@ void
xs_enter()
PROTOTYPE:
CODE:
- if (TRUE_COMPILING != 0) {
- croak("true: scope overflow");
- } else {
+ /* don't hook OP_LEAVEEVAL if it's already been hooked */
+ if (TRUE_COMPILING == 0) {
TRUE_COMPILING = 1;
TRUE_CHECK_LEAVEEVAL_ID = hook_op_check(OP_LEAVEEVAL, true_check_leaveeval, NULL);
}
Please sign in to comment.
Something went wrong with that request. Please try again.