Variable-Magic-0.53/0000750000175000017500000000000012210676250013172 5ustar vincevinceVariable-Magic-0.53/lib/0000750000175000017500000000000012210676250013740 5ustar vincevinceVariable-Magic-0.53/lib/Variable/0000750000175000017500000000000012210676250015465 5ustar vincevinceVariable-Magic-0.53/lib/Variable/Magic.pm0000644000175000017500000005303312210676176017063 0ustar vincevincepackage Variable::Magic; use 5.008; use strict; use warnings; =head1 NAME Variable::Magic - Associate user-defined magic to variables from Perl. =head1 VERSION Version 0.53 =cut our $VERSION; BEGIN { $VERSION = '0.53'; } =head1 SYNOPSIS use Variable::Magic qw; { # A variable tracer my $wiz = wizard( set => sub { print "now set to ${$_[0]}!\n" }, free => sub { print "destroyed!\n" }, ); my $a = 1; cast $a, $wiz; $a = 2; # "now set to 2!" } # "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 %h = (_default => 0, apple => 2); cast %h, $wiz, '_default'; print $h{banana}, "\n"; # "0" (there is no 'banana' key in %h) $h{pear} = 1; # "key pear stored in helem" } =head1 DESCRIPTION Magic is Perl's way of enhancing variables. This mechanism lets the user add extra data to any variable and hook syntactical operations (such as access, assignment or destruction) that can be applied to it. With this module, you can add your own magic to any variable without having to write a single line of XS. You'll realize that these magic variables look a lot like tied variables. It is not surprising, as tied variables are implemented as a special kind of magic, just like any 'irregular' Perl variable : scalars like C<$!>, C<$(> or C<$^W>, the C<%ENV> and C<%SIG> hashes, the C<@ISA> array, C and C lvalues, L variables... They all share the same underlying C API, and this module gives you direct access to it. Still, the magic made available by this module differs from tieing and overloading in several ways : =over 4 =item * Magic is not copied on assignment. You attach it to variables, not values (as for blessed references). =item * Magic does not replace the original semantics. Magic callbacks usually get triggered before the original action takes place, and cannot prevent it from happening. This also makes catching individual events easier than with C, where you have to provide fallbacks methods for all actions by usually inheriting from the correct C class and overriding individual methods in your own class. =item * Magic is multivalued. You can safely apply different kinds of magics to the same variable, and each of them will be invoked successively. =item * Magic is type-agnostic. The same magic can be applied on scalars, arrays, hashes, subs or globs. But the same hook (see below for a list) may trigger differently depending on the type of the variable. =item * Magic is invisible at Perl level. Magical and non-magical variables cannot be distinguished with C, C or another trick. =item * Magic is notably faster. Mainly because perl's way of handling magic is lighter by nature, and because there is no need for any method resolution. Also, since you don't have to reimplement all the variable semantics, you only pay for what you actually use. =back The operations that can be overloaded are : =over 4 =item * I This magic is invoked when the variable is evaluated. It is never called for arrays and hashes. =item * I This magic is called each time the value of the variable changes. It is called for array subscripts and slices, but never for hashes. =item * I This magic only applies to arrays (though it used to also apply to scalars), and is triggered when the 'size' or the 'length' of the variable has to be known by Perl. This is typically the magic involved when an array is evaluated in scalar context, but also on array assignment and loops (C, C or C). The length is returned from the callback as an integer. Starting from perl 5.12, this magic is no longer called by the C keyword, and starting from perl 5.17.4 it is also no longer called for scalars in any situation, making this magic only meaningful on arrays. You can use the constants L and L to see if this magic is available for scalars or not. =item * I This magic is invoked when the variable is reset, such as when an array is emptied. Please note that this is different from undefining the variable, even though the magic is called when the clearing is a result of the undefine (e.g. for an array, but actually a bug prevent it to work before perl 5.9.5 - see the L). =item * I This magic is called when a variable is destroyed as the result of going out of scope (but not when it is undefined). It behaves roughly like Perl object destructors (i.e. C methods), except that exceptions thrown from inside a I callback will always be propagated to the surrounding code. =item * I This magic only applies to tied arrays and hashes, and fires when you try to access or change their elements. =item * I This magic is invoked when the variable is cloned across threads. It is currently not available. =item * I When this magic is set on a variable, all subsequent localizations of the variable will trigger the callback. It is available on your perl if and only if C is true. =back The following actions only apply to hashes and are available if and only if L is true. They are referred to as I magics. =over 4 =item * I This magic is invoked each time an element is fetched from the hash. =item * I This one is called when an element is stored into the hash. =item * I This magic fires when a key is tested for existence in the hash. =item * I This magic is triggered when a key is deleted in the hash, regardless of whether the key actually exists in it. =back You can refer to the tests to have more insight of where the different magics are invoked. =head1 FUNCTIONS =cut BEGIN { require XSLoader; XSLoader::load(__PACKAGE__, $VERSION); } =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 ], ) This function creates a 'wizard', an opaque object that holds the magic information. It takes a list of keys / values as argument, whose keys can be : =over 4 =item * C A code (or string) reference to a private data constructor. It is called in scalar context each time the magic is cast onto a variable, with C<$_[0]> being a reference to this variable and C<@_[1 .. @_-1]> being all extra arguments that were passed to L. The scalar returned from this call is then attached to the variable and can be retrieved later with L. =item * C, C, C, C, C, C, C, C, C, C and C Code (or string) references to the respective magic callbacks. You don't have to specify all of them : the magic corresponding to undefined entries will simply not be hooked. When those callbacks are executed, C<$_[0]> is a reference to the magic variable and C<$_[1]> is the associated private data (or C when no private data constructor is supplied with the wizard). Other arguments depend on which kind of magic is involved : =over 8 =item * I C<$_[2]> contains the natural, non-magical length of the variable (which can only be a scalar or an array as I magic is only relevant for these types). The callback is expected to return the new scalar or array length to use, or C to default to the normal length. =item * I C<$_[2]> is a either an alias or a copy of the current key, and C<$_[3]> is an alias to the current element (i.e. the value). Because C<$_[2]> might be a copy, it is useless to try to change it or cast magic on it. =item * I, I, I and I C<$_[2]> is an alias to the current key. Note that C<$_[2]> may rightfully be readonly if the key comes from a bareword, and as such it is unsafe to assign to it. You can ask for a copy instead by passing C<< copy_key => 1 >> to L which, at the price of a small performance hit, allows you to safely assign to C<$_[2]> in order to e.g. redirect the action to another key. =back Finally, if C<< op_info => $num >> is also passed to C, then one extra element is appended to C<@_>. Its nature depends on the value of C<$num> : =over 8 =item * C C<$_[-1]> is the current op name. =item * C C<$_[-1]> is the C object for the current op. =back Both result in a small performance hit, but just getting the name is lighter than getting the op object. These callbacks are executed in scalar context and are expected to return an integer, which is then passed straight to the perl magic API. However, only the return value of the I magic callback currently holds a meaning. =back Each callback can be specified as : =over 4 =item * a code reference, which will be called as a subroutine. =item * a string reference, where the string denotes which subroutine is to be called when magic is triggered. If the subroutine name is not fully qualified, then the current package at the time the magic is invoked will be used instead. =item * a reference to C, in which case a no-op magic callback is installed instead of the default one. This may especially be helpful for I magic, where an empty callback prevents magic from being copied during localization. =back Note that I magic is never called during global destruction, as there is no way to ensure that the wizard object and the callback were not destroyed before the variable. Here is 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" }, ); =cut sub wizard { if (@_ % 2) { require Carp; Carp::croak('Wrong number of arguments for wizard()'); } my %opts = @_; my @keys = qw; push @keys, 'local' if MGf_LOCAL; push @keys, qw if VMG_UVAR; my ($wiz, $err); { local $@; $wiz = eval { _wizard(map $opts{$_}, @keys) }; $err = $@; } if ($err) { $err =~ s/\sat\s+.*?\n//; require Carp; Carp::croak($err); } return $wiz; } =head2 C cast [$@%&*]var, $wiz, @args This function associates C<$wiz> magic to the supplied variable, without overwriting any other kind of magic. It returns true on success or when C<$wiz> magic is already attached, and croaks on error. When C<$wiz> provides a data constructor, it is called just before magic is cast onto the variable, and it receives a reference to the target variable in C<$_[0]> and the content of C<@args> in C<@_[1 .. @args]>. Otherwise, C<@args> is ignored. # Casts $wiz onto $x, passing (\$x, '1') to the data constructor. my $x; cast $x, $wiz, 1; The C argument can be an array or hash value. Magic for these scalars behaves like for any other, except that it is dispelled when the entry is deleted from the container. For example, if you want to call C each time the C<'TZ'> environment variable is changed in C<%ENV>, you can use : use POSIX; cast $ENV{TZ}, wizard set => sub { POSIX::tzset(); () }; If you want to handle the possible deletion of the C<'TZ'> entry, you must also specify I magic. =head2 C getdata [$@%&*]var, $wiz This accessor fetches the private data associated with the magic C<$wiz> in the variable. It croaks when C<$wiz> does not represent a valid magic object, and returns an empty list if no such magic is attached to the variable or when the wizard has no data constructor. # Get the data attached to $wiz in $x, or undef if $wiz # did not attach any. my $data = getdata $x, $wiz; =head2 C dispell [$@%&*]variable, $wiz The exact opposite of L : it dissociates C<$wiz> magic from the variable. This function returns true on success, C<0> when no magic represented by C<$wiz> could be found in the variable, and croaks if the supplied wizard is invalid. # Dispell now. die 'no such magic in $x' unless dispell $x, $wiz; =head1 CONSTANTS =head2 C Evaluates to true if and only if the I magic is available. This is the case for perl 5.7.3 and greater, which is ensured by the requirements of this module. =head2 C Evaluates to true if and only if the I magic is available. This is the case for perl 5.7.3 and greater, which is ensured by the requirements of this module. =head2 C Evaluates to true if and only if the I magic is available. This is the case for perl 5.9.3 and greater. =head2 C When this constant is true, you can use the I, I, I and I magics on hashes. Initial L capability was introduced in perl 5.9.5, with a fully functional implementation shipped with perl 5.10.0. =head2 C True for perls that don't call I magic when taking the C of a magical scalar. =head2 C True for perls that don't call I magic on scalars. Implies L. =head2 C True for perls that don't call I magic when you push an element in a magical array. Starting from perl 5.11.0, this only refers to pushes in non-void context and hence is false. =head2 C True for perls that don't call I magic when you push in void context an element in a magical array. =head2 C True for perls that don't call I magic when you unshift in void context an element in a magical array. =head2 C True for perls that call I magic when undefining magical arrays. =head2 C True for perls that don't call I magic when you delete an element from a hash in void context. =head2 C True for perls that call I magic for operations on globs. =head2 C The perl patchlevel this module was built with, or C<0> for non-debugging perls. =head2 C True if and only if this module could have been built with thread-safety features enabled. =head2 C True if and only if this module could have been built with fork-safety features enabled. This is always true except on Windows where it is false for perl 5.10.0 and below. =head2 C Value to pass with C to get the current op name in the magic callbacks. =head2 C Value to pass with C to get a C object representing the current op in the magic callbacks. =head1 COOKBOOK =head2 Associate an object to any perl variable This technique can be useful for passing user data through limited APIs. It is similar to using inside-out objects, but without the drawback of having to implement a complex destructor. { package Magical::UserData; use Variable::Magic qw; my $wiz = wizard data => sub { \$_[1] }; sub ud (\[$@%*&]) : lvalue { my ($var) = @_; my $data = &getdata($var, $wiz); unless (defined $data) { $data = \(my $slot); &cast($var, $wiz, $slot) or die "Couldn't cast UserData magic onto the variable"; } $$data; } } { BEGIN { *ud = \&Magical::UserData::ud } my $cb; $cb = sub { print 'Hello, ', ud(&$cb), "!\n" }; ud(&$cb) = 'world'; $cb->(); # Hello, world! } =head2 Recursively cast magic on datastructures C can be called from any magical callback, and in particular from C. This allows you to recursively cast magic on datastructures : my $wiz; $wiz = wizard data => sub { my ($var, $depth) = @_; $depth ||= 0; my $r = ref $var; if ($r eq 'ARRAY') { &cast((ref() ? $_ : \$_), $wiz, $depth + 1) for @$var; } elsif ($r eq 'HASH') { &cast((ref() ? $_ : \$_), $wiz, $depth + 1) for values %$var; } return $depth; }, free => sub { my ($var, $depth) = @_; my $r = ref $var; print "free $r at depth $depth\n"; (); }; { my %h = ( a => [ 1, 2 ], b => { c => 3 } ); cast %h, $wiz; } When C<%h> goes out of scope, this prints something among the lines of : free HASH at depth 0 free HASH at depth 1 free SCALAR at depth 2 free ARRAY at depth 1 free SCALAR at depth 3 free SCALAR at depth 3 Of course, this example does nothing with the values that are added after the C. =head1 PERL MAGIC HISTORY The places where magic is invoked have changed a bit through perl history. Here is a little list of the most recent ones. =over 4 =item * B<5.6.x> I : I and I magic. =item * B<5.8.9> I : Integration of I (see below). I : Integration of I (see below). =item * B<5.9.3> I : I magic is no longer called when pushing an element into a magic array. I : I magic. =item * B<5.9.5> I : Meaningful I magic. I : I magic was not invoked when undefining an array. The bug is fixed as of this version. =item * B<5.10.0> Since C is uppercased, C triggers I magic on hash stores for (non-tied) hashes that also have I magic. =item * B<5.11.x> I : I magic is no longer invoked when calling C with a magical scalar. I : I magic is no longer called when pushing / unshifting an element into a magical array in void context. The C part was already covered by I. I : I magic is called again when pushing into a magical array in non-void context. =back =head1 EXPORT The functions L, L, L and L are only exported on request. All of them are exported by the tags C<':funcs'> and C<':all'>. All the constants are also only exported on request, either individually or by the tags C<':consts'> and C<':all'>. =cut use base qw; our @EXPORT = (); our %EXPORT_TAGS = ( 'funcs' => [ qw ], 'consts' => [ qw< MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR VMG_COMPAT_SCALAR_LENGTH_NOLEN VMG_COMPAT_SCALAR_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 ]; =head1 CAVEATS In order to hook hash operations with magic, you need at least perl 5.10.0 (see L). If you want to store a magic object in the private data slot, you will not be able to recover the magic with L, since magic is not copied by assignment. You can work around this gotcha by storing a reference to the magic object instead. If you define a wizard with I magic and cast it on itself, it results in a memory cycle, so this destructor will not be called when the wizard is freed. =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 (core since perl 5), L (since 5.6.0). Copy tests need L (core since perl 5.005) and L (since 5.002). Some uvar tests need L (since 5.9.4). Glob tests need L (since 5.002). Threads tests need L and L (both since 5.7.3). =head1 SEE ALSO L and L for internal information about magic. L and L for other ways of enhancing objects. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Variable::Magic Tests code coverage report is available at L. =head1 COPYRIGHT & LICENSE Copyright 2007,2008,2009,2010,2011,2012,2013 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. =cut 1; # End of Variable::Magic Variable-Magic-0.53/t/0000750000175000017500000000000012210676250013435 5ustar vincevinceVariable-Magic-0.53/t/31-array.t0000644000175000017500000000550011652053015015163 0ustar vincevince#!perl -T use strict; use warnings; use Test::More tests => 2 * 27 + 13 + 1; use Variable::Magic qw< cast dispell VMG_COMPAT_ARRAY_PUSH_NOLEN VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID VMG_COMPAT_ARRAY_UNDEF_CLEAR >; use lib 't/lib'; use Variable::Magic::TestWatcher; my $wiz = init_watcher [ qw ], 'array'; my @n = map { int rand 1000 } 1 .. 5; my @a = @n; watch { cast @a, $wiz } { }, 'cast'; my $b = watch { $a[2] } { }, 'assign element to'; is $b, $n[2], 'array: assign element to correctly'; my @b = watch { @a } { len => 1 }, 'assign to'; is_deeply \@b, \@n, 'array: assign to correctly'; $b = watch { "X@{a}Y" } { len => 1 }, 'interpolate'; is $b, "X@{n}Y", 'array: interpolate correctly'; $b = watch { \@a } { }, 'reference'; @b = watch { @a[2 .. 4] } { }, 'slice'; is_deeply \@b, [ @n[2 .. 4] ], 'array: slice correctly'; watch { @a = qw } { set => 3, clear => 1 }, 'assign'; watch { $a[2] = 'c' } { }, 'assign old element'; watch { $a[4] = 'd' } { set => 1 }, 'assign new element'; $b = watch { exists $a[4] } { }, 'exists'; is $b, 1, 'array: exists correctly'; $b = watch { delete $a[4] } { set => 1 }, 'delete'; is $b, 'd', 'array: delete correctly'; $b = watch { @a } { len => 1 }, 'length @'; is $b, 3, 'array: length @ correctly'; # $b has to be set inside the block for the test to pass on 5.8.3 and lower watch { $b = $#a } { len => 1 }, 'length $#'; is $b, 2, 'array: length $# correctly'; watch { push @a, 'x'; () } # push looks at the static context { set => 1, (len => 1) x !VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID }, 'push (void)'; $b = watch { push @a, 'y' } { set => 1, (len => 1) x !VMG_COMPAT_ARRAY_PUSH_NOLEN }, 'push (scalar)'; is $b, 5, 'array: push (scalar) correctly'; $b = watch { pop @a } { set => 1, len => 1 }, 'pop'; is $b, 'y', 'array: pop correctly'; watch { unshift @a, 'z'; () } # unshift looks at the static context { set => 1, (len => 1) x !VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID }, 'unshift (void)'; $b = watch { unshift @a, 't' } { set => 1, len => 1 }, 'unshift (scalar)'; is $b, 6, 'unshift (scalar) correctly'; $b = watch { shift @a } { set => 1, len => 1 }, 'shift'; is $b, 't', 'array: shift correctly'; watch { my $i; @a = map ++$i, @a } { set => 5, len => 1, clear => 1}, 'map'; @b = watch { grep { $_ >= 4 } @a } { len => 1 }, 'grep'; is_deeply \@b, [ 4 .. 5 ], 'array: grep correctly'; watch { 1 for @a } { len => 5 + 1 }, 'for'; watch { my @b = @n; watch { cast @b, $wiz } { }, 'cast 2'; } { free => 1 }, 'scope end'; watch { undef @a } +{ (clear => 1) x VMG_COMPAT_ARRAY_UNDEF_CLEAR }, 'undef'; watch { dispell @a, $wiz } { }, 'dispell'; Variable-Magic-0.53/t/41-clone.t0000644000175000017500000000622111652012300015137 0ustar vincevince#!perl -T use strict; use warnings; use lib 't/lib'; use Variable::Magic::TestThreads; use Test::More 'no_plan'; use Variable::Magic qw< wizard cast dispell getdata VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT >; my $destroyed : shared = 0; my $c : shared = 0; sub spawn_wiz { my ($op_info) = @_; my $desc = "wizard with op_info $op_info in main thread"; local $@; my $wiz = eval { wizard( data => sub { $_[1] + threads->tid() }, get => sub { lock $c; ++$c; 0 }, set => sub { my $op = $_[-1]; my $tid = threads->tid(); if ($op_info == VMG_OP_INFO_OBJECT) { is_deeply { class => ref($op), name => $op->name }, { class => 'B::BINOP', name => 'sassign' }, "op object in thread $tid is correct"; } else { is $op, 'sassign', "op name in thread $tid is correct"; } return 0 }, free => sub { lock $destroyed; ++$destroyed; 0 }, op_info => $op_info, ); }; is $@, '', "$desc doesn't croak"; isnt $wiz, undef, "$desc is defined"; is $c, 0, "$desc doesn't trigger magic"; return $wiz; } sub try { my ($dispell, $wiz) = @_; my $tid = threads->tid; my $a = 3; { local $@; my $res = eval { cast $a, $wiz, sub { 5 }->() }; is $@, '', "cast in thread $tid doesn't croak"; } { local $@; my $b; eval { $b = $a }; is $@, '', "get in thread $tid doesn't croak"; is $b, 3, "get in thread $tid returns the right thing"; } { local $@; my $d = eval { getdata $a, $wiz }; is $@, '', "getdata in thread $tid doesn't croak"; is $d, 5 + $tid, "getdata in thread $tid returns the right thing"; } { local $@; eval { $a = 9 }; is $@, '', "set in thread $tid (check opname) doesn't croak"; } if ($dispell) { { local $@; my $res = eval { dispell $a, $wiz }; is $@, '', "dispell in thread $tid doesn't croak"; } { local $@; my $b; eval { $b = $a }; is $@, '', "get in thread $tid after dispell doesn't croak"; is $b, 9, "get in thread $tid after dispell returns the right thing"; } } return; } my $wiz_name = spawn_wiz VMG_OP_INFO_NAME; my $wiz_obj = spawn_wiz VMG_OP_INFO_OBJECT; for my $dispell (1, 0) { for my $wiz ($wiz_name, $wiz_obj) { { lock $c; $c = 0; } { lock $destroyed; $destroyed = 0; } my @threads = map spawn(\&try, $dispell, $wiz), 1 .. 2; $_->join for @threads; { lock $c; is $c, 2, "get triggered twice"; } { lock $destroyed; is $destroyed, (1 - $dispell) * 2, 'destructors'; } } } { my @threads; my $flag : shared = 0; my $destroyed; { my $wiz = wizard( set => sub { my $tid = threads->tid; pass "set callback called in thread $tid" }, free => sub { ++$destroyed }, ); my $var = 123; cast $var, $wiz; @threads = map spawn( sub { my $tid = threads->tid; my $exp = 456 + $tid; { lock $flag; threads::shared::cond_wait($flag) until $flag; } $var = $exp; is $var, $exp, "\$var could be assigned to in thread $tid"; } ), 1 .. 5; } is $destroyed, 1, 'wizard is destroyed'; { lock $flag; $flag = 1; threads::shared::cond_broadcast($flag); } $_->join for @threads; } Variable-Magic-0.53/t/27-local.t0000644000175000017500000000402611717504000015143 0ustar vincevince#!perl -T use strict; use warnings; use Test::More; use Variable::Magic qw; if (MGf_LOCAL) { plan tests => 2 * 3 + 1 + (2 + 2 * 7) + 1; } else { plan skip_all => 'No local magic for this perl'; } use lib 't/lib'; use Variable::Magic::TestWatcher; my $wiz = init_watcher 'local', 'local'; our $a = int rand 1000; my $res = watch { cast $a, $wiz } { }, 'cast'; ok $res, 'local: cast succeeded'; watch { local $a } { local => 1 }, 'localized'; { local $@; my $w1 = eval { wizard local => \undef, data => sub { 'w1' } }; is $@, '', 'local: noop wizard creation does not croak'; my $w2 = eval { wizard data => sub { 'w2' } }; is $@, '', 'local: dummy wizard creation does not croak'; { our $u; eval { cast $u, $w1 }; is $@, '', 'local: noop magic (first) cast does not croak'; is getdata($u, $w1), 'w1', 'local: noop magic (first) cast succeeded'; eval { cast $u, $w2 }; is $@, '', 'local: dummy magic (second) cast does not croak'; is getdata($u, $w2), 'w2', 'local: dummy magic (second) cast succeeded'; my ($z1, $z2); eval { local $u = ''; $z1 = getdata $u, $w1; $z2 = getdata $u, $w2; }; is $@, '', 'local: noop/dummy magic invocation does not croak'; is $z1, undef, 'local: noop magic (first) prevented magic copy'; is $z2, 'w2', 'local: dummy magic (second) was copied'; } { our $v; eval { cast $v, $w2 }; is $@, '', 'local: dummy magic (first) cast does not croak'; is getdata($v, $w2), 'w2', 'local: dummy magic (first) cast succeeded'; eval { cast $v, $w1 }; is $@, '', 'local: noop magic (second) cast does not croak'; is getdata($v, $w1), 'w1', 'local: noop magic (second) cast succeeded'; my ($z1, $z2); eval { local $v = ''; $z1 = getdata $v, $w1; $z2 = getdata $v, $w2; }; is $@, '', 'local: dummy/noop magic invocation does not croak'; is $z2, 'w2', 'local: dummy magic (first) was copied'; is $z1, undef, 'local: noop magic (second) prevented magic copy'; } } Variable-Magic-0.53/t/40-threads.t0000644000175000017500000000510511652012433015477 0ustar vincevince#!perl -T use strict; use warnings; use lib 't/lib'; use Variable::Magic::TestThreads; use Test::More 'no_plan'; use Variable::Magic qw< wizard cast dispell getdata VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT >; my $destroyed : shared = 0; sub try { my ($dispell, $op_info) = @_; my $tid = threads->tid; my $c = 0; my $wiz; { local $@; $wiz = eval { wizard( data => sub { $_[1] + $tid }, get => sub { ++$c; 0 }, set => sub { my $op = $_[-1]; if ($op_info == VMG_OP_INFO_OBJECT) { is_deeply { class => ref($op), name => $op->name }, { class => 'B::BINOP', name => 'sassign' }, "op object in thread $tid is correct"; } else { is $op, 'sassign', "op name in thread $tid is correct"; } return 0; }, free => sub { lock $destroyed; ++$destroyed; 0 }, op_info => $op_info, ); }; is $@, '', "wizard in thread $tid doesn't croak"; isnt $wiz, undef, "wizard in thread $tid is defined"; is $c, 0, "wizard in thread $tid doesn't trigger magic"; } my $a = 3; { local $@; my $res = eval { cast $a, $wiz, sub { 5 }->() }; is $@, '', "cast in thread $tid doesn't croak"; is $c, 0, "cast in thread $tid doesn't trigger magic"; } { local $@; my $b; eval { $b = $a }; is $@, '', "get in thread $tid doesn't croak"; is $b, 3, "get in thread $tid returns the right thing"; is $c, 1, "get in thread $tid triggers magic"; } { local $@; my $d = eval { getdata $a, $wiz }; is $@, '', "getdata in thread $tid doesn't croak"; is $d, 5 + $tid, "getdata in thread $tid returns the right thing"; is $c, 1, "getdata in thread $tid doesn't trigger magic"; } { local $@; eval { $a = 9 }; is $@, '', "set in thread $tid (check opname) doesn't croak"; } if ($dispell) { { local $@; my $res = eval { dispell $a, $wiz }; is $@, '', "dispell in thread $tid doesn't croak"; is $c, 1, "dispell in thread $tid doesn't trigger magic"; } { local $@; my $b; eval { $b = $a }; is $@, '', "get in thread $tid after dispell doesn't croak"; is $b, 9, "get in thread $tid after dispell returns the right thing"; is $c, 1, "get in thread $tid after dispell doesn't trigger magic"; } } return; # Ugly if not here } for my $dispell (1, 0) { { lock $destroyed; $destroyed = 0; } my @threads = map spawn(\&try, $dispell, $_), (VMG_OP_INFO_NAME) x 2, (VMG_OP_INFO_OBJECT) x 2; $_->join for @threads; { lock $destroyed; is $destroyed, (1 - $dispell) * 4, 'destructors'; } } Variable-Magic-0.53/t/lib/0000750000175000017500000000000012210676250014203 5ustar vincevinceVariable-Magic-0.53/t/lib/Variable/0000750000175000017500000000000012210676250015730 5ustar vincevinceVariable-Magic-0.53/t/lib/Variable/Magic/0000750000175000017500000000000012210676250016750 5ustar vincevinceVariable-Magic-0.53/t/lib/Variable/Magic/TestThreads.pm0000644000175000017500000000230012153113706021536 0ustar vincevincepackage Variable::Magic::TestThreads; use strict; use warnings; use Config qw<%Config>; use Variable::Magic qw; use VPIT::TestHelpers; sub diag { require Test::More; Test::More::diag($_) for @_; } sub import { shift; skip_all 'This Variable::Magic isn\'t thread safe' unless VMG_THREADSAFE; my $force = $ENV{PERL_VARIABLE_MAGIC_TEST_THREADS} ? 1 : !1; skip_all 'This perl wasn\'t built to support threads' unless $Config{useithreads}; skip_all 'perl 5.13.4 required to test thread safety' unless $force or "$]" >= 5.013_004; load_or_skip_all('threads', $force ? '0' : '1.67', [ ]); load_or_skip_all('threads::shared', $force ? '0' : '1.14', [ ]); my %exports = ( spawn => \&spawn, ); my $pkg = caller; while (my ($name, $code) = each %exports) { no strict 'refs'; *{$pkg.'::'.$name} = $code; } } sub spawn { local $@; my @diag; my $thread = eval { local $SIG{__WARN__} = sub { push @diag, "Thread creation warning: @_" }; threads->create(@_); }; push @diag, "Thread creation error: $@" if $@; diag(@diag) if @diag; return $thread ? $thread : (); } 1; Variable-Magic-0.53/t/lib/Variable/Magic/TestGlobalDestruction.pm0000644000175000017500000000210011771706730023600 0ustar vincevincepackage Variable::Magic::TestGlobalDestruction; use strict; use warnings; # Silence possible 'used only once' warnings from Test::Builder our $TODO; local $TODO; sub _diag { require Test::More; Test::More::diag(@_); } sub import { shift; my %args = @_; my $level = $args{level} || 1; my $env_level = int($ENV{PERL_DESTRUCT_LEVEL} || 0); if ($env_level >= $level) { my $is_debugging = do { local $@; eval { require Config; grep /-DDEBUGGING\b/, @Config::Config{qw}; } }; require Test::More; if ($is_debugging) { _diag("Global destruction level $env_level set by PERL_DESTRUCT_LEVEL (debugging perl)"); return; } else { _diag("PERL_DESTRUCT_LEVEL is set to $env_level, but this perl doesn't seem to have debugging enabled"); } } my $has_perl_destruct_level = do { local $@; eval { require Perl::Destruct::Level; Perl::Destruct::Level->import(level => $level); 1; } }; if ($has_perl_destruct_level) { _diag("Global destruction level $level set by Perl::Destruct::Level"); return; } } 1; Variable-Magic-0.53/t/lib/Variable/Magic/TestWatcher.pm0000644000175000017500000000316011717277114021557 0ustar vincevincepackage Variable::Magic::TestWatcher; use strict; use warnings; use Test::More; use Carp qw; use Variable::Magic qw; use base qw; our @EXPORT = qw; sub _types { my $t = shift; return { } unless defined $t; return { '' => sub { +{ $t => 1 } }, 'ARRAY' => sub { my $h = { }; ++$h->{$_} for @$t; $h }, 'HASH' => sub { +{ map { $_ => $t->{$_} } grep $t->{$_}, keys %$t } } }->{ref $t}->(); } our ($wiz, $prefix, %mg); sub init_watcher ($;$) { croak 'can\'t initialize twice' if defined $wiz; my $types = _types shift; $prefix = (defined) ? "$_: " : '' for shift; local $@; %mg = (); $wiz = eval 'wizard ' . join(', ', map { "$_ => sub { \$mg{$_}++;" . ($_ eq 'len' ? '$_[2]' : '0') . '}' } keys %$types); is $@, '', $prefix . 'wizard() doesn\'t croak'; is_deeply \%mg, { }, $prefix . 'wizard() doesn\'t trigger magic'; return $wiz; } sub watch (&;$$) { my $code = shift; my $exp = _types shift; my $desc = shift; my $want = wantarray; my @ret; local %mg = (); local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1; local $@; if (not defined $want) { # void context eval { $code->() }; } elsif (not $want) { # scalar context $ret[0] = eval { $code->() }; } else { @ret = eval { $code->() }; } is $@, '', $prefix . $desc . ' doesn\'t croak'; is_deeply \%mg, $exp, $prefix . $desc . ' triggers magic correctly'; return $want ? @ret : $ret[0]; } our $mg_end; END { if (defined $wiz) { undef $wiz; $mg_end = { } unless defined $mg_end; is_deeply \%mg, $mg_end, $prefix . 'magic triggered at END time'; } } 1; Variable-Magic-0.53/t/lib/Variable/Magic/TestScopeEnd.pm0000644000175000017500000000050111630713431021645 0ustar vincevincepackage Variable::Magic::TestScopeEnd; use Test::More; use Variable::Magic qw; my $wiz; BEGIN { $wiz = wizard data => sub { $_[1] }, free => sub { $_[1]->(); () }; } sub hook (&) { $^H |= 0x020000; cast %^H, $wiz, shift; } BEGIN { hook { pass 'in hints hash destructor' }; die 'turnip'; } 1; Variable-Magic-0.53/t/lib/Variable/Magic/TestDestroyRequired.pm0000644000175000017500000000015611630713431023305 0ustar vincevincepackage Variable::Magic::TestDestroyRequired; use Variable::Magic; my $tag = Variable::Magic::wizard(); 1; Variable-Magic-0.53/t/lib/Variable/Magic/TestValue.pm0000644000175000017500000000227411630713431021232 0ustar vincevincepackage Variable::Magic::TestValue; use strict; use warnings; use Test::More; use Variable::Magic qw; use base qw; our @EXPORT = qw; our ($exp, $prefix, $desc); sub value_cb { my $data = $_[1]; return if $data->{guard}; local $data->{guard} = 1; local $Test::Builder::Level = ($Test::Builder::Level || 0) + 3; is_deeply $_[0], $exp, $desc; () } sub init_value (\[$@%&*]$;$) { my $type = $_[1]; $prefix = (defined) ? "$_: " : '' for $_[2]; my $wiz = eval "wizard data => sub { +{ guard => 0 } }, $type => \\&value_cb"; is $@, '', $prefix . 'wizard() doesn\'t croak'; eval { &cast($_[0], $wiz, $prefix) }; is $@, '', $prefix . 'cast() doesn\'t croak'; return $wiz; } sub value (&$;$) { my ($code, $_exp, $_desc) = @_; my $want = wantarray; $_desc = 'value' unless defined $desc; $_desc = $prefix . $_desc; my @ret; { local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1; local $exp = $_exp; local $desc = $_desc; if (defined $want and not $want) { # scalar context $ret[0] = eval { $code->() }; } else { @ret = eval { $code->() }; } is $@, '', $desc . ' doesn\'t croak'; } return $want ? @ret : $ret[0]; } 1; Variable-Magic-0.53/t/lib/VPIT/0000750000175000017500000000000012210676250014765 5ustar vincevinceVariable-Magic-0.53/t/lib/VPIT/TestHelpers.pm0000644000175000017500000000376712153113706017605 0ustar vincevincepackage VPIT::TestHelpers; use strict; use warnings; my %exports = ( load_or_skip => \&load_or_skip, load_or_skip_all => \&load_or_skip_all, skip_all => \&skip_all, ); sub import { my $pkg = caller; while (my ($name, $code) = each %exports) { no strict 'refs'; *{$pkg.'::'.$name} = $code; } } my $test_sub = sub { my $sub = shift; my $stash; if ($INC{'Test/Leaner.pm'}) { $stash = \%Test::Leaner::; } else { require Test::More; $stash = \%Test::More::; } my $glob = $stash->{$sub}; return $glob ? *$glob{CODE} : undef; }; sub skip { $test_sub->('skip')->(@_) } sub skip_all { $test_sub->('plan')->(skip_all => $_[0]) } sub diag { my $diag = $test_sub->('diag'); $diag->($_) for @_; } our $TODO; local $TODO; sub load { my ($pkg, $ver, $imports) = @_; my $spec = $ver && $ver !~ /^[0._]*$/ ? "$pkg $ver" : $pkg; my $err; local $@; if (eval "use $spec (); 1") { $ver = do { no strict 'refs'; ${"${pkg}::VERSION"} }; $ver = 'undef' unless defined $ver; if ($imports) { my @imports = @$imports; my $caller = (caller 1)[0]; local $@; my $res = eval <<"IMPORTER"; package $caller; BEGIN { \$pkg->import(\@imports) } 1; IMPORTER $err = "Could not import '@imports' from $pkg $ver: $@" unless $res; } } else { (my $file = "$pkg.pm") =~ s{::}{/}g; delete $INC{$file}; $err = "Could not load $spec"; } if ($err) { return wantarray ? (0, $err) : 0; } else { diag "Using $pkg $ver"; return 1; } } sub load_or_skip { my ($pkg, $ver, $imports, $tests) = @_; die 'You must specify how many tests to skip' unless defined $tests; my ($loaded, $err) = load($pkg, $ver, $imports); skip $err => $tests unless $loaded; return $loaded; } sub load_or_skip_all { my ($pkg, $ver, $imports) = @_; my ($loaded, $err) = load($pkg, $ver, $imports); skip_all $err unless $loaded; return $loaded; } package VPIT::TestHelpers::Guard; sub new { my ($class, $code) = @_; bless { code => $code }, $class; } sub DESTROY { $_[0]->{code}->() } 1; Variable-Magic-0.53/t/18-opinfo.t0000644000175000017500000001010011771431403015337 0ustar vincevince#!perl -T use strict; use warnings; use Test::More tests => 17 * (3 + 4) + 5 + 1; use Config qw<%Config>; use Variable::Magic qw; sub Variable::Magic::TestPkg::foo { } my $is_5130_release = ("$]" == 5.013 && !$Config{git_describe}) ? 1 : 0; my $aelem = "$]" <= 5.008_003 ? 'aelem' : ("$]" < 5.013 or $is_5130_release) ? 'aelemfast' : 'sassign'; my $aelemf = ("$]" < 5.013 or $is_5130_release) ? 'aelemfast' : 'sassign'; my $aelemf_op = $aelemf eq 'sassign' ? 'B::BINOP' : $Config{useithreads} ? 'B::PADOP' : 'B::SVOP'; our @o; my @tests = ( [ 'len', '@c', 'my @c', 'my $x = @c', [ 'padav', 'B::OP' ] ], [ 'get', '$c[0]', 'my @c', 'my $x = $c[0]', [ $aelem, 'B::OP' ] ], [ 'get', '$o[0]', 'local @o', 'my $x = $o[0]', [ $aelemf, $aelemf_op ] ], [ 'get', '$c', 'my $c = 1', '++$c', [ 'preinc', 'B::UNOP' ] ], [ 'get', '$c', 'my $c = 1', '$c ** 2', [ 'pow', 'B::BINOP' ] ], [ 'get', '$c', 'my $c = 1', 'my $x = $c', [ 'sassign', 'B::BINOP' ] ], [ 'get', '$c', 'my $c = 1', '1 if $c', [ 'and', 'B::LOGOP' ] ], [ 'get', '$c', 'my $c = []','ref $c', [ 'ref', 'B::UNOP' ] ], [ 'get', '$c', 'my $c = $0','-f $c', [ 'ftfile', 'B::UNOP' ] ], [ 'get', '$c', 'my $c = "Z"', 'my $i = 1; Z:goto $c if $i--', [ 'goto', 'B::UNOP' ] ], [ 'set', '$c', 'my $c = 1', 'bless \$c, "main"', [ 'bless', 'B::LISTOP' ] ], [ 'get', '$c', 'my $c = ""','$c =~ /x/', [ 'match', 'B::PMOP' ] ], [ 'get', '$c', 'my $c = "Variable::Magic::TestPkg"', '$c->foo()', [ 'method_named', 'B::SVOP' ] ], [ 'get', '$c', 'my $c = ""','$c =~ y/x/y/', [ 'trans', 'B::PVOP' ] ], [ 'get', '$c', 'my $c = 1', '1 for 1 .. $c', [ 'enteriter', 'B::LOOP' ] ], [ 'free','$c', 'my $c = 1', 'last', [ 'last', 'B::OP' ] ], [ 'free','$c', 'L:{my $c = 1', 'last L}', [ 'last', 'B::OP' ] ], ); our $done; for (@tests) { my ($key, $var, $init, $test, $exp) = @$_; for my $op_info (VMG_OP_INFO_NAME, VMG_OP_INFO_OBJECT) { my $wiz; # We must test for the $op correctness inside the callback because, if we # bring it out, it will go outside of the eval STRING scope, and what it # points to will no longer exist. eval { $wiz = wizard $key => sub { return if $done; my $op = $_[-1]; my $desc = "$key magic with op_info == $op_info"; if ($op_info == VMG_OP_INFO_NAME) { is $op, $exp->[0], "$desc gets the right op info"; } elsif ($op_info == VMG_OP_INFO_OBJECT) { isa_ok $op, $exp->[1], $desc; is $op->name, $exp->[0], "$desc gets the right op info"; } else { is $op, undef, "$desc gets the right op info"; } $done = 1; () }, op_info => $op_info }; is $@, '', "$key wizard with op_info == $op_info doesn't croak"; local $done = 0; my $testcase = "{ $init; cast $var, \$wiz; $test }"; eval $testcase; is $@, '', "$key magic with op_info == $op_info doesn't croak"; diag $testcase if $@; } } { my $c; my $wiz = eval { wizard get => sub { is $_[-1], undef, 'get magic with out of bounds op_info'; }, op_info => 3; }; is $@, '', "get wizard with out of bounds op_info doesn't croak"; eval { cast $c, $wiz }; is $@, '', "get cast with out of bounds op_info doesn't croak"; eval { my $x = $c }; is $@, '', "get magic with out of bounds op_info doesn't croak"; eval { dispell $c, $wiz }; is $@, '', "get dispell with out of bounds op_info doesn't croak"; } { local $@; my $wiz = eval { local $SIG{__WARN__} = sub { die @_ }; wizard op_info => "hlagh"; }; like $@, qr/^Argument "hlagh" isn't numeric in subroutine entry at \Q$0\E/, 'wizard(op_info => "text") throws numeric warnings'; } Variable-Magic-0.53/t/23-clear.t0000644000175000017500000000140211630713431015132 0ustar vincevince#!perl -T use strict; use warnings; use Test::More tests => (2 * 5 + 2) + (2 * 2 + 1) + 1; use Variable::Magic qw; use lib 't/lib'; use Variable::Magic::TestWatcher; use Variable::Magic::TestValue; my $wiz = init_watcher 'clear', 'clear'; my @a = qw; watch { cast @a, $wiz } { }, 'cast array'; watch { @a = () } { clear => 1 }, 'clear array'; is_deeply \@a, [ ], 'clear: clear array correctly'; my %h = (foo => 1, bar => 2); watch { cast %h, $wiz } { }, 'cast hash'; watch { %h = () } { clear => 1 }, 'clear hash'; is_deeply \%h, { }, 'clear: clear hash correctly'; { my @val = (4 .. 6); my $wv = init_value @val, 'clear', 'clear'; value { @val = () } [ 4 .. 6 ]; dispell @val, $wv; is_deeply \@val, [ ], 'clear: value after'; } Variable-Magic-0.53/t/24-free.t0000644000175000017500000000076311630713431014777 0ustar vincevince#!perl -T use strict; use warnings; use Test::More tests => 2 * 5 + 1; use Variable::Magic qw; use lib 't/lib'; use Variable::Magic::TestWatcher; my $wiz = init_watcher 'free', 'free'; my $n = int rand 1000; watch { my $a = $n; watch { cast $a, $wiz } { }, 'cast'; } { free => 1 }, 'deletion at the end of the scope'; my $a = $n; watch { cast $a, $wiz } { }, 'cast 2'; watch { undef $a } { }, 'explicit deletion with undef()'; $Variable::Magic::TestWatcher::mg_end = { free => 1 }; Variable-Magic-0.53/t/28-uvar.t0000644000175000017500000000761312153113706015040 0ustar vincevince#!perl -T use strict; use warnings; use Test::More; use lib 't/lib'; use VPIT::TestHelpers; use Variable::Magic qw; if (VMG_UVAR) { plan tests => 2 * 15 + 12 + 14 + (4 * 2 * 2 + 1 + 1) + 1; } else { plan skip_all => 'No nice uvar magic for this perl'; } use lib 't/lib'; use Variable::Magic::TestWatcher; use Variable::Magic::TestValue; my $wiz = init_watcher [ qw ], 'uvar'; my %h = (a => 1, b => 2, c => 3); my $res = watch { cast %h, $wiz } { }, 'cast'; ok $res, 'uvar: cast succeeded'; my $x = watch { $h{a} } { fetch => 1 }, 'fetch directly'; is $x, 1, 'uvar: fetch directly correctly'; $x = watch { "$h{b}" } { fetch => 1 }, 'fetch by interpolation'; is $x, 2, 'uvar: fetch by interpolation correctly'; watch { $h{c} = 4 } { store => 1 }, 'store directly'; $x = watch { $h{c} = 5 } { store => 1 }, 'fetch and store'; is $x, 5, 'uvar: fetch and store correctly'; $x = watch { exists $h{c} } { exists => 1 }, 'exists'; ok $x, 'uvar: exists correctly'; $x = watch { delete $h{c} } { delete => 1 }, 'delete existing key'; is $x, 5, 'uvar: delete existing key correctly'; $x = watch { delete $h{z} } { delete => 1 }, 'delete non-existing key'; ok !defined $x, 'uvar: delete non-existing key correctly'; my $wiz2 = wizard get => sub { 0 }; cast %h, $wiz2; $x = watch { $h{a} } { fetch => 1 }, 'fetch directly with also non uvar magic'; is $x, 1, 'uvar: fetch directly with also non uvar magic correctly'; SKIP: { load_or_skip('Tie::Hash', undef, undef, 2 * 5 + 4); tie my %h, 'Tie::StdHash'; %h = (x => 7, y => 8); $res = watch { cast %h, $wiz } { }, 'cast on tied hash'; ok $res, 'uvar: cast on tied hash succeeded'; $x = watch { $h{x} } { fetch => 1 }, 'fetch on tied hash'; is $x, 7, 'uvar: fetch on tied hash succeeded'; watch { $h{x} = 9 } { store => 1 }, 'store on tied hash'; $x = watch { exists $h{x} } { exists => 1 }, 'exists on tied hash'; ok $x, 'uvar: exists on tied hash succeeded'; $x = watch { delete $h{x} } { delete => 1 }, 'delete on tied hash'; is $x, 9, 'uvar: delete on tied hash succeeded'; } $wiz2 = wizard fetch => sub { 0 }; my %h2 = (a => 37, b => 2, c => 3); cast %h2, $wiz2; $x = eval { local $SIG{__WARN__} = sub { die }; $h2{a}; }; is $@, '', 'uvar: fetch with incomplete magic doesn\'t croak'; is $x, 37, 'uvar: fetch with incomplete magic correctly'; eval { local $SIG{__WARN__} = sub { die }; $h2{a} = 73; }; is $@, '', 'uvar: store with incomplete magic doesn\'t croak'; is $h2{a}, 73, 'uvar: store with incomplete magic correctly'; my $wiz3 = wizard store => sub { ++$_[2]; 0 }, copy_key => 1; my %h3 = (a => 3); cast %h3, $wiz3; for my $i (1 .. 2) { my $key = 'a'; eval { $h3{$key} = 3 + $i }; is $@, '', "uvar: change key in store doesn't croak ($i)"; is $key, 'a', "uvar: change key didn't clobber \$key ($i)"; is_deeply \%h3, { a => 3, b => 3 + $i }, "uvar: change key in store correcty ($i)"; } for my $i (1 .. 2) { eval { $h3{b} = 5 + $i }; is $@, '', "uvar: change readonly key in store doesn't croak ($i)"; is_deeply \%h3, { a => 3, b => 5, c => 5 + $i }, "uvar: change readonly key in store correcty ($i)"; } { my %val = (apple => 1); init_value %val, 'fetch', 'uvar'; value { my $x = $val{apple} } { apple => 1 }, 'value store'; } { my %val = (apple => 1); my $wv = init_value %val, 'store', 'uvar'; value { $val{apple} = 2 } { apple => 1 }, 'value store'; dispell %val, $wv; is_deeply \%val, { apple => 2 }, 'uvar: value after store'; } { my %val = (apple => 1); init_value %val, 'exists', 'uvar'; value { my $x = exists $val{apple} } { apple => 1 }, 'value exists'; } { my %val = (apple => 1, banana => 2); my $wv = init_value %val, 'delete', 'uvar'; value { delete $val{apple} } { apple => 1, banana => 2 }, 'value delete'; dispell %val, $wv; is_deeply \%val, { banana => 2 }, 'uvar: value after delete'; } Variable-Magic-0.53/t/00-load.t0000644000175000017500000000064312207502470014764 0ustar vincevince#!perl -T use strict; use warnings; use Test::More tests => 1; BEGIN { use_ok( 'Variable::Magic' ); } my $p = Variable::Magic::VMG_PERL_PATCHLEVEL; $p = $p ? 'patchlevel ' . $p : 'no patchlevel'; diag( "Testing Variable::Magic $Variable::Magic::VERSION, Perl $] ($p), $^X" ); if (eval { require ActivePerl; 1 } and defined &ActivePerl::BUILD) { diag "This is ActiveState Perl $] build " . ActivePerl::BUILD(); } Variable-Magic-0.53/t/22-len.t0000644000175000017500000001260312153113706014626 0ustar vincevince#!perl -T use strict; use warnings; use Test::More tests => 39 + (2 * 2 + 1) + (5 + 2 * 3); use Variable::Magic qw< wizard cast dispell VMG_COMPAT_SCALAR_LENGTH_NOLEN VMG_COMPAT_SCALAR_NOLEN >; use lib 't/lib'; use Variable::Magic::TestValue; my $c = 0; my $n = 1 + int rand 1000; my $d; my $wiz = wizard len => sub { $d = $_[2]; ++$c; return $n }; is $c, 0, 'len: wizard() doesn\'t trigger magic'; my @a = qw; $c = 0; cast @a, $wiz; is $c, 0, 'len: cast on array doesn\'t trigger magic'; $c = 0; $d = undef; my $b = scalar @a; is $c, 1, 'len: get array length triggers magic correctly'; is $d, 3, 'len: get array length have correct default length'; is $b, $n, 'len: get array length correctly'; $c = 0; $d = undef; $b = $#a; is $c, 1, 'len: get last array index triggers magic correctly'; is $d, 3, 'len: get last array index have correct default length'; is $b, $n - 1, 'len: get last array index correctly'; $n = 0; $c = 0; $d = undef; $b = scalar @a; is $c, 1, 'len: get array length 0 triggers magic correctly'; is $d, 3, 'len: get array length 0 have correct default length'; is $b, 0, 'len: get array length 0 correctly'; $n = undef; @a = (); cast @a, $wiz; $c = 0; $d = undef; $b = scalar @a; is $c, 1, 'len: get empty array length triggers magic correctly'; is $d, 0, 'len: get empty array length have correct default length'; is $b, 0, 'len: get empty array length correctly'; $c = 0; $d = undef; $b = $#a; is $c, 1, 'len: get last empty array index triggers magic correctly'; is $d, 0, 'len: get last empty array index have correct default length'; is $b, -1, 'len: get last empty array index correctly'; SKIP: { skip 'len magic is no longer called for scalars' => 16 + 6 if VMG_COMPAT_SCALAR_NOLEN; SKIP: { skip 'length() no longer calls len magic on plain scalars' => 16 if VMG_COMPAT_SCALAR_LENGTH_NOLEN; $c = 0; $n = 1 + int rand 1000; # length magic on scalars needs also get magic to be triggered. my $wiz = wizard get => sub { return 'anything' }, len => sub { $d = $_[2]; ++$c; return $n }; my $x = 6789; $c = 0; cast $x, $wiz; is $c, 0, 'len: cast on scalar doesn\'t trigger magic'; $c = 0; $d = undef; $b = length $x; is $c, 1, 'len: get scalar length triggers magic correctly'; is $d, 4, 'len: get scalar length have correct default length'; is $b, $n, 'len: get scalar length correctly'; $n = 0; $c = 0; $d = undef; $b = length $x; is $c, 1, 'len: get scalar length 0 triggers magic correctly'; is $d, 4, 'len: get scalar length 0 have correct default length'; is $b, $n, 'len: get scalar length 0 correctly'; $n = undef; $x = ''; cast $x, $wiz; $c = 0; $d = undef; $b = length $x; is $c, 1, 'len: get empty scalar length triggers magic correctly'; is $d, 0, 'len: get empty scalar length have correct default length'; is $b, 0, 'len: get empty scalar length correctly'; $x = "\x{20AB}ongs"; cast $x, $wiz; { use bytes; $c = 0; $d = undef; $b = length $x; is $c, 1, 'len: get utf8 scalar length in bytes triggers magic correctly'; is $d, 7, 'len: get utf8 scalar length in bytes have correct default length'; is $b, $d,'len: get utf8 scalar length in bytes correctly'; } $c = 0; $d = undef; $b = length $x; is $c, 1, 'len: get utf8 scalar length triggers magic correctly'; is $d, 5, 'len: get utf8 scalar length have correct default length'; is $b, $d, 'len: get utf8 scalar length correctly'; } { our $c; # length magic on scalars needs also get magic to be triggered. my $wiz = wizard get => sub { 0 }, len => sub { $d = $_[2]; ++$c; return $_[2] }; { my $x = "banana"; cast $x, $wiz; local $c = 0; pos($x) = 2; is $c, 1, 'len: pos scalar triggers magic correctly'; is $d, 6, 'len: pos scalar have correct default length'; is $x, 'banana', 'len: pos scalar works correctly' } { my $x = "hl\x{20AB}gh"; # Force utf8 on string cast $x, $wiz; local $c = 0; substr($x, 2, 1) = 'a'; is $c, 1, 'len: substr utf8 scalar triggers magic correctly'; is $d, 5, 'len: substr utf8 scalar have correct default length'; is $x, 'hlagh', 'len: substr utf8 scalar correctly'; } } } { my @val = (4 .. 6); my $wv = init_value @val, 'len', 'len'; value { $val[-1] = 8 } [ 4, 5, 6 ]; dispell @val, $wv; is_deeply \@val, [ 4, 5, 8 ], 'len: after value'; } { local $@; my $wua = eval { wizard len => \undef }; is $@, '', 'len: noop wizard (for arrays) creation does not croak'; my @a = ('a' .. 'z'); eval { cast @a, $wua }; is $@, '', 'len: noop wizard (for arrays) cast does not croak'; my $l; eval { $l = $#a }; is $@, '', 'len: noop wizard (for arrays) invocation does not croak'; is $l, 25, 'len: noop magic on an array returns the previous length'; my $wus = eval { wizard get => \undef, len => \undef }; is $@, '', 'len: noop wizard (for strings) creation does not croak'; for ([ 'euro', 'string' ], [ "\x{20AC}uro", 'unicode string' ]) { my ($euro, $desc) = @$_; eval { cast $euro, $wus }; is $@, '', 'len: noop wizard (for strings) cast does not croak'; eval { pos($euro) = 2 }; is $@, '', 'len: noop wizard (for strings) invocation does not croak'; my ($rest) = ($euro =~ /(.*)/g); is $rest, 'ro', "len: noop magic on a $desc returns the previous length"; } } Variable-Magic-0.53/t/30-scalar.t0000644000175000017500000000651612153113706015322 0ustar vincevince#!perl -T use strict; use warnings; use Config qw<%Config>; use Test::More tests => (2 * 14 + 2) + 2 * (2 * 8 + 4) + 5 + 1; use lib 't/lib'; use VPIT::TestHelpers; use Variable::Magic qw; use lib 't/lib'; use Variable::Magic::TestWatcher; my $is_5130_release = ("$]" == 5.013 && !$Config{git_describe}) ? 1 : 0; my $wiz = init_watcher [ qw ], 'scalar'; my $n = int rand 1000; my $a = $n; watch { cast $a, $wiz } { }, 'cast'; my $b; # $b has to be set inside the block for the test to pass on 5.8.3 and lower watch { $b = $a } { get => 1 }, 'assign to'; is $b, $n, 'scalar: assign to correctly'; $b = watch { "X${a}Y" } { get => 1 }, 'interpolate'; is $b, "X${n}Y", 'scalar: interpolate correctly'; $b = watch { \$a } { }, 'reference'; watch { $a = 123 } { set => 1 }, 'assign to'; watch { ++$a } { get => 1, set => 1 }, 'increment'; watch { --$a } { get => 1, set => 1 }, 'decrement'; watch { $a *= 1.5 } { get => 1, set => 1 }, 'multiply in place'; watch { $a /= 1.5 } { get => 1, set => 1 }, 'divide in place'; watch { my $b = $n; watch { cast $b, $wiz } { }, 'cast 2'; } { free => 1 }, 'scope end'; watch { undef $a } { set => 1 }, 'undef'; watch { dispell $a, $wiz } { }, 'dispell'; # Array element my @a = (7, 8, 9); watch { cast $a[1], $wiz } { }, 'array element: cast'; watch { $a[1] = 6 } { set => 1 }, 'array element: set'; $b = watch { $a[1] } { get => ($is_5130_release ? 2 : 1) },'array element: get'; is $b, 6, 'scalar: array element: get correctly'; watch { $a[0] = 5 } { }, 'array element: set other'; $b = watch { $a[2] } { }, 'array element: get other'; is $b, 9, 'scalar: array element: get other correctly'; $b = watch { exists $a[1] } { }, 'array element: exists'; is $b, 1, 'scalar: array element: exists correctly'; # $b has to be set inside the block for the test to pass on 5.8.3 and lower watch { $b = delete $a[1] } { get => 1, free => ("$]" > 5.008_005 ? 1 : 0) }, 'array element: delete'; is $b, 6, 'scalar: array element: delete correctly'; watch { $a[1] = 4 } { }, 'array element: set after delete'; # Hash element my %h = (a => 7, b => 8); watch { cast $h{b}, $wiz } { }, 'hash element: cast'; watch { $h{b} = 6 } { set => 1 }, 'hash element: set'; $b = watch { $h{b} } { get => ($is_5130_release ? 2 : 1) }, 'hash element: get'; is $b, 6, 'scalar: hash element: get correctly'; watch { $h{a} = 5 } { }, 'hash element: set other'; $b = watch { $h{a} } { }, 'hash element: get other'; is $b, 5, 'scalar: hash element: get other correctly'; $b = watch { exists $h{b} } { }, 'hash element: exists'; is $b, 1, 'scalar: hash element: exists correctly'; $b = watch { delete $h{b} } { get => 1, free => 1 }, 'hash element: delete'; is $b, 6, 'scalar: hash element: delete correctly'; watch { $h{b} = 4 } { }, 'hash element: set after delete'; SKIP: { load_or_skip('Tie::Array', undef, undef, 5); tie my @a, 'Tie::StdArray'; $a[0] = $$; $a[1] = -$$; eval { cast @a, wizard copy => sub { cast $_[3], $wiz; () }; }; is $@, '', 'cast copy magic on tied array'; watch { delete $a[0] } [ qw ], 'delete from tied array in void context'; $b = watch { delete $a[1] } [ qw ], 'delete from tied array in scalar context'; } Variable-Magic-0.53/t/21-set.t0000644000175000017500000000120011630713431014631 0ustar vincevince#!perl -T use strict; use warnings; use Test::More tests => (2 * 5 + 3) + (2 * 2 + 1); use Variable::Magic qw; use lib 't/lib'; use Variable::Magic::TestWatcher; use Variable::Magic::TestValue; my $wiz = init_watcher 'set', 'set'; my $a = 0; watch { cast $a, $wiz } { }, 'cast'; my $n = int rand 1000; watch { $a = $n } { set => 1 }, 'assign'; is $a, $n, 'set: assign correctly'; watch { ++$a } { set => 1 }, 'increment'; is $a, $n + 1, 'set: increment correctly'; watch { --$a } { set => 1 }, 'decrement'; is $a, $n, 'set: decrement correctly'; { my $val = 0; init_value $val, 'set', 'set'; value { $val = 1 } \1; } Variable-Magic-0.53/t/34-glob.t0000644000175000017500000000327612153113706015004 0ustar vincevince#!perl -T use strict; use warnings; use Test::More; use lib 't/lib'; use VPIT::TestHelpers; BEGIN { load_or_skip_all('Symbol', undef, [ 'gensym' ]); plan tests => 2 * 17 + 1; } use Variable::Magic qw; my %get = VMG_COMPAT_GLOB_GET ? (get => 1) : (); use lib 't/lib'; use Variable::Magic::TestWatcher; my $wiz = init_watcher [ qw ], 'glob'; local *a = gensym(); watch { cast *a, $wiz } +{ }, 'cast'; watch { local *b = *a } +{ %get }, 'assign to'; SKIP: { skip 'This failed temporarily between perls 5.13.1 and 5.13.8 (included)' => 5 * 2 if "$]" >= 5.013_001 and "$]" <= 5.013_008; my $cxt = 'void contex'; my $exp = { set => 1 }; watch { *a = \1 } $exp, "assign scalar slot in $cxt"; watch { *a = [ qw ] } $exp, "assign array slot in $cxt"; watch { *a = { u => 1 } } $exp, "assign hash slot in $cxt"; watch { *a = sub { } } $exp, "assign code slot in $cxt"; watch { *a = gensym() } $exp, "assign glob in $cxt"; } { my $cxt = 'scalar context'; my $exp = { %get, set => 1 }; my $v; $v = watch { *a = \1 } $exp, "assign scalar slot in $cxt"; $v = watch { *a = [ qw ] } $exp, "assign array slot in $cxt"; $v = watch { *a = { u => 1 } } $exp, "assign hash slot in $cxt"; $v = watch { *a = sub { } } $exp, "assign code slot in $cxt"; $v = watch { *a = gensym() } $exp, "assign glob in $cxt"; } watch { local *b = gensym(); watch { cast *b, $wiz } +{ }, 'cast 2'; } +{ }, 'scope end'; %get = () if "$]" >= 5.013_007; watch { undef *a } +{ %get }, 'undef'; watch { dispell *a, $wiz } +{ %get }, 'dispell'; Variable-Magic-0.53/t/13-data.t0000644000175000017500000000575711630713431014775 0ustar vincevince#!perl -T use strict; use warnings; use Test::More tests => 35; use Variable::Magic qw; my $c = 1; my $wiz = eval { wizard data => sub { return { foo => $_[1] || 12, bar => $_[3] || 27 } }, get => sub { $c += $_[1]->{foo}; $_[1]->{foo} = $c }, set => sub { $c += $_[1]->{bar}; $_[1]->{bar} = $c } }; is($@, '', 'wizard doesn\'t croak'); ok(defined $wiz, 'wizard is defined'); is(ref $wiz, 'SCALAR', 'wizard is a scalar ref'); my $a = 75; my $res = eval { cast $a, $wiz }; is($@, '', 'cast doesn\'t croak'); ok($res, 'cast returns true'); my $data = eval { getdata my $b, $wiz }; is($@, '', 'getdata from non-magical scalar doesn\'t croak'); is($data, undef, 'getdata from non-magical scalar returns undef'); $data = eval { getdata $a, $wiz }; is($@, '', 'getdata from wizard doesn\'t croak'); ok($res, 'getdata from wizard returns true'); is_deeply($data, { foo => 12, bar => 27 }, 'getdata from wizard return value is ok'); my $b = $a; is($c, 13, 'get magic : pass data'); is($data->{foo}, 13, 'get magic : data updated'); $a = 57; is($c, 40, 'set magic : pass data'); is($data->{bar}, 40, 'set magic : pass data'); $data = eval { getdata $a, \"blargh" }; like($@, qr/Invalid\s+wizard\s+object\s+at\s+\Q$0\E/, 'getdata from invalid wizard croaks'); is($data, undef, 'getdata from invalid wizard returns undef'); $data = eval { getdata $a, undef }; like($@, qr/Invalid\s+wizard\s+object\s+at\s+\Q$0\E/, 'getdata from undef croaks'); is($data, undef, 'getdata from undef doesn\'t return anything'); $res = eval { dispell $a, $wiz }; is($@, '', 'dispell doesn\'t croak'); ok($res, 'dispell returns true'); $res = eval { cast $a, $wiz, qw }; is($@, '', 'cast with arguments doesn\'t croak'); ok($res, 'cast with arguments returns true'); $data = eval { getdata $a, $wiz }; is($@, '', 'getdata from wizard with arguments doesn\'t croak'); ok($res, 'getdata from wizard with arguments returns true'); is_deeply($data, { foo => 'z', bar => 't' }, 'getdata from wizard with arguments return value is ok'); dispell $a, $wiz; $wiz = wizard get => sub { }; $a = 63; $res = eval { cast $a, $wiz }; is($@, '', 'cast non-data wizard doesn\'t croak'); ok($res, 'cast non-data wizard returns true'); my @data = eval { getdata $a, $wiz }; is($@, '', 'getdata from non-data wizard doesn\'t croak'); is_deeply(\@data, [ ], 'getdata from non-data wizard invalid returns undef'); $wiz = wizard data => sub { ++$_[1] }; my ($di, $ei) = (1, 10); my ($d, $e); cast $d, $wiz, $di; cast $e, $wiz, $ei; my $dd = getdata $d, $wiz; my $ed = getdata $e, $wiz; is($dd, 2, 'data from d is what we expected'); is($di, 2, 'cast arguments from d were passed by alias'); is($ed, 11, 'data from e is what we expected'); is($ei, 11, 'cast arguments from e were passed by alias'); $di *= 2; $dd = getdata $d, $wiz; $ed = getdata $e, $wiz; is($dd, 2, 'data from d wasn\'t changed'); is($ed, 11, 'data from e wasn\'t changed'); Variable-Magic-0.53/t/16-huf.t0000644000175000017500000000245112153113706014635 0ustar vincevince#!perl -T use strict; use warnings; use Test::More; use lib 't/lib'; use VPIT::TestHelpers; use Variable::Magic qw; if (VMG_UVAR) { load_or_skip_all('Hash::Util::FieldHash', undef, [ ]); plan tests => 2 * 5 + 7 + 1; } else { skip_all 'No nice uvar magic for this perl'; } use Variable::Magic::TestWatcher; my $wiz = init_watcher [ qw ], 'huf'; ok defined($wiz), 'huf: wizard with uvar is defined'; is ref($wiz), 'SCALAR', 'huf: wizard with uvar is a scalar ref'; Hash::Util::FieldHash::fieldhash(\my %h); my $obj = { }; bless $obj, 'Variable::Magic::Test::Mock'; $h{$obj} = 5; my ($res) = watch { cast %h, $wiz } { }, 'cast uvar magic on fieldhash'; ok $res, 'huf: cast uvar magic on fieldhash succeeded'; my ($s) = watch { $h{$obj} } { fetch => 1 }, 'fetch on magical fieldhash'; is $s, 5, 'huf: fetch on magical fieldhash succeeded'; watch { $h{$obj} = 7 } { store => 1 }, 'store on magical fieldhash'; is $h{$obj}, 7, 'huf: store on magical fieldhash succeeded'; ($res) = watch { dispell %h, $wiz } { }, 'dispell uvar magic on fieldhash'; ok $res, 'huf: dispell uvar magic on fieldhash succeeded'; $h{$obj} = 11; $s = $h{$obj}; is $s, 11, 'huf: store/fetch on fieldhash after dispell still ok'; $Variable::Magic::TestWatcher::mg_end = { fetch => 1 }; Variable-Magic-0.53/t/17-ctl.t0000644000175000017500000002221212153113702014627 0ustar vincevince#!perl use strict; use warnings; use Test::More tests => 4 * 8 + 4 * (2 * 6 + 1) + 10 + 1 + 1; use Variable::Magic qw; sub expect { my ($name, $where, $suffix) = @_; $where = defined $where ? quotemeta $where : '\(eval \d+\)'; my $end = defined $suffix ? "$suffix\$" : '$'; qr/^\Q$name\E at $where line \d+\.$end/ } my @scalar_tests = ( [ 'data', sub { \(my $x) }, sub { } ], [ 'get', sub { \(my $x) }, sub { my $y = ${$_[0]} } ], [ 'set', sub { \(my $x) }, sub { ${$_[0]} = 1 } ], [ 'len', sub { [ 1 .. 3 ] }, sub { my $res = @{$_[0]} } ], ); # Data, get, set, len for my $t (@scalar_tests) { my ($name, $init, $code) = @$t; my $wiz = wizard $name => sub { die 'leek' }; { local $@; eval { my $x = $init->(); &cast($x, $wiz); $code->($x); }; like $@, expect('leek', $0), "die in $name callback (direct, \$@ unset) in eval"; } { local $@; eval { my $x = $init->(); &cast($x, $wiz); $@ = 'artichoke'; $code->($x); }; like $@, expect('leek', $0), "die in $name callback (direct, \$@ set) in eval"; } { local $@; eval q{BEGIN { my $x = $init->(); &cast($x, $wiz); $code->($x); }}; like $@, expect('leek', $0, "\nBEGIN.*"), "die in $name callback (direct, \$@ unset) in BEGIN"; } { local $@; eval q{BEGIN { my $x = $init->(); &cast($x, $wiz); $@ = 'artichoke'; $code->($x); }}; like $@, expect('leek', $0, "\nBEGIN.*"), "die in $name callback (direct, \$@ set) in BEGIN"; } $wiz = wizard( ($name eq 'data' ? () : (data => sub { $_[1] })), $name => sub { $_[1]->(); () }, ); { local $@; eval { my $x = $init->(); &cast($x, $wiz, sub { die 'lettuce' }); $code->($x); }; like $@, expect('lettuce', $0), "die in $name callback (indirect, \$@ unset) in eval"; } { local $@; eval { my $x = $init->(); &cast($x, $wiz, sub { die 'carrot' }); $@ = 'artichoke'; $code->($x); }; like $@, expect('carrot', $0), "die in $name callback (indirect, \$@ unset) in eval"; } { local $@; eval q{BEGIN { my $x = $init->(); &cast($x, $wiz, sub { die "pumpkin" }); $code->($x); }}; like $@, expect('pumpkin', undef, "\nBEGIN.*"), "die in $name callback (indirect, \$@ unset) in BEGIN"; } { local $@; eval q{BEGIN { my $x = $init->(); &cast($x, $wiz, sub { die "chard" }); $@ = 'artichoke'; $code->($x); }}; like $@, expect('chard', undef, "\nBEGIN.*"), "die in $name callback (indirect, \$@ set) in BEGIN"; } } # Free { my $wiz = wizard free => sub { die 'avocado' }; my $check = sub { like $@, expect('avocado', $0), $_[0] }; for my $local_out (0, 1) { for my $local_in (0, 1) { my $desc = "die in free callback"; if ($local_in or $local_out) { $desc .= ' with $@ localized '; if ($local_in and $local_out) { $desc .= 'inside and outside'; } elsif ($local_in) { $desc .= 'inside'; } else { $desc .= 'outside'; } } local $@ = $local_out ? 'xxx' : undef; eval { local $@ = 'yyy' if $local_in; my $x; cast $x, $wiz; }; $check->("$desc at eval BLOCK 1a"); local $@ = $local_out ? 'xxx' : undef; eval q{ local $@ = 'yyy' if $local_in; my $x; cast $x, $wiz; }; $check->("$desc at eval STRING 1a"); local $@ = $local_out ? 'xxx' : undef; eval { my $x; local $@ = 'yyy' if $local_in; cast $x, $wiz; }; $check->("$desc at eval BLOCK 1b"); local $@ = $local_out ? 'xxx' : undef; eval q{ my $x; local $@ = 'yyy' if $local_in; cast $x, $wiz; }; $check->("$desc at eval STRING 1b"); local $@ = $local_out ? 'xxx' : undef; eval { local $@ = 'yyy' if $local_in; my $x; my $y = \$x; &cast($y, $wiz); }; $check->("$desc at eval BLOCK 2a"); local $@ = $local_out ? 'xxx' : undef; eval q{ local $@ = 'yyy' if $local_in; my $x; my $y = \$x; &cast($y, $wiz); }; $check->("$desc at eval STRING 2a"); local $@ = $local_out ? 'xxx' : undef; eval { my $x; my $y = \$x; local $@ = 'yyy' if $local_in; &cast($y, $wiz); }; $check->("$desc at eval BLOCK 2b"); local $@ = $local_out ? 'xxx' : undef; eval q{ my $x; my $y = \$x; local $@ = 'yyy' if $local_in; &cast($y, $wiz); }; $check->("$desc at eval STRING 2b"); local $@ = $local_out ? 'xxx' : undef; eval { local $@ = 'yyy' if $local_in; my $x; cast $x, $wiz; my $y = 1; }; $check->("$desc at eval BLOCK 3"); local $@ = $local_out ? 'xxx' : undef; eval q{ local $@ = 'yyy' if $local_in; my $x; cast $x, $wiz; my $y = 1; }; $check->("$desc at eval STRING 3"); local $@ = $local_out ? 'xxx' : undef; eval { local $@ = 'yyy' if $local_in; { my $x; cast $x, $wiz; } }; $check->("$desc at block in eval BLOCK"); local $@ = $local_out ? 'xxx' : undef; eval q{ local $@ = 'yyy' if $local_in; { my $x; cast $x, $wiz; } }; $check->("$desc at block in eval STRING"); ok defined($desc), "$desc did not over-unwind the save stack"; } } } my $wiz; eval { $wiz = wizard data => sub { $_[1] }, free => sub { $_[1]->(); () }; my $x; cast $x, $wiz, sub { die "spinach" }; }; like $@, expect('spinach', $0), 'die in sub in free callback'; eval { $wiz = wizard free => sub { die 'zucchini' }; $@ = ""; { my $x; cast $x, $wiz; } die 'not reached'; }; like $@, expect('zucchini', $0), 'die in free callback in block in eval with $@ unset'; eval { $wiz = wizard free => sub { die 'eggplant' }; $@ = "artichoke"; { my $x; cast $x, $wiz; } die 'not reached again'; }; like $@, expect('eggplant', $0), 'die in free callback in block in eval with $@ set'; eval q{BEGIN { $wiz = wizard free => sub { die 'onion' }; my $x; cast $x, $wiz; }}; like $@, expect('onion', undef, "\nBEGIN.*"), 'die in free callback in BEGIN'; eval q{BEGIN { $wiz = wizard data => sub { $_[1] }, len => sub { $_[1]->(); $_[2] }, free => sub { my $x = @{$_[0]}; () }; my @a = (1 .. 5); cast @a, $wiz, sub { die "pepperoni" }; }}; like $@, expect('pepperoni', undef, "\nBEGIN.*"), 'die in free callback in len callback in BEGIN'; # Inspired by B::Hooks::EndOfScope eval q{BEGIN { $wiz = wizard data => sub { $_[1] }, free => sub { $_[1]->(); () }; $^H |= 0x020000; cast %^H, $wiz, sub { die 'cabbage' }; }}; like $@, expect('cabbage'), 'die in free callback at end of scope'; use lib 't/lib'; my $vm_tse_file = 't/lib/Variable/Magic/TestScopeEnd.pm'; eval "use Variable::Magic::TestScopeEnd"; like $@, expect('turnip', $vm_tse_file, "\nBEGIN(?s:.*)"), 'die in BEGIN in require in eval string triggers hints hash destructor'; eval q{BEGIN { Variable::Magic::TestScopeEnd::hook { pass 'in hints hash destructor 2'; }; die "tomato"; }}; like $@, expect('tomato', undef, "\nBEGIN.*"), 'die in BEGIN in eval triggers hints hash destructor'; sub run_perl { my $code = shift; my ($SystemRoot, $PATH) = @ENV{qw}; local %ENV; $ENV{SystemRoot} = $SystemRoot if $^O eq 'MSWin32' and defined $SystemRoot; $ENV{PATH} = $PATH if $^O eq 'cygwin' and defined $PATH; system { $^X } $^X, '-T', map("-I$_", @INC), '-e', $code; } my $has_capture_tiny = do { local $@; eval { require Capture::Tiny; Capture::Tiny->VERSION('0.08'); } }; if ($has_capture_tiny) { local $@; my $output = eval { Capture::Tiny::capture_merged(sub { run_perl <<' CODE' }); print STDOUT "pants\n"; print STDERR "trousers\n"; CODE }; unless (defined $output and $output =~ /pants/ and $output =~ /trousers/) { $has_capture_tiny = 0; } } if ($has_capture_tiny) { defined and diag "Using Capture::Tiny $_" for $Capture::Tiny::VERSION; } SKIP: { my $count = 1; skip 'No working Capture::Tiny is installed'=> $count unless $has_capture_tiny; my $output = Capture::Tiny::capture_merged(sub { run_perl <<' CODE' }); use Variable::Magic qw; { BEGIN { $^H |= 0x020000; cast %^H, wizard free => sub { die q[cucumber] } } } CODE skip 'Test code didn\'t run properly' => $count unless defined $output; like $output, expect('cucumber', '-e', "\nExecution(?s:.*)"), 'die in free callback at compile time and not in eval string'; --$count; } # Uvar SKIP: { my $count = 1; skip 'No nice uvar magic for this perl' => $count unless VMG_UVAR; skip 'No working Capture::Tiny is installed'=> $count unless $has_capture_tiny; my $output = Capture::Tiny::capture_merged(sub { run_perl <<' CODE' }); use Variable::Magic qw; BEGIN { cast %derp::, wizard fetch => sub { die q[raddish] } } derp::hlagh() CODE skip 'Test code didn\'t run properly' => $count unless defined $output; like $output, expect('raddish', '-e', "\nExecution(?s:.*)"), 'die in free callback at compile time and not in eval string'; --$count; } Variable-Magic-0.53/t/33-code.t0000644000175000017500000000305311630713431014763 0ustar vincevince#!perl -T use strict; use warnings; use Test::More tests => 2 * 12 + 11 + 1; use Variable::Magic qw; use lib 't/lib'; use Variable::Magic::TestWatcher; my $wiz = init_watcher [ qw ], 'code'; my $x = 0; sub hlagh { ++$x }; watch { cast &hlagh, $wiz } { }, 'cast'; is $x, 0, 'code: cast didn\'t called code'; watch { hlagh() } { }, 'call without arguments'; is $x, 1, 'code: call without arguments succeeded'; watch { hlagh(1, 2, 3) } { }, 'call with arguments'; is $x, 2, 'code: call with arguments succeeded'; watch { undef *hlagh } { free => 1 }, 'undef symbol table entry'; is $x, 2, 'code: undef symbol table entry didn\'t call code'; my $y = 0; watch { *hlagh = sub { ++$y } } { }, 'redefining sub'; watch { cast &hlagh, $wiz } { }, 're-cast'; is $y, 0, 'code: re-cast didn\'t called code'; my ($r) = watch { \&hlagh } { }, 'reference'; is $y, 0, 'code: reference didn\'t called code'; watch { $r->() } { }, 'call reference'; is $y, 1, 'code: call reference succeeded'; is $x, 2, 'code: call reference didn\'t called the previous code'; my $z = 0; watch { no warnings 'redefine'; *hlagh = sub { ++$z } } { }, 'redefining sub 2'; watch { hlagh() } { }, 'call without arguments 2'; is $z, 1, 'code: call without arguments 2 succeeded'; is $y, 1, 'code: call without arguments 2 didn\'t called the previous code'; watch { dispell &hlagh, $wiz } { }, 'dispell'; is $z, 1, 'code: dispell didn\'t called code'; $Variable::Magic::TestWatcher::mg_end = { free => 1 }; Variable-Magic-0.53/t/10-simple.t0000644000175000017500000000367511651752633015361 0ustar vincevince#!perl -T use strict; use warnings; use Test::More tests => 43; use Variable::Magic qw; my $inv_wiz_obj = qr/Invalid\s+wizard\s+object\s+at\s+\Q$0\E/; my $args = 9; ++$args if MGf_LOCAL; $args += 5 if VMG_UVAR; for (0 .. 20) { next if $_ == $args; eval { Variable::Magic::_wizard(('hlagh') x $_) }; like($@, qr/Wrong\s+number\s+of\s+arguments\s+at\s+\Q$0\E/, '_wizard called directly with a wrong number of arguments croaks'); } for (0 .. 3) { eval { wizard(('dong') x (2 * $_ + 1)) }; like($@, qr/Wrong\s+number\s+of\s+arguments\s+for\s+&?wizard\(\)\s+at\s+\Q$0\E/, 'wizard called with an odd number of arguments croaks'); } my $wiz = eval { wizard }; is($@, '', 'wizard doesn\'t croak'); ok(defined $wiz, 'wizard is defined'); is(ref $wiz, 'SCALAR', 'wizard is a scalar ref'); my $res = eval { cast $a, $wiz }; is($@, '', 'cast doesn\'t croak'); ok($res, 'cast is valid'); $res = eval { dispell $a, $wiz }; is($@, '', 'dispell from wizard doesn\'t croak'); ok($res, 'dispell from wizard is valid'); $res = eval { cast $a, $wiz }; is($@, '', 're-cast doesn\'t croak'); ok($res, 're-cast is valid'); $res = eval { dispell $a, \"blargh" }; like($@, $inv_wiz_obj, 're-dispell from wrong wizard croaks'); is($res, undef, 're-dispell from wrong wizard doesn\'t return anything'); $res = eval { dispell $a, undef }; like($@, $inv_wiz_obj, 're-dispell from undef croaks'); is($res, undef, 're-dispell from undef doesn\'t return anything'); $res = eval { dispell $a, $wiz }; is($@, '', 're-dispell from good wizard doesn\'t croak'); ok($res, 're-dispell from good wizard is valid'); $res = eval { dispell my $b, $wiz }; is($@, '', 'dispell non-magic object doesn\'t croak'); is($res, 0, 'dispell non-magic object returns 0'); my $c = 3; $res = eval { cast $c, undef }; like($@, $inv_wiz_obj, 'cast from undef croaks'); is($res, undef, 'cast from undef doesn\'t return anything'); Variable-Magic-0.53/t/35-stash.t0000644000175000017500000001501512153113706015176 0ustar vincevince#!perl -T use strict; use warnings; use Test::More; use Variable::Magic qw< wizard cast dispell VMG_UVAR VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT >; my $run; if (VMG_UVAR) { plan tests => 43; $run = 1; } else { plan skip_all => 'uvar magic is required to test symbol table hooks'; } our %mg; my $code = 'wizard ' . join (', ', map { < sub { my \$d = \$_[1]; return 0 if \$d->{guard}; local \$d->{guard} = 1; push \@{\$mg{$_}}, \$_[2]; () } CB } qw); $code .= ', data => sub { +{ guard => 0 } }'; my $wiz = eval $code; diag $@ if $@; cast %Hlagh::, $wiz; { local %mg; eval q{ die "ok\n"; package Hlagh; our $thing; { package NotHlagh; our $what = @Hlagh::stuff; } }; is $@, "ok\n", 'stash: variables compiled fine'; is_deeply \%mg, { fetch => [ qw ], store => [ qw ], }, 'stash: variables'; } { local %mg; eval q[ die "ok\n"; package Hlagh; sub eat; sub shoot; sub leave { "bye" }; sub shoot { "bang" }; ]; is $@, "ok\n", 'stash: function definitions compiled fine'; is_deeply \%mg, { store => [ qw ], }, 'stash: function definitions'; } { local %mg; eval q{ die "ok\n"; package Hlagh; eat(); shoot(); leave(); roam(); yawn(); roam(); }; my @calls = qw; is $@, "ok\n", 'stash: function calls compiled fine'; is_deeply \%mg, { fetch => \@calls, store => ("$]" < 5.011_002 ? \@calls : [ map { ($_) x 2 } @calls ]), }, 'stash: function calls'; } { local %mg; eval q{ Hlagh->shoot() }; is $@, '', 'stash: valid method call ran fine'; is_deeply \%mg, { fetch => [ qw ], }, 'stash: valid method call'; } { local %mg; eval q{ Hlagh->shoot() }; is $@, '', 'stash: second valid method call ran fine'; is_deeply \%mg, { fetch => [ qw ], }, 'stash: second valid method call'; } { local %mg; eval q{ my $meth = 'shoot'; Hlagh->$meth() }; is $@, '', 'stash: valid dynamic method call ran fine'; is_deeply \%mg, { store => [ qw ], }, 'stash: valid dynamic method call'; } { local %mg; eval q[ package Hlagher; our @ISA; BEGIN { @ISA = 'Hlagh' } Hlagher->leave() ]; is $@, '', 'inherited valid method call ran fine'; is_deeply \%mg, { fetch => [ qw ], }, 'stash: inherited valid method call'; } { local %mg; eval q{ Hlagher->leave() }; is $@, '', 'second inherited valid method call ran fine'; is_deeply \%mg, { }, 'stash: second inherited valid method call doesn\'t call magic'; } { local %mg; eval q{ Hlagher->shoot() }; is $@, '', 'inherited previously called valid method call ran fine'; is_deeply \%mg, { fetch => [ qw ], }, 'stash: inherited previously called valid method call'; } { local %mg; eval q{ Hlagher->shoot() }; is $@, '', 'second inherited previously called valid method call ran fine'; is_deeply \%mg, { }, 'stash: second inherited previously called valid method call doesn\'t call magic'; } { local %mg; eval q{ Hlagh->unknown() }; like $@, qr/^Can't locate object method "unknown" via package "Hlagh"/, 'stash: invalid method call croaked'; is_deeply \%mg, { fetch => [ qw ], store => [ qw ], }, 'stash: invalid method call'; } { local %mg; eval q{ my $meth = 'unknown_too'; Hlagh->$meth() }; like $@, qr/^Can't locate object method "unknown_too" via package "Hlagh"/, 'stash: invalid dynamic method call croaked'; is_deeply \%mg, { store => [ qw ], }, 'stash: invalid dynamic method call'; } { local %mg; eval q{ Hlagher->also_unknown() }; like $@, qr/^Can't locate object method "also_unknown" via package "Hlagher"/, 'stash: invalid inherited method call croaked'; is_deeply \%mg, { fetch => [ qw ], }, 'stash: invalid method call'; } { local %mg; my @expected_stores = qw; @expected_stores = map { ($_) x 2 } @expected_stores if "$]" < 5.017_004; push @expected_stores, 'nevermentioned' if "$]" < 5.017_001; eval q{ package Hlagh; undef &nevermentioned; undef &eat; undef &shoot; }; is $@, '', 'stash: delete executed fine'; is_deeply \%mg, { store => \@expected_stores }, 'stash: delete'; } END { is_deeply \%mg, { }, 'stash: magic that remains at END time' if $run; } dispell %Hlagh::, $wiz; { package AutoHlagh; use vars qw<$AUTOLOAD>; sub AUTOLOAD { return $AUTOLOAD } } cast %AutoHlagh::, $wiz; { local %mg; my $res = eval q{ AutoHlagh->autoloaded() }; is $@, '', 'stash: autoloaded method call ran fine'; is $res, 'AutoHlagh::autoloaded', 'stash: autoloaded method call returned the right thing'; is_deeply \%mg, { fetch => [ qw ], store => [ qw ], }, 'stash: autoloaded method call'; } { package AutoHlagher; our @ISA; BEGIN { @ISA = ('AutoHlagh') } } { local %mg; my $res = eval q{ AutoHlagher->also_autoloaded() }; is $@, '', 'stash: inherited autoloaded method call ran fine'; is $res, 'AutoHlagher::also_autoloaded', 'stash: inherited autoloaded method returned the right thing'; is_deeply \%mg, { fetch => [ qw ], store => [ qw ], }, 'stash: inherited autoloaded method call'; } dispell %AutoHlagh::, $wiz; my $uo = 0; $code = 'wizard ' . join (', ', map { < sub { my \$d = \$_[1]; return 0 if \$d->{guard}; local \$d->{guard} = 1; ++\$uo; () } CB } qw); my $uo_exp = "$]" < 5.011_002 ? 2 : 3; $code .= ', data => sub { +{ guard => 0 } }'; $wiz = eval $code . ', op_info => ' . VMG_OP_INFO_NAME; diag $@ if $@; cast %Hlagh::, $wiz; is $uo, 0, 'stash: no undef op before function call with op name'; eval q{ die "ok\n"; package Hlagh; meh(); }; is $@, "ok\n", 'stash: function call with op name compiled fine'; is $uo, $uo_exp, 'stash: undef op after function call with op name'; dispell %Hlagh::, $wiz; is $uo, $uo_exp, 'stash: undef op after dispell for function call with op name'; $uo = 0; $wiz = eval $code . ', op_info => ' . VMG_OP_INFO_OBJECT; diag $@ if $@; cast %Hlagh::, $wiz; is $uo, 0, 'stash: no undef op before function call with op object'; eval q{ die "ok\n"; package Hlagh; wat(); }; is $@, "ok\n", 'stash: function call with op object compiled fine'; is $uo, $uo_exp, 'stash: undef op after dispell for function call with op object'; dispell %Hlagh::, $wiz; is $uo, $uo_exp, 'stash: undef op after dispell for function call with op object'; Variable-Magic-0.53/t/80-leaks.t0000644000175000017500000000174111630713431015154 0ustar vincevince#!perl -T use strict; use warnings; use Test::More tests => 11; use Variable::Magic qw; our $destroyed; { package Variable::Magic::TestDestructor; sub new { bless { }, shift } sub DESTROY { ++$::destroyed } } sub D () { 'Variable::Magic::TestDestructor' } { local $destroyed = 0; my $w = wizard data => sub { $_[1] }; { my $obj = D->new; { my $x = 1; cast $x, $w, $obj; is $destroyed, 0; } is $destroyed, 0; } is $destroyed, 1; } { local $destroyed = 0; my $w = wizard data => sub { $_[1] }; { my $copy; { my $obj = D->new; { my $x = 1; cast $x, $w, $obj; is $destroyed, 0; $copy = getdata $x, $w; } is $destroyed, 0; } is $destroyed, 0; } is $destroyed, 1; } { local $destroyed = 0; { my $obj = D->new; { my $w = wizard set => $obj; { my $x = 1; cast $x, $w; is $destroyed, 0; } is $destroyed, 0; } is $destroyed, 0; } is $destroyed, 1; } Variable-Magic-0.53/t/25-copy.t0000644000175000017500000000407012153113706015024 0ustar vincevince#!perl -T use strict; use warnings; use Test::More; use lib 't/lib'; use VPIT::TestHelpers; use Variable::Magic qw; plan tests => 2 + ((2 * 5 + 3) + (2 * 2 + 1)) + (2 * 9 + 6) + 1; use lib 't/lib'; use Variable::Magic::TestWatcher; use Variable::Magic::TestValue; my $wiz = init_watcher 'copy', 'copy'; SKIP: { load_or_skip('Tie::Array', undef, undef, (2 * 5 + 3) + (2 * 2 + 1)); tie my @a, 'Tie::StdArray'; @a = (1 .. 10); my $res = watch { cast @a, $wiz } { }, 'cast on tied array'; ok $res, 'copy: cast on tied array succeeded'; watch { $a[3] = 13 } { copy => 1 }, 'tied array store'; my $s = watch { $a[3] } { copy => 1 }, 'tied array fetch'; is $s, 13, 'copy: tied array fetch correctly'; $s = watch { exists $a[3] } { copy => 1 }, 'tied array exists'; ok $s, 'copy: tied array exists correctly'; watch { undef @a } { }, 'tied array undef'; { tie my @val, 'Tie::StdArray'; @val = (4 .. 6); my $wv = init_value @val, 'copy', 'copy'; value { $val[3] = 8 } [ 4 .. 6 ]; dispell @val, $wv; is_deeply \@val, [ 4 .. 6, 8 ], 'copy: value after'; } } SKIP: { load_or_skip('Tie::Hash', undef, undef, 2 * 9 + 6); tie my %h, 'Tie::StdHash'; %h = (a => 1, b => 2, c => 3); my $res = watch { cast %h, $wiz } { }, 'cast on tied hash'; ok $res, 'copy: cast on tied hash succeeded'; watch { $h{b} = 7 } { copy => 1 }, 'tied hash store'; my $s = watch { $h{c} } { copy => 1 }, 'tied hash fetch'; is $s, 3, 'copy: tied hash fetch correctly'; $s = watch { exists $h{a} } { copy => 1 }, 'tied hash exists'; ok $s, 'copy: tied hash exists correctly'; $s = watch { delete $h{b} } { copy => 1 }, 'tied hash delete'; is $s, 7, 'copy: tied hash delete correctly'; watch { my ($k, $v) = each %h } { copy => 1 }, 'tied hash each'; my @k = watch { keys %h } { }, 'tied hash keys'; is_deeply [ sort @k ], [ qw ], 'copy: tied hash keys correctly'; my @v = watch { values %h } { copy => 2 }, 'tied hash values'; is_deeply [ sort { $a <=> $b } @v ], [ 1, 3 ], 'copy: tied hash values correctly'; watch { undef %h } { }, 'tied hash undef'; } Variable-Magic-0.53/t/01-import.t0000644000175000017500000000140212153113706015352 0ustar vincevince#!perl -T use strict; use warnings; use Test::More tests => 2 * 21; require Variable::Magic; my %syms = ( wizard => undef, cast => '\[$@%&*]$@', getdata => '\[$@%&*]$', dispell => '\[$@%&*]$', map { $_ => '' } qw< MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR VMG_COMPAT_SCALAR_LENGTH_NOLEN VMG_COMPAT_SCALAR_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 > ); for (sort keys %syms) { eval { Variable::Magic->import($_) }; is $@, '', "import $_"; is prototype($_), $syms{$_}, "prototype $_"; } Variable-Magic-0.53/t/15-self.t0000644000175000017500000001121112013721757015003 0ustar vincevince#!perl -T use strict; use warnings; use Test::More; my $tests; BEGIN { $tests = 17 } plan tests => $tests; use Variable::Magic qw; use lib 't/lib'; use Variable::Magic::TestGlobalDestruction; my $c = 0; { my $wiz = eval { wizard data => sub { $_[0] }, get => sub { ++$c }, free => sub { --$c } }; is($@, '', 'wizard creation error doesn\'t croak'); ok(defined $wiz, 'wizard is defined'); is(ref $wiz, 'SCALAR', 'wizard is a scalar ref'); my $res = eval { cast $wiz, $wiz }; is($@, '', 'cast on self doesn\'t croak'); ok($res, 'cast on self is valid'); my $w = $wiz; is($c, 1, 'magic works correctly on self'); $res = eval { dispell $wiz, $wiz }; is($@, '', 'dispell on self doesn\'t croak'); ok($res, 'dispell on self is valid'); $w = $wiz; is($c, 1, 'magic is no longer invoked on self when dispelled'); $res = eval { cast $wiz, $wiz, $wiz }; is($@, '', 're-cast on self doesn\'t croak'); ok($res, 're-cast on self is valid'); $w = getdata $wiz, $wiz; is($c, 1, 'getdata on magical self doesn\'t trigger callbacks'); $res = eval { dispell $wiz, $wiz }; is($@, '', 're-dispell on self doesn\'t croak'); ok($res, 're-dispell on self is valid'); $res = eval { cast $wiz, $wiz }; is($@, '', 're-re-cast on self doesn\'t croak'); ok($res, 're-re-cast on self is valid'); } { my %testcases; BEGIN { my %magics = do { my @magics = qw; push @magics, 'local' if MGf_LOCAL; push @magics, qw if VMG_UVAR; map { $_ => 1 } @magics; }; %testcases = ( SCALAR => { id => 1, ctor => sub { my $val = 123; \$val }, tests => [ get => [ sub { my $val = ${$_[0]} } => 123 ], set => [ sub { ${$_[0]} = 456; $_[0] } => \456 ], free => [ ], ], }, ARRAY => { id => 2, ctor => sub { [ 0 .. 2 ] }, tests => [ len => [ sub { my $len = @{$_[0]} } => 3 ], clear => [ sub { @{$_[0]} = (); $_[0] } => [ ] ], free => [ ], ], }, HASH => { id => 3, ctor => sub { +{ foo => 'bar' } }, tests => [ clear => [ sub { %{$_[0]} = (); $_[0] } => +{ } ], free => [ ], fetch => [ sub { my $val = $_[0]->{foo} } => 'bar' ], store => [ sub { $_[0]->{foo} = 'baz'; $_[0] } => { foo => 'baz' } ], exists => [ sub { my $res = exists $_[0]->{foo} } => 1 ], delete => [ sub { my $val = delete $_[0]->{foo} } => 'bar' ], ], }, ); my $count; for my $testcases (map $_->{tests}, values %testcases) { my $i = 0; while ($i < $#$testcases) { if ($magics{$testcases->[$i]}) { $i += 2; ++$count; } else { splice @$testcases, $i, 2; } } } $tests += $count * 2 * 2 * 3; } my @types = sort { $testcases{$a}->{id} <=> $testcases{$b}->{id} } keys %testcases; my $other_wiz = wizard data => sub { 'abc' }; for my $type (@types) { my $ctor = $testcases{$type}->{ctor}; my @testcases = @{$testcases{$type}->{tests}}; while (@testcases >= 2) { my ($magic, $test) = splice @testcases, 0, 2; for my $dispell (0, 1) { for my $die (0, 1) { my $desc = $dispell ? 'dispell' : 'cast'; $desc .= " a $type from a $magic callback"; $desc .= ' and dieing' if $die; my $wiz; my $code = $dispell ? sub { &dispell($_[0], $wiz); die 'oops' if $die; return } : sub { &cast($_[0], $other_wiz); die 'oops' if $die; return }; $wiz = wizard( data => sub { 'xyz' }, $magic => $code, ); my ($var, $res, $err); if ($magic eq 'free') { eval { my $v = $ctor->(); &cast($v, $wiz); }; $err = $@; } else { $var = $ctor->(); &cast($var, $wiz); $res = eval { $test->[0]->($var); }; $err = $@; } if ($die) { like $err, qr/^oops at/, "$desc: correct error"; is $res, undef, "$desc: returned undef"; } else { is $err, '', "$desc: no error"; is_deeply $res, $test->[1], "$desc: returned value"; } if (not defined $var) { pass "$desc: meaningless"; } elsif ($dispell) { my $data = &getdata($var, $wiz); is $data, undef, "$desc: correctly dispelled"; } else { my $data = &getdata($var, $other_wiz); is $data, 'abc', "$desc: correctly cast"; } } } } } } eval q[ use lib 't/lib'; BEGIN { require Variable::Magic::TestDestroyRequired; } ]; is $@, '', 'wizard destruction at the end of BEGIN-time require doesn\'t panic'; Variable-Magic-0.53/t/02-constants.t0000644000175000017500000000027411651753143016072 0ustar vincevince#!perl -T use strict; use warnings; use Test::More tests => 2; use Variable::Magic qw; ok MGf_COPY, 'MGf_COPY is always true'; ok MGf_DUP, 'MGf_DUP is always true'; Variable-Magic-0.53/t/14-callbacks.t0000644000175000017500000000554411717276272016013 0ustar vincevince#!perl -T use strict; use warnings; use Test::More tests => 26; use Variable::Magic qw; my $wiz = eval { wizard get => sub { undef } }; is($@, '', 'wizard creation doesn\'t croak'); ok(defined $wiz, 'wizard is defined'); is(ref $wiz, 'SCALAR', 'wizard is a scalar ref'); my $n = int rand 1000; my $a = $n; my $res = eval { cast $a, $wiz }; is($@, '', 'cast doesn\'t croak'); ok($res, 'cast is valid'); my $x; eval { local $SIG{__WARN__} = sub { die }; $x = $a }; is($@, '', 'callback returning undef doesn\'t warn/croak'); is($x, $n, 'callback returning undef fails'); { my $c = 0; sub X::wat { ++$c } my $wiz = eval { wizard get => \'X::wat' }; is($@, '', 'wizard with a qualified string callback doesn\'t croak'); my $b = $n; my $res = eval { cast $b, $wiz }; is($@, '', 'cast a wizard with a qualified string callback doesn\'t croak'); my $x; eval { local $SIG{__WARN__} = sub { die }; $x = $b; }; is($@, '', 'qualified string callback doesn\'t warn/croak'); is($c, 1, 'qualified string callback is called'); is($x, $n, 'qualified string callback returns the right thing'); } { my $c = 0; sub wut { fail 'main::wut was called' } sub Y::wut { ++$c } my $wiz = eval { wizard get => \'wut' }; is($@, '', 'wizard with a short string callback doesn\'t croak'); my $b = $n; my $res = eval { cast $b, $wiz }; is($@, '', 'cast a wizard with a short string callback doesn\'t croak'); my $x; eval { local $SIG{__WARN__} = sub { die }; package Y; $x = $b; }; is($@, '', 'short string callback doesn\'t warn/croak'); is($c, 1, 'short string callback is called'); is($x, $n, 'short string callback returns the right thing'); } { my $wiz = eval { wizard get => \undef }; is($@, '', 'wizard with a ref-to-undef callback doesn\'t croak'); my $b = $n; my $res = eval { cast $b, $wiz }; is($@, '', 'cast a wizard with a ref-to-undef callback doesn\'t croak'); my $x; eval { local $SIG{__WARN__} = sub { die }; $x = $b; }; is($@, '', 'ref-to-undef callback doesn\'t warn/croak'); is($x, $n, 'ref-to-undef callback returns the right thing'); } my @callers; $wiz = wizard get => sub { my @c; my $i = 0; while (@c = caller $i++) { push @callers, [ @c[0, 1, 2] ]; } }; my $b; cast $b, $wiz; my $u = $b; is_deeply(\@callers, [ ([ 'main', $0, __LINE__-2 ]) x 2, ], 'caller into callback returns the right thing'); @callers = (); $u = $b; is_deeply(\@callers, [ ([ 'main', $0, __LINE__-2 ]) x 2, ], 'caller into callback returns the right thing (second time)'); { @callers = (); my $u = $b; is_deeply(\@callers, [ ([ 'main', $0, __LINE__-2 ]) x 2, ], 'caller into callback into block returns the right thing'); } @callers = (); eval { my $u = $b }; is($@, '', 'caller into callback doesn\'t croak'); is_deeply(\@callers, [ ([ 'main', $0, __LINE__-3 ]) x 3, ], 'caller into callback into eval returns the right thing'); Variable-Magic-0.53/t/20-get.t0000644000175000017500000000123211630713431014621 0ustar vincevince#!perl -T use strict; use warnings; use Test::More tests => (2 * 4 + 2) + (2 * 2) + 1; use Variable::Magic qw; use lib 't/lib'; use Variable::Magic::TestWatcher; use Variable::Magic::TestValue; my $wiz = init_watcher 'get', 'get'; my $n = int rand 1000; my $a = $n; watch { cast $a, $wiz } { }, 'cast'; my $b; # $b has to be set inside the block for the test to pass on 5.8.3 and lower watch { $b = $a } { get => 1 }, 'assign to'; is $b, $n, 'get: assign to correctly'; $b = watch { "X${a}Y" } { get => 1 }, 'interpolate'; is $b, "X${n}Y", 'get: interpolate correctly'; { my $val = 0; init_value $val, 'get', 'get'; value { my $x = $val } \0; } Variable-Magic-0.53/t/32-hash.t0000644000175000017500000001074412011742457015004 0ustar vincevince#!perl -T use strict; use warnings; use Test::More tests => (2 * 27 + 9) + 2 * (2 * 5 + 5) + 1; use Variable::Magic qw< cast dispell VMG_UVAR VMG_COMPAT_HASH_DELETE_NOUVAR_VOID >; use lib 't/lib'; use Variable::Magic::TestWatcher; my $wiz = init_watcher [ qw ], 'hash'; my %n = map { $_ => int rand 1000 } qw; my %h = %n; watch { cast %h, $wiz } { }, 'cast'; my $s = watch { $h{foo} } +{ (fetch => 1) x VMG_UVAR }, 'assign element to'; is $s, $n{foo}, 'hash: assign element to correctly'; my %b; watch { %b = %h } { }, 'assign to'; is_deeply \%b, \%n, 'hash: assign to correctly'; $s = watch { \%h } { }, 'reference'; my @b = watch { @h{qw} } +{ (fetch => 2) x VMG_UVAR }, 'slice'; is_deeply \@b, [ @n{qw} ], 'hash: slice correctly'; # exists watch { exists $h{bar} } +{ (exists => 1) x VMG_UVAR },'exists in void context'; for (1 .. 2) { $s = watch { exists $h{bar} } +{ (exists => 1) x VMG_UVAR }, "exists in scalar context ($_)"; ok $s, "hash: exists correctly ($_)"; } # delete watch { delete $h{bar} } +{ ((delete => 1) x !VMG_COMPAT_HASH_DELETE_NOUVAR_VOID, copy => 1) x VMG_UVAR }, 'delete in void context'; for (1 .. 2) { $s = watch { delete $h{baz} } +{ (delete => 1, copy => 1) x VMG_UVAR }, "delete in scalar context ($_)"; my $exp = $_ == 1 ? $n{baz} : undef; is $s, $exp, "hash: delete correctly ($_)"; } # clear watch { %h = () } { clear => 1 }, 'empty in list context'; watch { $h{a} = -1; %h = (b => $h{a}) } +{ (fetch => 1, store => 2, copy => 2) x VMG_UVAR, clear => 1 }, 'empty and set in void context'; watch { %h = (a => 1, d => 3) } +{ (store => 2, copy => 2) x VMG_UVAR, clear => 1 }, 'assign from list in void context'; @b = watch { %h = (a => 1, d => 3) } +{ (exists => 2, store => 2, copy => 2) x VMG_UVAR, clear => 1 }, 'assign from list in void context'; watch { %h = map { $_ => 1 } qw; } +{ (store => 3, copy => 3) x VMG_UVAR, clear => 1 }, 'assign from map in void context'; watch { $h{d} = 2 } +{ (store => 1) x VMG_UVAR }, 'assign old element'; watch { $h{c} = 3 } +{ (store => 1, copy => 1) x VMG_UVAR }, 'assign new element'; $s = watch { %h } { }, 'buckets'; @b = watch { keys %h } { }, 'keys'; is_deeply [ sort @b ], [ qw ], 'hash: keys correctly'; @b = watch { values %h } { }, 'values'; is_deeply [ sort { $a <=> $b } @b ], [ 1, 1, 2, 3 ], 'hash: values correctly'; watch { while (my ($k, $v) = each %h) { } } { }, 'each'; watch { my %b = %n; watch { cast %b, $wiz } { }, 'cast 2'; } { free => 1 }, 'scope end'; watch { undef %h } { clear => 1 }, 'undef'; watch { dispell %h, $wiz } { }, 'dispell'; SKIP: { my $SKIP; if (!VMG_UVAR) { $SKIP = 'uvar magic'; } else { local $@; unless (eval { require B; require B::Deparse; 1 }) { $SKIP = 'B and B::Deparse'; } } if ($SKIP) { $SKIP .= ' required to test uvar/clear interaction fix'; skip $SKIP => 2 * ( 2 * 5 + 5); } my $bd = B::Deparse->new; my %h1 = (a => 13, b => 15); my %h2 = (a => 17, b => 19); my @tests = ( [ \%h1 => 'first hash' => (14, 16) ], [ \%h2 => 'second hash' => (18, 20) ], ); for my $test (@tests) { my ($h, $desc, @exp) = @$test; watch { &cast($h, $wiz) } { }, "cast clear/uvar on $desc"; my $code = sub { my $x = $h->{$_[0]}; ++$x; $x }; my $before = $bd->coderef2text($code); my $res; watch { $res = $code->('a') } { fetch => 1 }, "fetch constant 'a' from $desc"; is $res, $exp[0], "uvar: fetch constant 'a' from $desc was correct"; my $after = $bd->coderef2text($code); is $before, $after, "uvar: code deparses correctly after constant fetch from $desc"; my $key = 'b'; watch { $res = $code->($key) } { fetch => 1 },"fetch variable 'b' from $desc"; is $res, $exp[1], "uvar: fetch variable 'b' from $desc was correct"; $after = $bd->coderef2text($code); is $before, $after, "uvar: code deparses correctly after variable fetch from $desc"; watch { %$h = () } { clear => 1 }, "fixed clear for $desc"; watch { &dispell($h, $wiz) } { }, "dispell clear/uvar from $desc"; ok(!(B::svref_2object($h)->FLAGS & B::SVs_RMG()), "$desc no longer has the RMG flag set"); } } Variable-Magic-0.53/t/11-multiple.t0000644000175000017500000001006711651337622015712 0ustar vincevince#!perl -T use strict; use warnings; use Test::More tests => 33 + 41; use Variable::Magic qw; my $n = 3; my @w; my @c = (0) x $n; sub multi { my ($cb, $tests) = @_; for (my $i = 0; $i < $n; ++$i) { my $res = eval { $cb->($i) }; $tests->($i, $res, $@); } } eval { $w[0] = wizard get => sub { ++$c[0] }, set => sub { --$c[0] } }; is($@, '', 'wizard 0 creation doesn\'t croak'); eval { $w[1] = wizard get => sub { ++$c[1] }, set => sub { --$c[1] } }; is($@, '', 'wizard 1 creation doesn\'t croak'); eval { $w[2] = wizard get => sub { ++$c[2] }, set => sub { --$c[2] } }; is($@, '', 'wizard 2 creation doesn\'t croak'); multi sub { my ($i) = @_; $w[$i] }, sub { my ($i, $res, $err) = @_; ok(defined $res, "wizard $i is defined"); is(ref $w[$i], 'SCALAR', "wizard $i is a scalar ref"); }; my $a = 0; multi sub { my ($i) = @_; cast $a, $w[$i]; }, sub { my ($i, $res, $err) = @_; is($err, '', "cast magic $i doesn't croak"); ok($res, "cast magic $i is valid"); }; my $b = $a; for (0 .. $n - 1) { is($c[$_], 1, "get magic $_"); } $a = 1; for (0 .. $n - 1) { is($c[$_], 0, "set magic $_"); } my $res = eval { dispell $a, $w[1] }; is($@, '', 'dispell magic 1 doesn\'t croak'); ok($res, 'dispell magic 1 is valid'); $b = $a; for (0, 2) { is($c[$_], 1, "get magic $_ after dispelled 1"); } $a = 2; for (0, 2) { is($c[$_], 0, "set magic $_ after dispelled 1"); } $res = eval { dispell $a, $w[0] }; is($@, '', 'dispell magic 0 doesn\'t croak'); ok($res, 'dispell magic 0 is valid'); $b = $a; is($c[2], 1, 'get magic 2 after dispelled 1 & 0'); $a = 3; is($c[2], 0, 'set magic 2 after dispelled 1 & 0'); $res = eval { dispell $a, $w[2] }; is($@, '', 'dispell magic 2 doesn\'t croak'); ok($res, 'dispell magic 2 is valid'); SKIP: { skip 'No nice uvar magic for this perl' => 41 unless VMG_UVAR; $n = 3; @c = (0) x $n; eval { $w[0] = wizard fetch => sub { ++$c[0] }, store => sub { --$c[0] } }; is($@, '', 'wizard with uvar 0 doesn\'t croak'); eval { $w[1] = wizard fetch => sub { ++$c[1] }, store => sub { --$c[1] } }; is($@, '', 'wizard with uvar 1 doesn\'t croak'); eval { $w[2] = wizard fetch => sub { ++$c[2] }, store => sub { --$c[2] } }; is($@, '', 'wizard with uvar 2 doesn\'t croak'); multi sub { my ($i) = @_; $w[$i] }, sub { my ($i, $res, $err) = @_; ok(defined $res, "wizard with uvar $i is defined"); is(ref $w[$i], 'SCALAR', "wizard with uvar $i is a scalar ref"); }; my %h = (a => 1, b => 2); multi sub { my ($i) = @_; cast %h, $w[$i]; }, sub { my ($i, $res, $err) = @_; is($err, '', "cast uvar magic $i doesn't croak"); ok($res, "cast uvar magic $i is valid"); }; my $s = $h{a}; is($s, 1, 'fetch magic doesn\'t clobber'); for (0 .. $n - 1) { is($c[$_], 1, "fetch magic $_"); } $h{a} = 3; for (0 .. $n - 1) { is($c[$_], 0, "store magic $_"); } is($h{a}, 3, 'store magic doesn\'t clobber'); # $c[$_] == 1 for 0 .. 2 my $res = eval { dispell %h, $w[1] }; is($@, '', 'dispell uvar magic 1 doesn\'t croak'); ok($res, 'dispell uvar magic 1 is valid'); $s = $h{b}; is($s, 2, 'fetch magic after dispelled 1 doesn\'t clobber'); for (0, 2) { is($c[$_], 2, "fetch magic $_ after dispelled 1"); } $h{b} = 4; for (0, 2) { is($c[$_], 1, "store magic $_ after dispelled 1"); } is($h{b}, 4, 'store magic after dispelled 1 doesn\'t clobber'); # $c[$_] == 2 for 0, 2 $res = eval { dispell %h, $w[2] }; is($@, '', 'dispell uvar magic 2 doesn\'t croak'); ok($res, 'dispell uvar magic 2 is valid'); $s = $h{b}; is($s, 4, 'fetch magic after dispelled 1,2 doesn\'t clobber'); for (0) { is($c[$_], 3, "fetch magic $_ after dispelled 1,2"); } $h{b} = 6; for (0) { is($c[$_], 2, "store magic $_ after dispelled 1,2"); } is($h{b}, 6, 'store magic after dispelled 1,2 doesn\'t clobber'); # $c[$_] == 3 for 0 $res = eval { dispell %h, $w[0] }; is($@, '', 'dispell uvar magic 0 doesn\'t croak'); ok($res, 'dispell uvar magic 0 is valid'); $s = $h{b}; is($s, 6, 'fetch magic after dispelled 1,2,0 doesn\'t clobber'); $h{b} = 8; is($h{b}, 8, 'store magic after dispelled 1,2,0 doesn\'t clobber'); } Variable-Magic-0.53/META.json0000640000175000017500000000307312210676250014617 0ustar vincevince{ "abstract" : "Associate user-defined magic to variables from Perl.", "author" : [ "Vincent Pit " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.120921", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Variable-Magic", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "Carp" : "0", "Config" : "0", "Exporter" : "0", "ExtUtils::MakeMaker" : "0", "Test::More" : "0", "XSLoader" : "0", "base" : "0" } }, "configure" : { "requires" : { "Config" : "0", "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Carp" : "0", "Exporter" : "0", "XSLoader" : "0", "base" : "0", "perl" : "5.008" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://rt.cpan.org/Dist/Display.html?Name=Variable-Magic" }, "homepage" : "http://search.cpan.org/dist/Variable-Magic/", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "http://git.profvince.com/?p=perl%2Fmodules%2FVariable-Magic.git" } }, "version" : "0.53" } Variable-Magic-0.53/Magic.xs0000644000175000017500000013332612153113706014601 0ustar vincevince/* This file is part of the Variable::Magic Perl module. * See http://search.cpan.org/dist/Variable-Magic/ */ #include /* , va_{start,arg,end}, ... */ #include /* sprintf() */ #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #define __PACKAGE__ "Variable::Magic" #undef VOID2 #ifdef __cplusplus # define VOID2(T, P) static_cast(P) #else # define VOID2(T, P) (P) #endif #ifndef VMG_PERL_PATCHLEVEL # ifdef PERL_PATCHNUM # define VMG_PERL_PATCHLEVEL PERL_PATCHNUM # else # define VMG_PERL_PATCHLEVEL 0 # endif #endif #define VMG_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) #define VMG_HAS_PERL_BRANCH(R, V, S) (PERL_REVISION == (R) && PERL_VERSION == (V) && PERL_SUBVERSION >= (S)) #define VMG_HAS_PERL_MAINT(R, V, S, P) (PERL_REVISION == (R) && PERL_VERSION == (V) && (VMG_PERL_PATCHLEVEL >= (P) || (!VMG_PERL_PATCHLEVEL && PERL_SUBVERSION >= (S)))) /* --- Threads and multiplicity -------------------------------------------- */ #ifndef NOOP # define NOOP #endif #ifndef dNOOP # define dNOOP #endif /* Safe unless stated otherwise in Makefile.PL */ #ifndef VMG_FORKSAFE # define VMG_FORKSAFE 1 #endif #ifndef VMG_MULTIPLICITY # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT) # define VMG_MULTIPLICITY 1 # else # define VMG_MULTIPLICITY 0 # endif #endif #if VMG_MULTIPLICITY && defined(USE_ITHREADS) && defined(dMY_CXT) && defined(MY_CXT) && defined(START_MY_CXT) && defined(MY_CXT_INIT) && (defined(MY_CXT_CLONE) || defined(dMY_CXT_SV)) # define VMG_THREADSAFE 1 # ifndef MY_CXT_CLONE # define MY_CXT_CLONE \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \ Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) # endif #else # define VMG_THREADSAFE 0 # undef dMY_CXT # define dMY_CXT dNOOP # undef MY_CXT # define MY_CXT vmg_globaldata # undef START_MY_CXT # define START_MY_CXT STATIC my_cxt_t MY_CXT; # undef MY_CXT_INIT # define MY_CXT_INIT NOOP # undef MY_CXT_CLONE # define MY_CXT_CLONE NOOP #endif #if VMG_THREADSAFE # define VMG_LOCK(M) MUTEX_LOCK(M) # define VMG_UNLOCK(M) MUTEX_UNLOCK(M) #else # define VMG_LOCK(M) # define VMG_UNLOCK(M) #endif /* --- Compatibility ------------------------------------------------------- */ #ifndef Newx # define Newx(v, n, c) New(0, v, n, c) #endif #ifndef SvMAGIC_set # define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val)) #endif #ifndef SvRV_const # define SvRV_const(sv) SvRV((SV *) sv) #endif #ifndef SvREFCNT_inc_simple_void # define SvREFCNT_inc_simple_void(sv) ((void) SvREFCNT_inc(sv)) #endif #ifndef mPUSHu # define mPUSHu(U) PUSHs(sv_2mortal(newSVuv(U))) #endif #ifndef PERL_MAGIC_ext # define PERL_MAGIC_ext '~' #endif #ifndef PERL_MAGIC_tied # define PERL_MAGIC_tied 'P' #endif #ifndef MGf_LOCAL # define MGf_LOCAL 0 #endif #ifndef IN_PERL_COMPILETIME # define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) #endif /* uvar magic and Hash::Util::FieldHash were commited with 28419, but we only * enable them on 5.10 */ #if VMG_HAS_PERL(5, 10, 0) # define VMG_UVAR 1 #else # define VMG_UVAR 0 #endif #if VMG_HAS_PERL_MAINT(5, 11, 0, 32969) || VMG_HAS_PERL(5, 12, 0) # define VMG_COMPAT_SCALAR_LENGTH_NOLEN 1 #else # define VMG_COMPAT_SCALAR_LENGTH_NOLEN 0 #endif #if VMG_HAS_PERL(5, 17, 4) # define VMG_COMPAT_SCALAR_NOLEN 1 #else # define VMG_COMPAT_SCALAR_NOLEN 0 #endif /* Applied to dev-5.9 as 25854, integrated to maint-5.8 as 28160, partially * reverted to dev-5.11 as 9cdcb38b */ #if VMG_HAS_PERL_MAINT(5, 8, 9, 28160) || VMG_HAS_PERL_MAINT(5, 9, 3, 25854) || VMG_HAS_PERL(5, 10, 0) # ifndef VMG_COMPAT_ARRAY_PUSH_NOLEN # if VMG_HAS_PERL(5, 11, 0) # define VMG_COMPAT_ARRAY_PUSH_NOLEN 0 # else # define VMG_COMPAT_ARRAY_PUSH_NOLEN 1 # endif # endif # ifndef VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID # define VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID 1 # endif #else # ifndef VMG_COMPAT_ARRAY_PUSH_NOLEN # define VMG_COMPAT_ARRAY_PUSH_NOLEN 0 # endif # ifndef VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID # define VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID 0 # endif #endif /* Applied to dev-5.11 as 34908 */ #if VMG_HAS_PERL_MAINT(5, 11, 0, 34908) || VMG_HAS_PERL(5, 12, 0) # define VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID 1 #else # define VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID 0 #endif /* Applied to dev-5.9 as 31473 (see #43357), integrated to maint-5.8 as 32542 */ #if VMG_HAS_PERL_MAINT(5, 8, 9, 32542) || VMG_HAS_PERL_MAINT(5, 9, 5, 31473) || VMG_HAS_PERL(5, 10, 0) # define VMG_COMPAT_ARRAY_UNDEF_CLEAR 1 #else # define VMG_COMPAT_ARRAY_UNDEF_CLEAR 0 #endif #if VMG_HAS_PERL(5, 11, 0) # define VMG_COMPAT_HASH_DELETE_NOUVAR_VOID 1 #else # define VMG_COMPAT_HASH_DELETE_NOUVAR_VOID 0 #endif #if VMG_HAS_PERL(5, 13, 2) # define VMG_COMPAT_GLOB_GET 1 #else # define VMG_COMPAT_GLOB_GET 0 #endif #define VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE (VMG_HAS_PERL(5, 10, 0) && !VMG_HAS_PERL(5, 10, 1)) /* NewOp() isn't public in perl 5.8.0. */ #define VMG_RESET_RMG_NEEDS_TRAMPOLINE (VMG_UVAR && (VMG_THREADSAFE || !VMG_HAS_PERL(5, 8, 1))) /* ... Bug-free mg_magical ................................................. */ /* See the discussion at http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-01/msg00036.html */ #if VMG_HAS_PERL(5, 11, 3) #define vmg_mg_magical(S) mg_magical(S) #else STATIC void vmg_mg_magical(SV *sv) { const MAGIC *mg; SvMAGICAL_off(sv); if ((mg = SvMAGIC(sv))) { do { const MGVTBL* const vtbl = mg->mg_virtual; if (vtbl) { if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP)) SvGMAGICAL_on(sv); if (vtbl->svt_set) SvSMAGICAL_on(sv); if (vtbl->svt_clear) SvRMAGICAL_on(sv); } } while ((mg = mg->mg_moremagic)); if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG))) SvRMAGICAL_on(sv); } } #endif /* --- Trampoline ops ------------------------------------------------------ */ #define VMG_NEEDS_TRAMPOLINE VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE || VMG_RESET_RMG_NEEDS_TRAMPOLINE #if VMG_NEEDS_TRAMPOLINE typedef struct { OP temp; SVOP target; } vmg_trampoline; STATIC void vmg_trampoline_init(vmg_trampoline *t, OP *(*cb)(pTHX)) { t->temp.op_type = OP_STUB; t->temp.op_ppaddr = 0; t->temp.op_next = (OP *) &t->target; t->temp.op_flags = 0; t->temp.op_private = 0; t->target.op_type = OP_STUB; t->target.op_ppaddr = cb; t->target.op_next = NULL; t->target.op_flags = 0; t->target.op_private = 0; t->target.op_sv = NULL; } STATIC OP *vmg_trampoline_bump(pTHX_ vmg_trampoline *t, SV *sv, OP *o) { #define vmg_trampoline_bump(T, S, O) vmg_trampoline_bump(aTHX_ (T), (S), (O)) t->temp = *o; t->temp.op_next = (OP *) &t->target; t->target.op_sv = sv; t->target.op_next = o->op_next; return &t->temp; } #endif /* VMG_NEEDS_TRAMPOLINE */ /* --- Safe version of call_sv() ------------------------------------------- */ STATIC I32 vmg_call_sv(pTHX_ SV *sv, I32 flags, int (*cleanup)(pTHX_ void *), void *ud) { #define vmg_call_sv(S, F, C, U) vmg_call_sv(aTHX_ (S), (F), (C), (U)) I32 ret, cxix; PERL_CONTEXT saved_cx; SV *old_err = NULL; if (SvTRUE(ERRSV)) { old_err = ERRSV; ERRSV = newSV(0); } cxix = (cxstack_ix < cxstack_max) ? (cxstack_ix + 1) : Perl_cxinc(aTHX); /* The last popped context will be reused by call_sv(), but our callers may * still need its previous value. Back it up so that it isn't clobbered. */ saved_cx = cxstack[cxix]; ret = call_sv(sv, flags | G_EVAL); cxstack[cxix] = saved_cx; if (SvTRUE(ERRSV)) { if (old_err) { sv_setsv(old_err, ERRSV); SvREFCNT_dec(ERRSV); ERRSV = old_err; } if (IN_PERL_COMPILETIME) { if (!PL_in_eval) { if (PL_errors) sv_catsv(PL_errors, ERRSV); else Perl_warn(aTHX_ "%s", SvPV_nolen(ERRSV)); SvCUR_set(ERRSV, 0); } #if VMG_HAS_PERL(5, 10, 0) || defined(PL_parser) if (PL_parser) ++PL_parser->error_count; #elif defined(PL_error_count) ++PL_error_count; #else ++PL_Ierror_count; #endif } else { if (!cleanup || cleanup(aTHX_ ud)) croak(NULL); } } else { if (old_err) { SvREFCNT_dec(ERRSV); ERRSV = old_err; } } return ret; } /* --- Stolen chunk of B --------------------------------------------------- */ typedef enum { OPc_NULL = 0, OPc_BASEOP = 1, OPc_UNOP = 2, OPc_BINOP = 3, OPc_LOGOP = 4, OPc_LISTOP = 5, OPc_PMOP = 6, OPc_SVOP = 7, OPc_PADOP = 8, OPc_PVOP = 9, OPc_LOOP = 10, OPc_COP = 11, OPc_MAX = 12 } opclass; STATIC const char *const vmg_opclassnames[] = { "B::NULL", "B::OP", "B::UNOP", "B::BINOP", "B::LOGOP", "B::LISTOP", "B::PMOP", "B::SVOP", "B::PADOP", "B::PVOP", "B::LOOP", "B::COP" }; STATIC opclass vmg_opclass(const OP *o) { #if 0 if (!o) return OPc_NULL; #endif if (o->op_type == 0) return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP; if (o->op_type == OP_SASSIGN) return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP); if (o->op_type == OP_AELEMFAST) { #if PERL_VERSION <= 14 if (o->op_flags & OPf_SPECIAL) return OPc_BASEOP; else #endif #ifdef USE_ITHREADS return OPc_PADOP; #else return OPc_SVOP; #endif } #ifdef USE_ITHREADS if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_RCATLINE) return OPc_PADOP; #endif switch (PL_opargs[o->op_type] & OA_CLASS_MASK) { case OA_BASEOP: return OPc_BASEOP; case OA_UNOP: return OPc_UNOP; case OA_BINOP: return OPc_BINOP; case OA_LOGOP: return OPc_LOGOP; case OA_LISTOP: return OPc_LISTOP; case OA_PMOP: return OPc_PMOP; case OA_SVOP: return OPc_SVOP; case OA_PADOP: return OPc_PADOP; case OA_PVOP_OR_SVOP: return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF)) ? OPc_SVOP : OPc_PVOP; case OA_LOOP: return OPc_LOOP; case OA_COP: return OPc_COP; case OA_BASEOP_OR_UNOP: return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP; case OA_FILESTATOP: return ((o->op_flags & OPf_KIDS) ? OPc_UNOP : #ifdef USE_ITHREADS (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP); #else (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP); #endif case OA_LOOPEXOP: if (o->op_flags & OPf_STACKED) return OPc_UNOP; else if (o->op_flags & OPf_SPECIAL) return OPc_BASEOP; else return OPc_PVOP; } return OPc_BASEOP; } /* --- Error messages ------------------------------------------------------ */ STATIC const char vmg_invalid_wiz[] = "Invalid wizard object"; STATIC const char vmg_wrongargnum[] = "Wrong number of arguments"; STATIC const char vmg_argstorefailed[] = "Error while storing arguments"; /* --- Context-safe global data -------------------------------------------- */ #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION typedef struct { HV *b__op_stashes[OPc_MAX]; I32 depth; MAGIC *freed_tokens; #if VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE vmg_trampoline propagate_errsv; #endif #if VMG_RESET_RMG_NEEDS_TRAMPOLINE vmg_trampoline reset_rmg; #endif } my_cxt_t; START_MY_CXT /* --- structure ---------------------------------------------- */ #if VMG_THREADSAFE typedef struct { MGVTBL *vtbl; U32 refcount; } vmg_vtable; STATIC vmg_vtable *vmg_vtable_alloc(pTHX) { #define vmg_vtable_alloc() vmg_vtable_alloc(aTHX) vmg_vtable *t; t = VOID2(vmg_vtable *, PerlMemShared_malloc(sizeof *t)); t->vtbl = VOID2(MGVTBL *, PerlMemShared_malloc(sizeof *t->vtbl)); t->refcount = 1; return t; } #define vmg_vtable_vtbl(T) (T)->vtbl STATIC perl_mutex vmg_vtable_refcount_mutex; STATIC vmg_vtable *vmg_vtable_dup(pTHX_ vmg_vtable *t) { #define vmg_vtable_dup(T) vmg_vtable_dup(aTHX_ (T)) VMG_LOCK(&vmg_vtable_refcount_mutex); ++t->refcount; VMG_UNLOCK(&vmg_vtable_refcount_mutex); return t; } STATIC void vmg_vtable_free(pTHX_ vmg_vtable *t) { #define vmg_vtable_free(T) vmg_vtable_free(aTHX_ (T)) U32 refcount; VMG_LOCK(&vmg_vtable_refcount_mutex); refcount = --t->refcount; VMG_UNLOCK(&vmg_vtable_refcount_mutex); if (!refcount) { PerlMemShared_free(t->vtbl); PerlMemShared_free(t); } } #else /* VMG_THREADSAFE */ typedef MGVTBL vmg_vtable; STATIC vmg_vtable *vmg_vtable_alloc(pTHX) { #define vmg_vtable_alloc() vmg_vtable_alloc(aTHX) vmg_vtable *t; Newx(t, 1, vmg_vtable); return t; } #define vmg_vtable_vtbl(T) ((MGVTBL *) (T)) #define vmg_vtable_free(T) Safefree(T) #endif /* !VMG_THREADSAFE */ /* --- structure ---------------------------------------------- */ typedef struct { vmg_vtable *vtable; U8 opinfo; U8 uvar; SV *cb_data; SV *cb_get, *cb_set, *cb_len, *cb_clear, *cb_free; SV *cb_copy; SV *cb_dup; #if MGf_LOCAL SV *cb_local; #endif /* MGf_LOCAL */ #if VMG_UVAR SV *cb_fetch, *cb_store, *cb_exists, *cb_delete; #endif /* VMG_UVAR */ } vmg_wizard; STATIC void vmg_op_info_init(pTHX_ unsigned int opinfo); STATIC vmg_wizard *vmg_wizard_alloc(pTHX_ UV opinfo) { #define vmg_wizard_alloc(O) vmg_wizard_alloc(aTHX_ (O)) vmg_wizard *w; Newx(w, 1, vmg_wizard); w->uvar = 0; w->opinfo = (U8) ((opinfo < 255) ? opinfo : 255); if (w->opinfo) vmg_op_info_init(aTHX_ w->opinfo); w->vtable = vmg_vtable_alloc(); return w; } STATIC void vmg_wizard_free(pTHX_ vmg_wizard *w) { #define vmg_wizard_free(W) vmg_wizard_free(aTHX_ (W)) if (!w) return; /* During global destruction, any of the callbacks may already have been * freed, so we can't rely on still being able to access them. */ if (!PL_dirty) { SvREFCNT_dec(w->cb_data); SvREFCNT_dec(w->cb_get); SvREFCNT_dec(w->cb_set); SvREFCNT_dec(w->cb_len); SvREFCNT_dec(w->cb_clear); SvREFCNT_dec(w->cb_free); SvREFCNT_dec(w->cb_copy); #if 0 SvREFCNT_dec(w->cb_dup); #endif #if MGf_LOCAL SvREFCNT_dec(w->cb_local); #endif /* MGf_LOCAL */ #if VMG_UVAR SvREFCNT_dec(w->cb_fetch); SvREFCNT_dec(w->cb_store); SvREFCNT_dec(w->cb_exists); SvREFCNT_dec(w->cb_delete); #endif /* VMG_UVAR */ } /* PerlMemShared_free() and Safefree() are still fine during global * destruction though. */ vmg_vtable_free(w->vtable); Safefree(w); return; } #if VMG_THREADSAFE #define VMG_CLONE_CB(N) \ z->cb_ ## N = (w->cb_ ## N) ? SvREFCNT_inc(sv_dup(w->cb_ ## N, params)) \ : NULL; STATIC const vmg_wizard *vmg_wizard_dup(pTHX_ const vmg_wizard *w, CLONE_PARAMS *params) { #define vmg_wizard_dup(W, P) vmg_wizard_dup(aTHX_ (W), (P)) vmg_wizard *z; if (!w) return NULL; Newx(z, 1, vmg_wizard); z->vtable = vmg_vtable_dup(w->vtable); z->uvar = w->uvar; z->opinfo = w->opinfo; VMG_CLONE_CB(data); VMG_CLONE_CB(get); VMG_CLONE_CB(set); VMG_CLONE_CB(len); VMG_CLONE_CB(clear); VMG_CLONE_CB(free); VMG_CLONE_CB(copy); VMG_CLONE_CB(dup); #if MGf_LOCAL VMG_CLONE_CB(local); #endif /* MGf_LOCAL */ #if VMG_UVAR VMG_CLONE_CB(fetch); VMG_CLONE_CB(store); VMG_CLONE_CB(exists); VMG_CLONE_CB(delete); #endif /* VMG_UVAR */ return z; } #endif /* VMG_THREADSAFE */ #define vmg_wizard_id(W) PTR2IV(vmg_vtable_vtbl((W)->vtable)) /* --- Wizard SV objects --------------------------------------------------- */ STATIC int vmg_wizard_sv_free(pTHX_ SV *sv, MAGIC *mg) { vmg_wizard_free((vmg_wizard *) mg->mg_ptr); return 0; } #if VMG_THREADSAFE STATIC int vmg_wizard_sv_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *params) { mg->mg_ptr = (char *) vmg_wizard_dup((const vmg_wizard *) mg->mg_ptr, params); return 0; } #endif /* VMG_THREADSAFE */ STATIC MGVTBL vmg_wizard_sv_vtbl = { NULL, /* get */ NULL, /* set */ NULL, /* len */ NULL, /* clear */ vmg_wizard_sv_free, /* free */ NULL, /* copy */ #if VMG_THREADSAFE vmg_wizard_sv_dup, /* dup */ #else NULL, /* dup */ #endif #if MGf_LOCAL NULL, /* local */ #endif /* MGf_LOCAL */ }; STATIC SV *vmg_wizard_sv_new(pTHX_ const vmg_wizard *w) { #define vmg_wizard_sv_new(W) vmg_wizard_sv_new(aTHX_ (W)) SV *wiz; #if VMG_THREADSAFE wiz = newSV(0); #else wiz = newSViv(PTR2IV(w)); #endif if (w) { MAGIC *mg = sv_magicext(wiz, NULL, PERL_MAGIC_ext, &vmg_wizard_sv_vtbl, (const char *) w, 0); mg->mg_private = 0; #if VMG_THREADSAFE mg->mg_flags |= MGf_DUP; #endif } SvREADONLY_on(wiz); return wiz; } #if VMG_THREADSAFE #define vmg_sv_has_wizard_type(S) (SvTYPE(S) >= SVt_PVMG) STATIC const vmg_wizard *vmg_wizard_from_sv_nocheck(const SV *wiz) { MAGIC *mg; for (mg = SvMAGIC(wiz); mg; mg = mg->mg_moremagic) { if (mg->mg_type == PERL_MAGIC_ext && mg->mg_virtual == &vmg_wizard_sv_vtbl) return (const vmg_wizard *) mg->mg_ptr; } return NULL; } #else /* VMG_THREADSAFE */ #define vmg_sv_has_wizard_type(S) SvIOK(S) #define vmg_wizard_from_sv_nocheck(W) INT2PTR(const vmg_wizard *, SvIVX(W)) #endif /* !VMG_THREADSAFE */ #define vmg_wizard_from_sv(W) (vmg_sv_has_wizard_type(W) ? vmg_wizard_from_sv_nocheck(W) : NULL) STATIC const vmg_wizard *vmg_wizard_from_mg(const MAGIC *mg) { if (mg->mg_type == PERL_MAGIC_ext && mg->mg_len == HEf_SVKEY) { SV *sv = (SV *) mg->mg_ptr; if (vmg_sv_has_wizard_type(sv)) return vmg_wizard_from_sv_nocheck(sv); } return NULL; } #define vmg_wizard_from_mg_nocheck(M) vmg_wizard_from_sv_nocheck((const SV *) (M)->mg_ptr) /* --- User-level functions implementation --------------------------------- */ STATIC const MAGIC *vmg_find(const SV *sv, const vmg_wizard *w) { const MAGIC *mg; IV wid; if (SvTYPE(sv) < SVt_PVMG) return NULL; wid = vmg_wizard_id(w); for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { const vmg_wizard *z = vmg_wizard_from_mg(mg); if (z && vmg_wizard_id(z) == wid) return mg; } return NULL; } /* ... Construct private data .............................................. */ STATIC SV *vmg_data_new(pTHX_ SV *ctor, SV *sv, SV **args, I32 items) { #define vmg_data_new(C, S, A, I) vmg_data_new(aTHX_ (C), (S), (A), (I)) I32 i; SV *nsv; dSP; ENTER; SAVETMPS; PUSHMARK(SP); EXTEND(SP, items + 1); PUSHs(sv_2mortal(newRV_inc(sv))); for (i = 0; i < items; ++i) PUSHs(args[i]); PUTBACK; vmg_call_sv(ctor, G_SCALAR, 0, NULL); SPAGAIN; nsv = POPs; #if VMG_HAS_PERL(5, 8, 3) SvREFCNT_inc_simple_void(nsv); /* Or it will be destroyed in FREETMPS */ #else nsv = sv_newref(nsv); /* Workaround some bug in SvREFCNT_inc() */ #endif PUTBACK; FREETMPS; LEAVE; return nsv; } STATIC SV *vmg_data_get(pTHX_ SV *sv, const vmg_wizard *w) { #define vmg_data_get(S, W) vmg_data_get(aTHX_ (S), (W)) const MAGIC *mg = vmg_find(sv, w); return mg ? mg->mg_obj : NULL; } /* ... Magic cast/dispell .................................................. */ #if VMG_UVAR STATIC I32 vmg_svt_val(pTHX_ IV, SV *); typedef struct { struct ufuncs new_uf; struct ufuncs old_uf; } vmg_uvar_ud; #endif /* VMG_UVAR */ STATIC void vmg_mg_del(pTHX_ SV *sv, MAGIC *prevmagic, MAGIC *mg, MAGIC *moremagic) { #define vmg_mg_del(S, P, M, N) vmg_mg_del(aTHX_ (S), (P), (M), (N)) dMY_CXT; if (prevmagic) prevmagic->mg_moremagic = moremagic; else SvMAGIC_set(sv, moremagic); /* Destroy private data */ #if VMG_UVAR if (mg->mg_type == PERL_MAGIC_uvar) { Safefree(mg->mg_ptr); } else { #endif /* VMG_UVAR */ if (mg->mg_obj != sv) { SvREFCNT_dec(mg->mg_obj); mg->mg_obj = NULL; } /* Unreference the wizard */ SvREFCNT_dec((SV *) mg->mg_ptr); mg->mg_ptr = NULL; #if VMG_UVAR } #endif /* VMG_UVAR */ if (MY_CXT.depth) { mg->mg_moremagic = MY_CXT.freed_tokens; MY_CXT.freed_tokens = mg; } else { mg->mg_moremagic = NULL; Safefree(mg); } } STATIC int vmg_magic_chain_free(pTHX_ MAGIC *mg, MAGIC *skip) { #define vmg_magic_chain_free(M, S) vmg_magic_chain_free(aTHX_ (M), (S)) int skipped = 0; while (mg) { MAGIC *moremagic = mg->mg_moremagic; if (mg == skip) ++skipped; else Safefree(mg); mg = moremagic; } return skipped; } STATIC UV vmg_cast(pTHX_ SV *sv, const vmg_wizard *w, const SV *wiz, SV **args, I32 items) { #define vmg_cast(S, W, WIZ, A, I) vmg_cast(aTHX_ (S), (W), (WIZ), (A), (I)) MAGIC *mg; MGVTBL *t; SV *data; U32 oldgmg; if (vmg_find(sv, w)) return 1; oldgmg = SvGMAGICAL(sv); data = (w->cb_data) ? vmg_data_new(w->cb_data, sv, args, items) : NULL; t = vmg_vtable_vtbl(w->vtable); mg = sv_magicext(sv, data, PERL_MAGIC_ext, t, (const char *) wiz, HEf_SVKEY); mg->mg_private = 0; /* sv_magicext() calls mg_magical and increments data's refcount */ SvREFCNT_dec(data); if (t->svt_copy) mg->mg_flags |= MGf_COPY; #if 0 if (t->svt_dup) mg->mg_flags |= MGf_DUP; #endif #if MGf_LOCAL if (t->svt_local) mg->mg_flags |= MGf_LOCAL; #endif /* MGf_LOCAL */ if (SvTYPE(sv) < SVt_PVHV) goto done; /* The GMAGICAL flag only says that a hash is tied or has uvar magic - get * magic is actually never called for them. If the GMAGICAL flag was off before * calling sv_magicext(), the hash isn't tied and has no uvar magic. If it's * now on, then this wizard has get magic. Hence we can work around the * get/clear shortcoming by turning the GMAGICAL flag off. If the current magic * has uvar callbacks, it will be turned back on later. */ if (!oldgmg && SvGMAGICAL(sv)) SvGMAGICAL_off(sv); #if VMG_UVAR if (w->uvar) { MAGIC *prevmagic, *moremagic = NULL; vmg_uvar_ud ud; ud.new_uf.uf_val = vmg_svt_val; ud.new_uf.uf_set = NULL; ud.new_uf.uf_index = 0; ud.old_uf.uf_val = NULL; ud.old_uf.uf_set = NULL; ud.old_uf.uf_index = 0; /* One uvar magic in the chain is enough. */ for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic) { moremagic = mg->mg_moremagic; if (mg->mg_type == PERL_MAGIC_uvar) break; } if (mg) { /* Found another uvar magic. */ struct ufuncs *uf = (struct ufuncs *) mg->mg_ptr; if (uf->uf_val == vmg_svt_val) { /* It's our uvar magic, nothing to do. oldgmg was true. */ goto done; } else { /* It's another uvar magic, backup it and replace it by ours. */ ud.old_uf = *uf; vmg_mg_del(sv, prevmagic, mg, moremagic); } } sv_magic(sv, NULL, PERL_MAGIC_uvar, (const char *) &ud, sizeof(ud)); vmg_mg_magical(sv); /* Our hash now carries uvar magic. The uvar/clear shortcoming has to be * handled by our uvar callback. */ } #endif /* VMG_UVAR */ done: return 1; } STATIC UV vmg_dispell(pTHX_ SV *sv, const vmg_wizard *w) { #define vmg_dispell(S, W) vmg_dispell(aTHX_ (S), (W)) #if VMG_UVAR U32 uvars = 0; #endif /* VMG_UVAR */ MAGIC *mg, *prevmagic, *moremagic = NULL; IV wid = vmg_wizard_id(w); if (SvTYPE(sv) < SVt_PVMG) return 0; for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic) { const vmg_wizard *z; moremagic = mg->mg_moremagic; z = vmg_wizard_from_mg(mg); if (z) { IV zid = vmg_wizard_id(z); #if VMG_UVAR if (zid == wid) { /* If the current has no uvar, short-circuit uvar deletion. */ uvars = z->uvar ? (uvars + 1) : 0; break; } else if (z->uvar) { ++uvars; /* We can't break here since we need to find the ext magic to delete. */ } #else /* VMG_UVAR */ if (zid == wid) break; #endif /* !VMG_UVAR */ } } if (!mg) return 0; vmg_mg_del(sv, prevmagic, mg, moremagic); #if VMG_UVAR if (uvars == 1 && SvTYPE(sv) >= SVt_PVHV) { /* mg was the first ext magic in the chain that had uvar */ for (mg = moremagic; mg; mg = mg->mg_moremagic) { const vmg_wizard *z = vmg_wizard_from_mg(mg); if (z && z->uvar) { ++uvars; break; } } if (uvars == 1) { vmg_uvar_ud *ud; for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic){ moremagic = mg->mg_moremagic; if (mg->mg_type == PERL_MAGIC_uvar) break; } ud = (vmg_uvar_ud *) mg->mg_ptr; if (ud->old_uf.uf_val || ud->old_uf.uf_set) { /* Revert the original uvar magic. */ struct ufuncs *uf; Newx(uf, 1, struct ufuncs); *uf = ud->old_uf; Safefree(ud); mg->mg_ptr = (char *) uf; mg->mg_len = sizeof(*uf); } else { /* Remove the uvar magic. */ vmg_mg_del(sv, prevmagic, mg, moremagic); } } } #endif /* VMG_UVAR */ vmg_mg_magical(sv); return 1; } /* ... OP info ............................................................. */ #define VMG_OP_INFO_NAME 1 #define VMG_OP_INFO_OBJECT 2 #if VMG_THREADSAFE STATIC perl_mutex vmg_op_name_init_mutex; #endif STATIC U32 vmg_op_name_init = 0; STATIC unsigned char vmg_op_name_len[MAXO] = { 0 }; STATIC void vmg_op_info_init(pTHX_ unsigned int opinfo) { #define vmg_op_info_init(W) vmg_op_info_init(aTHX_ (W)) switch (opinfo) { case VMG_OP_INFO_NAME: VMG_LOCK(&vmg_op_name_init_mutex); if (!vmg_op_name_init) { OPCODE t; for (t = 0; t < OP_max; ++t) vmg_op_name_len[t] = strlen(PL_op_name[t]); vmg_op_name_init = 1; } VMG_UNLOCK(&vmg_op_name_init_mutex); break; case VMG_OP_INFO_OBJECT: { dMY_CXT; if (!MY_CXT.b__op_stashes[0]) { int c; require_pv("B.pm"); for (c = OPc_NULL; c < OPc_MAX; ++c) MY_CXT.b__op_stashes[c] = gv_stashpv(vmg_opclassnames[c], 1); } break; } default: break; } } STATIC SV *vmg_op_info(pTHX_ unsigned int opinfo) { #define vmg_op_info(W) vmg_op_info(aTHX_ (W)) if (!PL_op) return &PL_sv_undef; switch (opinfo) { case VMG_OP_INFO_NAME: { OPCODE t = PL_op->op_type; return sv_2mortal(newSVpvn(PL_op_name[t], vmg_op_name_len[t])); } case VMG_OP_INFO_OBJECT: { dMY_CXT; return sv_bless(sv_2mortal(newRV_noinc(newSViv(PTR2IV(PL_op)))), MY_CXT.b__op_stashes[vmg_opclass(PL_op)]); } default: break; } return &PL_sv_undef; } /* --- svt callbacks ------------------------------------------------------- */ #define VMG_CB_CALL_ARGS_MASK 15 #define VMG_CB_CALL_ARGS_SHIFT 4 #define VMG_CB_CALL_OPINFO (VMG_OP_INFO_NAME|VMG_OP_INFO_OBJECT) /* 1|2 */ #define VMG_CB_CALL_GUARD 4 STATIC int vmg_dispell_guard_oncroak(pTHX_ void *ud) { dMY_CXT; MY_CXT.depth--; /* If we're at the upmost magic call and we're about to die, we can just free * the tokens right now, since we will jump past the problematic part of our * caller. */ if (MY_CXT.depth == 0 && MY_CXT.freed_tokens) { vmg_magic_chain_free(MY_CXT.freed_tokens, NULL); MY_CXT.freed_tokens = NULL; } return 1; } STATIC int vmg_dispell_guard_free(pTHX_ SV *sv, MAGIC *mg) { vmg_magic_chain_free((MAGIC *) mg->mg_ptr, NULL); return 0; } #if VMG_THREADSAFE STATIC int vmg_dispell_guard_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *params) { /* The freed magic tokens aren't cloned by perl because it cannot reach them * (they have been detached from their parent SV when they were enqueued). * Hence there's nothing to purge in the new thread. */ mg->mg_ptr = NULL; return 0; } #endif /* VMG_THREADSAFE */ STATIC MGVTBL vmg_dispell_guard_vtbl = { NULL, /* get */ NULL, /* set */ NULL, /* len */ NULL, /* clear */ vmg_dispell_guard_free, /* free */ NULL, /* copy */ #if VMG_THREADSAFE vmg_dispell_guard_dup, /* dup */ #else NULL, /* dup */ #endif #if MGf_LOCAL NULL, /* local */ #endif /* MGf_LOCAL */ }; STATIC SV *vmg_dispell_guard_new(pTHX_ MAGIC *root) { #define vmg_dispell_guard_new(R) vmg_dispell_guard_new(aTHX_ (R)) SV *guard; guard = sv_newmortal(); sv_magicext(guard, NULL, PERL_MAGIC_ext, &vmg_dispell_guard_vtbl, (char *) root, 0); return guard; } STATIC int vmg_cb_call(pTHX_ SV *cb, unsigned int flags, SV *sv, ...) { va_list ap; int ret = 0; unsigned int i, args, opinfo; MAGIC **chain = NULL; SV *svr; dSP; args = flags & VMG_CB_CALL_ARGS_MASK; flags >>= VMG_CB_CALL_ARGS_SHIFT; opinfo = flags & VMG_CB_CALL_OPINFO; ENTER; SAVETMPS; PUSHMARK(SP); EXTEND(SP, args + 1); PUSHs(sv_2mortal(newRV_inc(sv))); va_start(ap, sv); for (i = 0; i < args; ++i) { SV *sva = va_arg(ap, SV *); PUSHs(sva ? sva : &PL_sv_undef); } va_end(ap); if (opinfo) XPUSHs(vmg_op_info(opinfo)); PUTBACK; if (flags & VMG_CB_CALL_GUARD) { dMY_CXT; MY_CXT.depth++; vmg_call_sv(cb, G_SCALAR, vmg_dispell_guard_oncroak, NULL); MY_CXT.depth--; if (MY_CXT.depth == 0 && MY_CXT.freed_tokens) chain = &MY_CXT.freed_tokens; } else { vmg_call_sv(cb, G_SCALAR, 0, NULL); } SPAGAIN; svr = POPs; if (SvOK(svr)) ret = (int) SvIV(svr); PUTBACK; FREETMPS; LEAVE; if (chain) { vmg_dispell_guard_new(*chain); *chain = NULL; } return ret; } #define VMG_CB_FLAGS(OI, A) \ ((((unsigned int) (OI)) << VMG_CB_CALL_ARGS_SHIFT) | (A)) #define vmg_cb_call1(I, OI, S, A1) \ vmg_cb_call(aTHX_ (I), VMG_CB_FLAGS((OI), 1), (S), (A1)) #define vmg_cb_call2(I, OI, S, A1, A2) \ vmg_cb_call(aTHX_ (I), VMG_CB_FLAGS((OI), 2), (S), (A1), (A2)) #define vmg_cb_call3(I, OI, S, A1, A2, A3) \ vmg_cb_call(aTHX_ (I), VMG_CB_FLAGS((OI), 3), (S), (A1), (A2), (A3)) /* ... Default no-op magic callback ........................................ */ STATIC int vmg_svt_default_noop(pTHX_ SV *sv, MAGIC *mg) { return 0; } /* ... get magic ........................................................... */ STATIC int vmg_svt_get(pTHX_ SV *sv, MAGIC *mg) { const vmg_wizard *w = vmg_wizard_from_mg_nocheck(mg); return vmg_cb_call1(w->cb_get, w->opinfo, sv, mg->mg_obj); } #define vmg_svt_get_noop vmg_svt_default_noop /* ... set magic ........................................................... */ STATIC int vmg_svt_set(pTHX_ SV *sv, MAGIC *mg) { const vmg_wizard *w = vmg_wizard_from_mg_nocheck(mg); return vmg_cb_call1(w->cb_set, w->opinfo, sv, mg->mg_obj); } #define vmg_svt_set_noop vmg_svt_default_noop /* ... len magic ........................................................... */ STATIC U32 vmg_sv_len(pTHX_ SV *sv) { #define vmg_sv_len(S) vmg_sv_len(aTHX_ (S)) STRLEN len; #if VMG_HAS_PERL(5, 9, 3) const U8 *s = VOID2(const U8 *, VOID2(const void *, SvPV_const(sv, len))); #else U8 *s = SvPV(sv, len); #endif return DO_UTF8(sv) ? utf8_length(s, s + len) : len; } STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) { const vmg_wizard *w = vmg_wizard_from_mg_nocheck(mg); unsigned int opinfo = w->opinfo; U32 len, ret; SV *svr; svtype t = SvTYPE(sv); dSP; ENTER; SAVETMPS; PUSHMARK(SP); EXTEND(SP, 3); PUSHs(sv_2mortal(newRV_inc(sv))); PUSHs(mg->mg_obj ? mg->mg_obj : &PL_sv_undef); if (t < SVt_PVAV) { len = vmg_sv_len(sv); mPUSHu(len); } else if (t == SVt_PVAV) { len = av_len((AV *) sv) + 1; mPUSHu(len); } else { len = 0; PUSHs(&PL_sv_undef); } if (opinfo) XPUSHs(vmg_op_info(opinfo)); PUTBACK; vmg_call_sv(w->cb_len, G_SCALAR, 0, NULL); SPAGAIN; svr = POPs; ret = SvOK(svr) ? (U32) SvUV(svr) : len; if (t == SVt_PVAV) --ret; PUTBACK; FREETMPS; LEAVE; return ret; } STATIC U32 vmg_svt_len_noop(pTHX_ SV *sv, MAGIC *mg) { U32 len = 0; svtype t = SvTYPE(sv); if (t < SVt_PVAV) { len = vmg_sv_len(sv); } else if (t == SVt_PVAV) { len = (U32) av_len((AV *) sv); } return len; } /* ... clear magic ......................................................... */ STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) { const vmg_wizard *w = vmg_wizard_from_mg_nocheck(mg); unsigned int flags = w->opinfo; #if !VMG_HAS_PERL(5, 12, 0) flags |= VMG_CB_CALL_GUARD; #endif return vmg_cb_call1(w->cb_clear, flags, sv, mg->mg_obj); } #define vmg_svt_clear_noop vmg_svt_default_noop /* ... free magic .......................................................... */ #if VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE STATIC OP *vmg_pp_propagate_errsv(pTHX) { SVOP *o = cSVOPx(PL_op); if (o->op_sv) { SvREFCNT_dec(ERRSV); ERRSV = o->op_sv; o->op_sv = NULL; } return NORMAL; } #endif /* VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE */ STATIC int vmg_propagate_errsv_free(pTHX_ SV *sv, MAGIC *mg) { if (mg->mg_obj) { ERRSV = mg->mg_obj; mg->mg_obj = NULL; mg->mg_flags &= ~MGf_REFCOUNTED; } return 0; } /* perl is already kind enough to handle the cloning of the mg_obj member, hence we don't need to define a dup magic callback. */ STATIC MGVTBL vmg_propagate_errsv_vtbl = { 0, /* get */ 0, /* set */ 0, /* len */ 0, /* clear */ vmg_propagate_errsv_free, /* free */ 0, /* copy */ 0, /* dup */ #if MGf_LOCAL 0, /* local */ #endif /* MGf_LOCAL */ }; typedef struct { SV *sv; int in_eval; I32 base; } vmg_svt_free_cleanup_ud; STATIC int vmg_svt_free_cleanup(pTHX_ void *ud_) { vmg_svt_free_cleanup_ud *ud = VOID2(vmg_svt_free_cleanup_ud *, ud_); if (ud->in_eval) { U32 optype = PL_op ? PL_op->op_type : OP_NULL; if (optype == OP_LEAVETRY || optype == OP_LEAVEEVAL) { SV *errsv = newSVsv(ERRSV); FREETMPS; LEAVE_SCOPE(ud->base); #if VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE if (optype == OP_LEAVETRY) { dMY_CXT; PL_op = vmg_trampoline_bump(&MY_CXT.propagate_errsv, errsv, PL_op); } else if (optype == OP_LEAVEEVAL) { SV *guard = sv_newmortal(); sv_magicext(guard, errsv, PERL_MAGIC_ext, &vmg_propagate_errsv_vtbl, NULL, 0); } #else /* !VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE */ # if !VMG_HAS_PERL(5, 8, 9) { SV *guard = sv_newmortal(); sv_magicext(guard, errsv, PERL_MAGIC_ext, &vmg_propagate_errsv_vtbl, NULL, 0); } # else sv_magicext(ERRSV, errsv, PERL_MAGIC_ext, &vmg_propagate_errsv_vtbl, NULL, 0); SvREFCNT_dec(errsv); # endif #endif /* VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE */ SAVETMPS; } /* Don't propagate */ return 0; } else { SV *sv = ud->sv; MAGIC *mg; /* We are about to croak() while sv is being destroyed. Try to clean up * things a bit. */ mg = SvMAGIC(sv); if (mg) { vmg_mg_del(sv, NULL, mg, mg->mg_moremagic); mg_magical(sv); } SvREFCNT_dec(sv); vmg_dispell_guard_oncroak(aTHX_ NULL); /* After that, propagate the error upwards. */ return 1; } } STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) { vmg_svt_free_cleanup_ud ud; const vmg_wizard *w; int ret = 0; SV *svr; dSP; /* During global destruction, we cannot be sure that the wizard and its free * callback are still alive. */ if (PL_dirty) return 0; w = vmg_wizard_from_mg_nocheck(mg); /* So that it survives the temp cleanup below */ SvREFCNT_inc_simple_void(sv); #if !(VMG_HAS_PERL_MAINT(5, 11, 0, 32686) || VMG_HAS_PERL(5, 12, 0)) /* The previous magic tokens were freed but the magic chain wasn't updated, so * if you access the sv from the callback the old deleted magics will trigger * and cause memory misreads. Change 32686 solved it that way : */ SvMAGIC_set(sv, mg); #endif ud.sv = sv; if (cxstack_ix < cxstack_max) { ud.in_eval = (CxTYPE(cxstack + cxstack_ix + 1) == CXt_EVAL); ud.base = ud.in_eval ? PL_scopestack[PL_scopestack_ix] : 0; } else { ud.in_eval = 0; ud.base = 0; } ENTER; SAVETMPS; PUSHMARK(SP); EXTEND(SP, 2); PUSHs(sv_2mortal(newRV_inc(sv))); PUSHs(mg->mg_obj ? mg->mg_obj : &PL_sv_undef); if (w->opinfo) XPUSHs(vmg_op_info(w->opinfo)); PUTBACK; { dMY_CXT; MY_CXT.depth++; vmg_call_sv(w->cb_free, G_SCALAR, vmg_svt_free_cleanup, &ud); MY_CXT.depth--; if (MY_CXT.depth == 0 && MY_CXT.freed_tokens) { /* Free all the tokens in the chain but the current one (if it's present). * It will be taken care of by our caller, Perl_mg_free(). */ vmg_magic_chain_free(MY_CXT.freed_tokens, mg); MY_CXT.freed_tokens = NULL; } } SPAGAIN; svr = POPs; if (SvOK(svr)) ret = (int) SvIV(svr); PUTBACK; FREETMPS; LEAVE; /* Calling SvREFCNT_dec() will trigger destructors in an infinite loop, so * we have to rely on SvREFCNT() being a lvalue. Heck, even the core does it */ --SvREFCNT(sv); /* Perl_mg_free will get rid of the magic and decrement mg->mg_obj and * mg->mg_ptr reference count */ return ret; } #define vmg_svt_free_noop vmg_svt_default_noop #if VMG_HAS_PERL_MAINT(5, 11, 0, 33256) || VMG_HAS_PERL(5, 12, 0) # define VMG_SVT_COPY_KEYLEN_TYPE I32 #else # define VMG_SVT_COPY_KEYLEN_TYPE int #endif /* ... copy magic .......................................................... */ STATIC int vmg_svt_copy(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *key, VMG_SVT_COPY_KEYLEN_TYPE keylen) { const vmg_wizard *w = vmg_wizard_from_mg_nocheck(mg); SV *keysv; int ret; if (keylen == HEf_SVKEY) { keysv = (SV *) key; } else { keysv = newSVpvn(key, keylen); } ret = vmg_cb_call3(w->cb_copy, w->opinfo, sv, mg->mg_obj, keysv, nsv); if (keylen != HEf_SVKEY) { SvREFCNT_dec(keysv); } return ret; } STATIC int vmg_svt_copy_noop(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *key, VMG_SVT_COPY_KEYLEN_TYPE keylen) { return 0; } /* ... dup magic ........................................................... */ #if 0 STATIC int vmg_svt_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) { return 0; } #define vmg_svt_dup_noop vmg_svt_dup #endif /* ... local magic ......................................................... */ #if MGf_LOCAL STATIC int vmg_svt_local(pTHX_ SV *nsv, MAGIC *mg) { const vmg_wizard *w = vmg_wizard_from_mg_nocheck(mg); return vmg_cb_call1(w->cb_local, w->opinfo, nsv, mg->mg_obj); } #define vmg_svt_local_noop vmg_svt_default_noop #endif /* MGf_LOCAL */ /* ... uvar magic .......................................................... */ #if VMG_UVAR STATIC OP *vmg_pp_reset_rmg(pTHX) { SVOP *o = cSVOPx(PL_op); SvRMAGICAL_on(o->op_sv); o->op_sv = NULL; return NORMAL; } STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) { vmg_uvar_ud *ud; MAGIC *mg, *umg, *moremagic; SV *key = NULL, *newkey = NULL; int tied = 0; umg = mg_find(sv, PERL_MAGIC_uvar); /* umg can't be NULL or we wouldn't be there. */ key = umg->mg_obj; ud = (vmg_uvar_ud *) umg->mg_ptr; if (ud->old_uf.uf_val) ud->old_uf.uf_val(aTHX_ action, sv); if (ud->old_uf.uf_set) ud->old_uf.uf_set(aTHX_ action, sv); for (mg = SvMAGIC(sv); mg; mg = moremagic) { const vmg_wizard *w; /* mg may be freed later by the uvar call, so we need to fetch the next * token before reaching that fateful point. */ moremagic = mg->mg_moremagic; switch (mg->mg_type) { case PERL_MAGIC_ext: break; case PERL_MAGIC_tied: ++tied; continue; default: continue; } w = vmg_wizard_from_mg(mg); if (!w) continue; switch (w->uvar) { case 0: continue; case 2: if (!newkey) newkey = key = umg->mg_obj = sv_mortalcopy(umg->mg_obj); } switch (action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS|HV_FETCH_LVALUE|HV_DELETE)) { case 0: if (w->cb_fetch) vmg_cb_call2(w->cb_fetch, w->opinfo | VMG_CB_CALL_GUARD, sv, mg->mg_obj, key); break; case HV_FETCH_ISSTORE: case HV_FETCH_LVALUE: case (HV_FETCH_ISSTORE|HV_FETCH_LVALUE): if (w->cb_store) vmg_cb_call2(w->cb_store, w->opinfo | VMG_CB_CALL_GUARD, sv, mg->mg_obj, key); break; case HV_FETCH_ISEXISTS: if (w->cb_exists) vmg_cb_call2(w->cb_exists, w->opinfo | VMG_CB_CALL_GUARD, sv, mg->mg_obj, key); break; case HV_DELETE: if (w->cb_delete) vmg_cb_call2(w->cb_delete, w->opinfo | VMG_CB_CALL_GUARD, sv, mg->mg_obj, key); break; } } if (SvRMAGICAL(sv) && !tied && !(action & (HV_FETCH_ISSTORE|HV_DELETE))) { /* Temporarily hide the RMAGICAL flag of the hash so it isn't wrongly * mistaken for a tied hash by the rest of hv_common. It will be reset by * the op_ppaddr of a new fake op injected between the current and the next * one. */ #if VMG_RESET_RMG_NEEDS_TRAMPOLINE dMY_CXT; PL_op = vmg_trampoline_bump(&MY_CXT.reset_rmg, sv, PL_op); #else /* !VMG_RESET_RMG_NEEDS_TRAMPOLINE */ OP *nop = PL_op->op_next; SVOP *svop = NULL; if (nop && nop->op_ppaddr == vmg_pp_reset_rmg) { svop = (SVOP *) nop; } else { NewOp(1101, svop, 1, SVOP); svop->op_type = OP_STUB; svop->op_ppaddr = vmg_pp_reset_rmg; svop->op_next = nop; svop->op_flags = 0; svop->op_private = 0; PL_op->op_next = (OP *) svop; } svop->op_sv = sv; #endif /* VMG_RESET_RMG_NEEDS_TRAMPOLINE */ SvRMAGICAL_off(sv); } return 0; } #endif /* VMG_UVAR */ /* --- Macros for the XS section ------------------------------------------- */ #ifdef CvISXSUB # define VMG_CVOK(C) \ ((CvISXSUB(C) ? (void *) CvXSUB(C) : (void *) CvROOT(C)) ? 1 : 0) #else # define VMG_CVOK(C) (CvROOT(C) || CvXSUB(C)) #endif #define VMG_CBOK(S) ((SvTYPE(S) == SVt_PVCV) ? VMG_CVOK(S) : SvOK(S)) #define VMG_SET_CB(S, N) { \ SV *cb = (S); \ if (SvOK(cb) && SvROK(cb)) { \ cb = SvRV(cb); \ if (VMG_CBOK(cb)) \ SvREFCNT_inc_simple_void(cb); \ else \ cb = NULL; \ } else { \ cb = NULL; \ } \ w->cb_ ## N = cb; \ } #define VMG_SET_SVT_CB(S, N) { \ SV *cb = (S); \ if (SvOK(cb) && SvROK(cb)) { \ cb = SvRV(cb); \ if (VMG_CBOK(cb)) { \ t->svt_ ## N = vmg_svt_ ## N; \ SvREFCNT_inc_simple_void(cb); \ } else { \ t->svt_ ## N = vmg_svt_ ## N ## _noop; \ cb = NULL; \ } \ } else { \ t->svt_ ## N = NULL; \ cb = NULL; \ } \ w->cb_ ## N = cb; \ } /* --- XS ------------------------------------------------------------------ */ MODULE = Variable::Magic PACKAGE = Variable::Magic PROTOTYPES: ENABLE BOOT: { HV *stash; int c; MY_CXT_INIT; for (c = OPc_NULL; c < OPc_MAX; ++c) MY_CXT.b__op_stashes[c] = NULL; MY_CXT.depth = 0; MY_CXT.freed_tokens = NULL; /* XS doesn't like a blank line here */ #if VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE vmg_trampoline_init(&MY_CXT.propagate_errsv, vmg_pp_propagate_errsv); #endif #if VMG_RESET_RMG_NEEDS_TRAMPOLINE vmg_trampoline_init(&MY_CXT.reset_rmg, vmg_pp_reset_rmg); #endif /* XS doesn't like a blank line here */ #if VMG_THREADSAFE MUTEX_INIT(&vmg_vtable_refcount_mutex); MUTEX_INIT(&vmg_op_name_init_mutex); #endif stash = gv_stashpv(__PACKAGE__, 1); newCONSTSUB(stash, "MGf_COPY", newSVuv(MGf_COPY)); newCONSTSUB(stash, "MGf_DUP", newSVuv(MGf_DUP)); newCONSTSUB(stash, "MGf_LOCAL", newSVuv(MGf_LOCAL)); newCONSTSUB(stash, "VMG_UVAR", newSVuv(VMG_UVAR)); newCONSTSUB(stash, "VMG_COMPAT_SCALAR_LENGTH_NOLEN", newSVuv(VMG_COMPAT_SCALAR_LENGTH_NOLEN)); newCONSTSUB(stash, "VMG_COMPAT_SCALAR_NOLEN", newSVuv(VMG_COMPAT_SCALAR_NOLEN)); newCONSTSUB(stash, "VMG_COMPAT_ARRAY_PUSH_NOLEN", newSVuv(VMG_COMPAT_ARRAY_PUSH_NOLEN)); newCONSTSUB(stash, "VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID", newSVuv(VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID)); newCONSTSUB(stash, "VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID", newSVuv(VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID)); newCONSTSUB(stash, "VMG_COMPAT_ARRAY_UNDEF_CLEAR", newSVuv(VMG_COMPAT_ARRAY_UNDEF_CLEAR)); newCONSTSUB(stash, "VMG_COMPAT_HASH_DELETE_NOUVAR_VOID", newSVuv(VMG_COMPAT_HASH_DELETE_NOUVAR_VOID)); newCONSTSUB(stash, "VMG_COMPAT_GLOB_GET", newSVuv(VMG_COMPAT_GLOB_GET)); newCONSTSUB(stash, "VMG_PERL_PATCHLEVEL", newSVuv(VMG_PERL_PATCHLEVEL)); newCONSTSUB(stash, "VMG_THREADSAFE", newSVuv(VMG_THREADSAFE)); newCONSTSUB(stash, "VMG_FORKSAFE", newSVuv(VMG_FORKSAFE)); newCONSTSUB(stash, "VMG_OP_INFO_NAME", newSVuv(VMG_OP_INFO_NAME)); newCONSTSUB(stash, "VMG_OP_INFO_OBJECT", newSVuv(VMG_OP_INFO_OBJECT)); } #if VMG_THREADSAFE void CLONE(...) PROTOTYPE: DISABLE PREINIT: U32 had_b__op_stash = 0; I32 old_depth; int c; PPCODE: { dMY_CXT; for (c = OPc_NULL; c < OPc_MAX; ++c) { if (MY_CXT.b__op_stashes[c]) had_b__op_stash |= (((U32) 1) << c); } old_depth = MY_CXT.depth; } { MY_CXT_CLONE; for (c = OPc_NULL; c < OPc_MAX; ++c) { MY_CXT.b__op_stashes[c] = (had_b__op_stash & (((U32) 1) << c)) ? gv_stashpv(vmg_opclassnames[c], 1) : NULL; } MY_CXT.depth = old_depth; MY_CXT.freed_tokens = NULL; } XSRETURN(0); #endif /* VMG_THREADSAFE */ SV *_wizard(...) PROTOTYPE: DISABLE PREINIT: vmg_wizard *w; MGVTBL *t; SV *op_info, *copy_key; I32 i = 0; CODE: if (items != 9 #if MGf_LOCAL + 1 #endif /* MGf_LOCAL */ #if VMG_UVAR + 5 #endif /* VMG_UVAR */ ) { croak(vmg_wrongargnum); } op_info = ST(i++); w = vmg_wizard_alloc(SvOK(op_info) ? SvUV(op_info) : 0); t = vmg_vtable_vtbl(w->vtable); VMG_SET_CB(ST(i++), data); VMG_SET_SVT_CB(ST(i++), get); VMG_SET_SVT_CB(ST(i++), set); VMG_SET_SVT_CB(ST(i++), len); VMG_SET_SVT_CB(ST(i++), clear); VMG_SET_SVT_CB(ST(i++), free); VMG_SET_SVT_CB(ST(i++), copy); /* VMG_SET_SVT_CB(ST(i++), dup); */ i++; t->svt_dup = NULL; w->cb_dup = NULL; #if MGf_LOCAL VMG_SET_SVT_CB(ST(i++), local); #endif /* MGf_LOCAL */ #if VMG_UVAR VMG_SET_CB(ST(i++), fetch); VMG_SET_CB(ST(i++), store); VMG_SET_CB(ST(i++), exists); VMG_SET_CB(ST(i++), delete); copy_key = ST(i++); if (w->cb_fetch || w->cb_store || w->cb_exists || w->cb_delete) w->uvar = SvTRUE(copy_key) ? 2 : 1; #endif /* VMG_UVAR */ RETVAL = newRV_noinc(vmg_wizard_sv_new(w)); OUTPUT: RETVAL SV *cast(SV *sv, SV *wiz, ...) PROTOTYPE: \[$@%&*]$@ PREINIT: const vmg_wizard *w = NULL; SV **args = NULL; I32 i = 0; CODE: if (items > 2) { i = items - 2; args = &ST(2); } if (SvROK(wiz)) { wiz = SvRV_const(wiz); w = vmg_wizard_from_sv(wiz); } if (!w) croak(vmg_invalid_wiz); RETVAL = newSVuv(vmg_cast(SvRV(sv), w, wiz, args, i)); OUTPUT: RETVAL void getdata(SV *sv, SV *wiz) PROTOTYPE: \[$@%&*]$ PREINIT: const vmg_wizard *w = NULL; SV *data; PPCODE: if (SvROK(wiz)) w = vmg_wizard_from_sv(SvRV_const(wiz)); if (!w) croak(vmg_invalid_wiz); data = vmg_data_get(SvRV(sv), w); if (!data) XSRETURN_EMPTY; ST(0) = data; XSRETURN(1); SV *dispell(SV *sv, SV *wiz) PROTOTYPE: \[$@%&*]$ PREINIT: const vmg_wizard *w = NULL; CODE: if (SvROK(wiz)) w = vmg_wizard_from_sv(SvRV_const(wiz)); if (!w) croak(vmg_invalid_wiz); RETVAL = newSVuv(vmg_dispell(SvRV(sv), w)); OUTPUT: RETVAL Variable-Magic-0.53/README0000644000175000017500000005301212210676251014061 0ustar vincevinceNAME Variable::Magic - Associate user-defined magic to variables from Perl. VERSION Version 0.53 SYNOPSIS use Variable::Magic qw; { # A variable tracer my $wiz = wizard( set => sub { print "now set to ${$_[0]}!\n" }, free => sub { print "destroyed!\n" }, ); my $a = 1; cast $a, $wiz; $a = 2; # "now set to 2!" } # "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 %h = (_default => 0, apple => 2); cast %h, $wiz, '_default'; print $h{banana}, "\n"; # "0" (there is no 'banana' key in %h) $h{pear} = 1; # "key pear stored in helem" } DESCRIPTION Magic is Perl's way of enhancing variables. This mechanism lets the user add extra data to any variable and hook syntactical operations (such as access, assignment or destruction) that can be applied to it. With this module, you can add your own magic to any variable without having to write a single line of XS. You'll realize that these magic variables look a lot like tied variables. It is not surprising, as tied variables are implemented as a special kind of magic, just like any 'irregular' Perl variable : scalars like $!, $( or $^W, the %ENV and %SIG hashes, the @ISA array, "vec()" and "substr()" lvalues, threads::shared variables... They all share the same underlying C API, and this module gives you direct access to it. Still, the magic made available by this module differs from tieing and overloading in several ways : * Magic is not copied on assignment. You attach it to variables, not values (as for blessed references). * Magic does not replace the original semantics. Magic callbacks usually get triggered before the original action takes place, and cannot prevent it from happening. This also makes catching individual events easier than with "tie", where you have to provide fallbacks methods for all actions by usually inheriting from the correct "Tie::Std*" class and overriding individual methods in your own class. * Magic is multivalued. You can safely apply different kinds of magics to the same variable, and each of them will be invoked successively. * Magic is type-agnostic. The same magic can be applied on scalars, arrays, hashes, subs or globs. But the same hook (see below for a list) may trigger differently depending on the type of the variable. * Magic is invisible at Perl level. Magical and non-magical variables cannot be distinguished with "ref", "tied" or another trick. * Magic is notably faster. Mainly because perl's way of handling magic is lighter by nature, and because there is no need for any method resolution. Also, since you don't have to reimplement all the variable semantics, you only pay for what you actually use. The operations that can be overloaded are : * *get* This magic is invoked when the variable is evaluated. It is never called for arrays and hashes. * *set* This magic is called each time the value of the variable changes. It is called for array subscripts and slices, but never for hashes. * *len* This magic only applies to arrays (though it used to also apply to scalars), and is triggered when the 'size' or the 'length' of the variable has to be known by Perl. This is typically the magic involved when an array is evaluated in scalar context, but also on array assignment and loops ("for", "map" or "grep"). The length is returned from the callback as an integer. Starting from perl 5.12, this magic is no longer called by the "length" keyword, and starting from perl 5.17.4 it is also no longer called for scalars in any situation, making this magic only meaningful on arrays. You can use the constants "VMG_COMPAT_SCALAR_LENGTH_NOLEN" and "VMG_COMPAT_SCALAR_NOLEN" to see if this magic is available for scalars or not. * *clear* This magic is invoked when the variable is reset, such as when an array is emptied. Please note that this is different from undefining the variable, even though the magic is called when the clearing is a result of the undefine (e.g. for an array, but actually a bug prevent it to work before perl 5.9.5 - see the history). * *free* This magic is called when a variable is destroyed as the result of going out of scope (but not when it is undefined). It behaves roughly like Perl object destructors (i.e. "DESTROY" methods), except that exceptions thrown from inside a *free* callback will always be propagated to the surrounding code. * *copy* This magic only applies to tied arrays and hashes, and fires when you try to access or change their elements. * *dup* This magic is invoked when the variable is cloned across threads. It is currently not available. * *local* When this magic is set on a variable, all subsequent localizations of the variable will trigger the callback. It is available on your perl if and only if "MGf_LOCAL" is true. The following actions only apply to hashes and are available if and only if "VMG_UVAR" is true. They are referred to as *uvar* magics. * *fetch* This magic is invoked each time an element is fetched from the hash. * *store* This one is called when an element is stored into the hash. * *exists* This magic fires when a key is tested for existence in the hash. * *delete* This magic is triggered when a key is deleted in the hash, regardless of whether the key actually exists in it. You can refer to the tests to have more insight of where the different magics are invoked. FUNCTIONS "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 ], ) This function creates a 'wizard', an opaque object that holds the magic information. It takes a list of keys / values as argument, whose keys can be : * "data" A code (or string) reference to a private data constructor. It is called in scalar context each time the magic is cast onto a variable, with $_[0] being a reference to this variable and @_[1 .. @_-1] being all extra arguments that were passed to "cast". The scalar returned from this call is then attached to the variable and can be retrieved later with "getdata". * "get", "set", "len", "clear", "free", "copy", "local", "fetch", "store", "exists" and "delete" Code (or string) references to the respective magic callbacks. You don't have to specify all of them : the magic corresponding to undefined entries will simply not be hooked. When those callbacks are executed, $_[0] is a reference to the magic variable and $_[1] is the associated private data (or "undef" when no private data constructor is supplied with the wizard). Other arguments depend on which kind of magic is involved : * *len* $_[2] contains the natural, non-magical length of the variable (which can only be a scalar or an array as *len* magic is only relevant for these types). The callback is expected to return the new scalar or array length to use, or "undef" to default to the normal length. * *copy* $_[2] is a either an alias or a copy of the current key, and $_[3] is an alias to the current element (i.e. the value). Because $_[2] might be a copy, it is useless to try to change it or cast magic on it. * *fetch*, *store*, *exists* and *delete* $_[2] is an alias to the current key. Note that $_[2] may rightfully be readonly if the key comes from a bareword, and as such it is unsafe to assign to it. You can ask for a copy instead by passing "copy_key => 1" to "wizard" which, at the price of a small performance hit, allows you to safely assign to $_[2] in order to e.g. redirect the action to another key. Finally, if "op_info => $num" is also passed to "wizard", then one extra element is appended to @_. Its nature depends on the value of $num : * "VMG_OP_INFO_NAME" $_[-1] is the current op name. * "VMG_OP_INFO_OBJECT" $_[-1] is the "B::OP" object for the current op. Both result in a small performance hit, but just getting the name is lighter than getting the op object. These callbacks are executed in scalar context and are expected to return an integer, which is then passed straight to the perl magic API. However, only the return value of the *len* magic callback currently holds a meaning. Each callback can be specified as : * a code reference, which will be called as a subroutine. * a string reference, where the string denotes which subroutine is to be called when magic is triggered. If the subroutine name is not fully qualified, then the current package at the time the magic is invoked will be used instead. * a reference to "undef", in which case a no-op magic callback is installed instead of the default one. This may especially be helpful for *local* magic, where an empty callback prevents magic from being copied during localization. Note that *free* magic is never called during global destruction, as there is no way to ensure that the wizard object and the callback were not destroyed before the variable. Here is 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" }, ); "cast" cast [$@%&*]var, $wiz, @args This function associates $wiz magic to the supplied variable, without overwriting any other kind of magic. It returns true on success or when $wiz magic is already attached, and croaks on error. When $wiz provides a data constructor, it is called just before magic is cast onto the variable, and it receives a reference to the target variable in $_[0] and the content of @args in @_[1 .. @args]. Otherwise, @args is ignored. # Casts $wiz onto $x, passing (\$x, '1') to the data constructor. my $x; cast $x, $wiz, 1; The "var" argument can be an array or hash value. Magic for these scalars behaves like for any other, except that it is dispelled when the entry is deleted from the container. For example, if you want to call "POSIX::tzset" each time the 'TZ' environment variable is changed in %ENV, you can use : use POSIX; cast $ENV{TZ}, wizard set => sub { POSIX::tzset(); () }; If you want to handle the possible deletion of the 'TZ' entry, you must also specify *store* magic. "getdata" getdata [$@%&*]var, $wiz This accessor fetches the private data associated with the magic $wiz in the variable. It croaks when $wiz does not represent a valid magic object, and returns an empty list if no such magic is attached to the variable or when the wizard has no data constructor. # Get the data attached to $wiz in $x, or undef if $wiz # did not attach any. my $data = getdata $x, $wiz; "dispell" dispell [$@%&*]variable, $wiz The exact opposite of "cast" : it dissociates $wiz magic from the variable. This function returns true on success, 0 when no magic represented by $wiz could be found in the variable, and croaks if the supplied wizard is invalid. # Dispell now. die 'no such magic in $x' unless dispell $x, $wiz; CONSTANTS "MGf_COPY" Evaluates to true if and only if the *copy* magic is available. This is the case for perl 5.7.3 and greater, which is ensured by the requirements of this module. "MGf_DUP" Evaluates to true if and only if the *dup* magic is available. This is the case for perl 5.7.3 and greater, which is ensured by the requirements of this module. "MGf_LOCAL" Evaluates to true if and only if the *local* magic is available. This is the case for perl 5.9.3 and greater. "VMG_UVAR" When this constant is true, you can use the *fetch*, *store*, *exists* and *delete* magics on hashes. Initial "VMG_UVAR" capability was introduced in perl 5.9.5, with a fully functional implementation shipped with perl 5.10.0. "VMG_COMPAT_SCALAR_LENGTH_NOLEN" True for perls that don't call *len* magic when taking the "length" of a magical scalar. "VMG_COMPAT_SCALAR_NOLEN" True for perls that don't call *len* magic on scalars. Implies "VMG_COMPAT_SCALAR_LENGTH_NOLEN". "VMG_COMPAT_ARRAY_PUSH_NOLEN" True for perls that don't call *len* magic when you push an element in a magical array. Starting from perl 5.11.0, this only refers to pushes in non-void context and hence is false. "VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID" True for perls that don't call *len* magic when you push in void context an element in a magical array. "VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID" True for perls that don't call *len* magic when you unshift in void context an element in a magical array. "VMG_COMPAT_ARRAY_UNDEF_CLEAR" True for perls that call *clear* magic when undefining magical arrays. "VMG_COMPAT_HASH_DELETE_NOUVAR_VOID" True for perls that don't call *delete* magic when you delete an element from a hash in void context. "VMG_COMPAT_GLOB_GET" True for perls that call *get* magic for operations on globs. "VMG_PERL_PATCHLEVEL" The perl patchlevel this module was built with, or 0 for non-debugging perls. "VMG_THREADSAFE" True if and only if this module could have been built with thread-safety features enabled. "VMG_FORKSAFE" True if and only if this module could have been built with fork-safety features enabled. This is always true except on Windows where it is false for perl 5.10.0 and below. "VMG_OP_INFO_NAME" Value to pass with "op_info" to get the current op name in the magic callbacks. "VMG_OP_INFO_OBJECT" Value to pass with "op_info" to get a "B::OP" object representing the current op in the magic callbacks. COOKBOOK Associate an object to any perl variable This technique can be useful for passing user data through limited APIs. It is similar to using inside-out objects, but without the drawback of having to implement a complex destructor. { package Magical::UserData; use Variable::Magic qw; my $wiz = wizard data => sub { \$_[1] }; sub ud (\[$@%*&]) : lvalue { my ($var) = @_; my $data = &getdata($var, $wiz); unless (defined $data) { $data = \(my $slot); &cast($var, $wiz, $slot) or die "Couldn't cast UserData magic onto the variable"; } $$data; } } { BEGIN { *ud = \&Magical::UserData::ud } my $cb; $cb = sub { print 'Hello, ', ud(&$cb), "!\n" }; ud(&$cb) = 'world'; $cb->(); # Hello, world! } Recursively cast magic on datastructures "cast" can be called from any magical callback, and in particular from "data". This allows you to recursively cast magic on datastructures : my $wiz; $wiz = wizard data => sub { my ($var, $depth) = @_; $depth ||= 0; my $r = ref $var; if ($r eq 'ARRAY') { &cast((ref() ? $_ : \$_), $wiz, $depth + 1) for @$var; } elsif ($r eq 'HASH') { &cast((ref() ? $_ : \$_), $wiz, $depth + 1) for values %$var; } return $depth; }, free => sub { my ($var, $depth) = @_; my $r = ref $var; print "free $r at depth $depth\n"; (); }; { my %h = ( a => [ 1, 2 ], b => { c => 3 } ); cast %h, $wiz; } When %h goes out of scope, this prints something among the lines of : free HASH at depth 0 free HASH at depth 1 free SCALAR at depth 2 free ARRAY at depth 1 free SCALAR at depth 3 free SCALAR at depth 3 Of course, this example does nothing with the values that are added after the "cast". PERL MAGIC HISTORY The places where magic is invoked have changed a bit through perl history. Here is a little list of the most recent ones. * 5.6.x *p14416* : *copy* and *dup* magic. * 5.8.9 *p28160* : Integration of *p25854* (see below). *p32542* : Integration of *p31473* (see below). * 5.9.3 *p25854* : *len* magic is no longer called when pushing an element into a magic array. *p26569* : *local* magic. * 5.9.5 *p31064* : Meaningful *uvar* magic. *p31473* : *clear* magic was not invoked when undefining an array. The bug is fixed as of this version. * 5.10.0 Since "PERL_MAGIC_uvar" is uppercased, "hv_magic_check()" triggers *copy* magic on hash stores for (non-tied) hashes that also have *uvar* magic. * 5.11.x *p32969* : *len* magic is no longer invoked when calling "length" with a magical scalar. *p34908* : *len* magic is no longer called when pushing / unshifting an element into a magical array in void context. The "push" part was already covered by *p25854*. *g9cdcb38b* : *len* magic is called again when pushing into a magical array in non-void context. EXPORT The functions "wizard", "cast", "getdata" and "dispell" are only exported on request. All of them are exported by the tags ':funcs' and ':all'. All the constants are also only exported on request, either individually or by the tags ':consts' and ':all'. CAVEATS In order to hook hash operations with magic, you need at least perl 5.10.0 (see "VMG_UVAR"). If you want to store a magic object in the private data slot, you will not be able to recover the magic with "getdata", since magic is not copied by assignment. You can work around this gotcha by storing a reference to the magic object instead. If you define a wizard with *free* magic and cast it on itself, it results in a memory cycle, so this destructor will not be called when the wizard is freed. DEPENDENCIES 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. Carp (core since perl 5), XSLoader (since 5.6.0). Copy tests need Tie::Array (core since perl 5.005) and Tie::Hash (since 5.002). Some uvar tests need Hash::Util::FieldHash (since 5.9.4). Glob tests need Symbol (since 5.002). Threads tests need threads and threads::shared (both since 5.7.3). SEE ALSO perlguts and perlapi for internal information about magic. perltie and overload for other ways of enhancing objects. AUTHOR Vincent Pit, "", . You can contact me by mail or on "irc.perl.org" (vincent). BUGS Please report any bugs or feature requests to "bug-variable-magic at rt.cpan.org", or through the web interface at . I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. SUPPORT You can find documentation for this module with the perldoc command. perldoc Variable::Magic Tests code coverage report is available at . COPYRIGHT & LICENSE Copyright 2007,2008,2009,2010,2011,2012,2013 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. Variable-Magic-0.53/Changes0000644000175000017500000005377212210676105014507 0ustar vincevinceRevision history for Variable-Magic 0.53 2013-09-01 17:50 UTC This is a maintenance release. The code contains no functional change. Satisfied users of version 0.52 can skip this update. + Fix : [RT #86338] : typo fix. Thanks dsteinbrunner@pobox.com for the patch. + Tst : Author tests are no longer bundled with this distribution. They are only made available to authors in the git repository. 0.52 2012-11-05 02:30 UTC + Add : The new constant VMG_COMPAT_SCALAR_NOLEN evaluates to true when your perl does not call 'len' magic for scalars, which is the case for perl 5.17.4 and above. This fixes RT #80388. + Tst : t/35-stash.t has been taught about perl 5.17.4. + Tst : Author tests overhaul. 0.51 2012-08-18 15:00 UTC + Fix : It is now safe to call dispell() from inside 'free', 'copy' and 'uvar' callbacks to dispell the magic currently in use. Thanks Clinton Gormley for reporting. + Fix : Exceptions thrown from inside a 'free' callback are now always consistently propagated outside of the callback. They used to be lost when the 'free' callback was invoked at the end of an eval block or string. + Fix : The 'reset RMG flag' workaroundn used to allow wizards with both 'uvar' and 'clear' magics to be cast onto a hash, has been made thread-safe. 0.50 2012-06-24 23:00 UTC + Fix : Less memory is leaked when a wizard is freed during global destruction, or when an exception is thrown from a 'free' callback. + Fix : [RT #77991] : t/17-ctl.t fails on perl 5.14 and 5.16. This was actually an issue with ActivePerl, and this test has learned to cope with it. Thanks Gisle Aas for reporting. + Tst : t/35-stash.t has been taught about perl 5.17.1. + Doc : Many clarifications. 0.49 2012-06-05 21:40 UTC This is a maintenance release. The code contains no functional change. Satisfied users of version 0.48 can skip this update. + Fix : [RT #77644] : t/17_ctl.t fails in test 44 since 5.17.0. This test has been taught about perl 5.17.0. Thanks Reini Urban for reporting. + Tst : t/99-kwalitee.t will be skipped when only problematic versions of its dependencies are available. 0.48 2012-02-17 23:40 UTC + Add : You can now pass a reference to undef as the magic callback in order to install a no-op callback. Thanks Florian Ragwitz for the suggestion. 0.47 2011-10-27 16:55 UTC + Add : The new constant VMG_COMPAT_HASH_DELETE_NOUVAR_VOID evaluates to true when "delete $hash{key}" does not call 'delete' uvar magic in void context. + Chg : The MAGIC tokens created by this module no longer use the mg_private member for storing a "magical" signature. + Fix : Triggering magic in a thread on a variable cloned from the main interpreter, and when the wizard already went out of scope, will not segfault anymore. + Opt : The pointer table is no longer needed to ensure thread safety. The size of the object code is about 8% smaller for threaded perls. + Tst : Threads tests will not fail anymore if resources constraints prevent the system from creating all the required threads. 0.46 2011-01-23 16:45 UTC + Fix : [RT #64866] : Assertion failure with perl 5.13.9. The real problem was that dispell() wasn't properly resetting the magical sv flags, which became visible in the test suite only with perl 5.13.9. Thanks Joshua ben Jore for reporting. 0.45 2010-11-21 23:15 UTC This is a maintenance release. The code contains no functional change. Users of 0.44 can skip this update. + Doc : C++ compilers are officially NOT supported. + Doc : The minimum perl 5.10.0 requirement for uvar magic has been made more explicit. Thanks Peter Rabbitson for pointing this out and contributing a patch. + Tst : Tune for perl 5.13.7. + Tst : Capture::Tiny will be used in t/17-ctl.t if and only if it can capture a simple run. 0.44 2010-09-24 19:10 UTC + Fix : Broken linkage on Windows with gcc 3.4, which appears in particular when using ActivePerl's default compiler suite. For those setups, the Variable::Magic shared library will now be linked against the perl dll directly (instead of the import library). This (should) fix RT #51483. Thanks Christian Walde for helping to reproduce this failure and extra testing. + Rem : Support for development perls from the 5.11 branch but older than the 5.11.0 release was removed. This could cause more recent setups to fail. + Tst : Threads tests are now only run on perl 5.13.4 and higher. They could segfault randomly because of what seems to be an internal bug of Perl, which has been addressed in 5.13.4. There is also an environment variable that allows you to forcefully run those tests, but it should be set only for author testing and not for end users. 0.43 2010-06-25 23:35 UTC + Add : The new constant VMG_COMPAT_GLOB_GET tells you whether get magic is called for globs. It's true starting perl 5.13.2. + Chg : All callbacks are now called within an eval-like context. Only free callbacks used to be called that way. + Fix : Some exceptions thrown from a free callback could be lost. + Fix : Croak messages could sometimes be repeated several times. + Fix : t/41-clone.t segfaulting with perl 5.13.2. 0.42 2010-05-19 00:15 UTC This is a maintenance release. The code contains no functional change. Users of 0.41 can skip this update. + Fix : Test failures with perl 5.13. + Tst : Improve coverage. 0.41 2010-03-15 17:35 UTC + Doc : Tweaks and fixups. Thanks Shlomi Fish. + Fix : Compatibility with the soon-to-be-released perl 5.12.0. + Fix : Correctly propagate the errors thrown when variable destruction happens at compile-time and not from inside eval STRING. Thanks Florian Ragwitz and Ash Berlin for reporting. 0.40 2010-01-06 23:20 UTC + Fix : Possible memory miswrites when passing data arguments to cast(). + Fix : Minor C portability tweaks. 0.39 2009-12-01 00:05 UTC + Add : You can use a function name as a callback by passing a string reference to wizard() instead of a code reference. + Fix : Compatiblity with perl 5.11.1 and 5.11.2. + Fix : Scalars stored into the data slot no longer leak. + Fix : Thread destruction should not segfault anymore. + Opt : As a result of removing the deprecated features, less memory is used for both threaded (a pointer table is used instead of a hash) and non-threaded (no global structure is needed anymore) perls. + Rem : As advertised in the precendent version, all the signature related features were removed. This includes the 'sig' option to wizard(), the getsig() and gensig() functions, and the SIG_* constants. 0.38 2009-10-04 16:10 UTC + Dep : All the signature-related features are DEPRECATED and will be removed in december 2009. This includes the 'sig' option to wizard(), the getsig() and gensig() functions, and the SIG_* constants. Afaik those features were never used in real life, and they make the XS code slow and brittle. If you want your wizards to be globally available, you'll have to handle that yourself by storing them in a hash. + Doc : More examples in a new COOKBOOK section. + Fix : Compatiblity with the 5.11.0 release. The new compatibility constant VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID was added to cover this. + Fix : Work around Kwalitee test misfailures. 0.37 2009-08-25 15:25 UTC + Add : The new constant VMG_FORKSAFE can be tested to know whether the module will behave nicely when fork()ing. It's currently always true except on Windows where you need perl 5.10.1 for it to be true. + Doc : Nits and clarifications. 0.36 2009-07-05 16:30 UTC + Chg : getdata() now returns an empty list when no magic is present. It used to return undef but did not croak as stated in the doc. Thanks Matt S. Trout for pointing this out. + Fix : Building and tests with ActiveState Perl 5.8 build >= 822. 0.35 2009-05-15 20:50 UTC This is a maintenance release. Users of 0.34 can skip this update. + Chg : uvar magic used to be enabled for 5.9.5. It now requires 5.10 or later. + Fix : Silence compilation warnings for cxinc(). + Rem : The workaround introduced in 0.31 for the "Unknown errors" issue was removed, as regression tests show that 0.34 provides a better fix. + Tst : Skip t/40-threads.t on 5.8.x with old versions of threads and threads::shared. 0.34 2009-04-19 16:55 UTC + Fix : Destruction of wizards in require. + Fix : "panic: restartop" in 5.10 when dieing at compile time triggers a destructor. 0.33 2009-03-26 00:00 UTC + Chg : cast() and getsig() now croak too when an invalid signature is passed. + Fix : It was possible to generate with gensig() the same signature twice before actually defining the wizards. + Tst : More stash tests. + Tst : Test when the magic takes place in some cases. + Tst : Improved coverage for the op object feature. 0.32 2009-03-01 13:45 UTC + Chg : dispell() and getdata() now croak when an invalid signature is passed. + Doc : More examples and a brand new synopsis. + Fix : The signature is no longer stored in the mg_private member of the MAGIC struct. This fixes possible clashes with magics from other extensions. + Fix : op info objects weren't blessed into the right class. + Fix : Races when initializing the op names cache under threads. 0.31 2009-02-19 23:50 UTC + Doc : A somewhat better introduction. The FUNCTION section was moved before CONSTANTS and HISTORY since it's more important. And 'assignation' is really 'assignment', says Ricardo. :) + Fix : The op_info features are now thread safe. + Fix : Segfaults that occured when trying to get the op name during global destruction. + Fix : Segfaults and wrong "Unknown error" exceptions that happened when dieing in require caused a free callback to fire. Thanks Florian Ragwitz for reporting. 0.30 2009-02-12 17:05 UTC + Add : You can now get in all the callbacks either the name or a B::OP object representing the current op if you pass the new 'op_info' option to wizard() with respective values VMG_OP_INFO_NAME and VMG_OP_INFO_OBJECT. + Doc : Document magic on array/hashes values. + Fix : Completely skip free callbacks during global destruction. + Tst : Tests now pass again on 5.8.3 and lower (they were broken since 0.27). + Tst : Test magic on symbol table and on array/hash values. 0.29 2009-02-08 11:10 UTC + Add : Set $_[2] to the default length for len magic on scalars. + Chg : Perl 5.8 is required. + Chg : The CLONE method will no longer be defined for non-threaded perls. + Doc : Nits. + Fix : The logic for turning off the GMAGICAL flag on hashes when no uvar magic is involved could do nasty things on tied hashes. + Upd : More resources in META.yml. 0.28 2009-01-24 17:05 UTC + Add : The 'copy_key' option to wizard(), that enables the safe edition of $_[2] in uvar callbacks to redirect actions to another key. + Fix : Exception objects thrown from callbacks at compile time were not available in $@. + Fix : free callbacks triggered during global destruction could lead to segfaults because the wizard was already freed. + Fix : Refcount of scalars with free callback. + Fix : Segfaults when using get or uvar magic simultaneously with clear magic. + Doc : The documentation about what the callbacks take and should return is now somewhat clearer. 0.27 2009-01-18 23:40 UTC + Fix : Offset of 1 with len magic on scalars. + Fix : Segfaults that seem to happen when one croak in a callback at compile time (thanks Ash Berlin for the testcase). + Upd : Resources in META.yml (Florian Ragwitz) + Tst : Large cleanup resulting in a wider set of tested behaviours. 0.26 2008-11-29 22:05 UTC + Fix : Leaks of cloned coderefs that access lexicals. + Fix : Building with maint-5.8 and blead (thanks Andreas Koenig). 0.25 2008-11-12 19:40 UTC + Fix : Compatibility with 5.8.9. + Fix : Old Pod::Coverage don't ignore CLONE. + Upd : META.yml spec updated to 1.4. 0.24 2008-10-12 14:55 UTC + Fix : Really fix it. 0.23 2008-10-11 17:25 UTC + Fix : Building on perls with multiplicity but not ithreads. 0.22 2008-09-29 19:40 UTC + Doc : Explain how magic differs from overloading. + Fix : Disable thread safety for perl 5.8 on Windows. If you want it enabled, reliable feedback is welcome. 0.21_02 2008-09-28 23:10 UTC + Fix : Hide previously deleted magic tokens in vmg_svt_free (Yuval Kogman). 0.21_01 2008-09-22 13:25 UTC + Chg : Shrink the context data. + Fix : Enable thread safety features for perls that just lack MY_CXT_CLONE. + Tst : Output threads and threads::shared versions in threads tests. 0.20 2008-09-20 23:35 UTC + Fix : The module is now thread safe. You can test if it had been built with thread safety features enabled through the VMG_THREADSAFE constant. + Fix : Correct backtrace when wizard() croaks. + Fix : 'cast $a, undef' should throw an 'invalid wizard' error instead of an 'invalid signature'. 0.19 2008-07-05 15:05 UTC + Add : The patchlevel with which the module has been built is now exported with the VMG_PERL_PATCHLEVEL constant. + Chg : Version checking macros overhaul. + Fix : 'uvar' magic should only be enabled in maint-5.10 and higher since it's never going to be backported to 5.8. + Fix : Likewise, the copy callback API change should only be enabled in 5.11 and higher. + Fix : Instead of those ackward fake refcount increments in the wizard destructor, flag the wizard with SVf_BREAK and force temps cleanup. This should fix the wizard destruction for all perls, and solves the leak introduced by the previous solution. 0.18 2008-07-04 12:20 UTC + Fix : Enable uvar magic when patchlevel >= 28419. + Fix : Set VMG_COMPAT_ARRAY_PUSH_NOLEN for Windows ActiveState Perl 5.8.x. 0.17 2008-05-11 09:05 UTC + Fix : 5.8.4 and lower don't have mPUSHi. Gah. Yeah, I know, I should use Devel::PPPort. 0.16 2008-05-10 22:05 UTC + Add : The samples/copy.pl script. + Chg : The sv_magical() + vmg_mg_magical() combo was simplified into vmg_sv_magicuvar(). + Tst : t/33-code.t was testing scalars, not code. + Tst : is() and like() are better than ok(). + Tst : 100% coverage reached. 0.15 2008-04-11 18:25 UTC + Chg : Factor vmg_cb_call{1,2,3}() into one function. + Fix : len magic is no longer called when taking the length() of a magical scalar since p32969. The VMG_COMPAT_SCALAR_LENGTH_NOLEN constant was added to cover this. + Tst : More tests for t/22-len.t. 0.14 2008-03-24 12:35 UTC + Fix : t/16-huf.t failures on Solaris and FreeBSD caused by not updating mg->mg_ptr after Renew-ing it on dispell. + Fix : Undefining MGf_DUP caused the wizard's magic to be wrongly initialized. MGf_DUP now appears as true from the user point of view, but the dup callback isn't actually set. + Fix : Warnings with blead due to copy callbacks now taking an I32 (API change #33256). + Fix : vmg_svt_val() and vmg_uvar_del() aren't required if no uvar magic is available. + Tst : Tests now output the version of optional modules loaded. 0.13 2008-03-19 14:35 UTC + Doc : Link to coverage report. + Fix : Correct dependencies listing in META.yml. + Tst : Improved test coverage. + Tst : Print the patchlevel as a comment. + Tst : Use is() where it's relevant. + Tst : t/16-huf.t now really tests interaction with H::U::FH. 0.12 2008-02-07 18:15 UTC + Fix : POD error. Thanks to Chris Williams (BinGOs) for the quick feedback. 0.11 2008-02-07 17:55 UTC + Add : Copy callbacks now receive the current key/index in $_[2]. The current value/element is now in $_[3]. + Chg : The trigger of copy magic on list assignment with perls greater than 5.10.0 was caused by uvar magic. Hence, VMG_COMPAT_HASH_LISTASSIGN_COPY was removed. Use VMG_UVAR instead. + Fix : Build failures on patched perls. + Tst : Added missing exported symbols to 01-import.t. 0.10 2008-02-04 11:30 UTC + Add : New script : samples/vm_vs_tie.pl, that benchmarks our uvar magic versus tied hashes. + Add : The VMG_COMPAT_* constants can be used from userspace to check perl magic abilities. + Fix : Callbacks that returned undef made us croak, breaking the variable behaviour (regression test in 14-callbacks.t). + Fix : uvar callbacks weren't tested for non-NULL-ity before being called (regression test in 28-uvar.t). + Tst : Fix typo in 25-copy.t that prevented Tie::Hash tests to be ran. 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. + Add : uvar magics : fetch, store, exists, delete for hashes. 0.07_* 2008-01 Internal development versions. 0.06 2007-11-20 10:10 UTC + Chg : 5.7.3 is now officially required. + Fix : "data" test failures on 5.8.{0,2}. + Fix : Drand01() vs rand(). 0.05 2007-11-19 09:10 UTC + Fix : 5.10.0_RC1 compatibility fix. 0.04 2007-08-28 12:25 UTC + Chg : s/require (XSLoader)/use $1/. + Fix : Tests are now strict. + Fix : Complete dependencies. 0.03 2007-08-01 17:20 UTC + Add : Passing the signature of an already defined magic to wizard() now returns the corresponding magic object. + Add : You can pass the numeric signature as the wizard argument of cast(), dispell() and getdata(). + Add : Any argument specified after the wizard (or the signature) in a call to cast() is now passed to the private data constructor in $_[1] and after. + Chg : $_[0] is now always a reference to the magic variable in all callbacks. The reason for changing from the previous behaviour is that one may want to apply the same magic to a plain scalar and to a scalar reference, and needs a way to distinguish between them in the callback (say, ref()). + Fix : Wizard object destruction used not to free the signature. 0.02 2007-07-27 13:50 UTC + Fix : In response to test report 548152 : Newx() and SvMAGIC_set() not present on older perls. + Fix : In response to test report 548275 : Since perl 5.9.5, 'clear' magic is invoked when an array is undefined (bug #43357). Moreover, 'len' magic is no longer called by pushing an element since perl 5.9.3. + Fix : Missing glob test in MANIFEST. 0.01 2007-07-25 16:15 UTC First version, released on an unsuspecting world. Variable-Magic-0.53/MANIFEST0000644000175000017500000000143512207502470014331 0ustar vincevinceChanges MANIFEST META.json META.yml Magic.xs Makefile.PL README lib/Variable/Magic.pm samples/copy.pl samples/magic.pl samples/synopsis.pl samples/uvar.pl samples/vm_vs_tie.pl t/00-load.t t/01-import.t t/02-constants.t t/10-simple.t t/11-multiple.t t/13-data.t t/14-callbacks.t t/15-self.t t/16-huf.t t/17-ctl.t t/18-opinfo.t t/20-get.t t/21-set.t t/22-len.t t/23-clear.t t/24-free.t t/25-copy.t t/27-local.t t/28-uvar.t t/30-scalar.t t/31-array.t t/32-hash.t t/33-code.t t/34-glob.t t/35-stash.t t/40-threads.t t/41-clone.t t/80-leaks.t t/lib/VPIT/TestHelpers.pm t/lib/Variable/Magic/TestDestroyRequired.pm t/lib/Variable/Magic/TestGlobalDestruction.pm t/lib/Variable/Magic/TestScopeEnd.pm t/lib/Variable/Magic/TestThreads.pm t/lib/Variable/Magic/TestValue.pm t/lib/Variable/Magic/TestWatcher.pm Variable-Magic-0.53/META.yml0000640000175000017500000000161112210676250014443 0ustar vincevince--- abstract: 'Associate user-defined magic to variables from Perl.' author: - 'Vincent Pit ' build_requires: Carp: 0 Config: 0 Exporter: 0 ExtUtils::MakeMaker: 0 Test::More: 0 XSLoader: 0 base: 0 configure_requires: Config: 0 ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.120921' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Variable-Magic no_index: directory: - t - inc requires: Carp: 0 Exporter: 0 XSLoader: 0 base: 0 perl: 5.008 resources: bugtracker: http://rt.cpan.org/Dist/Display.html?Name=Variable-Magic homepage: http://search.cpan.org/dist/Variable-Magic/ license: http://dev.perl.org/licenses/ repository: http://git.profvince.com/?p=perl%2Fmodules%2FVariable-Magic.git version: 0.53 Variable-Magic-0.53/Makefile.PL0000644000175000017500000000620012207502470015145 0ustar vincevinceuse 5.008; use strict; use warnings; use ExtUtils::MakeMaker; use Config; my @DEFINES; my %macro; my $as_perl = eval { require ActivePerl; defined &ActivePerl::BUILD ? ActivePerl::BUILD() : undef }; my $is_as_822 = 0; print "Checking if this is ActiveState Perl 5.8.8 build 822 or higher... "; if ("$]" == 5.008_008 and defined $as_perl and $as_perl >= 822) { $is_as_822 = 1; push @DEFINES, '-DVMG_COMPAT_ARRAY_PUSH_NOLEN=1'; } print $is_as_822 ? "yes\n" : "no\n"; my $is_gcc_34 = 0; print "Checking if this is gcc 3.4 on Windows trying to link against an import library... "; if ($^O eq 'MSWin32' and not grep /^LD[A-Z]*=/, @ARGV) { my ($libperl, $gccversion) = map $_ || '', @Config{qw}; if ($gccversion =~ /^3\.4\.[0-9]+/ and $libperl =~ s/\.lib$//) { $is_gcc_34 = 1; my ($lddlflags, $ldflags) = @Config{qw}; $_ ||= '', s/-L(?:".*?"|\S+)//g for $lddlflags, $ldflags; $libperl = "-l$libperl"; my $libdirs = join ' ', map { s/(?}; $macro{LDDLFLAGS} = "$lddlflags $libdirs $libperl"; $macro{LDFLAGS} = "$ldflags $libdirs $libperl"; $macro{PERL_ARCHIVE} = '', } } print $is_gcc_34 ? "yes\n" : "no\n"; # Threads, Windows and 5.8.x don't seem to be best friends if ($^O eq 'MSWin32' && "$]" < 5.009) { push @DEFINES, '-DVMG_MULTIPLICITY=0'; print "Thread safety disabled for perl 5.8.x on Windows.\n" } # Fork emulation got "fixed" in 5.10.1 if ($^O eq 'MSWin32' && "$]" < 5.010_001) { push @DEFINES, '-DVMG_FORKSAFE=0'; print "Fork safety not ensured for perl 5.8.x and 5.10.0 on Windows.\n"; } @DEFINES = (DEFINE => join ' ', @DEFINES) if @DEFINES; %macro = (macro => { %macro }) if %macro; # Beware of the circle my $dist = 'Variable-Magic'; (my $name = $dist) =~ s{-}{::}g; (my $file = $dist) =~ s{-}{/}g; $file = "lib/$file.pm"; my %PREREQ_PM = ( 'Carp' => 0, 'Exporter' => 0, 'XSLoader' => 0, 'base' => 0, ); my %BUILD_REQUIRES = ( 'Carp' => 0, 'Config' => 0, 'ExtUtils::MakeMaker' => 0, 'Test::More' => 0, %PREREQ_PM, ); my %META = ( configure_requires => { 'Config' => 0, 'ExtUtils::MakeMaker' => 0, }, build_requires => { %BUILD_REQUIRES, }, dynamic_config => 1, resources => { bugtracker => "http://rt.cpan.org/Dist/Display.html?Name=$dist", homepage => "http://search.cpan.org/dist/$dist/", license => 'http://dev.perl.org/licenses/', repository => "http://git.profvince.com/?p=perl%2Fmodules%2F$dist.git", }, ); WriteMakefile( NAME => $name, AUTHOR => 'Vincent Pit ', LICENSE => 'perl', VERSION_FROM => $file, ABSTRACT_FROM => $file, PL_FILES => {}, @DEFINES, BUILD_REQUIRES => \%BUILD_REQUIRES, PREREQ_PM => \%PREREQ_PM, MIN_PERL_VERSION => '5.008', META_MERGE => \%META, dist => { PREOP => "pod2text -u $file > \$(DISTVNAME)/README", COMPRESS => 'gzip -9f', SUFFIX => 'gz' }, clean => { FILES => "$dist-* *.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt*" }, %macro, ); Variable-Magic-0.53/samples/0000750000175000017500000000000012210676250014636 5ustar vincevinceVariable-Magic-0.53/samples/vm_vs_tie.pl0000755000175000017500000000170111630713431017173 0ustar vincevince#!/usr/bin/env perl use strict; use warnings; use Tie::Hash; use lib qw; use Variable::Magic qw; use Benchmark qw; die 'Your perl does not support the nice uvar magic of 5.10.*' unless VMG_UVAR; tie my %t, 'Tie::StdHash'; $t{a} = 1; my $wiz = wizard fetch => sub { 0 }, store => sub { 0 }, exists => sub { 0 }, delete => sub { 0 }; my %v; cast %v, $wiz; $v{a} = 2; print "Using Variable::Magic ", $Variable::Magic::VERSION, "\n"; print "Fetch:\n"; cmpthese -1, { 'tie' => sub { $t{a} }, 'v::m' => sub { $v{a} } }; print "Store:\n"; cmpthese -1, { 'tie' => sub { $t{a} = 2 }, 'v::m' => sub { $v{a} = 2 } }; print "Exists:\n"; cmpthese -1, { 'tie' => sub { exists $t{a} }, 'v::m' => sub { exists $v{a} } }; print "Delete/store:\n"; cmpthese -1, { 'tie' => sub { delete $t{a}; $t{a} = 3 }, 'v::m' => sub { delete $v{a}; $v{a} = 3 } }; Variable-Magic-0.53/samples/magic.pl0000755000175000017500000000121611630713431016261 0ustar vincevince#!/usr/bin/env perl use strict; use warnings; use lib qw; use Variable::Magic qw; sub foo { print STDERR "got ${$_[0]}!\n" } my $bar = sub { ++${$_[0]}; print STDERR "now set to ${$_[0]}!\n"; }; my $a = 1; { my $wiz = wizard get => \&foo, set => $bar, free => sub { print STDERR "deleted!\n"; }; cast $a, $wiz, qw; ++$a; # "got 1!", "now set to 3!" dispell $a, $wiz; cast $a, $wiz; my $b = 123; cast $b, $wiz; } # "deleted!" my $b = $a; # "got 3!" $a = 3; # "now set to 4!" $b = 3; # (nothing) Variable-Magic-0.53/samples/synopsis.pl0000755000175000017500000000143711630713431017075 0ustar vincevince#!perl use strict; use warnings; use Variable::Magic qw; { my $wiz = wizard set => sub { print "now set to ${$_[0]}!\n" }, free => sub { print "destroyed!\n" }; my $a = 1; cast $a, $wiz; $a = 2; # "now set to 2!" } # "destroyed!" { 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 $h{pear} = 1; # "key pear stored in helem" } Variable-Magic-0.53/samples/copy.pl0000755000175000017500000000060611630713431016155 0ustar vincevince#!/usr/bin/env perl use strict; use warnings; use lib qw; use Variable::Magic qw; use Tie::Hash; my $wiz = wizard copy => sub { print STDERR "COPY $_[2] => $_[3]\n" }, free => sub { print STDERR "FREE\n" }; my %h; tie %h, 'Tie::StdHash'; %h = (a => 1, b => 2); cast %h, $wiz; $h{b} = 3; my $x = delete $h{b}; $x == 3 or die 'incorrect'; Variable-Magic-0.53/samples/uvar.pl0000755000175000017500000000120711630713431016156 0ustar vincevince#!/usr/bin/env perl use strict; use warnings; use lib qw; use Variable::Magic qw; my $wiz = wizard fetch => sub { print STDERR "$_[0] FETCH KEY $_[2]\n" }, store => sub { print STDERR "$_[0] STORE KEY $_[2]\n" }, 'exists' => sub { print STDERR "$_[0] EXISTS KEY $_[2]\n" }, 'delete' => sub { print STDERR "$_[0] DELETE KEY $_[2]\n" }; my %h = (foo => 1, bar => 2); cast %h, $wiz; print STDERR "foo was $h{foo}\n"; $h{foo} = 3; print STDERR "now foo is $h{foo}\n"; print STDERR "foo exists!\n" if exists $h{foo}; my $d = delete $h{foo}; print STDERR "foo deleted, got $d\n"; dispell %h, $wiz;