From 303821407dfc14f42786aaaf21a53ad9f2c4cb7c Mon Sep 17 00:00:00 2001 From: denghao Date: Fri, 2 Sep 2022 08:41:12 +0300 Subject: [PATCH] Import Upstream version 0.62 --- Changes | 557 +++++ MANIFEST | 54 + META.json | 71 + META.yml | 45 + Magic.xs | 2076 +++++++++++++++++ Makefile.PL | 133 ++ README | 653 ++++++ lib/Variable/Magic.pm | 761 ++++++ samples/copy.pl | 18 + samples/magic.pl | 26 + samples/synopsis.pl | 28 + samples/uvar.pl | 27 + samples/vm_vs_tie.pl | 50 + t/00-load.t | 18 + t/01-import.t | 35 + t/02-constants.t | 11 + t/09-load-threads.t | 424 ++++ t/10-simple.t | 62 + t/11-multiple.t | 155 ++ t/13-data.t | 93 + t/14-callbacks.t | 120 + t/15-self.t | 207 ++ t/16-huf.t | 48 + t/17-ctl.t | 375 +++ t/18-opinfo.t | 131 ++ t/20-get.t | 35 + t/21-set.t | 37 + t/22-len.t | 213 ++ t/23-clear.t | 39 + t/24-free.t | 26 + t/25-copy.t | 102 + t/27-local.t | 73 + t/28-uvar.t | 151 ++ t/30-scalar.t | 125 + t/31-array.t | 96 + t/32-hash.t | 165 ++ t/33-code.t | 58 + t/34-glob.t | 68 + t/35-stash.t | 350 +++ t/40-threads.t | 127 + t/41-clone.t | 181 ++ t/50-return.t | 195 ++ t/80-leaks.t | 163 ++ t/lib/Test/Leaner.pm | 946 ++++++++ t/lib/VPIT/TestHelpers.pm | 850 +++++++ t/lib/Variable/Magic/TestDestroyRequired.pm | 7 + t/lib/Variable/Magic/TestGlobalDestruction.pm | 114 + t/lib/Variable/Magic/TestScopeEnd.pm | 25 + t/lib/Variable/Magic/TestValue.pm | 55 + t/lib/Variable/Magic/TestWatcher.pm | 72 + xsh/caps.h | 47 + xsh/mem.h | 199 ++ xsh/threads.h | 502 ++++ xsh/util.h | 89 + 54 files changed, 11288 insertions(+) create mode 100644 Changes create mode 100644 MANIFEST create mode 100644 META.json create mode 100644 META.yml create mode 100644 Magic.xs create mode 100644 Makefile.PL create mode 100644 README create mode 100644 lib/Variable/Magic.pm create mode 100755 samples/copy.pl create mode 100755 samples/magic.pl create mode 100755 samples/synopsis.pl create mode 100755 samples/uvar.pl create mode 100755 samples/vm_vs_tie.pl create mode 100644 t/00-load.t create mode 100644 t/01-import.t create mode 100644 t/02-constants.t create mode 100644 t/09-load-threads.t create mode 100644 t/10-simple.t create mode 100644 t/11-multiple.t create mode 100644 t/13-data.t create mode 100644 t/14-callbacks.t create mode 100644 t/15-self.t create mode 100644 t/16-huf.t create mode 100644 t/17-ctl.t create mode 100644 t/18-opinfo.t create mode 100644 t/20-get.t create mode 100644 t/21-set.t create mode 100644 t/22-len.t create mode 100644 t/23-clear.t create mode 100644 t/24-free.t create mode 100644 t/25-copy.t create mode 100644 t/27-local.t create mode 100644 t/28-uvar.t create mode 100644 t/30-scalar.t create mode 100644 t/31-array.t create mode 100644 t/32-hash.t create mode 100644 t/33-code.t create mode 100644 t/34-glob.t create mode 100644 t/35-stash.t create mode 100644 t/40-threads.t create mode 100644 t/41-clone.t create mode 100644 t/50-return.t create mode 100644 t/80-leaks.t create mode 100644 t/lib/Test/Leaner.pm create mode 100644 t/lib/VPIT/TestHelpers.pm create mode 100644 t/lib/Variable/Magic/TestDestroyRequired.pm create mode 100644 t/lib/Variable/Magic/TestGlobalDestruction.pm create mode 100644 t/lib/Variable/Magic/TestScopeEnd.pm create mode 100644 t/lib/Variable/Magic/TestValue.pm create mode 100644 t/lib/Variable/Magic/TestWatcher.pm create mode 100644 xsh/caps.h create mode 100644 xsh/mem.h create mode 100644 xsh/threads.h create mode 100644 xsh/util.h diff --git a/Changes b/Changes new file mode 100644 index 0000000..54284b5 --- /dev/null +++ b/Changes @@ -0,0 +1,557 @@ +Revision history for Variable-Magic + +0.62 2017-11-04 16:35 UTC + + Fix : [RT #123314] : Compatibility with CV-in-stash optimisation + Thanks Father Chrysostomos for reporting and contributing a + patch. + +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. + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..83bea10 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,54 @@ +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 diff --git a/META.json b/META.json new file mode 100644 index 0000000..17b9e2a --- /dev/null +++ b/META.json @@ -0,0 +1,71 @@ +{ + "abstract" : "Associate user-defined magic to variables from Perl.", + "author" : [ + "Vincent Pit " + ], + "dynamic_config" : 1, + "generated_by" : "ExtUtils::MakeMaker version 7.3, 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.62", + "x_serialization_backend" : "JSON::PP version 2.94" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..30c72dd --- /dev/null +++ b/META.yml @@ -0,0 +1,45 @@ +--- +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.3, 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.62' +x_serialization_backend: 'CPAN::Meta::YAML version 0.018' diff --git a/Magic.xs b/Magic.xs new file mode 100644 index 0000000..aa4af35 --- /dev/null +++ b/Magic.xs @@ -0,0 +1,2076 @@ +/* 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 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..9abd407 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,133 @@ +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, +); diff --git a/README b/README new file mode 100644 index 0000000..925545c --- /dev/null +++ b/README @@ -0,0 +1,653 @@ +NAME + Variable::Magic - Associate user-defined magic to variables from Perl. + +VERSION + Version 0.62 + +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. + diff --git a/lib/Variable/Magic.pm b/lib/Variable/Magic.pm new file mode 100644 index 0000000..e35a3c3 --- /dev/null +++ b/lib/Variable/Magic.pm @@ -0,0 +1,761 @@ +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.62 + +=cut + +our $VERSION; +BEGIN { + $VERSION = '0.62'; +} + +=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 diff --git a/samples/copy.pl b/samples/copy.pl new file mode 100755 index 0000000..e24dc80 --- /dev/null +++ b/samples/copy.pl @@ -0,0 +1,18 @@ +#!/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'; diff --git a/samples/magic.pl b/samples/magic.pl new file mode 100755 index 0000000..3fc8a8f --- /dev/null +++ b/samples/magic.pl @@ -0,0 +1,26 @@ +#!/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) diff --git a/samples/synopsis.pl b/samples/synopsis.pl new file mode 100755 index 0000000..5b5cd7c --- /dev/null +++ b/samples/synopsis.pl @@ -0,0 +1,28 @@ +#!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" +} diff --git a/samples/uvar.pl b/samples/uvar.pl new file mode 100755 index 0000000..d1e52ab --- /dev/null +++ b/samples/uvar.pl @@ -0,0 +1,27 @@ +#!/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; diff --git a/samples/vm_vs_tie.pl b/samples/vm_vs_tie.pl new file mode 100755 index 0000000..b7f888d --- /dev/null +++ b/samples/vm_vs_tie.pl @@ -0,0 +1,50 @@ +#!/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 } +}; diff --git a/t/00-load.t b/t/00-load.t new file mode 100644 index 0000000..3c62ab3 --- /dev/null +++ b/t/00-load.t @@ -0,0 +1,18 @@ +#!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(); +} diff --git a/t/01-import.t b/t/01-import.t new file mode 100644 index 0000000..099ff31 --- /dev/null +++ b/t/01-import.t @@ -0,0 +1,35 @@ +#!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 $_"; +} diff --git a/t/02-constants.t b/t/02-constants.t new file mode 100644 index 0000000..f211897 --- /dev/null +++ b/t/02-constants.t @@ -0,0 +1,11 @@ +#!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'; diff --git a/t/09-load-threads.t b/t/09-load-threads.t new file mode 100644 index 0000000..cd8cfbc --- /dev/null +++ b/t/09-load-threads.t @@ -0,0 +1,424 @@ +#!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(); diff --git a/t/10-simple.t b/t/10-simple.t new file mode 100644 index 0000000..1692b44 --- /dev/null +++ b/t/10-simple.t @@ -0,0 +1,62 @@ +#!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'); diff --git a/t/11-multiple.t b/t/11-multiple.t new file mode 100644 index 0000000..7c92b78 --- /dev/null +++ b/t/11-multiple.t @@ -0,0 +1,155 @@ +#!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'); +} diff --git a/t/13-data.t b/t/13-data.t new file mode 100644 index 0000000..bc4248e --- /dev/null +++ b/t/13-data.t @@ -0,0 +1,93 @@ +#!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'); diff --git a/t/14-callbacks.t b/t/14-callbacks.t new file mode 100644 index 0000000..6a1f56f --- /dev/null +++ b/t/14-callbacks.t @@ -0,0 +1,120 @@ +#!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'); + diff --git a/t/15-self.t b/t/15-self.t new file mode 100644 index 0000000..a9560ab --- /dev/null +++ b/t/15-self.t @@ -0,0 +1,207 @@ +#!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'; diff --git a/t/16-huf.t b/t/16-huf.t new file mode 100644 index 0000000..024a39c --- /dev/null +++ b/t/16-huf.t @@ -0,0 +1,48 @@ +#!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 }; diff --git a/t/17-ctl.t b/t/17-ctl.t new file mode 100644 index 0000000..8834540 --- /dev/null +++ b/t/17-ctl.t @@ -0,0 +1,375 @@ +#!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; +} diff --git a/t/18-opinfo.t b/t/18-opinfo.t new file mode 100644 index 0000000..bcc70a0 --- /dev/null +++ b/t/18-opinfo.t @@ -0,0 +1,131 @@ +#!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'; +} diff --git a/t/20-get.t b/t/20-get.t new file mode 100644 index 0000000..3411417 --- /dev/null +++ b/t/20-get.t @@ -0,0 +1,35 @@ +#!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; +} diff --git a/t/21-set.t b/t/21-set.t new file mode 100644 index 0000000..70af0e4 --- /dev/null +++ b/t/21-set.t @@ -0,0 +1,37 @@ +#!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; +} diff --git a/t/22-len.t b/t/22-len.t new file mode 100644 index 0000000..8decac9 --- /dev/null +++ b/t/22-len.t @@ -0,0 +1,213 @@ +#!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"; + } +} diff --git a/t/23-clear.t b/t/23-clear.t new file mode 100644 index 0000000..3af5545 --- /dev/null +++ b/t/23-clear.t @@ -0,0 +1,39 @@ +#!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'; +} diff --git a/t/24-free.t b/t/24-free.t new file mode 100644 index 0000000..eaa7db3 --- /dev/null +++ b/t/24-free.t @@ -0,0 +1,26 @@ +#!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 }; diff --git a/t/25-copy.t b/t/25-copy.t new file mode 100644 index 0000000..46e3241 --- /dev/null +++ b/t/25-copy.t @@ -0,0 +1,102 @@ +#!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 +} diff --git a/t/27-local.t b/t/27-local.t new file mode 100644 index 0000000..ca557e1 --- /dev/null +++ b/t/27-local.t @@ -0,0 +1,73 @@ +#!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'; + } +} diff --git a/t/28-uvar.t b/t/28-uvar.t new file mode 100644 index 0000000..4c6d902 --- /dev/null +++ b/t/28-uvar.t @@ -0,0 +1,151 @@ +#!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'; +} diff --git a/t/30-scalar.t b/t/30-scalar.t new file mode 100644 index 0000000..59ab5e5 --- /dev/null +++ b/t/30-scalar.t @@ -0,0 +1,125 @@ +#!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'; +} diff --git a/t/31-array.t b/t/31-array.t new file mode 100644 index 0000000..3613dba --- /dev/null +++ b/t/31-array.t @@ -0,0 +1,96 @@ +#!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'; diff --git a/t/32-hash.t b/t/32-hash.t new file mode 100644 index 0000000..df46de2 --- /dev/null +++ b/t/32-hash.t @@ -0,0 +1,165 @@ +#!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"); + } +} diff --git a/t/33-code.t b/t/33-code.t new file mode 100644 index 0000000..a2d6711 --- /dev/null +++ b/t/33-code.t @@ -0,0 +1,58 @@ +#!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 }; diff --git a/t/34-glob.t b/t/34-glob.t new file mode 100644 index 0000000..af77a4f --- /dev/null +++ b/t/34-glob.t @@ -0,0 +1,68 @@ +#!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'; diff --git a/t/35-stash.t b/t/35-stash.t new file mode 100644 index 0000000..a9600bc --- /dev/null +++ b/t/35-stash.t @@ -0,0 +1,350 @@ +#!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'; + my %expected = ( fetch => [ qw ] ); + # Typeglob reification may cause a store in 5.28+ + if ("$]" >= 5.027 && %mg == 2) { + $expected{store} = $expected{fetch}; + } + is_deeply \%mg, \%expected, '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'; diff --git a/t/40-threads.t b/t/40-threads.t new file mode 100644 index 0000000..151116b --- /dev/null +++ b/t/40-threads.t @@ -0,0 +1,127 @@ +#!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'; + } +} diff --git a/t/41-clone.t b/t/41-clone.t new file mode 100644 index 0000000..2058cc5 --- /dev/null +++ b/t/41-clone.t @@ -0,0 +1,181 @@ +#!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; +} diff --git a/t/50-return.t b/t/50-return.t new file mode 100644 index 0000000..a52d768 --- /dev/null +++ b/t/50-return.t @@ -0,0 +1,195 @@ +#!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; +} diff --git a/t/80-leaks.t b/t/80-leaks.t new file mode 100644 index 0000000..9ccc1a3 --- /dev/null +++ b/t/80-leaks.t @@ -0,0 +1,163 @@ +#!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"; + } +} diff --git a/t/lib/Test/Leaner.pm b/t/lib/Test/Leaner.pm new file mode 100644 index 0000000..9944e25 --- /dev/null +++ b/t/lib/Test/Leaner.pm @@ -0,0 +1,946 @@ +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 diff --git a/t/lib/VPIT/TestHelpers.pm b/t/lib/VPIT/TestHelpers.pm new file mode 100644 index 0000000..f47bee1 --- /dev/null +++ b/t/lib/VPIT/TestHelpers.pm @@ -0,0 +1,850 @@ +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 ref \$glob eq 'GLOB' ? *$glob{CODE} + : ref $glob eq 'CODE' ? $glob + : 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 : + +=over 8 + +=item - + +L + +=back + +=item * + +Exports : + +=over 8 + +=item - + +C + +=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); + + # This is only required for run_perl_file(), so it is not needed for the + # threads feature which only calls run_perl() - don't forget to update its + # requirements if this ever changes. + require File::Spec; + + return ( + run_perl => \&run_perl, + run_perl_file => \&run_perl_file, + "${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; + }; +} + +sub run_perl_file { + my $file = shift; + + $file = File::Spec->rel2abs($file); + unless (-e $file and -r _) { + die 'Could not run perl file'; + } + + fresh_perl_env { + my ($perl, @perl_args) = @_; + system { $perl } $perl, @perl_args, $file; + }; +} + +=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; + # run_perl() doesn't actually require anything + 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; diff --git a/t/lib/Variable/Magic/TestDestroyRequired.pm b/t/lib/Variable/Magic/TestDestroyRequired.pm new file mode 100644 index 0000000..78c02f8 --- /dev/null +++ b/t/lib/Variable/Magic/TestDestroyRequired.pm @@ -0,0 +1,7 @@ +package Variable::Magic::TestDestroyRequired; + +use Variable::Magic; + +my $tag = Variable::Magic::wizard(); + +1; diff --git a/t/lib/Variable/Magic/TestGlobalDestruction.pm b/t/lib/Variable/Magic/TestGlobalDestruction.pm new file mode 100644 index 0000000..34c4b59 --- /dev/null +++ b/t/lib/Variable/Magic/TestGlobalDestruction.pm @@ -0,0 +1,114 @@ +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; diff --git a/t/lib/Variable/Magic/TestScopeEnd.pm b/t/lib/Variable/Magic/TestScopeEnd.pm new file mode 100644 index 0000000..1eca93b --- /dev/null +++ b/t/lib/Variable/Magic/TestScopeEnd.pm @@ -0,0 +1,25 @@ +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; diff --git a/t/lib/Variable/Magic/TestValue.pm b/t/lib/Variable/Magic/TestValue.pm new file mode 100644 index 0000000..2b735dc --- /dev/null +++ b/t/lib/Variable/Magic/TestValue.pm @@ -0,0 +1,55 @@ +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; diff --git a/t/lib/Variable/Magic/TestWatcher.pm b/t/lib/Variable/Magic/TestWatcher.pm new file mode 100644 index 0000000..a849922 --- /dev/null +++ b/t/lib/Variable/Magic/TestWatcher.pm @@ -0,0 +1,72 @@ +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; diff --git a/xsh/caps.h b/xsh/caps.h new file mode 100644 index 0000000..4559524 --- /dev/null +++ b/xsh/caps.h @@ -0,0 +1,47 @@ +#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 */ diff --git a/xsh/mem.h b/xsh/mem.h new file mode 100644 index 0000000..e1b90b3 --- /dev/null +++ b/xsh/mem.h @@ -0,0 +1,199 @@ +#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 */ diff --git a/xsh/threads.h b/xsh/threads.h new file mode 100644 index 0000000..4288444 --- /dev/null +++ b/xsh/threads.h @@ -0,0 +1,502 @@ +#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 */ diff --git a/xsh/util.h b/xsh/util.h new file mode 100644 index 0000000..7616aa4 --- /dev/null +++ b/xsh/util.h @@ -0,0 +1,89 @@ +#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 */