Test 'delete' uvar magic and introduce VMG_COMPAT_HASH_DELETE_NOUVAR_VOID

[perl/modules/Variable-Magic.git] / lib / Variable / Magic.pm

diff --git a/lib/Variable/Magic.pm b/lib/Variable/Magic.pm
index d792a8abd139ae74333117f5de875fd5cafb9598..ebfbc7c2a621cf91853dc8e09b7f68b1f9ca2673 100644 (file)
--- a/lib/Variable/Magic.pm
+++ b/lib/Variable/Magic.pm
@@ -5,30 +5,30 @@ use 5.008;
 use strict;
 use warnings;
 
 use strict;
 use warnings;
 

-use Carp qw/croak/;
-

 =head1 NAME
 
 Variable::Magic - Associate user-defined magic to variables from Perl.
 
 =head1 VERSION
 
 =head1 NAME
 
 Variable::Magic - Associate user-defined magic to variables from Perl.
 
 =head1 VERSION
 

-Version 0.42
+Version 0.46

 
 =cut
 
 our $VERSION;
 BEGIN {
 
 =cut
 
 our $VERSION;
 BEGIN {

- $VERSION = '0.42';
+ $VERSION = '0.46';

 }
 
 =head1 SYNOPSIS
 
 }
 
 =head1 SYNOPSIS
 

