Variable-Magic-0.61/000755 000765 000024 00000000000 13041666623 015023 5ustar00vincentstaff000000 000000 Variable-Magic-0.61/Changes000644 000765 000024 00000067403 13041666441 016326 0ustar00vincentstaff000000 000000 Revision history for Variable-Magic 0.61 2017-01-24 15:30 UTC + Fix : [RT #115792] : Latest blead stack unwind work causes infloop in a test. A change in how the core frees temporary values after eval interacted badly with Variable::Magic and caused infinite loops when a free callback was attached to a wizard. This change was temporarily reverted, but is going to be reinstated, and Variable::Magic is now able to play nicely when this happens. Thanks Peter Rabbitson for reporting and David Mitchell for providing a fix. 0.60 2016-09-06 22:30 UTC + Chg : A large chunk of boilerplate XS code, which is also used in other XS modules, has been factored out of the main .xs file to a collection of .h files in the xsh subdirectory. + Fix : [RT #128989] : Bleadperl v5.25.3-266-g1d7e644 breaks V::M. Len magic is no longer called for negative array indices fetches, so the relevant tests are now skipped. Thanks Andreas Koenig for reporting. 0.59 2015-10-05 19:05 UTC + Chg : The magic callbacks are now always executed in a new stack. This should have no negative impact (performance-wise or behaviour-wise) on your code, but may actually fix some obscure bugs. + Fix : [RT #107294] : Crash during install of Variable-Magic-0.58 running "t\18-opinfo.t". A recent change in the core implementation of transliterations caused an undefined behaviour when it interacted with this module, which resulted in visible stack corruption on Win32 perls compiled with MSVC when the op_info feature was enabled. This was fixed by using a separate stack for the magic callbacks. Thanks Peter Stokes for reporting and providing greatly helpful feedback. + Fix : The object op_info feature will now handle correctly Unicode transliteration, multideref and custom ops. 0.58 2015-07-21 16:00 UTC + Add : If a non-len magic callback returns a reference, it will now only be freed at the end of the statement that caused the magic to trigger. This allows the user to attach free magic (or a plain destructor) to a token returned from the callbacks in order to defer an action after the magic is processed by perl. + Fix : Test failures of threads tests on systems with harsh resource constraints causing the threads to exit() during run. 0.57 2015-04-17 15:20 UTC + Chg : The new environment variable to enable thread tests on older perls is PERL_FORCE_TEST_THREADS. Note that this variable should only be turned on by authors. + Fix : Segfaults when the module is loaded by several threads (or Windows emulated processes) ran in parallel. + Fix : Segfaults when the module is loaded in a thread, which spawns itself a new thread, and that child thread outlives its parent. + Fix : Small memory leaks of structures required for thread safety. + Fix : Update the Windows ActivePerl + gcc 3.4 workaround for ExtUtils::MakeMaker 7.04. Thanks Christian Walde for reporting and feedback on this issue. + Tst : The global destruction test will now be exercised on any perl that has DEBUGGING set. + Tst : Optional capturing tests in t/17-ctl.t that were only run when Capture::Tiny was present were converted to an IPC::Open3 based helper and will now be run everywhere. 0.56 2015-03-11 15:15 UTC + Fix : [RT #101410] : Install fails in blead Even though the change that caused this error was reverted from blead, lvalue uses of ERRSV have been removed from this module so that there will be no breakage when this change is possibly reintroduced in the following months. Thanks Dave Rolsky for reporting. + Tst : $ENV{$Config{ldlibpthname}} is now preserved on all platforms, which will address failures of t/17-ctl.t with unusual compilers (like icc) that link all their compiled objects to their own libraries. + Tst : The global destruction test is now only run on perl 5.13.4 and higher, and only if either Perl::Destruct::Level is installed or PERL_DESTRUCT_LEVEL is set and the perl is a debugging perl. This will solve rare crashes of t/15-self.t on perl 5.13.3 and older. 0.55 2014-10-20 23:45 UTC + Fix : [RT #99319] : t/18-opinfo.t: test failure due to change in perl 5 blead The new METHOP op class added in perl 5.21.5 is now supported. Thanks James E Keenan for reporting. 0.54 2014-09-22 17:30 UTC + Add : The new constant VMG_COMPAT_CODE_COPY_CLONE evaluates to true if your perl calls 'copy' magic when a magical code prototype is cloned, which is currently the case for perl 5.17.0 and above. + Fix : [RT #90205] : copy magic on subs puts raw CV in $_[3] $_[3] will now contain a reference to the cloned code when 'copy' magic is called for a coderef. Thanks Lukas Mai for reporting. + Fix : t/35-stash.t has been taught about perl 5.21.4. + Fix : Tests using run_perl() in t/17-ctl.t will no longer fail on Android. 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.61/lib/000755 000765 000024 00000000000 13041666623 015571 5ustar00vincentstaff000000 000000 Variable-Magic-0.61/Magic.xs000644 000765 000024 00000136470 13021660125 016417 0ustar00vincentstaff000000 000000 /* 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" /* --- XS helpers ---------------------------------------------------------- */ #define XSH_PACKAGE "Variable::Magic" #include "xsh/caps.h" #include "xsh/util.h" /* ... Features ............................................................ */ /* uvar magic and Hash::Util::FieldHash were commited with 28419, but we only * enable them on 5.10 */ #if XSH_HAS_PERL(5, 10, 0) # define VMG_UVAR 1 #else # define VMG_UVAR 0 #endif #if XSH_HAS_PERL_MAINT(5, 11, 0, 32969) || XSH_HAS_PERL(5, 12, 0) # define VMG_COMPAT_SCALAR_LENGTH_NOLEN 1 #else # define VMG_COMPAT_SCALAR_LENGTH_NOLEN 0 #endif #if XSH_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 XSH_HAS_PERL_MAINT(5, 8, 9, 28160) || XSH_HAS_PERL_MAINT(5, 9, 3, 25854) || XSH_HAS_PERL(5, 10, 0) # ifndef VMG_COMPAT_ARRAY_PUSH_NOLEN # if XSH_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 XSH_HAS_PERL_MAINT(5, 11, 0, 34908) || XSH_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 XSH_HAS_PERL_MAINT(5, 8, 9, 32542) || XSH_HAS_PERL_MAINT(5, 9, 5, 31473) || XSH_HAS_PERL(5, 10, 0) # define VMG_COMPAT_ARRAY_UNDEF_CLEAR 1 #else # define VMG_COMPAT_ARRAY_UNDEF_CLEAR 0 #endif #if XSH_HAS_PERL(5, 11, 0) # define VMG_COMPAT_HASH_DELETE_NOUVAR_VOID 1 #else # define VMG_COMPAT_HASH_DELETE_NOUVAR_VOID 0 #endif #if XSH_HAS_PERL(5, 17, 0) # define VMG_COMPAT_CODE_COPY_CLONE 1 #else # define VMG_COMPAT_CODE_COPY_CLONE 0 #endif #if XSH_HAS_PERL(5, 13, 2) # define VMG_COMPAT_GLOB_GET 1 #else # define VMG_COMPAT_GLOB_GET 0 #endif /* ... Trampoline ops ...................................................... */ #define VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE (XSH_HAS_PERL(5, 10, 0) && !XSH_HAS_PERL(5, 10, 1)) /* NewOp() isn't public in perl 5.8.0. */ #define VMG_RESET_RMG_NEEDS_TRAMPOLINE (VMG_UVAR && (XSH_THREADSAFE || !XSH_HAS_PERL(5, 8, 1))) #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 */ /* --- 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 SvREFCNT_dec_NN # define SvREFCNT_dec_NN(sv) ((void) SvREFCNT_dec(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 #ifndef OP_NAME # define OP_NAME(O) (PL_op_name[(O)->op_type]) #endif #ifndef OP_CLASS # define OP_CLASS(O) (PL_opargs[(O)->op_type] & OA_CLASS_MASK) #endif #define VMG_CAREFUL_SELF_DESTRUCTION XSH_HAS_PERL(5, 25, 3) /* ... Bug-free mg_magical ................................................. */ /* See the discussion at http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-01/msg00036.html */ #if XSH_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 /* ... Cleaner version of sv_magicext() .................................... */ static MAGIC *vmg_sv_magicext(pTHX_ SV *sv, SV *obj, const MGVTBL *vtbl, const void *ptr, I32 len) { #define vmg_sv_magicext(S, O, V, P, L) vmg_sv_magicext(aTHX_ (S), (O), (V), (P), (L)) MAGIC *mg; mg = sv_magicext(sv, obj, PERL_MAGIC_ext, vtbl, ptr, len); if (!mg) return NULL; mg->mg_private = 0; if (vtbl->svt_copy) mg->mg_flags |= MGf_COPY; #if MGf_DUP if (vtbl->svt_dup) mg->mg_flags |= MGf_DUP; #endif /* MGf_DUP */ #if MGf_LOCAL if (vtbl->svt_local) mg->mg_flags |= MGf_LOCAL; #endif /* MGf_LOCAL */ if (mg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(obj); return mg; } /* ... 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; SV *old_err = NULL; if (SvTRUE(ERRSV)) { old_err = newSVsv(ERRSV); sv_setsv(ERRSV, &PL_sv_undef); } ret = call_sv(sv, flags | G_EVAL); if (SvTRUE(ERRSV)) { SvREFCNT_dec(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 XSH_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) { sv_setsv(ERRSV, old_err); SvREFCNT_dec(old_err); } } return ret; } /* --- Stolen chunk of B --------------------------------------------------- */ typedef enum { OPc_NULL, OPc_BASEOP, OPc_UNOP, OPc_BINOP, OPc_LOGOP, OPc_LISTOP, OPc_PMOP, OPc_SVOP, OPc_PADOP, OPc_PVOP, OPc_LOOP, OPc_COP, #if XSH_HAS_PERL(5, 21, 5) OPc_METHOP, #endif #if XSH_HAS_PERL(5, 21, 7) OPc_UNOP_AUX, #endif OPc_MAX } 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", #if XSH_HAS_PERL(5, 21, 5) "B::METHOP", #endif #if XSH_HAS_PERL(5, 21, 7) "B::UNOP_AUX", #endif NULL }; static opclass vmg_opclass(pTHX_ const OP *o) { #define vmg_opclass(O) vmg_opclass(aTHX_ (O)) #if 0 if (!o) return OPc_NULL; #endif if (o->op_type == 0) { #if XSH_HAS_PERL(5, 21, 7) if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE) return OPc_COP; #endif 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 (OP_CLASS(o)) { 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 ( #if XSH_HAS_PERL(5, 13, 7) (o->op_type != OP_CUSTOM) && #endif (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))) #if defined(USE_ITHREADS) && XSH_HAS_PERL(5, 8, 9) ? OPc_PADOP : OPc_PVOP; #else ? OPc_SVOP : OPc_PVOP; #endif 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; #if XSH_HAS_PERL(5, 21, 5) case OA_METHOP: return OPc_METHOP; #endif #if XSH_HAS_PERL(5, 21, 7) case OA_UNOP_AUX: return OPc_UNOP_AUX; #endif } return OPc_BASEOP; } /* --- Error messages ------------------------------------------------------ */ static const char vmg_invalid_wiz[] = "Invalid wizard object"; static const char vmg_wrongargnum[] = "Wrong number of arguments"; /* --- Thread-local storage ------------------------------------------------ */ 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 } xsh_user_cxt_t; #if XSH_THREADSAFE static void xsh_user_clone(pTHX_ const xsh_user_cxt_t *old_cxt, xsh_user_cxt_t *new_cxt) { int c; for (c = OPc_NULL; c < OPc_MAX; ++c) { new_cxt->b__op_stashes[c] = old_cxt->b__op_stashes[c] ? gv_stashpv(vmg_opclassnames[c], 1) : NULL; } new_cxt->depth = old_cxt->depth; new_cxt->freed_tokens = NULL; return; } #endif /* XSH_THREADSAFE */ #define XSH_THREADS_NEED_TEARDOWN_LATE 1 #include "xsh/threads.h" /* --- structure ---------------------------------------------- */ #if XSH_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)) XSH_LOCK(&vmg_vtable_refcount_mutex); ++t->refcount; XSH_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; XSH_LOCK(&vmg_vtable_refcount_mutex); refcount = --t->refcount; XSH_UNLOCK(&vmg_vtable_refcount_mutex); if (!refcount) { PerlMemShared_free(t->vtbl); PerlMemShared_free(t); } } #else /* XSH_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 /* !XSH_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 XSH_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 /* XSH_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 XSH_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 /* XSH_THREADSAFE */ static MGVTBL vmg_wizard_sv_vtbl = { NULL, /* get */ NULL, /* set */ NULL, /* len */ NULL, /* clear */ vmg_wizard_sv_free, /* free */ NULL, /* copy */ #if XSH_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 XSH_THREADSAFE wiz = newSV(0); #else wiz = newSViv(PTR2IV(w)); #endif vmg_sv_magicext(wiz, NULL, &vmg_wizard_sv_vtbl, w, 0); SvREADONLY_on(wiz); return wiz; } #if XSH_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 /* XSH_THREADSAFE */ #define vmg_sv_has_wizard_type(S) SvIOK(S) #define vmg_wizard_from_sv_nocheck(W) INT2PTR(const vmg_wizard *, SvIVX(W)) #endif /* !XSH_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; PUSHSTACKi(PERLSI_MAGIC); 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 XSH_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; POPSTACK; 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)) dXSH_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 (XSH_CXT.depth) { mg->mg_moremagic = XSH_CXT.freed_tokens; XSH_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 = vmg_sv_magicext(sv, data, t, wiz, HEf_SVKEY); 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 XSH_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: XSH_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; } XSH_UNLOCK(&vmg_op_name_init_mutex); break; case VMG_OP_INFO_OBJECT: { dXSH_CXT; if (!XSH_CXT.b__op_stashes[0]) { int c; require_pv("B.pm"); for (c = OPc_NULL; c < OPc_MAX; ++c) XSH_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: { const char *name; STRLEN name_len; OPCODE t = PL_op->op_type; name = OP_NAME(PL_op); name_len = (t == OP_CUSTOM) ? strlen(name) : vmg_op_name_len[t]; return sv_2mortal(newSVpvn(name, name_len)); } case VMG_OP_INFO_OBJECT: { dXSH_CXT; return sv_bless(sv_2mortal(newRV_noinc(newSViv(PTR2IV(PL_op)))), XSH_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) { dXSH_CXT; XSH_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 (XSH_CXT.depth == 0 && XSH_CXT.freed_tokens) { vmg_magic_chain_free(XSH_CXT.freed_tokens, NULL); XSH_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 XSH_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 /* XSH_THREADSAFE */ static MGVTBL vmg_dispell_guard_vtbl = { NULL, /* get */ NULL, /* set */ NULL, /* len */ NULL, /* clear */ vmg_dispell_guard_free, /* free */ NULL, /* copy */ #if XSH_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(); vmg_sv_magicext(guard, NULL, &vmg_dispell_guard_vtbl, 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; PUSHSTACKi(PERLSI_MAGIC); 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) { dXSH_CXT; XSH_CXT.depth++; vmg_call_sv(cb, G_SCALAR, vmg_dispell_guard_oncroak, NULL); XSH_CXT.depth--; if (XSH_CXT.depth == 0 && XSH_CXT.freed_tokens) chain = &XSH_CXT.freed_tokens; } else { vmg_call_sv(cb, G_SCALAR, 0, NULL); } SPAGAIN; svr = POPs; if (SvOK(svr)) ret = (int) SvIV(svr); if (SvROK(svr)) SvREFCNT_inc(svr); else svr = NULL; PUTBACK; POPSTACK; FREETMPS; LEAVE; if (svr && !SvTEMP(svr)) sv_2mortal(svr); 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 XSH_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; PUSHSTACKi(PERLSI_MAGIC); 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; POPSTACK; 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 !XSH_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) { sv_setsv(ERRSV, o->op_sv); SvREFCNT_dec(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) sv_setsv(ERRSV, mg->mg_obj); 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; #if VMG_CAREFUL_SELF_DESTRUCTION SV *rsv; /* The ref to the sv currently being freed, pushed on the stack */ #endif 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) { dXSH_CXT; PL_op = vmg_trampoline_bump(&XSH_CXT.propagate_errsv, errsv, PL_op); } else if (optype == OP_LEAVEEVAL) { SV *guard = sv_newmortal(); vmg_sv_magicext(guard, errsv, &vmg_propagate_errsv_vtbl, NULL, 0); } #else /* !VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE */ # if !XSH_HAS_PERL(5, 8, 9) { SV *guard = sv_newmortal(); vmg_sv_magicext(guard, errsv, &vmg_propagate_errsv_vtbl, NULL, 0); } # else vmg_sv_magicext(ERRSV, errsv, &vmg_propagate_errsv_vtbl, NULL, 0); # endif #endif /* VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE */ SAVETMPS; } /* Don't propagate */ return 0; } else { SV *sv = ud->sv; MAGIC *mg; #if VMG_CAREFUL_SELF_DESTRUCTION /* Silently undo the ref - don't trigger destruction in the referent * for a second time */ if (SvROK(ud->rsv) && SvRV(ud->rsv) == sv) { SvRV_set(ud->rsv, NULL); SvROK_off(ud->rsv); --SvREFCNT(sv); /* Silent */ } SvREFCNT_dec_NN(ud->rsv); #endif /* 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); /* Re-trigger destruction */ 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 !(XSH_HAS_PERL_MAINT(5, 11, 0, 32686) || XSH_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; PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); EXTEND(SP, 2); /* This will bump the refcount of sv from 0 to 1 */ #if VMG_CAREFUL_SELF_DESTRUCTION ud.rsv = newRV_inc(sv); PUSHs(ud.rsv); #else PUSHs(sv_2mortal(newRV_inc(sv))); #endif PUSHs(mg->mg_obj ? mg->mg_obj : &PL_sv_undef); if (w->opinfo) XPUSHs(vmg_op_info(w->opinfo)); PUTBACK; { dXSH_CXT; XSH_CXT.depth++; vmg_call_sv(w->cb_free, G_SCALAR, vmg_svt_free_cleanup, &ud); XSH_CXT.depth--; if (XSH_CXT.depth == 0 && XSH_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(XSH_CXT.freed_tokens, mg); XSH_CXT.freed_tokens = NULL; } } SPAGAIN; svr = POPs; if (SvOK(svr)) ret = (int) SvIV(svr); PUTBACK; POPSTACK; #if VMG_CAREFUL_SELF_DESTRUCTION /* Silently undo the ref - don't trigger destruction in the referent * for a second time */ if (SvROK(ud.rsv) && SvRV(ud.rsv) == sv) { SvRV_set(ud.rsv, NULL); SvROK_off(ud.rsv); --SvREFCNT(sv); /* Silent */ } SvREFCNT_dec_NN(ud.rsv); #endif 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 XSH_HAS_PERL_MAINT(5, 11, 0, 33256) || XSH_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); } if (SvTYPE(sv) >= SVt_PVCV) nsv = sv_2mortal(newRV_inc(nsv)); 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 dXSH_CXT; PL_op = vmg_trampoline_bump(&XSH_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 */ /* --- Module setup/teardown ----------------------------------------------- */ #if XSH_THREADSAFE static void vmg_global_teardown_late_locked(pTHX_ void *ud) { #define vmg_global_teardown_late_locked(UD) vmg_global_teardown_late_locked(aTHX_ (UD)) MUTEX_DESTROY(&vmg_op_name_init_mutex); MUTEX_DESTROY(&vmg_vtable_refcount_mutex); return; } static signed char vmg_destruct_level(pTHX) { #define vmg_destruct_level() vmg_destruct_level(aTHX) signed char lvl; lvl = PL_perl_destruct_level; #ifdef DEBUGGING { const char *s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"); if (s) { int i; #if XSH_HAS_PERL(5, 21, 3) if (strEQ(s, "-1")) { i = -1; } else { # if XSH_HAS_PERL(5, 21, 10) UV uv; if (Perl_grok_atoUV(s, &uv, NULL) && uv <= INT_MAX) i = (int) uv; else i = 0; # else /* XSH_HAS_PERL(5, 21, 3) && !XSH_HAS_PERL(5, 21, 10) */ i = Perl_grok_atou(s, NULL); # endif } #else /* !XSH_HAS_PERL(5, 21, 3) */ i = atoi(s); #endif if (lvl < i) lvl = i; } } #endif return lvl; } #endif /* XSH_THREADSAFE */ static void xsh_user_global_setup(pTHX) { #if XSH_THREADSAFE MUTEX_INIT(&vmg_vtable_refcount_mutex); MUTEX_INIT(&vmg_op_name_init_mutex); #endif return; } static void xsh_user_local_setup(pTHX_ xsh_user_cxt_t *cxt) { HV *stash; int c; for (c = OPc_NULL; c < OPc_MAX; ++c) cxt->b__op_stashes[c] = NULL; cxt->depth = 0; cxt->freed_tokens = NULL; #if VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE vmg_trampoline_init(&cxt->propagate_errsv, vmg_pp_propagate_errsv); #endif #if VMG_RESET_RMG_NEEDS_TRAMPOLINE vmg_trampoline_init(&cxt->reset_rmg, vmg_pp_reset_rmg); #endif stash = gv_stashpv(XSH_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_CODE_COPY_CLONE", newSVuv(VMG_COMPAT_CODE_COPY_CLONE)); newCONSTSUB(stash, "VMG_COMPAT_GLOB_GET", newSVuv(VMG_COMPAT_GLOB_GET)); newCONSTSUB(stash, "VMG_PERL_PATCHLEVEL", newSVuv(XSH_PERL_PATCHLEVEL)); newCONSTSUB(stash, "VMG_THREADSAFE", newSVuv(XSH_THREADSAFE)); newCONSTSUB(stash, "VMG_FORKSAFE", newSVuv(XSH_FORKSAFE)); newCONSTSUB(stash, "VMG_OP_INFO_NAME", newSVuv(VMG_OP_INFO_NAME)); newCONSTSUB(stash, "VMG_OP_INFO_OBJECT", newSVuv(VMG_OP_INFO_OBJECT)); return; } static void xsh_user_local_teardown(pTHX_ xsh_user_cxt_t *cxt) { if (cxt->depth == 0 && cxt->freed_tokens) { vmg_magic_chain_free(cxt->freed_tokens, NULL); cxt->freed_tokens = NULL; } return; } static void xsh_user_global_teardown(pTHX) { #if XSH_THREADSAFE if (vmg_destruct_level() == 0) vmg_global_teardown_late_locked(NULL); else xsh_teardown_late_register(vmg_global_teardown_late_locked, NULL); #endif return; } /* --- 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: { xsh_setup(); } #if XSH_THREADSAFE void CLONE(...) PROTOTYPE: DISABLE PPCODE: xsh_clone(); XSRETURN(0); #endif /* XSH_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.61/Makefile.PL000644 000765 000024 00000006777 12616372334 017016 0ustar00vincentstaff000000 000000 use 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"; eval <<' MY_SECTION'; package MY; sub dynamic_lib { my $self = shift; my $inherited = $self->SUPER::dynamic_lib(@_); $inherited =~ s/"?\$\(PERL_ARCHIVE\)"?//g; return $inherited; } MY_SECTION die $@ if $@; } } 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, '-DXSH_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, '-DXSH_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, 'IO::Handle' => 0, 'IO::Select' => 0, 'IPC::Open3' => 0, 'POSIX' => 0, 'Socket' => 0, 'Test::More' => 0, 'lib' => 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.61/MANIFEST000644 000765 000024 00000001536 12763631461 016163 0ustar00vincentstaff000000 000000 Changes 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/09-load-threads.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/50-return.t t/80-leaks.t t/lib/Test/Leaner.pm 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/TestValue.pm t/lib/Variable/Magic/TestWatcher.pm xsh/caps.h xsh/mem.h xsh/threads.h xsh/util.h Variable-Magic-0.61/META.json000644 000765 000024 00000003446 13041666623 016453 0ustar00vincentstaff000000 000000 { "abstract" : "Associate user-defined magic to variables from Perl.", "author" : [ "Vincent Pit " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150010", "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", "IO::Handle" : "0", "IO::Select" : "0", "IPC::Open3" : "0", "POSIX" : "0", "Socket" : "0", "Test::More" : "0", "XSLoader" : "0", "base" : "0", "lib" : "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.61", "x_serialization_backend" : "JSON::PP version 2.27400" } Variable-Magic-0.61/META.yml000644 000765 000024 00000002077 13041666623 016302 0ustar00vincentstaff000000 000000 --- abstract: 'Associate user-defined magic to variables from Perl.' author: - 'Vincent Pit ' build_requires: Carp: '0' Config: '0' Exporter: '0' ExtUtils::MakeMaker: '0' IO::Handle: '0' IO::Select: '0' IPC::Open3: '0' POSIX: '0' Socket: '0' Test::More: '0' XSLoader: '0' base: '0' lib: '0' configure_requires: Config: '0' ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150010' 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.61' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Variable-Magic-0.61/README000644 000765 000024 00000057001 13041666623 015706 0ustar00vincentstaff000000 000000 NAME Variable::Magic - Associate user-defined magic to variables from Perl. VERSION Version 0.61 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* When applied to tied arrays and hashes, this magic fires when you try to access or change their elements. Starting from perl 5.17.0, it can also be applied to closure prototypes, in which case the magic will be called when the prototype is cloned. The "VMG_COMPAT_CODE_COPY_CLONE" constant is true when your perl support this feature. * *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* When the variable for which the magic is invoked is an array or an hash, $_[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). Since $_[2] might be a copy, it is useless to try to change it or cast magic on it. Starting from perl 5.17.0, this magic can also be called for code references. In this case, $_[2] is always "undef" and $_[3] is a reference to the cloned anonymous subroutine. * *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 always executed in scalar context. The returned value is coerced into a signed integer, which is then passed straight to the perl magic API. However, note that perl currently only cares about the return value of the *len* magic callback and ignores all the others. Starting with Variable::Magic 0.58, a reference returned from a non-*len* magic callback will not be destroyed immediately but will be allowed to survive until the end of the statement that triggered the magic. This lets you use this return value as a token for triggering a destructor after the original magic action takes place. You can see an example of this technique in the cookbook. 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_CODE_COPY_CLONE" True for perls that call *copy* magic when a magical closure prototype is cloned. "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". Delayed magic actions Starting with Variable::Magic 0.58, the return value of the magic callbacks can be used to delay the action until after the original action takes place : my $delayed; my $delayed_aux = wizard( data => sub { $_[1] }, free => sub { my ($target) = $_[1]; my $target_data = &getdata($target, $delayed); local $target_data->{guard} = 1; if (ref $target eq 'SCALAR') { my $orig = $$target; $$target = $target_data->{mangler}->($orig); } return; }, ); $delayed = wizard( data => sub { return +{ guard => 0, mangler => $_[1] }; }, set => sub { return if $_[1]->{guard}; my $token; cast $token, $delayed_aux, $_[0]; return \$token; }, ); my $x = 1; cast $x, $delayed => sub { $_[0] * 2 }; $x = 2; # $x is now 4 # But note that the delayed action only takes place at the end of the # current statement : my @y = ($x = 5, $x); # $x is now 10, but @y is (5, 5) 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). 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 COPYRIGHT & LICENSE Copyright 2007,2008,2009,2010,2011,2012,2013,2014,2015,2016,2017 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.61/samples/000755 000765 000024 00000000000 13041666623 016467 5ustar00vincentstaff000000 000000 Variable-Magic-0.61/t/000755 000765 000024 00000000000 13041666623 015266 5ustar00vincentstaff000000 000000 Variable-Magic-0.61/xsh/000755 000765 000024 00000000000 13041666623 015625 5ustar00vincentstaff000000 000000 Variable-Magic-0.61/xsh/caps.h000644 000765 000024 00000002630 12763631671 016732 0ustar00vincentstaff000000 000000 #ifndef XSH_CAPS_H #define XSH_CAPS_H 1 #define XSH_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) #define XSH_HAS_PERL_BRANCH(R, V, S) (PERL_REVISION == (R) && PERL_VERSION == (V) && PERL_SUBVERSION >= (S)) #define XSH_HAS_PERL_EXACT(R, V, S) ((PERL_REVISION == (R)) && (PERL_VERSION == (V)) && (PERL_SUBVERSION == (S))) #ifndef XSH_PERL_PATCHLEVEL # ifdef PERL_PATCHNUM # define XSH_PERL_PATCHLEVEL PERL_PATCHNUM # else # define XSH_PERL_PATCHLEVEL 0 # endif #endif #define XSH_HAS_PERL_MAINT(R, V, S, P) (PERL_REVISION == (R) && PERL_VERSION == (V) && (XSH_PERL_PATCHLEVEL >= (P) || (!XSH_PERL_PATCHLEVEL && PERL_SUBVERSION >= (S)))) #ifndef XSH_MULTIPLICITY # if defined(MULTIPLICITY) # define XSH_MULTIPLICITY 1 # else # define XSH_MULTIPLICITY 0 # endif #endif #if XSH_MULTIPLICITY # ifndef PERL_IMPLICIT_CONTEXT # error MULTIPLICITY builds must set PERL_IMPLICIT_CONTEXT # endif # ifndef tTHX # define tTHX PerlInterpreter* # endif #endif #if XSH_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 XSH_THREADSAFE 1 #else # define XSH_THREADSAFE 0 #endif /* Safe unless stated otherwise in Makefile.PL */ #ifndef XSH_FORKSAFE # define XSH_FORKSAFE 1 #endif #endif /* XSH_CAPS_H */ Variable-Magic-0.61/xsh/mem.h000644 000765 000024 00000011762 12763631363 016566 0ustar00vincentstaff000000 000000 #ifndef XSH_MEM_H #define XSH_MEM_H 1 #include "util.h" /* XSH_ASSERT() */ #ifdef DEBUGGING # ifdef Poison # define XSH_POISON(D, N, T) Poison((D), (N), T) # endif # ifdef PoisonNew # define XSH_POISON_NEW(D, N, T) PoisonNew((D), (N), T) # define XSH_HAS_POISON_NEW 1 # endif # ifdef PoisonFree # define XSH_POISON_FREE(D, N, T) PoisonFree((D), (N), T) # define XSH_HAS_POISON_FREE 1 # endif #endif #ifdef XSH_POISON # ifndef XSH_POISON_NEW # define XSH_POISON_NEW(D, N, T) XSH_POISON(D, N, T) # define XSH_HAS_POISON_NEW 1 # endif # ifndef XSH_POISON_FREE # define XSH_POISON_FREE(D, N, T) XSH_POISON(D, N, T) # define XSH_HAS_POISON_FREE 1 # endif #endif #ifndef XSH_HAS_POISON_NEW # define XSH_HAS_POISON_NEW 0 #endif #ifndef XSH_HAS_POISON_FREE # define XSH_HAS_POISON_FREE 0 #endif /* --- Shared memory ------------------------------------------------------- */ /* Context for PerlMemShared_*() functions */ #ifdef PERL_IMPLICIT_SYS # define pPMS pTHX # define pPMS_ pTHX_ # define aPMS aTHX # define aPMS_ aTHX_ #else # define pPMS void # define pPMS_ # define aPMS # define aPMS_ #endif /* ... xsh_shared_alloc() .................................................. */ #if XSH_HAS_POISON_NEW static void *xsh_shared_alloc(pPMS_ size_t size) { #define xsh_shared_alloc(S) xsh_shared_alloc(aPMS_ (S)) void *p; p = PerlMemShared_malloc(size); XSH_ASSERT(p); XSH_POISON_NEW(p, size, char); return p; } #else /* XSH_HAS_POISON_NEW */ #define xsh_shared_alloc(S) PerlMemShared_malloc(S) #endif /* !XSH_HAS_POISON_NEW */ #define XSH_SHARED_ALLOC(D, N, T) ((D) = xsh_shared_alloc((N) * sizeof(T))) /* ... xsh_shared_calloc() ................................................. */ #define xsh_shared_calloc(C, S) PerlMemShared_calloc((C), (S)) #define XSH_SHARED_CALLOC(D, N, T) ((D) = xsh_shared_calloc((N), sizeof(T))) /* ... xsh_shared_free() ................................................... */ #if XSH_HAS_POISON_FREE static void xsh_shared_free(pPMS_ void *p, size_t size) { #define xsh_shared_free(P, S) xsh_shared_free(aPMS_ (P), (S)) if (p) XSH_POISON_FREE(p, size, char); PerlMemShared_free(p); return; } #else /* XSH_HAS_POISON_FREE */ #define xsh_shared_free(P, S) PerlMemShared_free(P) #endif /* !XSH_HAS_POISON_FREE */ #define XSH_SHARED_FREE(D, N, T) (xsh_shared_free((D), (N) * sizeof(T)), (D) = NULL) /* ... xsh_shared_realloc() ................................................ */ #if XSH_HAS_POISON_NEW && XSH_HAS_POISON_FREE static void *xsh_shared_realloc(pPMS_ void *p, size_t old_size, size_t new_size) { #define xsh_shared_realloc(P, OS, NS) xsh_shared_realloc(aPMS_ (P), (OS), (NS)) void *q; if (!p) return xsh_shared_alloc(new_size); if (!new_size) { xsh_shared_free(p, old_size); return xsh_shared_alloc(1); } if (new_size < old_size) XSH_POISON_FREE(((char *) p) + new_size, old_size - new_size, char); q = PerlMemShared_realloc(p, new_size); XSH_ASSERT(q); if (old_size < new_size) XSH_POISON_NEW(((char *) q) + old_size, new_size - old_size, char); return q; } #else /* XSH_HAS_POISON_NEW && XSH_HAS_POISON_FREE */ #define xsh_shared_realloc(P, OS, NS) PerlMemShared_realloc((P), (NS)) #endif /* !XSH_HAS_POISON_NEW || !XSH_HAS_POISON_FREE */ #define XSH_SHARED_REALLOC(D, OL, NL, T) ((D) = xsh_shared_realloc((D), (OL) * sizeof(T), (NL) * sizeof(T))) /* ... xsh_shared_recalloc() ............................................... */ static void *xsh_shared_recalloc(pPMS_ void *p, size_t old_size, size_t new_size) { #define xsh_shared_recalloc(P, OS, NS) xsh_shared_recalloc(aPMS_ (P), (OS), (NS)) void *q; #ifdef XSH_POISON_FREE if (new_size < old_size) XSH_POISON_FREE(((char *) p) + new_size, old_size - new_size, char); #endif /* XSH_POISON_FREE */ q = PerlMemShared_realloc(p, new_size); XSH_ASSERT(q); if (old_size < new_size) Zero(((char *) q) + old_size, new_size - old_size, char); return q; } #define XSH_SHARED_RECALLOC(D, OL, NL, T) ((D) = xsh_shared_recalloc((D), (OL) * sizeof(T), (NL) * sizeof(T))) /* --- Interpreter-local memory -------------------------------------------- */ #ifndef Newx # define Newx(D, N, T) New(0, (D), (N), T) #endif #ifndef PERL_POISON #if XSH_HAS_POISON_NEW # define XSH_LOCAL_ALLOC(D, N, T) (Newx((D), (N), T), XSH_POISON_NEW((D), (N), T)) #endif #if XSH_HAS_POISON_FREE # define XSH_LOCAL_FREE(D, N, T) (XSH_POISON_FREE((D), (N), T), Safefree(D)) #endif #if XSH_HAS_POISON_NEW && XSH_HAS_POISON_FREE # define XSH_LOCAL_REALLOC(D, OL, NL, T) ((((D) && ((NL) < (OL))) ? XSH_POISON_FREE(((T *) (D)) + (NL), (OL) - (NL), T) : NOOP), Renew((D), (NL), T), (((OL) < (NL)) ? XSH_POISON_NEW(((T *) (D)) + (OL), (NL) - (OL), T) : NOOP)) #endif #endif /* !PERL_POISON */ #ifndef XSH_LOCAL_ALLOC # define XSH_LOCAL_ALLOC(D, N, T) Newx((D), (N), T) #endif #define XSH_LOCAL_CALLOC(D, N, T) Newxz((D), (N), T) #ifndef XSH_LOCAL_FREE # define XSH_LOCAL_FREE(D, N, T) Safefree(D) #endif #ifndef XSH_LOCAL_REALLOC # define XSH_LOCAL_REALLOC(D, OL, NL, T) Renew((D), (NL), T) #endif #endif /* XSH_MEM_H */ Variable-Magic-0.61/xsh/threads.h000644 000765 000024 00000025162 12763631375 017444 0ustar00vincentstaff000000 000000 #ifndef XSH_THREADS_H #define XSH_THREADS_H 1 #include "caps.h" /* XSH_HAS_PERL(), XSH_THREADSAFE */ #include "util.h" /* XSH_PACKAGE, dNOOP, NOOP */ #include "mem.h" /* XSH_SHARED_*() */ #ifndef XSH_THREADS_COMPILE_TIME_PROTECTION # define XSH_THREADS_COMPILE_TIME_PROTECTION 0 #endif #ifndef XSH_THREADS_USER_CONTEXT # define XSH_THREADS_USER_CONTEXT 1 #endif #ifndef XSH_THREADS_USER_GLOBAL_SETUP # define XSH_THREADS_USER_GLOBAL_SETUP 1 #endif #ifndef XSH_THREADS_USER_LOCAL_SETUP # define XSH_THREADS_USER_LOCAL_SETUP 1 #endif #ifndef XSH_THREADS_USER_LOCAL_TEARDOWN # define XSH_THREADS_USER_LOCAL_TEARDOWN 1 #endif #ifndef XSH_THREADS_USER_GLOBAL_TEARDOWN # define XSH_THREADS_USER_GLOBAL_TEARDOWN 1 #endif #ifndef XSH_THREADS_PEEP_CONTEXT # define XSH_THREADS_PEEP_CONTEXT 0 #endif #ifndef XSH_THREADS_HINTS_CONTEXT # define XSH_THREADS_HINTS_CONTEXT 0 #endif #ifndef XSH_THREADS_USER_CLONE_NEEDS_DUP # define XSH_THREADS_USER_CLONE_NEEDS_DUP 0 #endif #if XSH_THREADSAFE && (XSH_THREADS_HINTS_CONTEXT || XSH_THREADS_USER_CLONE_NEEDS_DUP) # define XSH_THREADS_CLONE_NEEDS_DUP 1 #else # define XSH_THREADS_CLONE_NEEDS_DUP 0 #endif #if defined(XSH_OPS_H) && (!XSH_THREADS_GLOBAL_SETUP || !XSH_THREADS_GLOBAL_TEARDOWN) # error settting up hook check functions require global setup/teardown #endif #ifndef XSH_THREADS_NEED_TEARDOWN_LATE # define XSH_THREADS_NEED_TEARDOWN_LATE 0 #endif #if XSH_THREADS_NEED_TEARDOWN_LATE && (!XSH_THREADS_USER_LOCAL_TEARDOWN || !XSH_THREADS_USER_GLOBAL_TEARDOWN) # error you need to declare local or global teardown handlers to use the late teardown feature #endif #if XSH_THREADSAFE # 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 # undef dMY_CXT # define dMY_CXT dNOOP # undef MY_CXT # define MY_CXT xsh_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 XSH_THREADSAFE /* We must use preexistent global mutexes or we will never be able to destroy * them. */ # if XSH_HAS_PERL(5, 9, 3) # define XSH_LOADED_LOCK MUTEX_LOCK(&PL_my_ctx_mutex) # define XSH_LOADED_UNLOCK MUTEX_UNLOCK(&PL_my_ctx_mutex) # else # define XSH_LOADED_LOCK OP_REFCNT_LOCK # define XSH_LOADED_UNLOCK OP_REFCNT_UNLOCK # endif #else # define XSH_LOADED_LOCK NOOP # define XSH_LOADED_UNLOCK NOOP #endif static I32 xsh_loaded = 0; #if XSH_THREADSAFE && XSH_THREADS_COMPILE_TIME_PROTECTION #define PTABLE_USE_DEFAULT 1 #include "ptable.h" #define ptable_loaded_store(T, K, V) ptable_default_store(aPTBL_ (T), (K), (V)) #define ptable_loaded_delete(T, K) ptable_default_delete(aPTBL_ (T), (K)) #define ptable_loaded_free(T) ptable_default_free(aPTBL_ (T)) static ptable *xsh_loaded_cxts = NULL; static int xsh_is_loaded(pTHX_ void *cxt) { #define xsh_is_loaded(C) xsh_is_loaded(aTHX_ (C)) int res = 0; XSH_LOADED_LOCK; if (xsh_loaded_cxts && ptable_fetch(xsh_loaded_cxts, cxt)) res = 1; XSH_LOADED_UNLOCK; return res; } static int xsh_set_loaded_locked(pTHX_ void *cxt) { #define xsh_set_loaded_locked(C) xsh_set_loaded_locked(aTHX_ (C)) int global_setup = 0; if (xsh_loaded <= 0) { XSH_ASSERT(xsh_loaded == 0); XSH_ASSERT(!xsh_loaded_cxts); xsh_loaded_cxts = ptable_new(4); global_setup = 1; } ++xsh_loaded; XSH_ASSERT(xsh_loaded_cxts); ptable_loaded_store(xsh_loaded_cxts, cxt, cxt); return global_setup; } static int xsh_clear_loaded_locked(pTHX_ void *cxt) { #define xsh_clear_loaded_locked(C) xsh_clear_loaded_locked(aTHX_ (C)) int global_teardown = 0; if (xsh_loaded > 1) { XSH_ASSERT(xsh_loaded_cxts); ptable_loaded_delete(xsh_loaded_cxts, cxt); --xsh_loaded; } else if (xsh_loaded_cxts) { XSH_ASSERT(xsh_loaded == 1); ptable_loaded_free(xsh_loaded_cxts); xsh_loaded_cxts = NULL; xsh_loaded = 0; global_teardown = 1; } return global_teardown; } #else /* XSH_THREADS_COMPILE_TIME_PROTECTION */ #define xsh_is_loaded_locked(C) (xsh_loaded > 0) #define xsh_set_loaded_locked(C) ((xsh_loaded++ <= 0) ? 1 : 0) #define xsh_clear_loaded_locked(C) ((--xsh_loaded <= 0) ? 1 : 0) #if XSH_THREADSAFE static int xsh_is_loaded(pTHX_ void *cxt) { #define xsh_is_loaded(C) xsh_is_loaded(aTHX_ (C)) int res = 0; XSH_LOADED_LOCK; res = xsh_is_loaded_locked(cxt); XSH_LOADED_UNLOCK; return res; } #else #define xsh_is_loaded(C) xsh_is_loaded_locked(C) #endif #endif /* !XSH_THREADS_COMPILE_TIME_PROTECTION */ #define MY_CXT_KEY XSH_PACKAGE "::_guts" XS_VERSION typedef struct { #if XSH_THREADS_USER_CONTEXT xsh_user_cxt_t cxt_user; #endif #if XSH_THREADS_PEEP_CONTEXT xsh_peep_cxt_t cxt_peep; #endif #if XSH_THREADS_HINTS_CONTEXT xsh_hints_cxt_t cxt_hints; #endif #if XSH_THREADS_CLONE_NEEDS_DUP tTHX owner; #endif #if !(XSH_THREADS_USER_CONTEXT || XSH_THREADS_PEEP_CONTEXT || XSH_THREADS_HINTS_CONTEXT || XSH_THREADS_CLONE_NEEDS_DUP) int dummy; #endif } my_cxt_t; START_MY_CXT #if XSH_THREADS_USER_CONTEXT # define dXSH_CXT dMY_CXT # define XSH_CXT (MY_CXT.cxt_user) #endif #if XSH_THREADS_USER_GLOBAL_SETUP static void xsh_user_global_setup(pTHX); #endif #if XSH_THREADS_USER_LOCAL_SETUP # if XSH_THREADS_USER_CONTEXT static void xsh_user_local_setup(pTHX_ xsh_user_cxt_t *cxt); # else static void xsh_user_local_setup(pTHX); # endif #endif #if XSH_THREADS_USER_LOCAL_TEARDOWN # if XSH_THREADS_USER_CONTEXT static void xsh_user_local_teardown(pTHX_ xsh_user_cxt_t *cxt); # else static void xsh_user_local_teardown(pTHX); # endif #endif #if XSH_THREADS_USER_GLOBAL_TEARDOWN static void xsh_user_global_teardown(pTHX); #endif #if XSH_THREADSAFE && XSH_THREADS_USER_CONTEXT # if XSH_THREADS_USER_CLONE_NEEDS_DUP static void xsh_user_clone(pTHX_ const xsh_user_cxt_t *old_cxt, xsh_user_cxt_t *new_cxt, CLONE_PARAMS *params); # else static void xsh_user_clone(pTHX_ const xsh_user_cxt_t *old_cxt, xsh_user_cxt_t *new_cxt); # endif #endif #if XSH_THREADS_PEEP_CONTEXT static xsh_peep_cxt_t *xsh_peep_get_cxt(pTHX) { dMY_CXT; XSH_ASSERT(xsh_is_loaded(&MY_CXT)); return &MY_CXT.cxt_peep; } #endif #if XSH_THREADS_HINTS_CONTEXT static xsh_hints_cxt_t *xsh_hints_get_cxt(pTHX) { dMY_CXT; XSH_ASSERT(xsh_is_loaded(&MY_CXT)); return &MY_CXT.cxt_hints; } #endif #if XSH_THREADS_NEED_TEARDOWN_LATE typedef void (*xsh_teardown_late_cb)(pTHX_ void *ud); static int xsh_teardown_late_simple_free(pTHX_ SV *sv, MAGIC *mg) { xsh_teardown_late_cb cb; cb = DPTR2FPTR(xsh_teardown_late_cb, mg->mg_ptr); XSH_LOADED_LOCK; if (xsh_loaded == 0) cb(aTHX_ NULL); XSH_LOADED_UNLOCK; return 0; } static MGVTBL xsh_teardown_late_simple_vtbl = { 0, 0, 0, 0, xsh_teardown_late_simple_free #if MGf_COPY , 0 #endif #if MGf_DUP , 0 #endif #if MGf_LOCAL , 0 #endif }; typedef struct { xsh_teardown_late_cb cb; void *ud; } xsh_teardown_late_token; static int xsh_teardown_late_arg_free(pTHX_ SV *sv, MAGIC *mg) { xsh_teardown_late_token *tok; tok = (xsh_teardown_late_token *) mg->mg_ptr; XSH_LOADED_LOCK; if (xsh_loaded == 0) tok->cb(aTHX_ tok->ud); XSH_LOADED_UNLOCK; XSH_SHARED_FREE(tok, 1, xsh_teardown_late_token); return 0; } static MGVTBL xsh_teardown_late_arg_vtbl = { 0, 0, 0, 0, xsh_teardown_late_arg_free #if MGf_COPY , 0 #endif #if MGf_DUP , 0 #endif #if MGf_LOCAL , 0 #endif }; static void xsh_teardown_late_register(pTHX_ xsh_teardown_late_cb cb, void *ud){ #define xsh_teardown_late_register(CB, UD) xsh_teardown_late_register(aTHX_ (CB), (UD)) void *ptr; if (!ud) { ptr = FPTR2DPTR(void *, cb); } else { xsh_teardown_late_token *tok; XSH_SHARED_ALLOC(tok, 1, xsh_teardown_late_token); tok->cb = cb; tok->ud = ud; ptr = tok; } if (!PL_strtab) PL_strtab = newHV(); sv_magicext((SV *) PL_strtab, NULL, PERL_MAGIC_ext, ud ? &xsh_teardown_late_arg_vtbl : &xsh_teardown_late_simple_vtbl, ptr, 0); return; } #endif /* XSH_THREADS_NEED_TEARDOWN_LATE */ static void xsh_teardown(pTHX_ void *root) { dMY_CXT; #if XSH_THREADS_USER_LOCAL_TEARDOWN # if XSH_THREADS_USER_CONTEXT xsh_user_local_teardown(aTHX_ &XSH_CXT); # else xsh_user_local_teardown(aTHX); # endif #endif #if XSH_THREADS_PEEP_CONTEXT xsh_peep_local_teardown(aTHX_ &MY_CXT.cxt_peep); #endif #if XSH_THREADS_HINTS_CONTEXT xsh_hints_local_teardown(aTHX_ &MY_CXT.cxt_hints); #endif XSH_LOADED_LOCK; if (xsh_clear_loaded_locked(&MY_CXT)) { #if XSH_THREADS_USER_GLOBAL_TEARDOWN xsh_user_global_teardown(aTHX); #endif #if XSH_THREADS_HINTS_CONTEXT xsh_hints_global_teardown(aTHX); #endif } XSH_LOADED_UNLOCK; return; } static void xsh_setup(pTHX) { #define xsh_setup() xsh_setup(aTHX) MY_CXT_INIT; /* Takes/release PL_my_ctx_mutex */ XSH_LOADED_LOCK; if (xsh_set_loaded_locked(&MY_CXT)) { #if XSH_THREADS_HINTS_CONTEXT xsh_hints_global_setup(aTHX); #endif #if XSH_THREADS_USER_GLOBAL_SETUP xsh_user_global_setup(aTHX); #endif } XSH_LOADED_UNLOCK; #if XSH_THREADS_CLONE_NEEDS_DUP MY_CXT.owner = aTHX; #endif #if XSH_THREADS_HINTS_CONTEXT xsh_hints_local_setup(aTHX_ &MY_CXT.cxt_hints); #endif #if XSH_THREADS_PEEP_CONTEXT xsh_peep_local_setup(aTHX_ &MY_CXT.cxt_peep); #endif #if XSH_THREADS_USER_LOCAL_SETUP # if XSH_THREADS_USER_CONTEXT xsh_user_local_setup(aTHX_ &XSH_CXT); # else xsh_user_local_setup(aTHX); # endif #endif call_atexit(xsh_teardown, NULL); return; } #if XSH_THREADSAFE static void xsh_clone(pTHX) { #define xsh_clone() xsh_clone(aTHX) const my_cxt_t *old_cxt; my_cxt_t *new_cxt; { dMY_CXT; old_cxt = &MY_CXT; } { int global_setup; MY_CXT_CLONE; new_cxt = &MY_CXT; XSH_LOADED_LOCK; global_setup = xsh_set_loaded_locked(new_cxt); XSH_ASSERT(!global_setup); XSH_LOADED_UNLOCK; #if XSH_THREADS_CLONE_NEEDS_DUP new_cxt->owner = aTHX; #endif } { #if XSH_THREADS_CLONE_NEEDS_DUP XSH_DUP_PARAMS_TYPE params; xsh_dup_params_init(params, old_cxt->owner); #endif #if XSH_THREADS_PEEP_CONTEXT xsh_peep_clone(aTHX_ &old_cxt->cxt_peep, &new_cxt->cxt_peep); #endif #if XSH_THREADS_HINTS_CONTEXT xsh_hints_clone(aTHX_ &old_cxt->cxt_hints, &new_cxt->cxt_hints, xsh_dup_params_ptr(params)); #endif #if XSH_THREADS_USER_CONTEXT # if XSH_THREADS_USER_CLONE_NEEDS_DUP xsh_user_clone(aTHX_ &old_cxt->cxt_user, &new_cxt->cxt_user, xsh_dup_params_ptr(params)); # else xsh_user_clone(aTHX_ &old_cxt->cxt_user, &new_cxt->cxt_user); # endif #endif #if XSH_THREADS_CLONE_NEEDS_DUP xsh_dup_params_deinit(params); #endif } return; } #endif /* XSH_THREADSAFE */ #endif /* XSH_THREADS_H */ Variable-Magic-0.61/xsh/util.h000644 000765 000024 00000003660 12763631716 016765 0ustar00vincentstaff000000 000000 #ifndef XSH_UTIL_H #define XSH_UTIL_H 1 #include "caps.h" /* XSH_HAS_PERL() */ #ifndef XSH_PACKAGE # error XSH_PACKAGE must be defined #endif #define XSH_PACKAGE_LEN (sizeof(XSH_PACKAGE)-1) #ifdef DEBUGGING # if XSH_HAS_PERL(5, 8, 9) || XSH_HAS_PERL(5, 9, 3) # define XSH_ASSERT(C) assert(C) # else # ifdef PERL_DEB # define XSH_DEB(X) PERL_DEB(X) # else # define XSH_DEB(X) (X) # endif # define XSH_ASSERT(C) XSH_DEB( \ ((C) ? ((void) 0) \ : (Perl_croak_nocontext("Assertion %s failed: file \"" __FILE__ \ "\", line %d", STRINGIFY(C), __LINE__), \ (void) 0))) # endif #else # define XSH_ASSERT(C) #endif #undef VOID2 #ifdef __cplusplus # define VOID2(T, P) static_cast(P) #else # define VOID2(T, P) (P) #endif #ifndef STMT_START # define STMT_START do #endif #ifndef STMT_END # define STMT_END while (0) #endif #ifndef dNOOP # define dNOOP #endif #ifndef NOOP # define NOOP #endif #if XSH_HAS_PERL(5, 13, 2) # define XSH_DUP_PARAMS_TYPE CLONE_PARAMS * # define xsh_dup_params_init(P, O) ((P) = Perl_clone_params_new((O), aTHX)) # define xsh_dup_params_deinit(P) Perl_clone_params_del(P) # define xsh_dup_params_ptr(P) (P) #else # define XSH_DUP_PARAMS_TYPE CLONE_PARAMS # define xsh_dup_params_init(P, O) \ ((P).stashes = newAV()); (P).flags = 0; ((P).proto_perl = (O)) # define xsh_dup_params_deinit(P) SvREFCNT_dec((P).stashes) # define xsh_dup_params_ptr(P) &(P) #endif #define xsh_dup(S, P) sv_dup((S), (P)) #define xsh_dup_inc(S, P) SvREFCNT_inc(xsh_dup((S), (P))) #ifdef USE_ITHREADS # define XSH_LOCK(M) MUTEX_LOCK(M) # define XSH_UNLOCK(M) MUTEX_UNLOCK(M) #else # define XSH_LOCK(M) NOOP # define XSH_UNLOCK(M) NOOP #endif #ifndef PTR2nat # define PTR2nat(p) (PTRV)(p) #endif #ifndef DPTR2FPTR # define DPTR2FPTR(t,p) ((t)PTR2nat(p)) #endif #ifndef FPTR2DPTR # define FPTR2DPTR(t,p) ((t)PTR2nat(p)) #endif #endif /* XSH_UTIL_H */ Variable-Magic-0.61/t/00-load.t000644 000765 000024 00000000643 12421276507 016611 0ustar00vincentstaff000000 000000 #!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.61/t/01-import.t000644 000765 000024 00000001437 12421276507 017207 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 2 * 22; 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_CODE_COPY_CLONE 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.61/t/02-constants.t000644 000765 000024 00000000274 12421276507 017710 0ustar00vincentstaff000000 000000 #!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.61/t/09-load-threads.t000644 000765 000024 00000016753 12553462062 020262 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; my ($module, $thread_safe_var); BEGIN { $module = 'Variable::Magic'; $thread_safe_var = 'Variable::Magic::VMG_THREADSAFE()'; } sub load_test { my $res = 0; if (defined &Variable::Magic::wizard) { my $wiz = Variable::Magic::wizard( free => sub { $res = 1; return }, ); my $var; &Variable::Magic::cast(\$var, $wiz); $res = 2; } return $res; } # Keep the rest of the file untouched use lib 't/lib'; use VPIT::TestHelpers threads => [ $module, $thread_safe_var ]; my $could_not_create_thread = 'Could not create thread'; use Test::Leaner; sub is_loaded { my ($affirmative, $desc) = @_; my $res = load_test(); my $expected; if ($affirmative) { $expected = 1; $desc = "$desc: module loaded"; } else { $expected = 0; $desc = "$desc: module not loaded"; } unless (is $res, $expected, $desc) { $res = defined $res ? "'$res'" : 'undef'; $expected = "'$expected'"; diag("Test '$desc' failed: got $res, expected $expected"); } return; } BEGIN { local $@; my $code = eval "sub { require $module }"; die $@ if $@; *do_load = $code; } is_loaded 0, 'main body, beginning'; # Test serial loadings SKIP: { my $thr = spawn(sub { my $here = "first serial thread"; is_loaded 0, "$here, beginning"; do_load; is_loaded 1, "$here, after loading"; return; }); skip "$could_not_create_thread (serial 1)" => 2 unless defined $thr; $thr->join; if (my $err = $thr->error) { die $err; } } is_loaded 0, 'main body, in between serial loadings'; SKIP: { my $thr = spawn(sub { my $here = "second serial thread"; is_loaded 0, "$here, beginning"; do_load; is_loaded 1, "$here, after loading"; return; }); skip "$could_not_create_thread (serial 2)" => 2 unless defined $thr; $thr->join; if (my $err = $thr->error) { die $err; } } is_loaded 0, 'main body, after serial loadings'; # Test nested loadings SKIP: { my $parent = spawn(sub { my $here = 'parent thread'; is_loaded 0, "$here, beginning"; SKIP: { my $kid = spawn(sub { my $here = 'child thread'; is_loaded 0, "$here, beginning"; do_load; is_loaded 1, "$here, after loading"; return; }); skip "$could_not_create_thread (nested child)" => 2 unless defined $kid; $kid->join; if (my $err = $kid->error) { die "in child thread: $err\n"; } } is_loaded 0, "$here, after child terminated"; do_load; is_loaded 1, "$here, after loading"; return; }); skip "$could_not_create_thread (nested parent)" => (3 + 2) unless defined $parent; $parent->join; if (my $err = $parent->error) { die $err; } } is_loaded 0, 'main body, after nested loadings'; # Test parallel loadings use threads; use threads::shared; my $sync_points = 7; my @locks_down = (1) x $sync_points; my @locks_up = (0) x $sync_points; share($_) for @locks_down, @locks_up; my $default_peers = 2; sub sync_master { my ($id, $peers) = @_; $peers = $default_peers unless defined $peers; { lock $locks_down[$id]; $locks_down[$id] = 0; cond_broadcast $locks_down[$id]; } LOCK: { lock $locks_up[$id]; my $timeout = time() + 10; until ($locks_up[$id] == $peers) { if (cond_timedwait $locks_up[$id], $timeout) { last LOCK; } else { return 0; } } } return 1; } sub sync_slave { my ($id) = @_; { lock $locks_down[$id]; cond_wait $locks_down[$id] until $locks_down[$id] == 0; } { lock $locks_up[$id]; $locks_up[$id]++; cond_signal $locks_up[$id]; } return 1; } for my $first_thread_ends_first (0, 1) { for my $id (0 .. $sync_points - 1) { { lock $locks_down[$id]; $locks_down[$id] = 1; } { lock $locks_up[$id]; $locks_up[$id] = 0; } } my $thr1_end = 'finishes first'; my $thr2_end = 'finishes last'; ($thr1_end, $thr2_end) = ($thr2_end, $thr1_end) unless $first_thread_ends_first; SKIP: { my $thr1 = spawn(sub { my $here = "first simultaneous thread ($thr1_end)"; sync_slave 0; is_loaded 0, "$here, beginning"; sync_slave 1; do_load; is_loaded 1, "$here, after loading"; sync_slave 2; sync_slave 3; sync_slave 4; is_loaded 1, "$here, still loaded while also loaded in the other thread"; sync_slave 5; sync_slave 6 unless $first_thread_ends_first; is_loaded 1, "$here, end"; return 1; }); skip "$could_not_create_thread (parallel 1)" => (4 * 2) unless defined $thr1; my $thr2 = spawn(sub { my $here = "second simultaneous thread ($thr2_end)"; sync_slave 0; is_loaded 0, "$here, beginning"; sync_slave 1; sync_slave 2; sync_slave 3; is_loaded 0, "$here, loaded in other thread but not here"; do_load; is_loaded 1, "$here, after loading"; sync_slave 4; sync_slave 5; sync_slave 6 if $first_thread_ends_first; is_loaded 1, "$here, end"; return 1; }); sync_master($_) for 0 .. 5; if (defined $thr2) { ($thr2, $thr1) = ($thr1, $thr2) unless $first_thread_ends_first; $thr1->join; if (my $err = $thr1->error) { die $err; } sync_master(6, 1); $thr2->join; if (my $err = $thr1->error) { die $err; } } else { sync_master(6, 1) unless $first_thread_ends_first; $thr1->join; if (my $err = $thr1->error) { die $err; } skip "$could_not_create_thread (parallel 2)" => (4 * 1); } } is_loaded 0, 'main body, after simultaneous threads'; } # Test simple clone SKIP: { my $parent = spawn(sub { my $here = 'simple clone, parent thread'; is_loaded 0, "$here, beginning"; do_load; is_loaded 1, "$here, after loading"; SKIP: { my $kid = spawn(sub { my $here = 'simple clone, child thread'; is_loaded 1, "$here, beginning"; return; }); skip "$could_not_create_thread (simple clone child)" => 1 unless defined $kid; $kid->join; if (my $err = $kid->error) { die "in child thread: $err\n"; } } is_loaded 1, "$here, after child terminated"; return; }); skip "$could_not_create_thread (simple clone parent)" => (3 + 1) unless defined $parent; $parent->join; if (my $err = $parent->error) { die $err; } } is_loaded 0, 'main body, after simple clone'; # Test clone outliving its parent SKIP: { my $kid_done; share($kid_done); my $parent = spawn(sub { my $here = 'outliving clone, parent thread'; is_loaded 0, "$here, beginning"; do_load; is_loaded 1, "$here, after loading"; my $kid_tid; SKIP: { my $kid = spawn(sub { my $here = 'outliving clone, child thread'; is_loaded 1, "$here, beginning"; { lock $kid_done; cond_wait $kid_done until $kid_done; } is_loaded 1, "$here, end"; return 1; }); if (defined $kid) { $kid_tid = $kid->tid; } else { $kid_tid = 0; skip "$could_not_create_thread (outliving clone child)" => 2; } } is_loaded 1, "$here, end"; return $kid_tid; }); skip "$could_not_create_thread (outliving clone parent)" => (3 + 2) unless defined $parent; my $kid_tid = $parent->join; if (my $err = $parent->error) { die $err; } if ($kid_tid) { my $kid = threads->object($kid_tid); if (defined $kid) { if ($kid->is_running) { lock $kid_done; $kid_done = 1; cond_signal $kid_done; } $kid->join; } } } is_loaded 0, 'main body, after outliving clone'; do_load; is_loaded 1, 'main body, loaded at end'; done_testing(); Variable-Magic-0.61/t/10-simple.t000644 000765 000024 00000003675 12421276507 017174 0ustar00vincentstaff000000 000000 #!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.61/t/11-multiple.t000644 000765 000024 00000010067 12421276507 017530 0ustar00vincentstaff000000 000000 #!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.61/t/13-data.t000644 000765 000024 00000005757 12421276507 016622 0ustar00vincentstaff000000 000000 #!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.61/t/14-callbacks.t000644 000765 000024 00000005544 12421276507 017623 0ustar00vincentstaff000000 000000 #!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.61/t/15-self.t000644 000765 000024 00000011752 13041665173 016634 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use Test::More; my $tests; BEGIN { $tests = 18 } 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"; } } } } } } SKIP: { skip "Called twice starting from perl 5.24" => 1 if "$]" >= 5.024; my $recasted = 0; my $wiz2 = wizard; my $wiz1 = wizard free => sub { ++$recasted; &cast($_[0], $wiz2); die 'xxx' }; local $@; my $res = eval { my $v = do { my $val = 123; \$val }; &cast($v, $wiz1); }; is $recasted, 1, 'recasting free callback called only once'; } 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.61/t/16-huf.t000644 000765 000024 00000002451 12421276507 016462 0ustar00vincentstaff000000 000000 #!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.61/t/17-ctl.t000644 000765 000024 00000020232 12511533177 016457 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use Test::More tests => 4 * 8 + 4 * (2 * 6 + 1) + 10 + 1 + 1; use lib 't/lib'; use VPIT::TestHelpers 'capture'; 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'; SKIP: { my $count = 1; my ($stat, $out, $err) = capture_perl <<' CODE'; use Variable::Magic qw; { BEGIN { $^H |= 0x020000; cast %^H, wizard free => sub { die q[cucumber] } } } CODE skip CAPTURE_PERL_FAILED($out) => $count unless defined $stat; like $err, 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; my ($stat, $out, $err) = capture_perl <<' CODE'; use Variable::Magic qw; BEGIN { cast %derp::, wizard fetch => sub { die q[raddish] } } derp::hlagh() CODE skip CAPTURE_PERL_FAILED($out) => $count unless defined $stat; like $err, expect('raddish', '-e', "\nExecution(?s:.*)"), 'die in free callback at compile time and not in eval string'; --$count; } Variable-Magic-0.61/t/18-opinfo.t000644 000765 000024 00000011302 12601220110 017142 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 19 * (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'; my $meth_op = ("$]" < 5.021_005) ? 'B::SVOP' : 'B::METHOP'; my $trutf_op = ($Config{useithreads} && "$]" >= 5.008_009) ? 'B::PADOP' : 'B::SVOP'; my $deref = ("$]" < 5.021_007) ? 'helem' : 'multideref'; my $deref_op = ($deref eq 'multideref') ? 'B::UNOP_AUX' : 'B::UNOP'; 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', '$x->{a}', 'my $x', 'my $y = $x->{a}{b}', [ $deref, $deref_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', $meth_op ] ], [ 'get', '$c', 'my $c = ""', '$c =~ y/x/y/', [ 'trans', 'B::PVOP' ] ], [ 'get', '$c', 'my $c = ""', '$c =~ y/\x{100}//', [ 'trans', $trutf_op ] ], [ '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; my $OP_INFO_NAME = VMG_OP_INFO_NAME; my $OP_INFO_OBJECT = VMG_OP_INFO_OBJECT; for (@tests) { my ($key, $var, $init, $test, $exp) = @$_; for my $op_info ($OP_INFO_NAME, $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 == $OP_INFO_NAME) { is $op, $exp->[0], "$desc gets the right op info"; } elsif ($op_info == $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.61/t/20-get.t000644 000765 000024 00000001232 12421276507 016446 0ustar00vincentstaff000000 000000 #!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.61/t/21-set.t000644 000765 000024 00000001200 12421276507 016456 0ustar00vincentstaff000000 000000 #!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.61/t/22-len.t000644 000765 000024 00000013041 12763632667 016464 0ustar00vincentstaff000000 000000 #!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'; } } } SKIP: { skip 'len magic is no longer called for negative array indices' => 5 if "$]" >= 5.025_004; 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.61/t/23-clear.t000644 000765 000024 00000001402 12421276507 016757 0ustar00vincentstaff000000 000000 #!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.61/t/24-free.t000644 000765 000024 00000000763 12421276507 016624 0ustar00vincentstaff000000 000000 #!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.61/t/25-copy.t000644 000765 000024 00000005262 12421276507 016655 0ustar00vincentstaff000000 000000 #!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) + 3 + 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'; } SKIP: { skip 'copy magic not called for cloned prototypes before perl 5.17.0' => 3 unless VMG_COMPAT_CODE_COPY_CLONE; my $w = wizard copy => sub { is ref($_[0]), 'CODE', 'first arg in copy on clone is a code ref'; is $_[2], undef, 'third arg in copy on clone is undef'; is ref($_[3]), 'CODE', 'fourth arg in copy on clone is a code ref'; }; eval <<'TEST_COPY'; package X; sub MODIFY_CODE_ATTRIBUTES { my ($pkg, $sub) = @_; &Variable::Magic::cast($sub, $w); return; } my $i; my $f = sub : Hello { $i }; TEST_COPY } Variable-Magic-0.61/t/27-local.t000644 000765 000024 00000004026 12421276507 016774 0ustar00vincentstaff000000 000000 #!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.61/t/28-uvar.t000644 000765 000024 00000007613 12421276507 016665 0ustar00vincentstaff000000 000000 #!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.61/t/30-scalar.t000644 000765 000024 00000006516 12421276507 017147 0ustar00vincentstaff000000 000000 #!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.61/t/31-array.t000644 000765 000024 00000005500 12421276507 017011 0ustar00vincentstaff000000 000000 #!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.61/t/32-hash.t000644 000765 000024 00000010744 12421276507 016625 0ustar00vincentstaff000000 000000 #!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.61/t/33-code.t000644 000765 000024 00000003053 12421276507 016610 0ustar00vincentstaff000000 000000 #!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.61/t/34-glob.t000644 000765 000024 00000003276 12421276507 016631 0ustar00vincentstaff000000 000000 #!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.61/t/35-stash.t000644 000765 000024 00000015235 12534261125 017022 0ustar00vincentstaff000000 000000 #!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; my (@fetch, @store); if ("$]" >= 5.011_002 && "$]" < 5.021_004) { @fetch = @calls; @store = map { ($_) x 2 } @calls; } else { @fetch = @calls; @store = @calls; } is $@, "ok\n", 'stash: function calls compiled fine'; is_deeply \%mg, { fetch => \@fetch, store => \@store, }, '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 && "$]" < 5.021_004 ? 3 : 2; $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.61/t/40-threads.t000644 000765 000024 00000005514 12553273562 017336 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib'; use VPIT::TestHelpers ( threads => [ 'Variable::Magic' => 'Variable::Magic::VMG_THREADSAFE()' ], ); use Test::Leaner 'no_plan'; my $destroyed : shared = 0; sub try { my ($dispell, $op_info) = @_; my $tid = threads->tid; my $c = 0; my $wiz; { local $@; eval { require Variable::Magic; 1 } or return; } { local $@; $wiz = eval { Variable::Magic::wizard( data => sub { $_[1] + $tid }, get => sub { ++$c; 0 }, set => sub { my $op = $_[-1]; if ($op_info eq '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 eq 'object' ? Variable::Magic::VMG_OP_INFO_OBJECT() : Variable::Magic::VMG_OP_INFO_NAME() ); }; 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 { &Variable::Magic::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 { &Variable::Magic::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 { &Variable::Magic::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 1; } for my $dispell (1, 0) { { lock $destroyed; $destroyed = 0; } my $completed = 0; my @threads = map spawn(\&try, $dispell, $_), ('name') x 2, ('object') x 2; for my $thr (@threads) { my $res = $thr->join; $completed += $res if defined $res; } { lock $destroyed; is $destroyed, (1 - $dispell) * $completed, 'destructors'; } } Variable-Magic-0.61/t/41-clone.t000644 000765 000024 00000006503 12553273562 017004 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use Variable::Magic qw< wizard cast dispell getdata VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT >; use lib 't/lib'; use VPIT::TestHelpers ( threads => [ 'Variable::Magic' => 'Variable::Magic::VMG_THREADSAFE()' ], ); use Test::Leaner 'no_plan'; 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 1; } 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 $completed = 0; my @threads = map spawn(\&try, $dispell, $wiz), 1 .. 2; for my $thr (@threads) { my $res = $thr->join; $completed += $res if defined $res; } { lock $c; is $c, $completed, "get triggered twice"; } { lock $destroyed; is $destroyed, (1 - $dispell) * $completed, '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.61/t/50-return.t000644 000765 000024 00000005426 12553231541 017215 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Variable::Magic qw; use Test::More tests => 3 * 11; our $destroyed; my $destructor = wizard free => sub { ++$destroyed; return }; { my $increment; my $increment_aux = wizard( data => sub { $_[1] }, free => sub { my ($target) = $_[1]; my $target_data = &getdata($target, $increment); local $target_data->{guard} = 1; ++$$target; return; }, ); $increment = wizard( data => sub { return +{ guard => 0 }; }, set => sub { return if $_[1]->{guard}; my $token; cast $token, $increment_aux, $_[0]; return \$token; }, ); local $destroyed = 0; { my $x = 0; cast $x, $destructor; { cast $x, $increment; is $x, 0; $x = 1; is $x, 2; $x = 123; is $x, 124; $x = -5; is $x, -4; $x = 27, is($x, 27); is $x, 28; my @y = ($x = -13, $x); is $x, -12; is "@y", '-13 -13'; } dispell $x, $increment; $x = 456; is $x, 456; is $destroyed, 0; } is $destroyed, 1; } { my $locker; my $locker_aux = wizard( data => sub { $_[1] }, free => sub { my ($target) = $_[1]; my $target_data = &getdata($target, $locker); local $target_data->{guard} = 1; $$target = $target_data->{value}; return; }, ); $locker = wizard( data => sub { return +{ guard => 0, value => $_[1] }; }, set => sub { return if $_[1]->{guard}; my $token; cast $token, $locker_aux, $_[0]; return \$token; }, ); local $destroyed = 0; { my $x = 0; cast $x, $destructor; { cast $x, $locker, 999; is $x, 0; $x = 1; is $x, 999; $x = 123; is $x, 999; $x = -5; is $x, 999; $x = 27, is($x, 27); is $x, 999; my @y = ($x = -13, $x); is $x, 999; is "@y", '-13 -13'; } dispell $x, $locker; $x = 456; is $x, 456; is $destroyed, 0; } is $destroyed, 1; } { my $delayed; my $delayed_aux = wizard( data => sub { $_[1] }, free => sub { my ($target) = $_[1]; my $target_data = &getdata($target, $delayed); local $target_data->{guard} = 1; if (ref $target eq 'SCALAR') { my $orig = $$target; $$target = $target_data->{mangler}->($orig); } return; }, ); $delayed = wizard( data => sub { return +{ guard => 0, mangler => $_[1] }; }, set => sub { return if $_[1]->{guard}; my $token; cast $token, $delayed_aux, $_[0]; return \$token; }, ); local $destroyed = 0; { my $x = 0; cast $x, $destructor; { cast $x, $delayed => sub { $_[0] * 2 }; is $x, 0; $x = 1; is $x, 2; $x = 123; is $x, 246; $x = -5; is $x, -10; $x = 27, is($x, 27); is $x, 54; my @y = ($x = -13, $x); is $x, -26; is "@y", '-13 -13'; } dispell $x, $delayed; $x = 456; is $x, 456; is $destroyed, 0; } is $destroyed, 1; } Variable-Magic-0.61/t/80-leaks.t000644 000765 000024 00000005107 12553222552 016776 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Variable::Magic qw; use Test::More; BEGIN { my $tests = 11; $tests += 4 * (4 + (MGf_LOCAL ? 1 : 0) + (VMG_UVAR ? 4 : 0)); plan tests => $tests; } 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; } # Test destruction of returned values my @methods = qw; push @methods, 'local' if MGf_LOCAL; push @methods, qw if VMG_UVAR; my %init = ( scalar_lexical => 'my $x = 1; cast $x, $w', scalar_global => 'our $X; local $X = 1; cast $X, $w', array => 'my @a = (1); cast @a, $w', hash => 'my %h = (a => 1); cast %h, $w', ); my %type; $type{$_} = 'scalar_lexical' for qw; $type{$_} = 'scalar_global' for qw; $type{$_} = 'array' for qw; $type{$_} = 'hash' for qw; sub void { } my %trigger = ( get => 'my $y = $x', set => '$x = 2', clear => '@a = ()', free => 'void()', local => 'local $X = 2', fetch => 'my $v = $h{a}', store => '$h{a} = 2', exists => 'my $e = exists $h{a}', delete => 'my $d = delete $h{a}', ); for my $meth (@methods) { local $destroyed = 0; { my $w = wizard $meth => sub { return D->new }; my $init = $init{$type{$meth}}; my $trigger = $trigger{$meth}; my $deinit = ''; if ($meth eq 'free') { $init = "{\n$init"; $deinit = '}'; } my $code = join ";\n", grep length, ( $init, 'is $destroyed, 0, "return from $meth, before trigger"', $trigger . ', is($destroyed, 0, "return from $meth, after trigger")', $deinit, 'is $destroyed, 1, "return from $meth, after trigger"', ); { local $@; eval $code; die $@ if $@; } is $destroyed, 1, "return from $meth, end"; } } Variable-Magic-0.61/t/lib/000755 000765 000024 00000000000 13041666623 016034 5ustar00vincentstaff000000 000000 Variable-Magic-0.61/t/lib/Test/000755 000765 000024 00000000000 13041666623 016753 5ustar00vincentstaff000000 000000 Variable-Magic-0.61/t/lib/Variable/000755 000765 000024 00000000000 13041666623 017561 5ustar00vincentstaff000000 000000 Variable-Magic-0.61/t/lib/VPIT/000755 000765 000024 00000000000 13041666623 016616 5ustar00vincentstaff000000 000000 Variable-Magic-0.61/t/lib/VPIT/TestHelpers.pm000644 000765 000024 00000034356 12553273520 021426 0ustar00vincentstaff000000 000000 package VPIT::TestHelpers; use strict; use warnings; use Config (); =head1 NAME VPIT::TestHelpers =head1 SYNTAX use VPIT::TestHelpers ( feature1 => \@feature1_args, feature2 => \@feature2_args, ); =cut sub export_to_pkg { my ($subs, $pkg) = @_; while (my ($name, $code) = each %$subs) { no strict 'refs'; *{$pkg.'::'.$name} = $code; } return 1; } sub sanitize_prefix { my $prefix = shift; if (defined $prefix) { if (length $prefix and $prefix !~ /_$/) { $prefix .= '_'; } } else { $prefix = ''; } return $prefix; } my %default_exports = ( load_or_skip => \&load_or_skip, load_or_skip_all => \&load_or_skip_all, skip_all => \&skip_all, ); my %features = ( threads => \&init_threads, usleep => \&init_usleep, run_perl => \&init_run_perl, capture => \&init_capture, ); sub import { shift; my @opts = @_; my %exports = %default_exports; for (my $i = 0; $i <= $#opts; ++$i) { my $feature = $opts[$i]; next unless defined $feature; my $args; if ($i < $#opts and defined $opts[$i+1] and ref $opts[$i+1] eq 'ARRAY') { ++$i; $args = $opts[$i]; } else { $args = [ ]; } my $handler = $features{$feature}; die "Unknown feature '$feature'" unless defined $handler; my %syms = $handler->(@$args); $exports{$_} = $syms{$_} for sort keys %syms; } export_to_pkg \%exports => scalar caller; } 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; } =head1 FEATURES =head2 C =over 4 =item * Import : use VPIT::TestHelpers run_perl => [ $p ] where : =over 8 =item - C<$p> is prefixed to the constants exported by this feature (defaults to C<''>). =back =item * Dependencies : none =item * Exports : =over 8 =item - C =item - C (possibly prefixed by C<$p>) =back =back =cut sub fresh_perl_env (&) { my $handler = shift; my ($SystemRoot, $PATH) = @ENV{qw}; my $ld_name = $Config::Config{ldlibpthname}; my $ldlibpth = $ENV{$ld_name}; local %ENV; $ENV{$ld_name} = $ldlibpth if defined $ldlibpth; $ENV{SystemRoot} = $SystemRoot if $^O eq 'MSWin32' and defined $SystemRoot; $ENV{PATH} = $PATH if $^O eq 'cygwin' and defined $PATH; my $perl = $^X; unless (-e $perl and -x $perl) { $perl = $Config::Config{perlpath}; unless (-e $perl and -x $perl) { return undef; } } return $handler->($perl, '-T', map("-I$_", @INC)); } sub init_run_perl { my $p = sanitize_prefix(shift); return ( run_perl => \&run_perl, "${p}RUN_PERL_FAILED" => sub () { 'Could not execute perl subprocess' }, ); } sub run_perl { my $code = shift; if ($code =~ /"/) { die 'Double quotes in evaluated code are not portable'; } fresh_perl_env { my ($perl, @perl_args) = @_; system { $perl } $perl, @perl_args, '-e', $code; }; } =head2 C =over 4 =item * Import : use VPIT::TestHelpers capture => [ $p ]; where : =over 8 =item - C<$p> is prefixed to the constants exported by this feature (defaults to C<''>). =back =item * Dependencies : =over 8 =item - Neither VMS nor OS/2 =item - L =item - L =item - L =item - On MSWin32 : L =back =item * Exports : =over 8 =item - C =item - C (possibly prefixed by C<$p>) =item - C =item - C (possibly prefixed by C<$p>) =back =back =cut sub init_capture { my $p = sanitize_prefix(shift); skip_all 'Cannot capture output on VMS' if $^O eq 'VMS'; skip_all 'Cannot capture output on OS/2' if $^O eq 'os2'; load_or_skip_all 'IO::Handle', '0', [ ]; load_or_skip_all 'IO::Select', '0', [ ]; load_or_skip_all 'IPC::Open3', '0', [ ]; if ($^O eq 'MSWin32') { load_or_skip_all 'Socket', '0', [ ]; } return ( capture => \&capture, "${p}CAPTURE_FAILED" => \&capture_failed_msg, capture_perl => \&capture_perl, "${p}CAPTURE_PERL_FAILED" => \&capture_perl_failed_msg, ); } # Inspired from IPC::Cmd sub capture { my @cmd = @_; my $want = wantarray; my $fail = sub { my $err = $!; my $ext_err = $^O eq 'MSWin32' ? $^E : undef; my $syscall = shift; my $args = join ', ', @_; my $msg = "$syscall($args) failed: "; if (defined $err) { no warnings 'numeric'; my ($err_code, $err_str) = (int $err, "$err"); $msg .= "$err_str ($err_code)"; } if (defined $ext_err) { no warnings 'numeric'; my ($ext_err_code, $ext_err_str) = (int $ext_err, "$ext_err"); $msg .= ", $ext_err_str ($ext_err_code)"; } die "$msg\n"; }; my ($status, $content_out, $content_err); local $@; my $ok = eval { my ($pid, $out, $err); if ($^O eq 'MSWin32') { my $pipe = sub { socketpair $_[0], $_[1], &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC or $fail->(qw); shutdown $_[0], 1 or $fail->(qw); shutdown $_[1], 0 or $fail->(qw); return 1; }; local (*IN_R, *IN_W); local (*OUT_R, *OUT_W); local (*ERR_R, *ERR_W); $pipe->(*IN_R, *IN_W); $pipe->(*OUT_R, *OUT_W); $pipe->(*ERR_R, *ERR_W); $pid = IPC::Open3::open3('>&IN_R', '<&OUT_W', '<&ERR_W', @cmd); close *IN_W or $fail->(qw); $out = *OUT_R; $err = *ERR_R; } else { my $in = IO::Handle->new; $out = IO::Handle->new; $out->autoflush(1); $err = IO::Handle->new; $err->autoflush(1); $pid = IPC::Open3::open3($in, $out, $err, @cmd); close $in; } # Forward signals to the child (except SIGKILL) my %sig_handlers; foreach my $s (keys %SIG) { $sig_handlers{$s} = sub { kill "$s" => $pid; $SIG{$s} = $sig_handlers{$s}; }; } local $SIG{$_} = $sig_handlers{$_} for keys %SIG; unless ($want) { close $out or $fail->(qw); close $err or $fail->(qw); waitpid $pid, 0; $status = $?; return 1; } my $sel = IO::Select->new(); $sel->add($out, $err); my $fd_out = fileno $out; my $fd_err = fileno $err; my %contents; $contents{$fd_out} = ''; $contents{$fd_err} = ''; while (my @ready = $sel->can_read) { for my $fh (@ready) { my $buf; my $bytes_read = sysread $fh, $buf, 4096; if (not defined $bytes_read) { $fail->('sysread', 'fd(' . fileno($fh) . ')'); } elsif ($bytes_read) { $contents{fileno($fh)} .= $buf; } else { $sel->remove($fh); close $fh or $fail->('close', 'fd(' . fileno($fh) . ')'); last unless $sel->count; } } } waitpid $pid, 0; $status = $?; if ($^O eq 'MSWin32') { # Manual CRLF translation that couldn't be done with sysread. s/\x0D\x0A/\n/g for values %contents; } $content_out = $contents{$fd_out}; $content_err = $contents{$fd_err}; 1; }; if ("$]" < 5.014 and $ok and ($status >> 8) == 255 and defined $content_err and $content_err =~ /^open3/) { # Before perl commit 8960aa87 (between 5.12 and 5.14), exceptions in open3 # could be reported to STDERR instead of being propagated, so work around # this. $ok = 0; $@ = $content_err; } if ($ok) { return ($status, $content_out, $content_err); } else { my $err = $@; chomp $err; return (undef, $err); } } sub capture_failed_msg { my $details = shift; my $msg = 'Could not capture command output'; $msg .= " ($details)" if defined $details; return $msg; } sub capture_perl { my $code = shift; if ($code =~ /"/) { die 'Double quotes in evaluated code are not portable'; } fresh_perl_env { my @perl = @_; capture @perl, '-e', $code; }; } sub capture_perl_failed_msg { my $details = shift; my $msg = 'Could not capture perl output'; $msg .= " ($details)" if defined $details; return $msg; } =head2 C =over 4 =item * Import : use VPIT::TestHelpers threads => [ $pkg, $threadsafe_var, $force_var ]; where : =over 8 =item - C<$pkg> is the target package name that will be exercised by this test ; =item - C<$threadsafe_var> is the name of an optional variable in C<$pkg> that evaluates to true if and only if the module claims to be thread safe (not checked if either C<$threadsafe_var> or C<$pkg> is C) ; =item - C<$force_var> is the name of the environment variable that can be used to force the thread tests (defaults to C). =back =item * Dependencies : =over 8 =item - C 5.13.4 =item - L =item - L 1.67 =item - L 1.14 =back =item * Exports : =over 8 =item - C =back =item * Notes : =over 8 =item - C<< exit => 'threads_only' >> is passed to C<< threads->import >>. =back =back =cut sub init_threads { my ($pkg, $threadsafe_var, $force_var) = @_; skip_all 'This perl wasn\'t built to support threads' unless $Config::Config{useithreads}; if (defined $pkg and defined $threadsafe_var) { my $threadsafe; my $stat = run_perl("require POSIX; require $pkg; exit($threadsafe_var ? POSIX::EXIT_SUCCESS() : POSIX::EXIT_FAILURE())"); if (defined $stat) { require POSIX; my $res = $stat >> 8; if ($res == POSIX::EXIT_SUCCESS()) { $threadsafe = 1; } elsif ($res == POSIX::EXIT_FAILURE()) { $threadsafe = !1; } } if (not defined $threadsafe) { skip_all "Could not detect if $pkg is thread safe or not"; } elsif (not $threadsafe) { skip_all "This $pkg is not thread safe"; } } $force_var = 'PERL_FORCE_TEST_THREADS' unless defined $force_var; my $force = $ENV{$force_var} ? 1 : !1; skip_all 'perl 5.13.4 required to test thread safety' unless $force or "$]" >= 5.013_004; unless ($INC{'threads.pm'}) { my $test_module; if ($INC{'Test/Leaner.pm'}) { $test_module = 'Test::Leaner'; } elsif ($INC{'Test/More.pm'}) { $test_module = 'Test::More'; } die "$test_module was loaded too soon" if defined $test_module; } load_or_skip_all 'threads', $force ? '0' : '1.67', [ exit => 'threads_only', ]; load_or_skip_all 'threads::shared', $force ? '0' : '1.14', [ ]; diag "Threads testing forced by \$ENV{$force_var}" if $force; return spawn => \&spawn; } 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; return $thread ? $thread : (); } =head2 C =over 4 =item * Import : use VPIT::TestHelpers 'usleep' => [ @impls ]; where : =over 8 =item - C<@impls> is the list of desired implementations (which may be C<'Time::HiRes'>, C<'select'> or C<'sleep'>), in the order they should be checked. When the list is empty, it defaults to all of them. =back =item * Dependencies : none =item * Exports : =over 8 =item - C =back =back =cut sub init_usleep { my (@impls) = @_; my %impls = ( 'Time::HiRes' => sub { if (do { local $@; eval { require Time::HiRes; 1 } }) { defined and diag "Using usleep() from Time::HiRes $_" for $Time::HiRes::VERSION; return \&Time::HiRes::usleep; } else { return undef; } }, 'select' => sub { if ($Config::Config{d_select}) { diag 'Using select()-based fallback usleep()'; return sub ($) { my $s = $_[0]; my $r = 0; while ($s > 0) { my ($found, $t) = select(undef, undef, undef, $s / 1e6); last unless defined $t; $t = int($t * 1e6); $s -= $t; $r += $t; } return $r; }; } else { return undef; } }, 'sleep' => sub { diag 'Using sleep()-based fallback usleep()'; return sub ($) { my $ms = int $_[0]; my $s = int($ms / 1e6) + ($ms % 1e6 == 0 ? 0 : 1); my $t = sleep $s; return $t * 1e6; }; }, ); @impls = qw unless @impls; my $usleep; for my $impl (@impls) { next unless defined $impl and $impls{$impl}; $usleep = $impls{$impl}->(); last if defined $usleep; } skip_all "Could not find a suitable usleep() implementation among: @impls" unless $usleep; return usleep => $usleep; } =head1 CLASSES =head2 C Syntax : { my $guard = VPIT::TestHelpers::Guard->new($coderef); ... } # $codref called here =cut package VPIT::TestHelpers::Guard; sub new { my ($class, $code) = @_; bless { code => $code }, $class; } sub DESTROY { $_[0]->{code}->() } =head1 AUTHOR Vincent Pit, C<< >>, L. =head1 COPYRIGHT & LICENSE Copyright 2012,2013,2014,2015 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; Variable-Magic-0.61/t/lib/Variable/Magic/000755 000765 000024 00000000000 13041666623 020601 5ustar00vincentstaff000000 000000 Variable-Magic-0.61/t/lib/Variable/Magic/TestDestroyRequired.pm000644 000765 000024 00000000156 12421276507 025132 0ustar00vincentstaff000000 000000 package Variable::Magic::TestDestroyRequired; use Variable::Magic; my $tag = Variable::Magic::wizard(); 1; Variable-Magic-0.61/t/lib/Variable/Magic/TestGlobalDestruction.pm000644 000765 000024 00000004642 12506324614 025425 0ustar00vincentstaff000000 000000 package 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(@_); } my $is_debugging; sub is_debugging_perl { return $is_debugging if defined $is_debugging; my $source; my $has_config_perl_v = do { local $@; eval { require Config::Perl::V; 1 }; }; if ($has_config_perl_v) { $is_debugging = do { local $@; eval { Config::Perl::V::myconfig()->{build}{options}{DEBUGGING} }; }; if (defined $is_debugging) { $source = "Config::Perl::V version $Config::Perl::V::VERSION"; } } unless (defined $is_debugging) { $is_debugging = 0; $source = "%Config"; require Config; my @fields = qw; for my $field (@fields) { my $content = $Config::Config{$field}; while ($content =~ /(-DD?EBUGGING((?:=\S*)?))/g) { my $extra = $2 || ''; if ($extra ne '=none') { $is_debugging = 1; $source = "\$Config{$field} =~ /$1/"; } } } } my $maybe_is = $is_debugging ? "is" : "is NOT"; _diag("According to $source, this $maybe_is a debugging perl"); return $is_debugging; } sub import { shift; my %args = @_; my $level = $args{level}; $level = 1 unless defined $level; if ("$]" < 5.013_004 and not $ENV{PERL_FORCE_TEST_THREADS}) { _diag("perl 5.13.4 required to safely test global destruction"); return 0; } my $env_level = $ENV{PERL_DESTRUCT_LEVEL}; if (defined $env_level) { no warnings 'numeric'; $env_level = int $env_level; } my $is_debugging = is_debugging_perl(); if ($is_debugging) { if (defined $env_level) { _diag("Global destruction level $env_level set by PERL_DESTRUCT_LEVEL (environment)"); return ($env_level >= $level) ? 1 : 0; } else { $ENV{PERL_DESTRUCT_LEVEL} = $level; _diag("Global destruction level $level set by PERL_DESTRUCT_LEVEL (forced)"); return 1; } } elsif (defined $env_level) { _diag("PERL_DESTRUCT_LEVEL is set to $env_level, but this perl doesn't seem to have debugging enabled, ignoring"); } 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; } _diag("Not testing global destruction"); return 0; } 1; Variable-Magic-0.61/t/lib/Variable/Magic/TestScopeEnd.pm000644 000765 000024 00000000501 12421276507 023472 0ustar00vincentstaff000000 000000 package 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.61/t/lib/Variable/Magic/TestValue.pm000644 000765 000024 00000002274 12421276507 023057 0ustar00vincentstaff000000 000000 package 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.61/t/lib/Variable/Magic/TestWatcher.pm000644 000765 000024 00000003160 12421276507 023373 0ustar00vincentstaff000000 000000 package 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.61/t/lib/Test/Leaner.pm000644 000765 000024 00000045374 12504303325 020522 0ustar00vincentstaff000000 000000 package Test::Leaner; use 5.006; use strict; use warnings; =head1 NAME Test::Leaner - A slimmer Test::More for when you favor performance over completeness. =head1 VERSION Version 0.05 =cut our $VERSION = '0.05'; =head1 SYNOPSIS use Test::Leaner tests => 10_000; for (1 .. 10_000) { ... is $one, 1, "checking situation $_"; } =head1 DESCRIPTION When profiling some L-based test script that contained about 10 000 unit tests, I realized that 60% of the time was spent in L itself, even though every single test actually involved a costly C. This module aims to be a partial replacement to L in those situations where you want to run a large number of simple tests. Its functions behave the same as their L counterparts, except for the following differences : =over 4 =item * Stringification isn't forced on the test operands. However, L honors C<'bool'> overloading, L and L honor C<'eq'> overloading (and just that one), L honors C<'ne'> overloading, and L honors whichever overloading category corresponds to the specified operator. =item * L, L, L, L, L, L, L, L and L are all guaranteed to return the truth value of the test. =item * C (the sub C in package C) is not aliased to L. =item * L and L don't special case regular expressions that are passed as C<'/.../'> strings. A string regexp argument is always treated as the source of the regexp, making C and C equivalent to each other and to C (and likewise for C). =item * L throws an exception if the given operator isn't a valid Perl binary operator (except C<'='> and variants). It also tests in scalar context, so C<'..'> will be treated as the flip-flop operator and not the range operator. =item * L doesn't guard for memory cycles. If the two first arguments present parallel memory cycles, the test may result in an infinite loop. =item * The tests don't output any kind of default diagnostic in case of failure ; the rationale being that if you have a large number of tests and a lot of them are failing, then you don't want to be flooded by diagnostics. Moreover, this allows a much faster variant of L. =item * C, C, C, C, C, C, C, C blocks and C are not implemented. =back =cut use Exporter (); my $main_process; BEGIN { $main_process = $$; if ("$]" >= 5.008 and $INC{'threads.pm'}) { my $use_ithreads = do { require Config; no warnings 'once'; $Config::Config{useithreads}; }; if ($use_ithreads) { require threads::shared; *THREADSAFE = sub () { 1 }; } } unless (defined &Test::Leaner::THREADSAFE) { *THREADSAFE = sub () { 0 } } } my ($TAP_STREAM, $DIAG_STREAM); my ($plan, $test, $failed, $no_diag, $done_testing); our @EXPORT = qw< plan skip done_testing pass fail ok is isnt like unlike cmp_ok is_deeply diag note BAIL_OUT >; =head1 ENVIRONMENT =head2 C If this environment variable is set, L will replace its functions by those from L. Moreover, the symbols that are imported when you C will be those from L, but you can still only import the symbols originally defined in L (hence the functions from L that are not implemented in L will not be imported). If your version of L is too old and doesn't have some symbols (like L or L), they will be replaced in L by croaking stubs. This may be useful if your L-based test script fails and you want extra diagnostics. =cut sub _handle_import_args { my @imports; my $i = 0; while ($i <= $#_) { my $item = $_[$i]; my $splice; if (defined $item) { if ($item eq 'import') { push @imports, @{ $_[$i+1] }; $splice = 2; } elsif ($item eq 'no_diag') { lock $plan if THREADSAFE; $no_diag = 1; $splice = 1; } } if ($splice) { splice @_, $i, $splice; } else { ++$i; } } return @imports; } if ($ENV{PERL_TEST_LEANER_USES_TEST_MORE}) { require Test::More; my $leaner_stash = \%Test::Leaner::; my $more_stash = \%Test::More::; my %stubbed; for (@EXPORT) { my $replacement = exists $more_stash->{$_} ? *{$more_stash->{$_}}{CODE} : undef; unless (defined $replacement) { $stubbed{$_}++; $replacement = sub { @_ = ("$_ is not implemented in this version of Test::More"); goto &croak; }; } no warnings 'redefine'; $leaner_stash->{$_} = $replacement; } my $import = sub { my $class = shift; my @imports = &_handle_import_args; if (@imports == grep /^!/, @imports) { # All imports are negated, or @imports is empty my %negated; /^!(.*)/ and ++$negated{$1} for @imports; push @imports, grep !$negated{$_}, @EXPORT; } my @test_more_imports; for (@imports) { if ($stubbed{$_}) { my $pkg = caller; no strict 'refs'; *{$pkg."::$_"} = $leaner_stash->{$_}; } elsif (/^!/ or !exists $more_stash->{$_} or exists $leaner_stash->{$_}) { push @test_more_imports, $_; } else { # Croak for symbols in Test::More but not in Test::Leaner Exporter::import($class, $_); } } my $test_more_import = 'Test::More'->can('import'); return unless $test_more_import; @_ = ( 'Test::More', @_, import => \@test_more_imports, ); { lock $plan if THREADSAFE; push @_, 'no_diag' if $no_diag; } goto $test_more_import; }; no warnings 'redefine'; *import = $import; return 1; } sub NO_PLAN () { -1 } sub SKIP_ALL () { -2 } BEGIN { if (THREADSAFE) { threads::shared::share($_) for $plan, $test, $failed, $no_diag, $done_testing; } lock $plan if THREADSAFE; $plan = undef; $test = 0; $failed = 0; } sub carp { my $level = 1 + ($Test::Builder::Level || 0); my @caller; do { @caller = caller $level--; } while (!@caller and $level >= 0); my ($file, $line) = @caller[1, 2]; warn @_, " at $file line $line.\n"; } sub croak { my $level = 1 + ($Test::Builder::Level || 0); my @caller; do { @caller = caller $level--; } while (!@caller and $level >= 0); my ($file, $line) = @caller[1, 2]; die @_, " at $file line $line.\n"; } sub _sanitize_comment { $_[0] =~ s/\n+\z//; $_[0] =~ s/#/\\#/g; $_[0] =~ s/\n/\n# /g; } =head1 FUNCTIONS The following functions from L are implemented and exported by default. =head2 C plan tests => $count; plan 'no_plan'; plan skip_all => $reason; See L. =cut sub plan { my ($key, $value) = @_; return unless $key; lock $plan if THREADSAFE; croak("You tried to plan twice") if defined $plan; my $plan_str; if ($key eq 'no_plan') { croak("no_plan takes no arguments") if $value; $plan = NO_PLAN; } elsif ($key eq 'tests') { croak("Got an undefined number of tests") unless defined $value; croak("You said to run 0 tests") unless $value; croak("Number of tests must be a positive integer. You gave it '$value'") unless $value =~ /^\+?[0-9]+$/; $plan = $value; $plan_str = "1..$value"; } elsif ($key eq 'skip_all') { $plan = SKIP_ALL; $plan_str = '1..0 # SKIP'; if (defined $value) { _sanitize_comment($value); $plan_str .= " $value" if length $value; } } else { my @args = grep defined, $key, $value; croak("plan() doesn't understand @args"); } if (defined $plan_str) { local $\; print $TAP_STREAM "$plan_str\n"; } exit 0 if $plan == SKIP_ALL; return 1; } sub import { my $class = shift; my @imports = &_handle_import_args; if (@_) { local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1; &plan; } @_ = ($class, @imports); goto &Exporter::import; } =head2 C skip $reason => $count; See L. =cut sub skip { my ($reason, $count) = @_; lock $plan if THREADSAFE; if (not defined $count) { carp("skip() needs to know \$how_many tests are in the block") unless defined $plan and $plan == NO_PLAN; $count = 1; } elsif ($count =~ /[^0-9]/) { carp('skip() was passed a non-numeric number of tests. Did you get the arguments backwards?'); $count = 1; } for (1 .. $count) { ++$test; my $skip_str = "ok $test # skip"; if (defined $reason) { _sanitize_comment($reason); $skip_str .= " $reason" if length $reason; } local $\; print $TAP_STREAM "$skip_str\n"; } no warnings 'exiting'; last SKIP; } =head2 C done_testing; done_testing $count; See L. =cut sub done_testing { my ($count) = @_; lock $plan if THREADSAFE; $count = $test unless defined $count; croak("Number of tests must be a positive integer. You gave it '$count'") unless $count =~ /^\+?[0-9]+$/; if (not defined $plan or $plan == NO_PLAN) { $plan = $count; # $plan can't be NO_PLAN anymore $done_testing = 1; local $\; print $TAP_STREAM "1..$plan\n"; } else { if ($done_testing) { @_ = ('done_testing() was already called'); goto &fail; } elsif ($plan != $count) { @_ = ("planned to run $plan tests but done_testing() expects $count"); goto &fail; } } return 1; } =head2 C ok $ok; ok $ok, $desc; See L. =cut sub ok ($;$) { my ($ok, $desc) = @_; lock $plan if THREADSAFE; ++$test; my $test_str = "ok $test"; $ok or do { $test_str = "not $test_str"; ++$failed; }; if (defined $desc) { _sanitize_comment($desc); $test_str .= " - $desc" if length $desc; } local $\; print $TAP_STREAM "$test_str\n"; return $ok; } =head2 C pass; pass $desc; See L. =cut sub pass (;$) { unshift @_, 1; goto &ok; } =head2 C fail; fail $desc; See L. =cut sub fail (;$) { unshift @_, 0; goto &ok; } =head2 C is $got, $expected; is $got, $expected, $desc; See L. =cut sub is ($$;$) { my ($got, $expected, $desc) = @_; no warnings 'uninitialized'; @_ = ( (not(defined $got xor defined $expected) and $got eq $expected), $desc, ); goto &ok; } =head2 C isnt $got, $expected; isnt $got, $expected, $desc; See L. =cut sub isnt ($$;$) { my ($got, $expected, $desc) = @_; no warnings 'uninitialized'; @_ = ( ((defined $got xor defined $expected) or $got ne $expected), $desc, ); goto &ok; } my %binops = ( 'or' => 'or', 'xor' => 'xor', 'and' => 'and', '||' => 'hor', ('//' => 'dor') x ("$]" >= 5.010), '&&' => 'hand', '|' => 'bor', '^' => 'bxor', '&' => 'band', 'lt' => 'lt', 'le' => 'le', 'gt' => 'gt', 'ge' => 'ge', 'eq' => 'eq', 'ne' => 'ne', 'cmp' => 'cmp', '<' => 'nlt', '<=' => 'nle', '>' => 'ngt', '>=' => 'nge', '==' => 'neq', '!=' => 'nne', '<=>' => 'ncmp', '=~' => 'like', '!~' => 'unlike', ('~~' => 'smartmatch') x ("$]" >= 5.010), '+' => 'add', '-' => 'substract', '*' => 'multiply', '/' => 'divide', '%' => 'modulo', '<<' => 'lshift', '>>' => 'rshift', '.' => 'concat', '..' => 'flipflop', '...' => 'altflipflop', ',' => 'comma', '=>' => 'fatcomma', ); my %binop_handlers; sub _create_binop_handler { my ($op) = @_; my $name = $binops{$op}; croak("Operator $op not supported") unless defined $name; { local $@; eval <<"IS_BINOP"; sub is_$name (\$\$;\$) { my (\$got, \$expected, \$desc) = \@_; \@_ = (scalar(\$got $op \$expected), \$desc); goto &ok; } IS_BINOP die $@ if $@; } $binop_handlers{$op} = do { no strict 'refs'; \&{__PACKAGE__."::is_$name"}; } } =head2 C like $got, $regexp_expected; like $got, $regexp_expected, $desc; See L. =head2 C unlike $got, $regexp_expected; unlike $got, $regexp_expected, $desc; See L. =cut { no warnings 'once'; *like = _create_binop_handler('=~'); *unlike = _create_binop_handler('!~'); } =head2 C cmp_ok $got, $op, $expected; cmp_ok $got, $op, $expected, $desc; See L. =cut sub cmp_ok ($$$;$) { my ($got, $op, $expected, $desc) = @_; my $handler = $binop_handlers{$op}; unless ($handler) { local $Test::More::Level = ($Test::More::Level || 0) + 1; $handler = _create_binop_handler($op); } @_ = ($got, $expected, $desc); goto $handler; } =head2 C is_deeply $got, $expected; is_deeply $got, $expected, $desc; See L. =cut BEGIN { local $@; if (eval { require Scalar::Util; 1 }) { *_reftype = \&Scalar::Util::reftype; } else { # Stolen from Scalar::Util::PP require B; my %tmap = qw< B::NULL SCALAR B::HV HASH B::AV ARRAY B::CV CODE B::IO IO B::GV GLOB B::REGEXP REGEXP >; *_reftype = sub ($) { my $r = shift; return undef unless length ref $r; my $t = ref B::svref_2object($r); return exists $tmap{$t} ? $tmap{$t} : length ref $$r ? 'REF' : 'SCALAR' } } } sub _deep_ref_check { my ($x, $y, $ry) = @_; no warnings qw; if ($ry eq 'ARRAY') { return 0 unless $#$x == $#$y; my ($ex, $ey); for (0 .. $#$y) { $ex = $x->[$_]; $ey = $y->[$_]; # Inline the beginning of _deep_check return 0 if defined $ex xor defined $ey; next if not(ref $ex xor ref $ey) and $ex eq $ey; $ry = _reftype($ey); return 0 if _reftype($ex) ne $ry; return 0 unless $ry and _deep_ref_check($ex, $ey, $ry); } return 1; } elsif ($ry eq 'HASH') { return 0 unless keys(%$x) == keys(%$y); my ($ex, $ey); for (keys %$y) { return 0 unless exists $x->{$_}; $ex = $x->{$_}; $ey = $y->{$_}; # Inline the beginning of _deep_check return 0 if defined $ex xor defined $ey; next if not(ref $ex xor ref $ey) and $ex eq $ey; $ry = _reftype($ey); return 0 if _reftype($ex) ne $ry; return 0 unless $ry and _deep_ref_check($ex, $ey, $ry); } return 1; } elsif ($ry eq 'SCALAR' or $ry eq 'REF') { return _deep_check($$x, $$y); } return 0; } sub _deep_check { my ($x, $y) = @_; no warnings qw; return 0 if defined $x xor defined $y; # Try object identity/eq overloading first. It also covers the case where # $x and $y are both undefined. # If either $x or $y is overloaded but none has eq overloading, the test will # break at that point. return 1 if not(ref $x xor ref $y) and $x eq $y; # Test::More::is_deeply happily breaks encapsulation if the objects aren't # overloaded. my $ry = _reftype($y); return 0 if _reftype($x) ne $ry; # Shortcut if $x and $y are both not references and failed the previous # $x eq $y test. return 0 unless $ry; # We know that $x and $y are both references of type $ry, without overloading. _deep_ref_check($x, $y, $ry); } sub is_deeply { @_ = ( &_deep_check, $_[2], ); goto &ok; } sub _diag_fh { my $fh = shift; return unless @_; lock $plan if THREADSAFE; return if $no_diag; my $msg = join '', map { defined($_) ? $_ : 'undef' } @_; _sanitize_comment($msg); return unless length $msg; local $\; print $fh "# $msg\n"; return 0; }; =head2 C diag @lines; See L. =cut sub diag { unshift @_, $DIAG_STREAM; goto &_diag_fh; } =head2 C note @lines; See L. =cut sub note { unshift @_, $TAP_STREAM; goto &_diag_fh; } =head2 C BAIL_OUT; BAIL_OUT $desc; See L. =cut sub BAIL_OUT { my ($desc) = @_; lock $plan if THREADSAFE; my $bail_out_str = 'Bail out!'; if (defined $desc) { _sanitize_comment($desc); $bail_out_str .= " $desc" if length $desc; # Two spaces } local $\; print $TAP_STREAM "$bail_out_str\n"; exit 255; } END { if ($main_process == $$ and not $?) { lock $plan if THREADSAFE; if (defined $plan) { if ($failed) { $? = $failed <= 254 ? $failed : 254; } elsif ($plan >= 0) { $? = $test == $plan ? 0 : 255; } if ($plan == NO_PLAN) { local $\; print $TAP_STREAM "1..$test\n"; } } } } =pod L also provides some functions of its own, which are never exported. =head2 C my $tap_fh = tap_stream; tap_stream $fh; Read/write accessor for the filehandle to which the tests are outputted. On write, it also turns autoflush on onto C<$fh>. Note that it can only be used as a write accessor before you start any thread, as L cannot reliably share filehandles. Defaults to C. =cut sub tap_stream (;*) { if (@_) { $TAP_STREAM = $_[0]; my $fh = select $TAP_STREAM; $|++; select $fh; } return $TAP_STREAM; } tap_stream *STDOUT; =head2 C my $diag_fh = diag_stream; diag_stream $fh; Read/write accessor for the filehandle to which the diagnostics are printed. On write, it also turns autoflush on onto C<$fh>. Just like L, it can only be used as a write accessor before you start any thread, as L cannot reliably share filehandles. Defaults to C. =cut sub diag_stream (;*) { if (@_) { $DIAG_STREAM = $_[0]; my $fh = select $DIAG_STREAM; $|++; select $fh; } return $DIAG_STREAM; } diag_stream *STDERR; =head2 C This constant evaluates to true if and only if L is thread-safe, i.e. when this version of C is at least 5.8, has been compiled with C defined, and L has been loaded B L. In that case, it also needs a working L. =head1 DEPENDENCIES L 5.6. L, L. =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 Test::Leaner =head1 COPYRIGHT & LICENSE Copyright 2010,2011,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. Except for the fallback implementation of the internal C<_reftype> function, which has been taken from L and is Copyright 1997-2007 Graham Barr, 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 Test::Leaner Variable-Magic-0.61/samples/copy.pl000755 000765 000024 00000000606 12553463314 020002 0ustar00vincentstaff000000 000000 #!/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.61/samples/magic.pl000755 000765 000024 00000001216 12553463314 020106 0ustar00vincentstaff000000 000000 #!/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.61/samples/synopsis.pl000755 000765 000024 00000001437 12553463314 020722 0ustar00vincentstaff000000 000000 #!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.61/samples/uvar.pl000755 000765 000024 00000001207 12553463315 020004 0ustar00vincentstaff000000 000000 #!/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; Variable-Magic-0.61/samples/vm_vs_tie.pl000755 000765 000024 00000001701 12553463315 021021 0ustar00vincentstaff000000 000000 #!/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.61/lib/Variable/000755 000765 000024 00000000000 13041666623 017316 5ustar00vincentstaff000000 000000 Variable-Magic-0.61/lib/Variable/Magic.pm000644 000765 000024 00000056452 13041665451 020706 0ustar00vincentstaff000000 000000 package 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.61 =cut our $VERSION; BEGIN { $VERSION = '0.61'; } =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 When applied to tied arrays and hashes, this magic fires when you try to access or change their elements. Starting from perl 5.17.0, it can also be applied to closure prototypes, in which case the magic will be called when the prototype is cloned. The L constant is true when your perl support this feature. =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 When the variable for which the magic is invoked is an array or an hash, 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). Since C<$_[2]> might be a copy, it is useless to try to change it or cast magic on it. Starting from perl 5.17.0, this magic can also be called for code references. In this case, C<$_[2]> is always C and C<$_[3]> is a reference to the cloned anonymous subroutine. =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 always executed in scalar context. The returned value is coerced into a signed integer, which is then passed straight to the perl magic API. However, note that perl currently only cares about the return value of the I magic callback and ignores all the others. Starting with Variable::Magic 0.58, a reference returned from a non-I magic callback will not be destroyed immediately but will be allowed to survive until the end of the statement that triggered the magic. This lets you use this return value as a token for triggering a destructor after the original magic action takes place. You can see an example of this technique in the L. =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 when a magical closure prototype is cloned. =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. =head2 Delayed magic actions Starting with Variable::Magic 0.58, the return value of the magic callbacks can be used to delay the action until after the original action takes place : my $delayed; my $delayed_aux = wizard( data => sub { $_[1] }, free => sub { my ($target) = $_[1]; my $target_data = &getdata($target, $delayed); local $target_data->{guard} = 1; if (ref $target eq 'SCALAR') { my $orig = $$target; $$target = $target_data->{mangler}->($orig); } return; }, ); $delayed = wizard( data => sub { return +{ guard => 0, mangler => $_[1] }; }, set => sub { return if $_[1]->{guard}; my $token; cast $token, $delayed_aux, $_[0]; return \$token; }, ); my $x = 1; cast $x, $delayed => sub { $_[0] * 2 }; $x = 2; # $x is now 4 # But note that the delayed action only takes place at the end of the # current statement : my @y = ($x = 5, $x); # $x is now 10, but @y is (5, 5) =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_CODE_COPY_CLONE 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). =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 =head1 COPYRIGHT & LICENSE Copyright 2007,2008,2009,2010,2011,2012,2013,2014,2015,2016,2017 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