Revision history for Variable-Magic
+0.09 2008-02-02 11:30 UTC
+ + Doc : Explicitely say that uvar callbacks are safely ignored for
+ non-hashes.
+ + Doc : Document caveats and fix the usual set of typos.
+ + Fix : vmg_dispell() didn't check if the ext magic were ours when
+ counting wizards that have uvar callbacks, resulting in a
+ possible memory misread.
+ + Fix : getdata() now returns directly the data object, and no longer a
+ copy. This caused a leak.
+ + Tst : Prefix author tests by 9*-.
+ + Tst : New optional author test : 95-portability-files.t, that uses
+ Test::Portability::Files when it's present.
+ + Tst : New test : 14-self.t, that tests application of magic on the
+ wizard itself.
+ + Tst : Move Hash::Util::FieldHash tests out of 11-multiple.t to
+ 15-huf.t.
+
0.08 2008-02-01 16:55 UTC
+ Add : copy magic for tied arrays/hashes.
+ Add : local magic.
t/11-multiple.t
t/12-data.t
t/13-sig.t
+t/14-self.t
+t/15-huf.t
t/20-get.t
t/21-set.t
t/22-len.t
t/32-hash.t
t/33-code.t
t/34-glob.t
-t/boilerplate.t
-t/kwalitee.t
-t/pod-coverage.t
-t/pod.t
+t/90-boilerplate.t
+t/91-pod.t
+t/92-pod-coverage.t
+t/95-portability-files.t
+t/99-kwalitee.t
--- #YAML:1.0
name: Variable-Magic
-version: 0.08
+version: 0.09
abstract: Associate user-defined magic to variables from Perl.
license: perl
author:
for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic) {
moremagic = mg->mg_moremagic;
if (mg->mg_type == PERL_MAGIC_ext) {
-#if VMG_UVAR
- MGWIZ *w = SV2MGWIZ(mg->mg_ptr);
- if (w->uvar) { ++uvars; }
-#endif /* VMG_UVAR */
if (mg->mg_private == sig) {
#if VMG_UVAR
- if (!w->uvar) { uvars = 0; } /* Short-circuit uvar deletion. */
+ /* If the current has no uvar, short-circuit uvar deletion. */
+ uvars = (SV2MGWIZ(mg->mg_ptr)->uvar) ? (uvars + 1) : 0;
#endif /* VMG_UVAR */
break;
+#if VMG_UVAR
+ } else if ((mg->mg_private >= SIG_MIN) &&
+ (mg->mg_private <= SIG_MAX) &&
+ SV2MGWIZ(mg->mg_ptr)->uvar) {
+ ++uvars;
+ /* We can't break here since we need to find the ext magic to delete. */
+#endif /* VMG_UVAR */
}
}
}
/* mg was the first ext magic in the chain that had uvar */
for (mg = moremagic; mg; mg = mg->mg_moremagic) {
- if ((mg->mg_type == PERL_MAGIC_ext) && SV2MGWIZ(mg->mg_ptr)->uvar) {
+ if ((mg->mg_type == PERL_MAGIC_ext) &&
+ (mg->mg_private >= SIG_MIN) &&
+ (mg->mg_private <= SIG_MAX) &&
+ SV2MGWIZ(mg->mg_ptr)->uvar) {
++uvars;
break;
}
}
data = vmg_data_get(SvRV(sv), sig);
if (!data) { XSRETURN_UNDEF; }
- ST(0) = newSVsv(data);
+ ST(0) = data;
XSRETURN(1);
SV *dispell(SV *sv, SV *wiz)
Variable::Magic - Associate user-defined magic to variables from Perl.
VERSION
- Version 0.08
+ Version 0.09
SYNOPSIS
use Variable::Magic qw/wizard cast dispell/;
of the variable will trigger the callback. It is available on your
perl iff "MGf_LOCAL" is true.
- The following actions only applies to hashes and are available iff
+ The following actions only apply to hashes and are available iff
"VMG_UVAR" is true. They are referred to as "uvar" magics.
"fetch"
magic is already present, 0 on error, and "undef" when no magic
corresponds to the given signature (in case $sig was supplied). All
extra arguments specified after $wiz are passed to the private data
- constructor.
+ constructor. If the variable isn't a hash, any "uvar" callback of the
+ wizard is safely ignored.
# Casts $wiz onto $x. If $wiz isn't a signature, undef can't be returned.
my $x;
"MGf_LOCAL" and "VMG_UVAR" are also only exported on request. They are
all exported by the tags ':consts' and ':all'.
+CAVEATS
+ If you store a magic object in the private data slot, the magic won't be
+ accessible by "getdata" since it's not copied by assignation. The only
+ way to address this would be to return a reference.
+
+ If you define a wizard with a "free" callback and cast it on itself,
+ this destructor won't be called because the wizard will be destroyed
+ first.
+
DEPENDENCIES
perl 5.7.3.
=head1 VERSION
-Version 0.08
+Version 0.09
=cut
our $VERSION;
BEGIN {
- $VERSION = '0.08';
+ $VERSION = '0.09';
}
=head1 SYNOPSIS
=back
-The following actions only applies to hashes and are available iff C<VMG_UVAR> is true. They are referred to as C<uvar> magics.
+The following actions only apply to hashes and are available iff C<VMG_UVAR> is true. They are referred to as C<uvar> magics.
=over 4
cast [$@%&*]var, [$wiz|$sig], ...
-This function associates C<$wiz> magic to the variable supplied, without overwriting any other kind of magic. You can also supply the numeric signature C<$sig> instead of C<$wiz>. It returns true on success or when C<$wiz> magic is already present, C<0> on error, and C<undef> when no magic corresponds to the given signature (in case C<$sig> was supplied). All extra arguments specified after C<$wiz> are passed to the private data constructor.
+This function associates C<$wiz> magic to the variable supplied, without overwriting any other kind of magic. You can also supply the numeric signature C<$sig> instead of C<$wiz>. It returns true on success or when C<$wiz> magic is already present, C<0> on error, and C<undef> when no magic corresponds to the given signature (in case C<$sig> was supplied). All extra arguments specified after C<$wiz> are passed to the private data constructor. If the variable isn't a hash, any C<uvar> callback of the wizard is safely ignored.
# Casts $wiz onto $x. If $wiz isn't a signature, undef can't be returned.
my $x;
our @EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
$EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
+=head1 CAVEATS
+
+If you store a magic object in the private data slot, the magic won't be accessible by L</getdata> since it's not copied by assignation. The only way to address this would be to return a reference.
+
+If you define a wizard with a C<free> callback and cast it on itself, this destructor won't be called because the wizard will be destroyed first.
+
=head1 DEPENDENCIES
L<perl> 5.7.3.
use strict;
use warnings;
-use Test::More tests => 33 + 24 + 12;
+use Test::More tests => 33 + 24;
use Variable::Magic qw/wizard cast dispell VMG_UVAR/;
ok(!$@, "dispell uvar magic 0 croaks ($@)");
ok($res, 'dispell uvar magic 0 invalid');
}
-
-SKIP: {
- eval "use Hash::Util::FieldHash qw/fieldhash/";
- skip 'Hash::Util::FieldHash required for testing uvar interaction', 12
- unless VMG_UVAR && !$@;
-
- fieldhash(my %h);
-
- bless \(my $obj = {}), 'Variable::Magic::Test::Mock';
- $h{$obj} = 5;
-
- my ($w, $c) = (undef, 0);
-
- eval { $w = wizard fetch => sub { ++$c }, store => sub { --$c } };
- ok(!$@, "wizard with uvar creation error ($@)");
- ok(defined $w, 'wizard with uvar is defined');
- ok(ref($w) eq 'SCALAR', 'wizard with uvar is a scalar ref');
-
- my $res = eval { cast %h, $w };
- ok(!$@, "cast uvar magic on fieldhash croaks ($@)");
- ok($res, 'cast uvar magic on fieldhash invalid');
-
- my $s = $h{$obj};
- ok($s == 5, 'fetch magic on fieldhash doesn\'t clobber');
- ok($c == 1, 'fetch magic on fieldhash');
-
- $h{$obj} = 7;
- ok($c == 0, 'store magic on fieldhash');
- ok($h{$obj} == 7, 'store magic on fieldhash doesn\'t clobber'); # $c == 1
-
- $res = eval { dispell %h, $w };
- ok(!$@, "dispell uvar magic on fieldhash croaks ($@)");
- ok($res, 'dispell uvar magic on fieldhash invalid');
-
- $h{$obj} = 11;
- $s = $h{$obj};
- ok($s == 11, 'store/fetch on fieldhash after dispell still ok');
-}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 16;
+
+use Variable::Magic qw/wizard cast dispell getdata getsig/;
+
+my $c = 0;
+
+{
+ my $wiz = eval {
+ wizard data => sub { $_[0] },
+ get => sub { ++$c },
+ free => sub { --$c }
+ };
+ ok(!$@, "wizard creation error ($@)");
+ ok(defined $wiz, 'wizard is defined');
+ ok(ref $wiz eq 'SCALAR', 'wizard is a scalar ref');
+
+ my $res = eval { cast $wiz, $wiz };
+ ok(!$@, "cast on self croaks ($@)");
+ ok($res, 'cast on self invalid');
+
+ my $w = $wiz;
+ ok($c == 1, 'magic works correctly on self');
+
+ $res = eval { dispell $wiz, $wiz };
+ ok(!$@, "dispell on self croaks ($@)");
+ ok($res, 'dispell on self invalid');
+
+ $w = $wiz;
+ ok($c == 1, 'magic is no longer invoked on self when dispelled');
+
+ $res = eval { cast $wiz, $wiz, $wiz };
+ ok(!$@, "re-cast on self croaks ($@)");
+ ok($res, 're-cast on self invalid');
+
+ $w = getdata $wiz, $wiz;
+ ok($c == 1, 'getdata on magical self doesn\'t trigger callbacks');
+ # ok(getsig($w) == getsig($wiz), 'getdata returns the correct wizard');
+
+ $res = eval { dispell $wiz, $wiz };
+ ok(!$@, "re-dispell on self croaks ($@)");
+ ok($res, 're-dispell on self invalid');
+
+ $res = eval { cast $wiz, $wiz };
+ ok(!$@, "re-re-cast on self croaks ($@)");
+ ok($res, 're-re-cast on self invalid');
+}
+
+# ok($c == 0, 'magic destructor is called');
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More;
+
+use Variable::Magic qw/wizard cast dispell VMG_UVAR/;
+
+if (!VMG_UVAR) {
+ plan skip_all => 'No nice uvar magic for this perl';
+}
+
+eval "use Hash::Util::FieldHash qw/fieldhash/";
+if ($@) {
+ plan skip_all => 'Hash::Util::FieldHash required for testing uvar interaction';
+} else {
+ plan tests => 12;
+}
+
+fieldhash(my %h);
+
+bless \(my $obj = {}), 'Variable::Magic::Test::Mock';
+$h{$obj} = 5;
+
+my ($w, $c) = (undef, 0);
+
+eval { $w = wizard fetch => sub { ++$c }, store => sub { --$c } };
+ok(!$@, "wizard with uvar creation error ($@)");
+ok(defined $w, 'wizard with uvar is defined');
+ok(ref($w) eq 'SCALAR', 'wizard with uvar is a scalar ref');
+
+my $res = eval { cast %h, $w };
+ok(!$@, "cast uvar magic on fieldhash croaks ($@)");
+ok($res, 'cast uvar magic on fieldhash invalid');
+
+my $s = $h{$obj};
+ok($s == 5, 'fetch magic on fieldhash doesn\'t clobber');
+ok($c == 1, 'fetch magic on fieldhash');
+
+$h{$obj} = 7;
+ok($c == 0, 'store magic on fieldhash');
+ok($h{$obj} == 7, 'store magic on fieldhash doesn\'t clobber'); # $c == 1
+
+$res = eval { dispell %h, $w };
+ok(!$@, "dispell uvar magic on fieldhash croaks ($@)");
+ok($res, 'dispell uvar magic on fieldhash invalid');
+
+$h{$obj} = 11;
+$s = $h{$obj};
+ok($s == 11, 'store/fetch on fieldhash after dispell still ok');
--- /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");
+ }
+}
+
+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)
+);
+
+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]/,
+ );
+}
+
+module_boilerplate_ok('lib/Variable/Magic.pm');
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More;
+
+eval "use Test::Pod 1.14";
+plan skip_all => "Test::Pod 1.14 required for testing POD" if $@;
+all_pod_files_ok();
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More;
+
+eval "use Test::Pod::Coverage 1.04";
+plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@;
+all_pod_coverage_ok( { also_private => [ qr/^_/ ] } );
--- /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 $@;
projects / perl / modules / Variable-Magic.git / commitdiff