X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FVariable%2FMagic.pm;h=fd2c0ef6b3b73e7b3f3e186626a9b1fe9c0f211a;hb=800e9f939f181af9766c3a3024ac9f57b9799510;hp=bdbb97e8acc365adb5144d31aa3a5e85009b36b9;hpb=ace906d7e76ed647adbd1ab1243ac9bdbde9b1d5;p=perl%2Fmodules%2FVariable-Magic.git diff --git a/lib/Variable/Magic.pm b/lib/Variable/Magic.pm index bdbb97e..fd2c0ef 100644 --- a/lib/Variable/Magic.pm +++ b/lib/Variable/Magic.pm @@ -5,30 +5,30 @@ use 5.008; use strict; use warnings; -use Carp qw/croak/; - =head1 NAME Variable::Magic - Associate user-defined magic to variables from Perl. =head1 VERSION -Version 0.40 +Version 0.46 =cut our $VERSION; BEGIN { - $VERSION = '0.40'; + $VERSION = '0.46'; } =head1 SYNOPSIS - use Variable::Magic qw/wizard cast VMG_OP_INFO_NAME/; + use Variable::Magic qw; { # 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; @@ -36,15 +36,17 @@ BEGIN { } # "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'; - 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" } @@ -161,7 +163,7 @@ It is available on your perl iff C is true. =back -The following actions only apply to hashes and are available iff C is true. +The following actions only apply to hashes and are available iff L is true. They are referred to as C magics. =over 4 @@ -208,20 +210,24 @@ BEGIN { =head2 C - 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 : @@ -289,26 +295,41 @@ Note that C callbacks are I called during global destruction, as th 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 { - croak 'Wrong number of arguments for wizard()' if @_ % 2; + if (@_ % 2) { + require Carp; + Carp::croak('Wrong number of arguments for wizard()'); + } + my %opts = @_; - my @keys = qw/data op_info get set len clear free/; + + my @keys = qw; push @keys, 'copy' if MGf_COPY; push @keys, 'dup' if MGf_DUP; 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 if VMG_UVAR; + + my ($wiz, $err); + { + local $@; + $wiz = eval { _wizard(map $opts{$_}, @keys) }; + $err = $@; + } + if ($err) { $err =~ s/\sat\s+.*?\n//; - croak $err; + require Carp; + Carp::croak($err); } - return $ret; + + return $wiz; } =head2 C @@ -370,6 +391,8 @@ Evaluates to true iff the 'local' magic is available. =head2 C When this constant is true, you can use the C 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 @@ -392,6 +415,10 @@ True for perls that call 'clear' magic when undefining magical arrays. True for perls that don't call 'len' magic when taking the C of a magical scalar. +=head2 C + +True for perls that call 'get' magic for operations on globs. + =head2 C The perl patchlevel this module was built with, or C<0> for non-debugging perls. @@ -423,7 +450,7 @@ It is similar to using inside-out objects, but without the drawback of having to { package Magical::UserData; - use Variable::Magic qw/wizard cast getdata/; + use Variable::Magic qw; my $wiz = wizard data => sub { \$_[1] }; @@ -433,7 +460,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) - or die "Couldn't cast UserData magic onto the variable"; + or die "Couldn't cast UserData magic onto the variable"; } $$data; } @@ -558,21 +585,22 @@ All the constants are also only exported on request, either individually or by t =cut -use base qw/Exporter/; +use base qw; 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 ], + 'consts' => [ qw< + MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR + VMG_COMPAT_ARRAY_PUSH_NOLEN VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID + VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID + VMG_COMPAT_ARRAY_UNDEF_CLEAR + VMG_COMPAT_SCALAR_LENGTH_NOLEN + 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 ]; @@ -584,10 +612,15 @@ 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. +In order to define magic on hash members, you need at least L 5.10.0 (see L) + =head1 DEPENDENCIES L 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 (standard since perl 5), L (standard since perl 5.006). Copy tests need L (standard since perl 5.005) and L (since 5.002). @@ -624,7 +657,7 @@ Tests code coverage report is available at L