From: Vincent Pit Date: Sun, 29 Jun 2008 16:24:40 +0000 (+0200) Subject: Importing Variable-Magic-0.09.tar.gz X-Git-Tag: v0.09^0 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FVariable-Magic.git;a=commitdiff_plain;h=751094f5d7b43171afc7104e957ca7fe2d21eb34 Importing Variable-Magic-0.09.tar.gz --- diff --git a/Changes b/Changes index 7853cff..d60708c 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,22 @@ 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. diff --git a/MANIFEST b/MANIFEST index 276b668..a29ee25 100644 --- a/MANIFEST +++ b/MANIFEST @@ -13,6 +13,8 @@ t/10-simple.t 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 @@ -26,7 +28,8 @@ t/31-array.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 diff --git a/META.yml b/META.yml index bba7b30..a02573d 100644 --- a/META.yml +++ b/META.yml @@ -1,6 +1,6 @@ --- #YAML:1.0 name: Variable-Magic -version: 0.08 +version: 0.09 abstract: Associate user-defined magic to variables from Perl. license: perl author: diff --git a/Magic.xs b/Magic.xs index 2ae40a1..c81db04 100644 --- a/Magic.xs +++ b/Magic.xs @@ -296,15 +296,19 @@ STATIC UV vmg_dispell(pTHX_ SV *sv, U16 sig) { 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 */ } } } @@ -326,7 +330,10 @@ STATIC UV vmg_dispell(pTHX_ SV *sv, U16 sig) { /* 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; } @@ -818,7 +825,7 @@ CODE: } 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) diff --git a/README b/README index 0a385c1..5ca2936 100644 --- a/README +++ b/README @@ -2,7 +2,7 @@ NAME 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/; @@ -64,7 +64,7 @@ DESCRIPTION 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" @@ -201,7 +201,8 @@ FUNCTIONS 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; @@ -239,6 +240,15 @@ EXPORT "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. diff --git a/lib/Variable/Magic.pm b/lib/Variable/Magic.pm index f700d74..0ac5b52 100644 --- a/lib/Variable/Magic.pm +++ b/lib/Variable/Magic.pm @@ -13,13 +13,13 @@ Variable::Magic - Associate user-defined magic to variables from Perl. =head1 VERSION -Version 0.08 +Version 0.09 =cut our $VERSION; BEGIN { - $VERSION = '0.08'; + $VERSION = '0.09'; } =head1 SYNOPSIS @@ -75,7 +75,7 @@ When this magic is set on a variable, all subsequent localizations of the variab =back -The following actions only applies to hashes and are available iff C is true. They are referred to as C magics. +The following actions only apply to hashes and are available iff C is true. They are referred to as C magics. =over 4 @@ -244,7 +244,7 @@ This accessor returns the magic signature of this wizard. 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 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 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 callback of the wizard is safely ignored. # Casts $wiz onto $x. If $wiz isn't a signature, undef can't be returned. my $x; @@ -286,6 +286,12 @@ our %EXPORT_TAGS = ( 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 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 callback and cast it on itself, this destructor won't be called because the wizard will be destroyed first. + =head1 DEPENDENCIES L 5.7.3. diff --git a/t/11-multiple.t b/t/11-multiple.t index 0c8da39..fc68cf2 100644 --- a/t/11-multiple.t +++ b/t/11-multiple.t @@ -3,7 +3,7 @@ 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/; @@ -131,41 +131,3 @@ SKIP: { 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'); -} diff --git a/t/14-self.t b/t/14-self.t new file mode 100644 index 0000000..6f6d9a4 --- /dev/null +++ b/t/14-self.t @@ -0,0 +1,53 @@ +#!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'); diff --git a/t/15-huf.t b/t/15-huf.t new file mode 100644 index 0000000..7d28277 --- /dev/null +++ b/t/15-huf.t @@ -0,0 +1,51 @@ +#!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'); diff --git a/t/90-boilerplate.t b/t/90-boilerplate.t new file mode 100644 index 0000000..a421e46 --- /dev/null +++ b/t/90-boilerplate.t @@ -0,0 +1,49 @@ +#!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'); diff --git a/t/91-pod.t b/t/91-pod.t new file mode 100644 index 0000000..f1e1d3e --- /dev/null +++ b/t/91-pod.t @@ -0,0 +1,10 @@ +#!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(); diff --git a/t/92-pod-coverage.t b/t/92-pod-coverage.t new file mode 100644 index 0000000..d0b482d --- /dev/null +++ b/t/92-pod-coverage.t @@ -0,0 +1,10 @@ +#!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/^_/ ] } ); 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 $@;