-    use Variable::Magic qw/wizard cast VMG_OP_INFO_NAME/;
+    use Variable::Magic qw<wizard cast VMG_OP_INFO_NAME>;

 
     { # A variable tracer
 
     { # A variable tracer

-     my $wiz = wizard set  => sub { print "now set to ${$_[0]}!\n" },
-                      free => sub { print "destroyed!\n" };
+     my $wiz = wizard(
+      set  => sub { print "now set to ${$_[0]}!\n" },
+      free => sub { print "destroyed!\n" },
+     );

 
      my $a = 1;
      cast $a, $wiz;
 
      my $a = 1;
      cast $a, $wiz;


@@ -36,15 +36,17 @@ BEGIN {
     }               # "destroyed!"
 
     { # A hash with a default value
     }               # "destroyed!"
 
     { # A hash with a default value

-     my $wiz = wizard data     => sub { $_[1] },
-                      fetch    => sub { $_[2] = $_[1] unless exists $_[0]->{$_[2]}; () },
-                      store    => sub { print "key $_[2] stored in $_[-1]\n" },
-                      copy_key => 1,
-                      op_info  => VMG_OP_INFO_NAME;
+     my $wiz = wizard(
+      data     => sub { $_[1] },
+      fetch    => sub { $_[2] = $_[1] unless exists $_[0]->{$_[2]}; () },
+      store    => sub { print "key $_[2] stored in $_[-1]\n" },
+      copy_key => 1,
+      op_info  => VMG_OP_INFO_NAME,
+     );

 
      my %h = (_default => 0, apple => 2);
      cast %h, $wiz, '_default';
 
      my %h = (_default => 0, apple => 2);
      cast %h, $wiz, '_default';

-     print $h{banana}, "\n"; # "0", because the 'banana' key doesn't exist in %h
+     print $h{banana}, "\n"; # "0" (there is no 'banana' key in %h)

      $h{pear} = 1;           # "key pear stored in helem"
     }
 
      $h{pear} = 1;           # "key pear stored in helem"
     }
 


@@ -161,7 +163,7 @@ It is available on your perl iff C<MGf_LOCAL> is true.
 
 =back
 
 
 =back
 

-The following actions only apply to hashes and are available iff C<VMG_UVAR> is true.
+The following actions only apply to hashes and are available iff L</VMG_UVAR> is true.

 They are referred to as C<uvar> magics.
 
 =over 4
 They are referred to as C<uvar> magics.
 
 =over 4


@@ -194,9 +196,6 @@ This last one triggers when a key is deleted in the hash, regardless of whether
 
 You can refer to the tests to have more insight of where the different magics are invoked.
 
 
 You can refer to the tests to have more insight of where the different magics are invoked.
 

-To prevent any clash between different magics defined with this module, an unique numerical signature is attached to each kind of magic (i.e. each set of callbacks for magic operations).
-At the C level, magic tokens owned by magic created by this module have their C<< mg->mg_private >> field set to C<0x3891> or C<0x3892>, so please don't use these magic (sic) numbers in other extensions.
-

 =head1 FUNCTIONS
 
 =cut
 =head1 FUNCTIONS
 
 =cut


@@ -208,20 +207,24 @@ BEGIN {
 
 =head2 C<wizard>
 
 
 =head2 C<wizard>
 

-    wizard data     => sub { ... },
-           get      => sub { my ($ref, $data [, $op]) = @_; ... },
-           set      => sub { my ($ref, $data [, $op]) = @_; ... },
-           len      => sub { my ($ref, $data, $len [, $op]) = @_; ... ; return $newlen; },
-           clear    => sub { my ($ref, $data [, $op]) = @_; ... },
-           free     => sub { my ($ref, $data [, $op]) = @_, ... },
-           copy     => sub { my ($ref, $data, $key, $elt [, $op]) = @_; ... },
-           local    => sub { my ($ref, $data [, $op]) = @_; ... },
-           fetch    => sub { my ($ref, $data, $key [, $op]) = @_; ... },
-           store    => sub { my ($ref, $data, $key [, $op]) = @_; ... },
-           exists   => sub { my ($ref, $data, $key [, $op]) = @_; ... },
-           delete   => sub { my ($ref, $data, $key [, $op]) = @_; ... },
-           copy_key => $bool,
-           op_info  => [ 0 | VMG_OP_INFO_NAME | VMG_OP_INFO_OBJECT ]
+    wizard(
+     data     => sub { ... },
+     get      => sub { my ($ref, $data [, $op]) = @_; ... },
+     set      => sub { my ($ref, $data [, $op]) = @_; ... },
+     len      => sub {
+      my ($ref, $data, $len [, $op]) = @_; ... ; return $newlen
+     },
+     clear    => sub { my ($ref, $data [, $op]) = @_; ... },
+     free     => sub { my ($ref, $data [, $op]) = @_, ... },
+     copy     => sub { my ($ref, $data, $key, $elt [, $op]) = @_; ... },
+     local    => sub { my ($ref, $data [, $op]) = @_; ... },
+     fetch    => sub { my ($ref, $data, $key [, $op]) = @_; ... },
+     store    => sub { my ($ref, $data, $key [, $op]) = @_; ... },
+     exists   => sub { my ($ref, $data, $key [, $op]) = @_; ... },
+     delete   => sub { my ($ref, $data, $key [, $op]) = @_; ... },
+     copy_key => $bool,
+     op_info  => [ 0 | VMG_OP_INFO_NAME | VMG_OP_INFO_OBJECT ],
+    )

 
 This function creates a 'wizard', an opaque type that holds the magic information.
 It takes a list of keys / values as argument, whose keys can be :
 
 This function creates a 'wizard', an opaque type that holds the magic information.
 It takes a list of keys / values as argument, whose keys can be :


@@ -289,26 +292,39 @@ Note that C<free> callbacks are I<never> called during global destruction, as th
 Here's a simple usage example :
 
     # A simple scalar tracer
 Here's a simple usage example :
 
     # A simple scalar tracer

-    my $wiz = wizard get  => sub { print STDERR "got ${$_[0]}\n" },
-                     set  => sub { print STDERR "set to ${$_[0]}\n" },
-                     free => sub { print STDERR "${$_[0]} was deleted\n" }
+    my $wiz = wizard(
+     get  => sub { print STDERR "got ${$_[0]}\n" },
+     set  => sub { print STDERR "set to ${$_[0]}\n" },
+     free => sub { print STDERR "${$_[0]} was deleted\n" },
+    );

 
 =cut
 
 sub wizard {
 
 =cut
 
 sub wizard {

- croak 'Wrong number of arguments for wizard()' if @_ % 2;
+ if (@_ % 2) {
+  require Carp;
+  Carp::croak('Wrong number of arguments for wizard()');
+ }
+

  my %opts = @_;
  my %opts = @_;

- my @keys = qw/data op_info get set len clear free/;
- push @keys, 'copy'  if MGf_COPY;
- push @keys, 'dup'   if MGf_DUP;
+
+ my @keys = qw<op_info data get set len clear free copy dup>;

  push @keys, 'local' if MGf_LOCAL;
  push @keys, 'local' if MGf_LOCAL;

- push @keys, qw/fetch store exists delete copy_key/ if VMG_UVAR;
- my $ret = eval { _wizard(map $opts{$_}, @keys) };
- if (my $err = $@) {
+ push @keys, qw<fetch store exists delete copy_key> if VMG_UVAR;
+
+ my ($wiz, $err);
+ {
+  local $@;
+  $wiz = eval { _wizard(map $opts{$_}, @keys) };
+  $err = $@;
+ }
+ if ($err) {

   $err =~ s/\sat\s+.*?\n//;
   $err =~ s/\sat\s+.*?\n//;

-  croak $err;
+  require Carp;
+  Carp::croak($err);

  }
  }

- return $ret;
+
+ return $wiz;

 }
 
 =head2 C<cast>
 }
 
 =head2 C<cast>


@@ -370,6 +386,12 @@ Evaluates to true iff the 'local' magic is available.
 =head2 C<VMG_UVAR>
 
 When this constant is true, you can use the C<fetch,store,exists,delete> callbacks on hashes.
 =head2 C<VMG_UVAR>
 
 When this constant is true, you can use the C<fetch,store,exists,delete> callbacks on hashes.

+Initial VMG_UVAR capability was introduced in perl 5.9.5, with a fully functional implementation
+shipped with perl 5.10.0.
+
+=head2 C<VMG_COMPAT_SCALAR_LENGTH_NOLEN>
+
+True for perls that don't call 'len' magic when taking the C<length> of a magical scalar.

 
 =head2 C<VMG_COMPAT_ARRAY_PUSH_NOLEN>
 
 
 =head2 C<VMG_COMPAT_ARRAY_PUSH_NOLEN>
 


@@ -388,9 +410,13 @@ True for perls that don't call 'len' magic when you unshift in void context an e
 
 True for perls that call 'clear' magic when undefining magical arrays.
 
 
 True for perls that call 'clear' magic when undefining magical arrays.
 

-=head2 C<VMG_COMPAT_SCALAR_LENGTH_NOLEN>
+=head2 C<VMG_COMPAT_HASH_DELETE_NOUVAR_VOID>

 
 

-True for perls that don't call 'len' magic when taking the C<length> of a magical scalar.
+True for perls that don't call 'delete' uvar magic when you delete an element from a hash in void context.
+
+=head2 C<VMG_COMPAT_GLOB_GET>
+
+True for perls that call 'get' magic for operations on globs.

 
 =head2 C<VMG_PERL_PATCHLEVEL>
 
 
 =head2 C<VMG_PERL_PATCHLEVEL>
 


@@ -423,7 +449,7 @@ It is similar to using inside-out objects, but without the drawback of having to
     {
      package Magical::UserData;
 
     {
      package Magical::UserData;
 

-     use Variable::Magic qw/wizard cast getdata/;
+     use Variable::Magic qw<wizard cast getdata>;

 
      my $wiz = wizard data => sub { \$_[1] };
 
 
      my $wiz = wizard data => sub { \$_[1] };
 


@@ -433,7 +459,7 @@ It is similar to using inside-out objects, but without the drawback of having to
       unless (defined $data) {
        $data = \(my $slot);
        &cast($var, $wiz, $slot)
       unless (defined $data) {
        $data = \(my $slot);
        &cast($var, $wiz, $slot)

-                        or die "Couldn't cast UserData magic onto the variable";
+                 or die "Couldn't cast UserData magic onto the variable";

       }
       $$data;
      }
       }
       $$data;
      }


@@ -558,21 +584,23 @@ All the constants are also only exported on request, either individually or by t
 
 =cut
 
 
 =cut
 

-use base qw/Exporter/;
+use base qw<Exporter>;

 
 our @EXPORT         = ();
 our %EXPORT_TAGS    = (
 
 our @EXPORT         = ();
 our %EXPORT_TAGS    = (

- 'funcs' =>  [ qw/wizard cast getdata dispell/ ],
- 'consts' => [
-               qw/MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR/,
-               qw/VMG_COMPAT_ARRAY_PUSH_NOLEN VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID/,
-               qw/VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID/,
-               qw/VMG_COMPAT_ARRAY_UNDEF_CLEAR/,
-               qw/VMG_COMPAT_SCALAR_LENGTH_NOLEN/,
-               qw/VMG_PERL_PATCHLEVEL/,
-               qw/VMG_THREADSAFE VMG_FORKSAFE/,
-               qw/VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT/
-             ]
+ 'funcs' =>  [ qw<wizard cast getdata dispell> ],
+ 'consts' => [ qw<
+   MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR
+   VMG_COMPAT_SCALAR_LENGTH_NOLEN
+   VMG_COMPAT_ARRAY_PUSH_NOLEN VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID
+   VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID
+   VMG_COMPAT_ARRAY_UNDEF_CLEAR
+   VMG_COMPAT_HASH_DELETE_NOUVAR_VOID
+   VMG_COMPAT_GLOB_GET
+   VMG_PERL_PATCHLEVEL
+   VMG_THREADSAFE VMG_FORKSAFE
+   VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT
+ > ],

 );
 our @EXPORT_OK      = map { @$_ } values %EXPORT_TAGS;
 $EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
 );
 our @EXPORT_OK      = map { @$_ } values %EXPORT_TAGS;
 $EXPORT_TAGS{'all'} = [ @EXPORT_OK ];


@@ -584,10 +612,15 @@ 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.
 
 
 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.
 

+In order to define magic on hash members, you need at least L<perl> 5.10.0 (see L</VMG_UVAR>)
+

 =head1 DEPENDENCIES
 
 L<perl> 5.8.
 
 =head1 DEPENDENCIES
 
 L<perl> 5.8.
 

+A C compiler.
+This module may happen to build with a C++ compiler as well, but don't rely on it, as no guarantee is made in this regard.
+

 L<Carp> (standard since perl 5), L<XSLoader> (standard since perl 5.006).
 
 Copy tests need L<Tie::Array> (standard since perl 5.005) and L<Tie::Hash> (since 5.002).
 L<Carp> (standard since perl 5), L<XSLoader> (standard since perl 5.006).
 
 Copy tests need L<Tie::Array> (standard since perl 5.005) and L<Tie::Hash> (since 5.002).


@@ -624,7 +657,7 @@ Tests code coverage report is available at L<http://www.profvince.com/perl/cover
 
 =head1 COPYRIGHT & LICENSE
 
 
 =head1 COPYRIGHT & LICENSE
 

-Copyright 2007,2008,2009,2010 Vincent Pit, all rights reserved.
+Copyright 2007,2008,2009,2010,2011 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.
 
 This program is free software; you can redistribute it and/or modify it
 under the same terms as Perl itself.