Import Upstream version 0.62
This commit is contained in:
denghao
commit
303821407d
|
|
@ -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.
|
||||
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1,71 @@
|
|||
{
|
||||
"abstract" : "Associate user-defined magic to variables from Perl.",
|
||||
"author" : [
|
||||
"Vincent Pit <perl@profvince.com>"
|
||||
],
|
||||
"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"
|
||||
}
|
||||
|
|
@ -0,0 +1,45 @@
|
|||
---
|
||||
abstract: 'Associate user-defined magic to variables from Perl.'
|
||||
author:
|
||||
- 'Vincent Pit <perl@profvince.com>'
|
||||
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'
|
||||
|
|
@ -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<libperl gccversion>};
|
||||
if ($gccversion =~ /^3\.4\.[0-9]+/ and $libperl =~ s/\.lib$//) {
|
||||
$is_gcc_34 = 1;
|
||||
my ($lddlflags, $ldflags) = @Config{qw<lddlflags ldflags>};
|
||||
$_ ||= '', s/-L(?:".*?"|\S+)//g for $lddlflags, $ldflags;
|
||||
$libperl = "-l$libperl";
|
||||
my $libdirs = join ' ',
|
||||
map { s/(?<!\\)((?:\\\\)*")/\\$1/g; qq[-L"$_"] }
|
||||
@Config{qw<bin sitebin>};
|
||||
$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 <perl@profvince.com>',
|
||||
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,
|
||||
);
|
||||
|
|
@ -0,0 +1,653 @@
|
|||
NAME
|
||||
Variable::Magic - Associate user-defined magic to variables from Perl.
|
||||
|
||||
VERSION
|
||||
Version 0.62
|
||||
|
||||
SYNOPSIS
|
||||
use Variable::Magic qw<wizard cast VMG_OP_INFO_NAME>;
|
||||
|
||||
{ # 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<wizard cast getdata>;
|
||||
|
||||
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, "<perl at profvince.com>", <http://www.profvince.com>.
|
||||
|
||||
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
|
||||
<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Variable-Magic>. 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.
|
||||
|
||||
|
|
@ -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<wizard cast VMG_OP_INFO_NAME>;
|
||||
|
||||
{ # 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<vec()> and C<substr()> lvalues, L<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 :
|
||||
|
||||
=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<tie>, where you have to provide fallbacks methods for all actions by usually inheriting from the correct C<Tie::Std*> 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<ref>, C<tied> 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<get>
|
||||
|
||||
This magic is invoked when the variable is evaluated.
|
||||
It is never called for arrays and hashes.
|
||||
|
||||
=item *
|
||||
|
||||
I<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.
|
||||
|
||||
=item *
|
||||
|
||||
I<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 (C<for>, C<map> or C<grep>).
|
||||
The length is returned from the callback as an integer.
|
||||
|
||||
Starting from perl 5.12, this magic is no longer called by the C<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 L</VMG_COMPAT_SCALAR_LENGTH_NOLEN> and L</VMG_COMPAT_SCALAR_NOLEN> to see if this magic is available for scalars or not.
|
||||
|
||||
=item *
|
||||
|
||||
I<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 L<history|/PERL MAGIC HISTORY>).
|
||||
|
||||
=item *
|
||||
|
||||
I<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. C<DESTROY> methods), except that exceptions thrown from inside a I<free> callback will always be propagated to the surrounding code.
|
||||
|
||||
=item *
|
||||
|
||||
I<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 L</VMG_COMPAT_CODE_COPY_CLONE> constant is true when your perl support this feature.
|
||||
|
||||
=item *
|
||||
|
||||
I<dup>
|
||||
|
||||
This magic is invoked when the variable is cloned across threads.
|
||||
It is currently not available.
|
||||
|
||||
=item *
|
||||
|
||||
I<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 C<MGf_LOCAL> is true.
|
||||
|
||||
=back
|
||||
|
||||
The following actions only apply to hashes and are available if and only if L</VMG_UVAR> is true.
|
||||
They are referred to as I<uvar> magics.
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
I<fetch>
|
||||
|
||||
This magic is invoked each time an element is fetched from the hash.
|
||||
|
||||
=item *
|
||||
|
||||
I<store>
|
||||
|
||||
This one is called when an element is stored into the hash.
|
||||
|
||||
=item *
|
||||
|
||||
I<exists>
|
||||
|
||||
This magic fires when a key is tested for existence in the hash.
|
||||
|
||||
=item *
|
||||
|
||||
I<delete>
|
||||
|
||||
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>
|
||||
|
||||
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<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 C<$_[0]> being a reference to this variable and C<@_[1 .. @_-1]> being all extra arguments that were passed to L</cast>.
|
||||
The scalar returned from this call is then attached to the variable and can be retrieved later with L</getdata>.
|
||||
|
||||
=item *
|
||||
|
||||
C<get>, C<set>, C<len>, C<clear>, C<free>, C<copy>, C<local>, C<fetch>, C<store>, C<exists> and C<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, C<$_[0]> is a reference to the magic variable and C<$_[1]> is the associated private data (or C<undef> when no private data constructor is supplied with the wizard).
|
||||
Other arguments depend on which kind of magic is involved :
|
||||
|
||||
=over 8
|
||||
|
||||
=item *
|
||||
|
||||
I<len>
|
||||
|
||||
C<$_[2]> contains the natural, non-magical length of the variable (which can only be a scalar or an array as I<len> magic is only relevant for these types).
|
||||
The callback is expected to return the new scalar or array length to use, or C<undef> to default to the normal length.
|
||||
|
||||
=item *
|
||||
|
||||
I<copy>
|
||||
|
||||
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<undef> and C<$_[3]> is a reference to the cloned anonymous subroutine.
|
||||
|
||||
=item *
|
||||
|
||||
I<fetch>, I<store>, I<exists> and I<delete>
|
||||
|
||||
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</wizard> 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<wizard>, then one extra element is appended to C<@_>.
|
||||
Its nature depends on the value of C<$num> :
|
||||
|
||||
=over 8
|
||||
|
||||
=item *
|
||||
|
||||
C<VMG_OP_INFO_NAME>
|
||||
|
||||
C<$_[-1]> is the current op name.
|
||||
|
||||
=item *
|
||||
|
||||
C<VMG_OP_INFO_OBJECT>
|
||||
|
||||
C<$_[-1]> is the C<B::OP> 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<len> magic callback and ignores all the others.
|
||||
Starting with Variable::Magic 0.58, a reference returned from a non-I<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 L<cookbook|/COOKBOOK>.
|
||||
|
||||
=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<undef>, in which case a no-op magic callback is installed instead of the default one.
|
||||
This may especially be helpful for I<local> magic, where an empty callback prevents magic from being copied during localization.
|
||||
|
||||
=back
|
||||
|
||||
Note that I<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" },
|
||||
);
|
||||
|
||||
=cut
|
||||
|
||||
sub wizard {
|
||||
if (@_ % 2) {
|
||||
require Carp;
|
||||
Carp::croak('Wrong number of arguments for wizard()');
|
||||
}
|
||||
|
||||
my %opts = @_;
|
||||
|
||||
my @keys = qw<op_info data get set len clear free copy dup>;
|
||||
push @keys, 'local' if MGf_LOCAL;
|
||||
push @keys, qw<fetch store exists delete copy_key> if VMG_UVAR;
|
||||
|
||||
my ($wiz, $err);
|
||||
{
|
||||
local $@;
|
||||
$wiz = eval { _wizard(map $opts{$_}, @keys) };
|
||||
$err = $@;
|
||||
}
|
||||
if ($err) {
|
||||
$err =~ s/\sat\s+.*?\n//;
|
||||
require Carp;
|
||||
Carp::croak($err);
|
||||
}
|
||||
|
||||
return $wiz;
|
||||
}
|
||||
|
||||
=head2 C<cast>
|
||||
|
||||
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<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 C<POSIX::tzset> 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<store> magic.
|
||||
|
||||
=head2 C<getdata>
|
||||
|
||||
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>
|
||||
|
||||
dispell [$@%&*]variable, $wiz
|
||||
|
||||
The exact opposite of L</cast> : 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<MGf_COPY>
|
||||
|
||||
Evaluates to true if and only if the I<copy> 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<MGf_DUP>
|
||||
|
||||
Evaluates to true if and only if the I<dup> 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<MGf_LOCAL>
|
||||
|
||||
Evaluates to true if and only if the I<local> magic is available.
|
||||
This is the case for perl 5.9.3 and greater.
|
||||
|
||||
=head2 C<VMG_UVAR>
|
||||
|
||||
When this constant is true, you can use the I<fetch>, I<store>, I<exists> and I<delete> magics on hashes.
|
||||
Initial L</VMG_UVAR> capability was introduced in perl 5.9.5, with a fully functional implementation shipped with perl 5.10.0.
|
||||
|
||||
=head2 C<VMG_COMPAT_SCALAR_LENGTH_NOLEN>
|
||||
|
||||
True for perls that don't call I<len> magic when taking the C<length> of a magical scalar.
|
||||
|
||||
=head2 C<VMG_COMPAT_SCALAR_NOLEN>
|
||||
|
||||
True for perls that don't call I<len> magic on scalars.
|
||||
Implies L</VMG_COMPAT_SCALAR_LENGTH_NOLEN>.
|
||||
|
||||
=head2 C<VMG_COMPAT_ARRAY_PUSH_NOLEN>
|
||||
|
||||
True for perls that don't call I<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.
|
||||
|
||||
=head2 C<VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID>
|
||||
|
||||
True for perls that don't call I<len> magic when you push in void context an element in a magical array.
|
||||
|
||||
=head2 C<VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID>
|
||||
|
||||
True for perls that don't call I<len> magic when you unshift in void context an element in a magical array.
|
||||
|
||||
=head2 C<VMG_COMPAT_ARRAY_UNDEF_CLEAR>
|
||||
|
||||
True for perls that call I<clear> magic when undefining magical arrays.
|
||||
|
||||
=head2 C<VMG_COMPAT_HASH_DELETE_NOUVAR_VOID>
|
||||
|
||||
True for perls that don't call I<delete> magic when you delete an element from a hash in void context.
|
||||
|
||||
=head2 C<VMG_COMPAT_CODE_COPY_CLONE>
|
||||
|
||||
True for perls that call I<copy> magic when a magical closure prototype is cloned.
|
||||
|
||||
=head2 C<VMG_COMPAT_GLOB_GET>
|
||||
|
||||
True for perls that call I<get> magic for operations on globs.
|
||||
|
||||
=head2 C<VMG_PERL_PATCHLEVEL>
|
||||
|
||||
The perl patchlevel this module was built with, or C<0> for non-debugging perls.
|
||||
|
||||
=head2 C<VMG_THREADSAFE>
|
||||
|
||||
True if and only if this module could have been built with thread-safety features enabled.
|
||||
|
||||
=head2 C<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.
|
||||
|
||||
=head2 C<VMG_OP_INFO_NAME>
|
||||
|
||||
Value to pass with C<op_info> to get the current op name in the magic callbacks.
|
||||
|
||||
=head2 C<VMG_OP_INFO_OBJECT>
|
||||
|
||||
Value to pass with C<op_info> to get a C<B::OP> 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<wizard cast getdata>;
|
||||
|
||||
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<cast> can be called from any magical callback, and in particular from C<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 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<cast>.
|
||||
|
||||
=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<p14416> : I<copy> and I<dup> magic.
|
||||
|
||||
=item *
|
||||
|
||||
B<5.8.9>
|
||||
|
||||
I<p28160> : Integration of I<p25854> (see below).
|
||||
|
||||
I<p32542> : Integration of I<p31473> (see below).
|
||||
|
||||
=item *
|
||||
|
||||
B<5.9.3>
|
||||
|
||||
I<p25854> : I<len> magic is no longer called when pushing an element into a magic array.
|
||||
|
||||
I<p26569> : I<local> magic.
|
||||
|
||||
=item *
|
||||
|
||||
B<5.9.5>
|
||||
|
||||
I<p31064> : Meaningful I<uvar> magic.
|
||||
|
||||
I<p31473> : I<clear> magic was not invoked when undefining an array.
|
||||
The bug is fixed as of this version.
|
||||
|
||||
=item *
|
||||
|
||||
B<5.10.0>
|
||||
|
||||
Since C<PERL_MAGIC_uvar> is uppercased, C<hv_magic_check()> triggers I<copy> magic on hash stores for (non-tied) hashes that also have I<uvar> magic.
|
||||
|
||||
=item *
|
||||
|
||||
B<5.11.x>
|
||||
|
||||
I<p32969> : I<len> magic is no longer invoked when calling C<length> with a magical scalar.
|
||||
|
||||
I<p34908> : I<len> magic is no longer called when pushing / unshifting an element into a magical array in void context.
|
||||
The C<push> part was already covered by I<p25854>.
|
||||
|
||||
I<g9cdcb38b> : I<len> magic is called again when pushing into a magical array in non-void context.
|
||||
|
||||
=back
|
||||
|
||||
=head1 EXPORT
|
||||
|
||||
The functions L</wizard>, L</cast>, L</getdata> and L</dispell> 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<Exporter>;
|
||||
|
||||
our @EXPORT = ();
|
||||
our %EXPORT_TAGS = (
|
||||
'funcs' => [ qw<wizard cast getdata dispell> ],
|
||||
'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</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 L</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 I<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.
|
||||
|
||||
=head1 DEPENDENCIES
|
||||
|
||||
L<perl> 5.8.
|
||||
|
||||
A C compiler.
|
||||
This module may happen to build with a C++ compiler as well, but don't rely on it, as no guarantee is made in this regard.
|
||||
|
||||
L<Carp> (core since perl 5), L<XSLoader> (since 5.6.0).
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<perlguts> and L<perlapi> for internal information about magic.
|
||||
|
||||
L<perltie> and L<overload> for other ways of enhancing objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
|
||||
|
||||
You can contact me by mail or on C<irc.perl.org> (vincent).
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Please report any bugs or feature requests to C<bug-variable-magic at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Variable-Magic>.
|
||||
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
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
#!/usr/bin/env perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use lib qw<blib/arch blib/lib>;
|
||||
use Variable::Magic qw<wizard cast>;
|
||||
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';
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
#!/usr/bin/env perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use lib qw<blib/arch blib/lib>;
|
||||
use Variable::Magic qw<wizard cast dispell>;
|
||||
|
||||
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 b c>;
|
||||
++$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)
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
#!perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Variable::Magic qw<wizard cast VMG_OP_INFO_NAME>;
|
||||
|
||||
{
|
||||
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"
|
||||
}
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
#!/usr/bin/env perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use lib qw<blib/arch blib/lib>;
|
||||
use Variable::Magic qw<wizard cast dispell>;
|
||||
|
||||
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;
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
#!/usr/bin/env perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Tie::Hash;
|
||||
|
||||
use lib qw<blib/arch blib/lib>;
|
||||
use Variable::Magic qw<wizard cast VMG_UVAR>;
|
||||
|
||||
use Benchmark qw<cmpthese>;
|
||||
|
||||
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 }
|
||||
};
|
||||
|
|
@ -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();
|
||||
}
|
||||
|
|
@ -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 $_";
|
||||
}
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
#!perl -T
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 2;
|
||||
|
||||
use Variable::Magic qw<MGf_COPY MGf_DUP>;
|
||||
|
||||
ok MGf_COPY, 'MGf_COPY is always true';
|
||||
ok MGf_DUP, 'MGf_DUP is always true';
|
||||
|
|
@ -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();
|
||||
|
|
@ -0,0 +1,62 @@
|
|||
#!perl -T
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 43;
|
||||
|
||||
use Variable::Magic qw<wizard cast dispell MGf_LOCAL VMG_UVAR>;
|
||||
|
||||
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');
|
||||
|
|
@ -0,0 +1,155 @@
|
|||
#!perl -T
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 33 + 41;
|
||||
|
||||
use Variable::Magic qw<wizard cast dispell VMG_UVAR>;
|
||||
|
||||
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');
|
||||
}
|
||||
|
|
@ -0,0 +1,93 @@
|
|||
#!perl -T
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 35;
|
||||
|
||||
use Variable::Magic qw<wizard getdata cast dispell>;
|
||||
|
||||
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<z j t> };
|
||||
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');
|
||||
|
|
@ -0,0 +1,120 @@
|
|||
#!perl -T
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 26;
|
||||
|
||||
use Variable::Magic qw<wizard cast>;
|
||||
|
||||
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');
|
||||
|
||||
|
|
@ -0,0 +1,207 @@
|
|||
#!perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
|
||||
my $tests;
|
||||
BEGIN { $tests = 18 }
|
||||
|
||||
plan tests => $tests;
|
||||
|
||||
use Variable::Magic qw<wizard cast dispell getdata MGf_LOCAL VMG_UVAR>;
|
||||
|
||||
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<get set len clear free copy>;
|
||||
push @magics, 'local' if MGf_LOCAL;
|
||||
push @magics, qw<fetch store exists delete> 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';
|
||||
|
|
@ -0,0 +1,48 @@
|
|||
#!perl -T
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
|
||||
use lib 't/lib';
|
||||
use VPIT::TestHelpers;
|
||||
|
||||
use Variable::Magic qw<wizard cast dispell VMG_UVAR>;
|
||||
|
||||
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<fetch store> ], '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 };
|
||||
|
|
@ -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<wizard cast VMG_UVAR>;
|
||||
|
||||
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<wizard cast>; { 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<wizard cast>; 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;
|
||||
}
|
||||
|
|
@ -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<wizard cast dispell VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT>;
|
||||
|
||||
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';
|
||||
}
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
#!perl -T
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => (2 * 4 + 2) + (2 * 2) + 1;
|
||||
|
||||
use Variable::Magic qw<cast>;
|
||||
|
||||
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;
|
||||
}
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
#!perl -T
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => (2 * 5 + 3) + (2 * 2 + 1);
|
||||
|
||||
use Variable::Magic qw<cast>;
|
||||
|
||||
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;
|
||||
}
|
||||
|
|
@ -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<a b c>;
|
||||
|
||||
$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";
|
||||
}
|
||||
}
|
||||
|
|
@ -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<cast dispell>;
|
||||
|
||||
use lib 't/lib';
|
||||
use Variable::Magic::TestWatcher;
|
||||
use Variable::Magic::TestValue;
|
||||
|
||||
my $wiz = init_watcher 'clear', 'clear';
|
||||
|
||||
my @a = qw<a b c>;
|
||||
|
||||
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';
|
||||
}
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
#!perl -T
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 2 * 5 + 1;
|
||||
|
||||
use Variable::Magic qw<cast>;
|
||||
|
||||
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 };
|
||||
|
|
@ -0,0 +1,102 @@
|
|||
#!perl -T
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
|
||||
use lib 't/lib';
|
||||
use VPIT::TestHelpers;
|
||||
|
||||
use Variable::Magic qw<wizard cast dispell VMG_COMPAT_CODE_COPY_CLONE>;
|
||||
|
||||
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<a c> ], '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
|
||||
}
|
||||
|
|
@ -0,0 +1,73 @@
|
|||
#!perl -T
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
|
||||
use Variable::Magic qw<wizard cast getdata MGf_LOCAL>;
|
||||
|
||||
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';
|
||||
}
|
||||
}
|
||||
|
|
@ -0,0 +1,151 @@
|
|||
#!perl -T
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
|
||||
use lib 't/lib';
|
||||
use VPIT::TestHelpers;
|
||||
|
||||
use Variable::Magic qw<wizard cast dispell VMG_UVAR>;
|
||||
|
||||
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<fetch store exists delete> ], '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';
|
||||
}
|
||||
|
|
@ -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<wizard cast dispell>;
|
||||
|
||||
use lib 't/lib';
|
||||
use Variable::Magic::TestWatcher;
|
||||
|
||||
my $is_5130_release = ("$]" == 5.013 && !$Config{git_describe}) ? 1 : 0;
|
||||
|
||||
my $wiz = init_watcher
|
||||
[ qw<get set len clear free copy dup local fetch store exists delete> ],
|
||||
'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<clear free> ],
|
||||
'delete from tied array in void context';
|
||||
|
||||
$b = watch { delete $a[1] } [ qw<get clear free> ],
|
||||
'delete from tied array in scalar context';
|
||||
}
|
||||
|
|
@ -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<get set len clear free copy dup local fetch store exists delete> ],
|
||||
'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<a b d> } { 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';
|
||||
|
|
@ -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<get set len clear free copy dup local fetch store exists delete> ],
|
||||
'hash';
|
||||
|
||||
my %n = map { $_ => int rand 1000 } qw<foo bar baz qux>;
|
||||
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<bar qux>} }
|
||||
+{ (fetch => 2) x VMG_UVAR }, 'slice';
|
||||
is_deeply \@b, [ @n{qw<bar qux>} ], '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<a b d>; }
|
||||
+{ (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<a b c d> ], '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");
|
||||
}
|
||||
}
|
||||
|
|
@ -0,0 +1,58 @@
|
|||
#!perl -T
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 2 * 12 + 11 + 1;
|
||||
|
||||
use Variable::Magic qw<cast dispell>;
|
||||
|
||||
use lib 't/lib';
|
||||
use Variable::Magic::TestWatcher;
|
||||
|
||||
my $wiz = init_watcher
|
||||
[ qw<get set len clear free copy dup local fetch store exists delete> ],
|
||||
'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 };
|
||||
|
|
@ -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<cast dispell VMG_COMPAT_GLOB_GET>;
|
||||
|
||||
my %get = VMG_COMPAT_GLOB_GET ? (get => 1) : ();
|
||||
|
||||
use lib 't/lib';
|
||||
use Variable::Magic::TestWatcher;
|
||||
|
||||
my $wiz = init_watcher
|
||||
[ qw<get set len clear free copy dup local fetch store exists delete> ],
|
||||
'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<x y> ] } $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<x y> ] } $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';
|
||||
|
|
@ -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 { <<CB;
|
||||
$_ => sub {
|
||||
my \$d = \$_[1];
|
||||
return 0 if \$d->{guard};
|
||||
local \$d->{guard} = 1;
|
||||
push \@{\$mg{$_}}, \$_[2];
|
||||
()
|
||||
}
|
||||
CB
|
||||
} qw<fetch store exists delete>);
|
||||
|
||||
$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<thing stuff> ],
|
||||
store => [ qw<thing stuff> ],
|
||||
}, '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<eat shoot leave shoot> ],
|
||||
}, 'stash: function definitions';
|
||||
}
|
||||
|
||||
{
|
||||
local %mg;
|
||||
|
||||
eval q{
|
||||
die "ok\n";
|
||||
package Hlagh;
|
||||
eat();
|
||||
shoot();
|
||||
leave();
|
||||
roam();
|
||||
yawn();
|
||||
roam();
|
||||
};
|
||||
|
||||
my @calls = qw<eat shoot leave roam yawn roam>;
|
||||
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<shoot> ] );
|
||||
# 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<shoot> ],
|
||||
}, '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<shoot> ],
|
||||
}, '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<ISA leave> ],
|
||||
}, '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<shoot> ],
|
||||
}, '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<unknown> ],
|
||||
store => [ qw<unknown AUTOLOAD> ],
|
||||
}, '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<unknown_too AUTOLOAD> ],
|
||||
}, '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<also_unknown AUTOLOAD> ],
|
||||
}, 'stash: invalid method call';
|
||||
}
|
||||
|
||||
{
|
||||
local %mg;
|
||||
|
||||
my @expected_stores = qw<nevermentioned eat shoot>;
|
||||
@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<autoloaded> ],
|
||||
store => [ qw<autoloaded AUTOLOAD AUTOLOAD> ],
|
||||
}, '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<also_autoloaded AUTOLOAD> ],
|
||||
store => [ qw<AUTOLOAD> ],
|
||||
}, 'stash: inherited autoloaded method call';
|
||||
}
|
||||
|
||||
dispell %AutoHlagh::, $wiz;
|
||||
|
||||
my $uo = 0;
|
||||
$code = 'wizard '
|
||||
. join (', ', map { <<CB;
|
||||
$_ => sub {
|
||||
my \$d = \$_[1];
|
||||
return 0 if \$d->{guard};
|
||||
local \$d->{guard} = 1;
|
||||
++\$uo;
|
||||
()
|
||||
}
|
||||
CB
|
||||
} qw<fetch store exists delete>);
|
||||
|
||||
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';
|
||||
|
|
@ -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';
|
||||
}
|
||||
}
|
||||
|
|
@ -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;
|
||||
}
|
||||
|
|
@ -0,0 +1,195 @@
|
|||
#!perl -T
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Variable::Magic qw<wizard cast dispell getdata>;
|
||||
|
||||
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;
|
||||
}
|
||||
|
|
@ -0,0 +1,163 @@
|
|||
#!perl -T
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Variable::Magic qw<wizard cast getdata dispell MGf_LOCAL VMG_UVAR>;
|
||||
|
||||
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<get set clear free>;
|
||||
push @methods, 'local' if MGf_LOCAL;
|
||||
push @methods, qw<fetch store exists delete> 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<get set free>;
|
||||
$type{$_} = 'scalar_global' for qw<local>;
|
||||
$type{$_} = 'array' for qw<clear>;
|
||||
$type{$_} = 'hash' for qw<fetch store exists delete>;
|
||||
|
||||
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";
|
||||
}
|
||||
}
|
||||
|
|
@ -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<Test::More>-based test script that contained about 10 000 unit tests, I realized that 60% of the time was spent in L<Test::Builder> itself, even though every single test actually involved a costly C<eval STRING>.
|
||||
|
||||
This module aims to be a partial replacement to L<Test::More> in those situations where you want to run a large number of simple tests.
|
||||
Its functions behave the same as their L<Test::More> counterparts, except for the following differences :
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Stringification isn't forced on the test operands.
|
||||
However, L</ok> honors C<'bool'> overloading, L</is> and L</is_deeply> honor C<'eq'> overloading (and just that one), L</isnt> honors C<'ne'> overloading, and L</cmp_ok> honors whichever overloading category corresponds to the specified operator.
|
||||
|
||||
=item *
|
||||
|
||||
L</pass>, L</fail>, L</ok>, L</is>, L</isnt>, L</like>, L</unlike>, L</cmp_ok> and L</is_deeply> are all guaranteed to return the truth value of the test.
|
||||
|
||||
=item *
|
||||
|
||||
C<isn't> (the sub C<t> in package C<isn>) is not aliased to L</isnt>.
|
||||
|
||||
=item *
|
||||
|
||||
L</like> and L</unlike> 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<like $text, $rx> and C<like $text, qr[$rx]> equivalent to each other and to C<cmp_ok $text, '=~', $rx> (and likewise for C<unlike>).
|
||||
|
||||
=item *
|
||||
|
||||
L</cmp_ok> 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</is_deeply> 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</is_deeply>.
|
||||
|
||||
=item *
|
||||
|
||||
C<use_ok>, C<require_ok>, C<can_ok>, C<isa_ok>, C<new_ok>, C<subtest>, C<explain>, C<TODO> blocks and C<todo_skip> 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<PERL_TEST_LEANER_USES_TEST_MORE>
|
||||
|
||||
If this environment variable is set, L<Test::Leaner> will replace its functions by those from L<Test::More>.
|
||||
Moreover, the symbols that are imported when you C<use Test::Leaner> will be those from L<Test::More>, but you can still only import the symbols originally defined in L<Test::Leaner> (hence the functions from L<Test::More> that are not implemented in L<Test::Leaner> will not be imported).
|
||||
If your version of L<Test::More> is too old and doesn't have some symbols (like L</note> or L</done_testing>), they will be replaced in L<Test::Leaner> by croaking stubs.
|
||||
|
||||
This may be useful if your L<Test::Leaner>-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<Test::More> are implemented and exported by default.
|
||||
|
||||
=head2 C<plan>
|
||||
|
||||
plan tests => $count;
|
||||
plan 'no_plan';
|
||||
plan skip_all => $reason;
|
||||
|
||||
See L<Test::More/plan>.
|
||||
|
||||
=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>
|
||||
|
||||
skip $reason => $count;
|
||||
|
||||
See L<Test::More/skip>.
|
||||
|
||||
=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;
|
||||
done_testing $count;
|
||||
|
||||
See L<Test::More/done_testing>.
|
||||
|
||||
=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 $ok, $desc;
|
||||
|
||||
See L<Test::More/ok>.
|
||||
|
||||
=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;
|
||||
pass $desc;
|
||||
|
||||
See L<Test::More/pass>.
|
||||
|
||||
=cut
|
||||
|
||||
sub pass (;$) {
|
||||
unshift @_, 1;
|
||||
goto &ok;
|
||||
}
|
||||
|
||||
=head2 C<fail>
|
||||
|
||||
fail;
|
||||
fail $desc;
|
||||
|
||||
See L<Test::More/fail>.
|
||||
|
||||
=cut
|
||||
|
||||
sub fail (;$) {
|
||||
unshift @_, 0;
|
||||
goto &ok;
|
||||
}
|
||||
|
||||
=head2 C<is>
|
||||
|
||||
is $got, $expected;
|
||||
is $got, $expected, $desc;
|
||||
|
||||
See L<Test::More/is>.
|
||||
|
||||
=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>
|
||||
|
||||
isnt $got, $expected;
|
||||
isnt $got, $expected, $desc;
|
||||
|
||||
See L<Test::More/isnt>.
|
||||
|
||||
=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>
|
||||
|
||||
like $got, $regexp_expected;
|
||||
like $got, $regexp_expected, $desc;
|
||||
|
||||
See L<Test::More/like>.
|
||||
|
||||
=head2 C<unlike>
|
||||
|
||||
unlike $got, $regexp_expected;
|
||||
unlike $got, $regexp_expected, $desc;
|
||||
|
||||
See L<Test::More/unlike>.
|
||||
|
||||
=cut
|
||||
|
||||
{
|
||||
no warnings 'once';
|
||||
*like = _create_binop_handler('=~');
|
||||
*unlike = _create_binop_handler('!~');
|
||||
}
|
||||
|
||||
=head2 C<cmp_ok>
|
||||
|
||||
cmp_ok $got, $op, $expected;
|
||||
cmp_ok $got, $op, $expected, $desc;
|
||||
|
||||
See L<Test::More/cmp_ok>.
|
||||
|
||||
=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>
|
||||
|
||||
is_deeply $got, $expected;
|
||||
is_deeply $got, $expected, $desc;
|
||||
|
||||
See L<Test::More/is_deeply>.
|
||||
|
||||
=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<numeric uninitialized>;
|
||||
|
||||
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<numeric uninitialized>;
|
||||
|
||||
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>
|
||||
|
||||
diag @lines;
|
||||
|
||||
See L<Test::More/diag>.
|
||||
|
||||
=cut
|
||||
|
||||
sub diag {
|
||||
unshift @_, $DIAG_STREAM;
|
||||
goto &_diag_fh;
|
||||
}
|
||||
|
||||
=head2 C<note>
|
||||
|
||||
note @lines;
|
||||
|
||||
See L<Test::More/note>.
|
||||
|
||||
=cut
|
||||
|
||||
sub note {
|
||||
unshift @_, $TAP_STREAM;
|
||||
goto &_diag_fh;
|
||||
}
|
||||
|
||||
=head2 C<BAIL_OUT>
|
||||
|
||||
BAIL_OUT;
|
||||
BAIL_OUT $desc;
|
||||
|
||||
See L<Test::More/BAIL_OUT>.
|
||||
|
||||
=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<Test::Leaner> also provides some functions of its own, which are never exported.
|
||||
|
||||
=head2 C<tap_stream>
|
||||
|
||||
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<threads::shared> cannot reliably share filehandles.
|
||||
|
||||
Defaults to C<STDOUT>.
|
||||
|
||||
=cut
|
||||
|
||||
sub tap_stream (;*) {
|
||||
if (@_) {
|
||||
$TAP_STREAM = $_[0];
|
||||
|
||||
my $fh = select $TAP_STREAM;
|
||||
$|++;
|
||||
select $fh;
|
||||
}
|
||||
|
||||
return $TAP_STREAM;
|
||||
}
|
||||
|
||||
tap_stream *STDOUT;
|
||||
|
||||
=head2 C<diag_stream>
|
||||
|
||||
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</tap_stream>, it can only be used as a write accessor before you start any thread, as L<threads::shared> cannot reliably share filehandles.
|
||||
|
||||
Defaults to C<STDERR>.
|
||||
|
||||
=cut
|
||||
|
||||
sub diag_stream (;*) {
|
||||
if (@_) {
|
||||
$DIAG_STREAM = $_[0];
|
||||
|
||||
my $fh = select $DIAG_STREAM;
|
||||
$|++;
|
||||
select $fh;
|
||||
}
|
||||
|
||||
return $DIAG_STREAM;
|
||||
}
|
||||
|
||||
diag_stream *STDERR;
|
||||
|
||||
=head2 C<THREADSAFE>
|
||||
|
||||
This constant evaluates to true if and only if L<Test::Leaner> is thread-safe, i.e. when this version of C<perl> is at least 5.8, has been compiled with C<useithreads> defined, and L<threads> has been loaded B<before> L<Test::Leaner>.
|
||||
In that case, it also needs a working L<threads::shared>.
|
||||
|
||||
=head1 DEPENDENCIES
|
||||
|
||||
L<perl> 5.6.
|
||||
|
||||
L<Exporter>, L<Test::More>.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
|
||||
|
||||
You can contact me by mail or on C<irc.perl.org> (vincent).
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Please report any bugs or feature requests to C<bug-test-leaner at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Leaner>.
|
||||
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<Scalar::Util> 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
|
||||
|
|
@ -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<run_perl>
|
||||
|
||||
=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<File::Spec>
|
||||
|
||||
=back
|
||||
|
||||
=item *
|
||||
|
||||
Exports :
|
||||
|
||||
=over 8
|
||||
|
||||
=item -
|
||||
|
||||
C<run_perl $code>
|
||||
|
||||
=item -
|
||||
|
||||
C<run_perl_file $file>
|
||||
|
||||
=item -
|
||||
|
||||
C<RUN_PERL_FAILED> (possibly prefixed by C<$p>)
|
||||
|
||||
=back
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub fresh_perl_env (&) {
|
||||
my $handler = shift;
|
||||
|
||||
my ($SystemRoot, $PATH) = @ENV{qw<SystemRoot PATH>};
|
||||
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<capture>
|
||||
|
||||
=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<IO::Handle>
|
||||
|
||||
=item -
|
||||
|
||||
L<IO::Select>
|
||||
|
||||
=item -
|
||||
|
||||
L<IPC::Open3>
|
||||
|
||||
=item -
|
||||
|
||||
On MSWin32 : L<Socket>
|
||||
|
||||
=back
|
||||
|
||||
=item *
|
||||
|
||||
Exports :
|
||||
|
||||
=over 8
|
||||
|
||||
=item -
|
||||
|
||||
C<capture @command>
|
||||
|
||||
=item -
|
||||
|
||||
C<CAPTURE_FAILED $details> (possibly prefixed by C<$p>)
|
||||
|
||||
=item -
|
||||
|
||||
C<capture_perl $code>
|
||||
|
||||
=item -
|
||||
|
||||
C<CAPTURE_PERL_FAILED $details> (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<socketpair reader writer>);
|
||||
shutdown $_[0], 1 or $fail->(qw<shutdown reader>);
|
||||
shutdown $_[1], 0 or $fail->(qw<shutdown writer>);
|
||||
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<close input>);
|
||||
$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 output>);
|
||||
close $err or $fail->(qw<close error>);
|
||||
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<threads>
|
||||
|
||||
=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<undef>) ;
|
||||
|
||||
=item -
|
||||
|
||||
C<$force_var> is the name of the environment variable that can be used to force the thread tests (defaults to C<PERL_FORCE_TEST_THREADS>).
|
||||
|
||||
=back
|
||||
|
||||
=item *
|
||||
|
||||
Dependencies :
|
||||
|
||||
=over 8
|
||||
|
||||
=item -
|
||||
|
||||
C<perl> 5.13.4
|
||||
|
||||
=item -
|
||||
|
||||
L<POSIX>
|
||||
|
||||
=item -
|
||||
|
||||
L<threads> 1.67
|
||||
|
||||
=item -
|
||||
|
||||
L<threads::shared> 1.14
|
||||
|
||||
=back
|
||||
|
||||
=item *
|
||||
|
||||
Exports :
|
||||
|
||||
=over 8
|
||||
|
||||
=item -
|
||||
|
||||
C<spawn $coderef>
|
||||
|
||||
=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<usleep>
|
||||
|
||||
=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<usleep $microseconds>
|
||||
|
||||
=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<Time::HiRes select sleep> 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<VPIT::TestHelpers::Guard>
|
||||
|
||||
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<< <perl at profvince.com> >>, L<http://www.profvince.com>.
|
||||
|
||||
=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;
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
package Variable::Magic::TestDestroyRequired;
|
||||
|
||||
use Variable::Magic;
|
||||
|
||||
my $tag = Variable::Magic::wizard();
|
||||
|
||||
1;
|
||||
|
|
@ -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<ccflags cppflags optimize>;
|
||||
|
||||
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;
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
package Variable::Magic::TestScopeEnd;
|
||||
|
||||
use Test::More;
|
||||
|
||||
use Variable::Magic qw<wizard cast>;
|
||||
|
||||
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;
|
||||
|
|
@ -0,0 +1,55 @@
|
|||
package Variable::Magic::TestValue;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
|
||||
use Variable::Magic qw<wizard cast>;
|
||||
|
||||
use base qw<Exporter>;
|
||||
|
||||
our @EXPORT = qw<init_value value>;
|
||||
|
||||
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;
|
||||
|
|
@ -0,0 +1,72 @@
|
|||
package Variable::Magic::TestWatcher;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
|
||||
use Carp qw<croak>;
|
||||
use Variable::Magic qw<wizard>;
|
||||
|
||||
use base qw<Exporter>;
|
||||
|
||||
our @EXPORT = qw<init_watcher watch>;
|
||||
|
||||
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;
|
||||
|
|
@ -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 */
|
||||
|
|
@ -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 */
|
||||
|
|
@ -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 */
|
||||
|
|
@ -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<T>(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 */
|
||||
Loading…
Reference in New Issue