Object-Pad-0.61000755001750001750 014203242261 12065 5ustar00leoleo000000000000Object-Pad-0.61/Build.PL000444001750001750 324614203242261 13523 0ustar00leoleo000000000000use strict; use warnings; use Module::Build; use XS::Parse::Keyword::Builder; use XS::Parse::Sublike::Builder; my @extra_compiler_flags = qw( -Iinclude -Ihax ); push @extra_compiler_flags, qw( -DDEBUGGING=-g ) if $^X =~ m|/debugperl|; use Config; if( $Config{ccname} eq "gcc" ) { # Enable some extra gcc warnings, largely just for author interest push @extra_compiler_flags, qw( -Wall -Wno-unused-function ); } my $build = Module::Build->new( module_name => 'Object::Pad', requires => { # On perl 5.31.9 onwards we use core's no feature 'indirect', ( $] >= 5.031009 ? () : ( 'indirect' => 0 ) ), 'perl' => '5.018', # pad_add_name_pvn, pad_add_name_pvs, gv_init_pvn # Technically probably would work on 5.16 but doesn't: # https://rt.cpan.org/Ticket/Display.html?id=132930 'XS::Parse::Keyword' => '0.19', 'XS::Parse::Sublike' => '0.15', }, test_requires => { 'Test::Fatal' => 0, 'Test::More' => '0.88', # done_testing 'Test::Refcount' => 0, }, configure_requires => { 'Module::Build' => '0.4004', # test_requires 'XS::Parse::Keyword::Builder' => '0.19', 'XS::Parse::Sublike::Builder' => '0.15', }, license => 'perl', create_license => 1, create_readme => 1, extra_compiler_flags => \@extra_compiler_flags, c_source => [ "src/" ], ); XS::Parse::Keyword::Builder->extend_module_build( $build ); XS::Parse::Sublike::Builder->extend_module_build( $build ); if( eval { require Devel::MAT::Dumper::Helper; Devel::MAT::Dumper::Helper->VERSION( '0.41' ) } ) { Devel::MAT::Dumper::Helper->extend_module_build( $build ); } $build->create_build_script; Object-Pad-0.61/Changes000444001750001750 5350714203242261 13547 0ustar00leoleo000000000000Revision history for Object-Pad 0.61 2022-02-16 [CHANGES] * Added Object::Pad::MOP::Class->create_{class,role} * Added $metaclass->seal (RT131294) * Added $metaclass->add_required_method and ->required_method_names (RT141314) * Accept bodyless `method NAME;` declarations to declare a required role method [BUGFIXES] * Assert when compclassmeta->name doesn't match PL_curstname (RT131293) 0.60 2022-02-01 [CHANGES] * The Great Slot/Field Rename: + "slot" is now called "field"; all perl-visible and XS API has been renamed. Various back-compatibility redirections exist for most of the parts used by other distributions. * Print a deprecation warning on the legacy 'implements' and 'extends' keywords * No longer supports the hooks API from pre-v57 * Perform unit testing using Data::Dumper instead of Data::Dump to reduce non-core test_requires dependencies 0.59 2021-12-15 [CHANGES] * Support lexical methods, stored in lexical variables [BUGFIXES] * Check :strict(params) even without any :param slots or ADJUSTPARAM blocks (RT140314) * Docs updates to improve searchability (RT140141) * Don't fiddle with PL_curcop on non-DEBUGGING builds to avoid disturbing caller() output (RT139408) 0.58 2021-11-25 [CHANGES] * Trim whitespace within :attribute values (RT140109) [BUGFIXES] * Early seal on outer class when deriving an inner subclass of it * Store the real slotix in fasthook cache, not its index within the direct_slots AV 0.57 2021-11-18 [CHANGES] * Defined new ABI version for class/slot hooks + Adds `funcdata` at registration and callback time + Adds MOP accessor functions for slotmeta default SV * Added :isa() and :does() class attributes; encourage those rather than the older keyword style * Added more MOP methods: + $classmeta->direct_methods, ->get_direct_method + $classmeta->all_methods, ->get_method + $slotmeta->has_attribute, ->get_attribute_value * Added Object::Pad::MOP::SlotAttr, allowing pure-perl slot attributes that provide simple metadata storage 0.56 2021-10-22 [CHANGES] * Support roles inheriting from (possibly-multiple) other roles (RT139772) * Recognise `accessor` argument to $classmeta->add_slot * Add some more MOP methods: + $classmeta->direct_roles + $classmeta->all_roles + $slotmeta->sigil [BUGFIXES] * Fix an uninitialised memory warning from valgrind to do with class creation * Quiet the compiler warnings about hv_fetch's key argument maybe being NULL Development time for this release was sponsored by Perl-Verein Schweiz 0.55 2021-10-11 [CHANGES] * Support :reader and :writer on array and hash slots (RT139647) [BUGFIXES] * Complain on attempt to invoke constructor of a class that is not yet complete (RT139664) * Ensure that psotslots and construct slothooks still run for superclasses and applied roles (RT139665) Development time for this release was sponsored by Deriv 0.54 2021-10-07 [CHANGES] * Support slot initialiser blocks; don't invoke blocks for values passed by :param * Support slot default values on non-scalars Development time for this release was sponsored by Deriv 0.53 2021-09-29 [CHANGES] * Support null-or-unary reader/writer accessors, called simply `:accessor` [BUGFIXES] * Avoid some C99'isms which upset Windows compilers * Remember to register pp_weaken() as a custom op * Account for the newer OP_ARGCHECK aux structure of perl 5.31.5 * Set correct XPK_LEXVARNAME() type (related to RT139444) 0.52 2021-08-25 [BUGFIXES] * Remember to actually enable `use warnings` (RT139027) * Permit slotmeta value lookup on roles applied to instances (RT138927) * Ensure `ADJUSTPARAMS` on superclass still works on subclasses that don't add an `ADJUSTPARAMS` themselves Development time for this release was sponsored by Perl-Verein Schweiz 0.51 2021-08-10 [CHANGES] * Added `ADJUSTPARAMS` blocks * Allow `apply` hook functions to modify the hookdata value that gets stored by the hook * Store method name data in accessor generator hooks, so other modules can reliably find it * Clarify in SYNOPSIS that the example requires perl 5.26 because of signatures; also provide another copy that doesn't (RT138578) [BUGFIXES] * Don't segfault on colliding :param names (RT138633) * Don't ship the authoring test xt/99exported-symbols.t (RT138634) Development time for this release was sponsored by Perl-Verein Schweiz 0.50 2021-08-08 [CHANGES] * Provide Object::Pad::ExtensionBuilder to assist 3rd party extension module building * Generally tidy up the exposed `object_pad.h` file to remove some definitions we don't want to make public * Add ABI version constants and fields in exposed hook function structures for (hopefully) better forward compatibility * Add the concept of class hooks, analogous to slot hooks Development time for this release was sponsored by Deriv 0.49 2021-08-06 [CHANGES] * Provide $XSAPI_VERSION to allow non-API-breaking changes to be made without disturbing compiled 3rd party modules * Better searching for Pad.so in t/99exported-symbols.t (thanks ppisar@redhat.com) (RT138320) * Gain a (small) runtime performance boost by remembering to set PERL_NO_GET_CONTEXT [BUGFIXES] * Ignore some internal linker symbols in t/99exported-symbols.t (RT138315) * Remember to bump the version requirement of XS::Parse::Keyword in the XS source (RT138318) * Make slots visible to string-eval(), PadWalker, perl -d, etc.. (RT138399) Development time for this release was partly sponsored by Perl-Verein Schweiz 0.48 2021-08-02 [CHANGES] * Added features to slothooks: + New hooks `.seal_slot` and `.post_construct` + `.post_initslot` now runs earlier before `:param` + Added a MOP function to query slot attributes + Set a minimal pad during construction-time slot hooks * Ensure that `:param` logic in constructor invokes setmagic [BUGFIXES] * Fixed many classes of UTF-8 bug on class/slot/method names (RT138073) * Fixed segfault caused by runtime generation of roles (RT137952) Development time for this release was sponsored by Deriv and Perl-Verein Schweiz 0.47 2021-07-29 [CHANGES] * Large internal rewrites + Split code among several smaller files instead of one giant lib/Object/Pad.xs + Rewrite the way that slot attributes work; allow an externally-visible plugin-type system of hooks * Removed `->param_name` and `->has_param` MOP::Slot accessors Development time for this release was sponsored by Perl-Verein Schweiz 0.46 2021-07-21 [CHANGES] * Accept reader, writer, mutator and weak as `->add_slot` parameters * Document the `O:P:MOP::Class->begin_class` method * Add `O:P:MOP::Class->begin_role` * Enable `-DDEBUGGING` if building via debugperl Development time for this release was sponsored by Deriv 0.45 2021-07-17 [BUGFIXES] * Don't give role embedding information a pad name or Future::AsyncAwait will break it (RT137649) * Make sure that `parammeta->is_weak` is initialised even for params applied via roles (RT137751) 0.44 2021-07-15 [CHANGES] * Added `:weak` slot attribute * Adjusted some documentation headings for better generation of HTML anchors on metacpan.org Development time for this release was sponsored by Oetiker+Partner AG 0.43 2021-07-03 [CHANGES] * Initial implementation of `ADJUST` blocks, without params * Better docs about ordering of stages of constructor * Initial attempt at (temporary) `:struct(params)` class attribute * Add O:P:MOP::Class and ::Slot support for slot params Development time for this release was sponsored by Oetiker+Partner AG 0.42 2021-07-01 [CHANGES] * Expose `$slotmeta->has_param` API * Clarify in docs that `:param` happens before `BUILD` * Remove the word "very" from "very experimental" in introduction docs paragraph * Add `$classmeta->slots` [BUGFIXES] * Make sure to embed params from roles correctly (RT136869) * Use `XS_INTERNAL()` rather than `static XS()` to (maybe?) keep cygwin happy Development time for this release was sponsored by Oetiker+Partner AG 0.41 2021-06-21 [CHANGES] * Recognise `:param` on slots, assign automatically from constructor, check for required parameters * Accept `isa` as a synonym for `extends`, and `does` as a synonym for `implements` * No longer allow `method BUILD` [BUGFIXES] * Complain about a lack of NAME for `class` (related to RT136798) Development time for this release was sponsored by Oetiker+Partner AG 0.40 2021-06-02 [CHANGES] * Updated for XS::Parse::Keyword v0.06 * Silence the -Wunused-variable warning about PL_savetype_name * Yield PL_sv_yes from `class` statements so as to keep `require` happy (RT136701) 0.39 2021-05-24 [CHANGES] * Update parsing logic to use XS::Parse::Keyword 0.38 2021-05-14 [CHANGES] * Added Object::Pad::MOP::Class->for_class and ->for_caller constructors * Provide a generated ->DOES method on each class to account for applied roles (RT136462) [BUGFIXES] * Make sure that generated accessors are recorded in the metaclass as real methods, ensuring role application includes them (RT136507) 0.37 2021-04-01 [BUGFIXES] * Don't get confused by sub signature parameters of the same name as slot variables (RT134456) * Don't crash if extends/implements package names are missing or malformed (RT134827) * Reject requests to make accessors with invalid identifier names (RT134795) 0.36 2021-02-19 [CHANGES] * Added $classmeta->compose_role() (RT134261) * Docs updates + Point out that slot variables can also be exposed via :reader etc + Reördering for better reading * Always add accessor method name to "Too (many/few) arguments" messages even on older perls [BUGFIXES] * Fix unit tests for change of argcheck message format in perl 5.33.6 (RT134074) 0.35 2020-12-28 [CHANGES] * Permit roles to request their methods still be directly invokable, to provide back/forward compatibility during code migration [BUGFIXES] * More sanity checking around `extends` and `implements` keywords * Better complaint about non-invokable methods directly from roles * Workaround for string buffer swipe of stack temporaries in O:P::MOP::Class->add_method() 0.34 2020-11-04 [CHANGES] * Reword the "experimental warning" at the top of the docs [BUGFIXES] * Use named enum for repr type (thanks ilmari) (RT133354) * Use named structs so pahole can see them (thanks ilmari) (RT133355) * Make sure to set the CvGV of embedded CVs of methods imported from roles * Fixed a crash case on Perl 5.18 and 5.20 involving the PadnameOUTER() flag when fixing up PARENT_PAD_INDEX() (RT132814) 0.33 2020-09-16 [CHANGES] * Roles can now have data slots * `use v5.14` in all files [BUGFIXES] * pp_sv() needs to EXTEND() before PUSH() * Avoid SEGV if ->begin_class is called without PL_parser set (RT133258) * Defer sealing of derived classes until their base class is sealed (RT133190) 0.32 2020-08-19 [CHANGES] * Initial attempt at roles, which can compose new methods into classes. No support yet for roles with data slots * Support compiletime declaration of `requires` methods 0.31 2020-06-30 [CHANGES] * Don't emit a named method for BUILD blocks + Enables subclassing of Moo classes * Begin documenting the (double-experimental) Object::Pad::MOP API [BUGFIXES] * Parser fix for `class NAME VERSION extends ...` without a linefeed (RT132903) * Placate some compiler warnings of uninitialised values * Find a different way to trigger class sealing which doesn't depend on `free` magic of hinthash values, in order to avoid core perl bug https://github.com/Perl/perl5/issues/17903 * Various small fixes to keep -DDEBUGGING perl happy 0.30 2020-06-20 [CHANGES] * Make generated writer methods return $self, for convenient chaining * Apply argument checking to generated accessor methods * Improved performance of constructor, by storing BUILD blocks directly in the class metadata, avoiding runtime method lookup * Updates for XS::Parse::Sublike 0.10 0.29 2020-06-16 [CHANGES] * Accept :override attribute on methods * Accept runtime expressions as `has $slot = DEFAULT` * Added Devel::MAT::Dumper::Helper support [BUGFIXES] * Fix various compiler warnings 0.28 2020-06-14 [BUGFIXES] * Declare correct version of XS::Parse::Sublike in configure_requires as we need it at Build.PL time * Fix printf formats for SLOTOFFSET arguments * Fix github URL in docs 0.27 2020-06-13 [CHANGES] * Support :reader :writer :mutator attributes on slot variables, to automatically generate accessor methods for them * Accept `BUILD { ... }` without the `method` keyword. Suggest this as usual style. Discourage the `method` form. * Updated advice to module authors on how to declare package/VERSION sufficient to keep toolchain modules happy 0.26 2020-04-27 [CHANGES] * Sanity-checking of ->add_slot names * Permit "anonymous" slots with sigils but no names; accessed only via $slotmeta->value * Warn when $self lexical is shadowed (partly fixes RT132428) [BUGFIXES] * Ensure to run GETMAGIC on ->add_slot names * Removed extranous and undeclared `use Devel::MAT::Dumper` from unit tests 0.25 2020-04-24 [CHANGES] * Further expanded the (undocumented) MOP API + Added beginnings of O:P:MOP::Class, O:P:MOP::Slot sufficient to create classes and add slots and methods to them [BUGFIXES] * Ensure that anonymous methods can perform lexical captures from outside scopes (RT132178) * Ensure that subclasses without BUILD methods don't double invoke that of their superclass * Ensure a method's optree begins with OP_NEXTSTATE as debug tools may rely on this (RT132413) * Don't rely on Test::MemoryGrowth at test time, so tests can still pass on non-Linux 0.24 (bad MANIFEST) 0.23 2020-04-21 [CHANGES] * Add another new :repr type of autoselect, which chooses the most appropriate type for the situation 0.22 2020-04-17 [CHANGES] * Allow classes to request their representation type using new class attribute :repr - choices are native(default), HASH, magic 0.21 2020-04-15 [CHANGES] * Added Object::Pad->begin_class() (undocumented) (mostly fixes RT132337 and RT132338) * Improved performance of OP_SLOTPAD * Handle UTF-8 package names more correctly [BUGFIXES] * Fix memory leaks related to OP_METHSTART (RT132332) 0.20 2020-04-10 [CHANGES] * Update suggested style for methods with signatures to put whitespace before open paren * Use core's `feature "indirect"` in preference to indirect.pm where available (perl 5.31.9 onwards) [BUGFIXES] * Fix for segfault when compiling inner anon methods inside other methods (RT132321) 0.19 2020-04-04 [CHANGES] * More sanity checking of HASH-based foreign superclass constructor * More unit testing of reliable destruction of constructor and BUILDARGS arguments [BUGFIXES] * Allow classic Perl superclass constructors to invoke methods on instances (RT132263) * Fix SP pointer discipline during method calls in generated constructor 0.18 2020-03-30 [CHANGES] * Implement the BUILDARGS part of constructor protocol * Apply the :method attribute to all method subs 0.17 2020-03-27 [CHANGES] * Add some style suggestions for code authors using the module * Updated for XS::Parse::Sublike 0.06 API [BUGFIXES] * Create a new slot pad for every method instead of reusing one; avoids some refcounting issues that cause segfaults (RT132249) 0.16 2020-03-26 [CHANGES] * Always generate the slots AV even with no slots because otherwise METHSTART gets upset about no-slot subclasses * Capture the `async method` unit tests from Future-AsyncAwait [BUGFIXES] * Ensure that object refs or slot values don't hang around in method lexicals after they've returned (RT132228) * Use OP_STUB to ensure no-slot subclasses don't crash OP_PUSH on perls 5.18 to 5.22 (thanks ilmari) 0.15 2020-03-19 [CHANGES] * Use XS::Parse::Sublike 0.04 + Provides bugfixes for parameters in sub signatures with defaults [BUGFIXES] * Handle class-scoped regular lexicals and outer captures 0.14 2020-03-17 [CHANGES] * Use XS::Parse::Sublike 0.02's `register_xs_parse_sublike()` ability 0.13 2020-03-15 [CHANGES] * Use XS::Parse::Sublike for the bulk of the `method` parsing work [BUGFIXES] * Inline the code for Perl_package_version() because it isn't exported API so not actually visible on non-ELF platforms 0.12 2020-03-10 [CHANGES] * Minor adjustments to order of operations in method keyword parsing to closer match core's parser [BUGFIXES] * Rename t/80dynamically+Object::Pad.t to use a hyphen because colons confuse MSWin32 (RT132087) 0.11 2020-03-07 [CHANGES] * More efficient method enter on perl 5.22 onwards by detecting which slots are being used per method and only set those ones up [BUGFIXES] * Fix some C99isms in XS code (RT131417) * Avoid a C++-style comment in hax/lexer-additions.c.inc 0.10 2019-11-20 [BUGFIXES] * Back-compat fixes for perl 5.16, 5.20 0.09 2019-11-20 [CHANGES] * Accept optional version number for `class` declaration and `extends` base class * Provide a default `BUILDALL` method which invokes all the available `BUILD` methods of component packages * Unit-test that Syntax::Keyword::Dynamically works correctly with object slots and document the fact that `local` does not [BUGFIXES] * Generate the constructor as an XSUB so we can find the superclass for derived subclasses better and avoid an infinite recusion loop on double-subclassing. 0.08 2019-11-10 [CHANGES] * Accept `class Name;` to introduce a toplevel class scope * Attempt to `require` the relevant module for `extends` if it doesn't appear to be loaded 0.07 2019-10-25 [CHANGES] * Allow subclassing of non-Object::Pad base classes, provided they are HASH-based [BUGFIXES] * Correct handling of UTF-8 package and slot names (thanks ilmari) 0.06 2019-10-23 [CHANGES] * First attempt at `has $slot = DEFAULT` expressions. Only accepts compiletime constants and only on scalar slots 0.05 2019-10-20 [CHANGES] * Implement single-inheriance subclassing 0.04 2019-10-19 [CHANGES] * Croak on attempts to invoke methods on non-instances, non-derived classes, etc... * Support perls back to 5.16 by various trickery * Store array and hash slot variables via RV so the instances are well-behaved as perl data structures 0.03 2019-10-18 [CHANGES] * Implement sub signatures * Apply automatic pragmata - strict, warnings, -indirect 0.02 2019-10-17 [CHANGES] * `method name :lvalue` and (maybe) other attributes * Support perls back to 5.22 due to wrap_keyword_plugin hax 0.01 2019-10-17 First version, released on an unsuspecting world. Object-Pad-0.61/LICENSE000444001750001750 4375514203242261 13265 0ustar00leoleo000000000000This software is copyright (c) 2022 by Paul Evans . This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2022 by Paul Evans . This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2022 by Paul Evans . This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End Object-Pad-0.61/MANIFEST000444001750001750 343614203242261 13361 0ustar00leoleo000000000000Build.PL Changes hax/dumpers.c.inc hax/forbid_outofblock_ops.c.inc hax/force_list_keeping_pushmark.c.inc hax/lexer-additions.c.inc hax/make_argcheck_aux.c.inc hax/make_argcheck_ops.c.inc hax/newOP_CUSTOM.c.inc hax/op_sibling_splice.c.inc hax/optree-additions.c.inc hax/perl-additions.c.inc hax/perl-backcompat.c.inc hax/sv_setrv.c.inc include/class.h include/field.h include/object_pad.h include/suspended_compcv.h lib/Object/mop-class.xsi lib/Object/mop-field.xsi lib/Object/mop-method.xsi lib/Object/Pad.pm lib/Object/Pad.xs lib/Object/Pad/ExtensionBuilder.pm lib/Object/Pad/ExtensionBuilder_data.pm.PL lib/Object/Pad/MOP/Class.pm lib/Object/Pad/MOP/Field.pm lib/Object/Pad/MOP/FieldAttr.pm lib/Object/Pad/MOP/Method.pm LICENSE MANIFEST This list of files META.json META.yml README src/class.c src/field.c src/suspended_compcv.c t/00use.t t/01method.t t/02fields.t t/03create.t t/04extend-classical.t t/05subclass.t t/06subclass-foreign-HASH.t t/07subclass-foreign-ARRAY.t t/08subclass-Moo.t t/10method-attrs.t t/11method-signatures.t t/12method-private.t t/20fields-private.t t/21fields-capture.t t/22fields-accesssors.t t/23fields-signatures.t t/24fields-constructor.t t/25fields-weak.t t/26fields-initexpr.t t/30unit-class.t t/31pad-outside.t t/40role.t t/41role-repr.t t/42role-BUILD.t t/43role-fields.t t/44role-accessors.t t/45role-does.t t/49role-compat.t t/50croak-method.t t/51pragmata.t t/52croak-scope.t t/53croak-override.t t/54croak-role.t t/60mop-class.t t/61mop-create-class.t t/62mop-field.t t/63mop-create-field.t t/64mop-method.t t/65mop-create-method.t t/66mop-role.t t/67mop-create-role.t t/68mop-compose-role.t t/69mop-generated.t t/70mop-custom-fieldattr.t t/80async-method.t t/80dynamically+Object-Pad.t t/81async-method+dynamically.t t/90leak.t t/92legacy-class-keywords.t t/95utf8.t t/99pod.t Object-Pad-0.61/META.json000444001750001750 374714203242261 13656 0ustar00leoleo000000000000{ "abstract" : "a simple syntax for lexical field-based objects", "author" : [ "Paul Evans " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4231", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Object-Pad", "prereqs" : { "build" : { "requires" : { "ExtUtils::CBuilder" : "0" } }, "configure" : { "requires" : { "Module::Build" : "0.4004", "XS::Parse::Keyword::Builder" : "0.19", "XS::Parse::Sublike::Builder" : "0.15" } }, "runtime" : { "requires" : { "XS::Parse::Keyword" : "0.19", "XS::Parse::Sublike" : "0.15", "perl" : "5.018" } }, "test" : { "requires" : { "Test::Fatal" : "0", "Test::More" : "0.88", "Test::Refcount" : "0" } } }, "provides" : { "Object::Pad" : { "file" : "lib/Object/Pad.pm", "version" : "0.61" }, "Object::Pad::ExtensionBuilder" : { "file" : "lib/Object/Pad/ExtensionBuilder.pm", "version" : "0.61" }, "Object::Pad::MOP::Class" : { "file" : "lib/Object/Pad/MOP/Class.pm", "version" : "0.61" }, "Object::Pad::MOP::Field" : { "file" : "lib/Object/Pad/MOP/Field.pm", "version" : "0.61" }, "Object::Pad::MOP::FieldAttr" : { "file" : "lib/Object/Pad/MOP/FieldAttr.pm", "version" : "0.61" }, "Object::Pad::MOP::Method" : { "file" : "lib/Object/Pad/MOP/Method.pm", "version" : "0.61" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.61", "x_serialization_backend" : "JSON::PP version 4.06" } Object-Pad-0.61/META.yml000444001750001750 242014203242261 13471 0ustar00leoleo000000000000--- abstract: 'a simple syntax for lexical field-based objects' author: - 'Paul Evans ' build_requires: ExtUtils::CBuilder: '0' Test::Fatal: '0' Test::More: '0.88' Test::Refcount: '0' configure_requires: Module::Build: '0.4004' XS::Parse::Keyword::Builder: '0.19' XS::Parse::Sublike::Builder: '0.15' dynamic_config: 1 generated_by: 'Module::Build version 0.4231, 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: Object-Pad provides: Object::Pad: file: lib/Object/Pad.pm version: '0.61' Object::Pad::ExtensionBuilder: file: lib/Object/Pad/ExtensionBuilder.pm version: '0.61' Object::Pad::MOP::Class: file: lib/Object/Pad/MOP/Class.pm version: '0.61' Object::Pad::MOP::Field: file: lib/Object/Pad/MOP/Field.pm version: '0.61' Object::Pad::MOP::FieldAttr: file: lib/Object/Pad/MOP/FieldAttr.pm version: '0.61' Object::Pad::MOP::Method: file: lib/Object/Pad/MOP/Method.pm version: '0.61' requires: XS::Parse::Keyword: '0.19' XS::Parse::Sublike: '0.15' perl: '5.018' resources: license: http://dev.perl.org/licenses/ version: '0.61' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Object-Pad-0.61/README000444001750001750 10675514203242261 13160 0ustar00leoleo000000000000NAME Object::Pad - a simple syntax for lexical field-based objects SYNOPSIS On perl version 5.26 onwards: use v5.26; use Object::Pad; class Point { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } method describe () { print "A point at ($x, $y)\n"; } } Point->new(x => 5, y => 10)->describe; Or, for older perls that lack signatures: use Object::Pad; class Point { has $x :param = 0; has $y :param = 0; method move { my ($dX, $dY) = @_; $x += $dX; $y += $dY; } method describe { print "A point at ($x, $y)\n"; } } Point->new(x => 5, y => 10)->describe; DESCRIPTION This module provides a simple syntax for creating object classes, which uses private variables that look like lexicals as object member fields. WARNING This module is still experimental. The parts that currently exist do seem to work reliably but much of the design is still evolving, and many features and have yet to be implemented. I don't yet guarantee I won't have to change existing details in order to continue its development. Feel free to try it out in experimental or newly-developed code, but don't complain if a later version is incompatible with your current code and you'll have to change it. That all said, please do get in contact if you find the module overall useful. The more feedback you provide in terms of what features you are using, what you find works, and what doesn't, will help the ongoing development and hopefully eventual stability of the design. See the "FEEDBACK" section. Automatic Construction Classes are automatically provided with a constructor method, called new, which helps create the object instances. This may respond to passed arguments, automatically assigning values of fields, and invoking other blocks of code provided by the class. It proceeds in the following stages: The BUILDARGS phase If the class provides a BUILDARGS class method, that is used to mangle the list of arguments before the BUILD blocks are called. Note this must be a class method not an instance method (and so implemented using sub). It should perform any SUPER chaining as may be required. @args = $class->BUILDARGS( @_ ) Field assignment If any field in the class has the :param attribute, then the constructor will expect to receive its argmuents in an even-sized list of name/value pairs. This applies even to fields inherited from the parent class or applied roles. It is therefore a good idea to shape the parameters to the constructor in this way in roles, and in classes if you intend your class to be extended. The constructor will also check for required parameters (these are all the parameters for fields that do not have default initialisation expressions). If any of these are missing an exception is thrown. The BUILD phase As part of the construction process, the BUILD block of every component class will be invoked, passing in the list of arguments the constructor was invoked with. Each class should perform its required setup behaviour, but does not need to chain to the SUPER class first; this is handled automatically. The ADJUST phase Next, the ADJUST and ADJUSTPARAMS block of every component class is invoked. This happens after the fields are assigned their initial values and the BUILD blocks have been run. Note also that both ADJUST and ADJUSTPARAMS blocks happen at the same time, in declaration order. The ADJUSTPARAMS blocks do not form their own separate phase. The strict-checking phase Finally, before the object is returned, if the ":strict(params)" class attribute is present, then the constructor will throw an exception if there are any remaining named arguments left over after assigning them to fields as per :param declarations, and running any ADJUSTPARAMS blocks. KEYWORDS class class Name :ATTRS... { ... } class Name :ATTRS...; Behaves similarly to the package keyword, but provides a package that defines a new class. Such a class provides an automatic constructor method called new. As with package, an optional block may be provided. If so, the contents of that block define the new class and the preceding package continues afterwards. If not, it sets the class as the package context of following keywords and definitions. As with package, an optional version declaration may be given. If so, this sets the value of the package's $VERSION variable. class Name VERSION { ... } class Name VERSION; A single superclass is supported by the keyword isa Since version 0.41. class Name isa BASECLASS { ... } class Name isa BASECLASS BASEVER { ... } Prior to version 0.41 this was called extends, which is currently recognised as a compatibility synonym. Both extends and isa keywords are now discouraged, in favour of the ":isa" attribute which is preferred because it follows a more standard grammar without this special-case. One or more roles can be composed into the class by the keyword does Since version 0.41. class Name does ROLE, ROLE,... { ... } Prior to version 0.41 this was called implements, which is currently recognised as a compatibility synonym. Both implements and does keywords are now discouraged, in favour of the ":does" attribute which is preferred because it follows a more standard grammar without this special-case. An optional list of attributes may be supplied in similar syntax as for subs or lexical variables. (These are annotations about the class itself; the concept should not be confused with per-object-instance data, which here is called "fields"). Whitespace is permitted within the value and is automatically trimmed, but as standard Perl parsing rules, no space is permitted between the attribute's name and the open parenthesis of its value: :attr( value here ) # is permitted :attr (value here) # not permitted The following class attributes are supported: :isa :isa(CLASS) :isa(CLASS CLASSVER) Since version 0.57. Declares a superclass that this class extends. At most one superclass is supported. If the package providing the superclass does not exist, an attempt is made to load it by code equivalent to require CLASS (); and thus it must either already exist, or be locatable via the usual @INC mechanisms. The superclass may or may not itself be implemented by Object::Pad, but if it is not then see "SUBCLASSING CLASSIC PERL CLASSES" for further detail on the semantics of how this operates. An optional version check can also be supplied; it performs the equivalent of BaseClass->VERSION( $ver ) :does :does(ROLE) :does(ROLE ROLEVER) Since version 0.57. Composes a role into the class; optionally requiring a version check on the role package. This is a newer form of the implements and does keywords and should be preferred for new code. Multiple roles can be composed by using multiple :does attributes, one per role. The package will be loaded in a similar way to how the ":isa" attribute is handled. :repr(TYPE) Sets the representation type for instances of this class. Must be one of the following values: :repr(native) The native representation. This is an opaque representation type whose contents are not specified. It only works for classes whose entire inheritence hierarchy is built only from classes based on Object::Pad. :repr(HASH) The representation will be a blessed hash reference. The instance data will be stored in an array referenced by a key called Object::Pad/slots, which is fairly unlikely to clash with existing storage on the instance. No other keys will be used; they are available for implementions and subclasses to use. The exact format of the value stored here is not specified and may change between module versions, though it can be relied on to be well-behaved as some kind of perl data structure for purposes of modules like Data::Dumper or serialisation into things like YAML or JSON. This representation type may be useful when converting existing classes into using Object::Pad where there may be existing subclasses of it that presume a blessed hash for their own use. :repr(magic) The representation will use MAGIC to apply the instance data in a way that is invisible at the Perl level, and shouldn't get in the way of other things the instance is doing even in XS modules. This representation type is the only one that will work for subclassing existing classes that do not use blessed hashes. :repr(autoselect), :repr(default) Since version 0.23. This representation will select one of the representations above depending on what is best for the situation. Classes not derived from a non-Object::Pad base class will pick native, and classes derived from non-Object::Pad bases will pick either the HASH or magic forms depending on whether the instance is a blessed hash reference or some other kind. This achieves the best combination of DWIM while still allowing the common forms of hash reference to be inspected by Data::Dumper, etc. This is the default representation type, and does not have to be specifically requested. :strict(params) Since version 0.43. Can only be applied to classes that contain no BUILD blocks. If set, then the constructor will complain about any unrecognised named arguments passed to it (i.e. names that do not correspond to the :param of any defined field and left unconsumed by any ADJUSTPARAMS block). Since BUILD blocks can inspect the arguments arbitrarily, the presence of any such block means the constructor cannot determine which named arguments are not recognised. This attribute is a temporary stepping-stone for compatibility with existing code. It is recommended to enable this whenever possible, as a later version of this module will likely perform this behaviour unconditionally whenever no BUILD blocks are present. role role Name :ATTRS... { ... } role Name :ATTRS...; Since version 0.32. Similar to class, but provides a package that defines a new role. A role acts simliar to a class in some respects, and differently in others. Like a class, a role can have a version, and named methods. role Name VERSION { method a { ... } method b { ... } } A role does not provide a constructor, and instances cannot directly be constructed. A role cannot extend a class. A role can declare that it requires methods of given names from any class that implements the role. role Name { requires METHOD; } A role can provide instance fields. These are visible to any BUILD blocks or methods provided by that role. Since version 0.33. role Name { has $field; BUILD { $field = "a value" } method field { return $field } } Since version 0.57 a role can declare that it provides another role: role Name :does(OTHERROLE) { ... } role Name :does(OTHERROLE OTHERVER) { ... } This will include all of the methods from the included role. Effectively this means that applying the "outer" role to a class will imply applying the other role as well. The following role attributes are supported: :compat(invokable) Since version 0.35. Enables a form of backward-compatibility behaviour useful for gradually upgrading existing code from classical Perl inheritance or mixins into using roles. Normally, methods of a role cannot be directly invoked and the role must be applied to an Object::Pad-based class in order to be used. This however presents a problem when gradually upgrading existing code that already uses techniques like roles, multiple inheritance or mixins when that code may be split across multiple distributions, or for some other reason cannot be upgraded all at once. Methods within a role that has the :compat(invokable) attribute applied to it may be directly invoked on any object instance. This allows the creation of a role that can still provide code for existing classes written in classical Perl that has not yet been rewritten to use Object::Pad. The tradeoff is that a :compat(invokable) role may not create field data using the "has" keyword. Whatever behaviours the role wishes to perform must be provided only by calling other methods on $self, or perhaps by making assumptions about the representation type of instances. It should be stressed again: This option is only intended for gradual upgrade of existing classical Perl code into using Object::Pad. When all existing code is using Object::Pad then this attribute can be removed from the role. has has $var; has @var; has %var; has $var :ATTR ATTR...; has $var = EXPR; has $var { BLOCK }; Declares that the instances of the class or role have a member field of the given name. This member field will be accessible as a lexical variable within any method declarations in the class. Array and hash members are permitted and behave as expected; you do not need to store references to anonymous arrays or hashes. Member fields are private to a class or role. They are not visible to users of the class, nor inherited by subclasses nor any class that a role is applied to. In order to provide access to them a class may wish to use "method" to create an accessor, or use the attributes such as ":reader" to get one generated. A scalar field may provide a expression that gives an initialisation value, which will be assigned into the field of every instance during the constructor before the BUILD blocks are invoked. Since version 0.29 this expression does not have to be a compiletime constant, though it is evaluated exactly once, at runtime, after the class definition has been parsed. It is not evaluated individually for every object instance of that class. Since version 0.54 this is also permitted on array and hash fields. Field Initialiser Blocks Since version 0.54 a deferred statement block is also permitted, on any field variable type. This is an experimental feature that permits code to be executed as part of the instance constructor, rather than running just once when the class is set up. Code in a field initialisation block is roughly equivalent to being placed in a BUILD or ADJUST block. Control flow that attempts to leave a field initialiser block is not permitted. This includes any return expression, any next/last/redo outside of a loop, with a dynamically-calculated label expression, or with a label that it doesn't appear in. goto statements are also currently forbidden, though known-safe ones may be permitted in future. Loop control expressions that are known at compiletime to affect a loop that they appear within are permitted. has $field { foreach(@list) { next; } } # this is fine has $field { LOOP: while(1) { last LOOP; } } # this is fine too The following field attributes are supported: :reader, :reader(NAME) Since version 0.27. Generates a reader method to return the current value of the field. If no name is given, the name of the field is used. A single prefix character _ will be removed if present. has $field :reader; # equivalent to has $field; method field { return $field } Since version 0.55 these are permitted on any field type, but prior versions only allowed them on scalar fields. The reader method behaves identically to how a lexical variable would behave in the same context; namely returning a list of values from an array or key/value pairs from a hash when in list context, or the number of items or keys when in scalar context. has @items :reader; foreach my $item ( $obj->items ) { ... } # iterates the list of items my $count = $obj->items; # yields count of items :writer, :writer(NAME) Since version 0.27. Generates a writer method to set a new value of the field from its arguments. If no name is given, the name of the field is used prefixed by set_. A single prefix character _ will be removed if present. has $field :writer; # equivalent to has $field; method set_field { $field = shift; return $self } Since version 0.28 a generated writer method will return the object invocant itself, allowing a chaining style. $obj->set_x("x") ->set_y("y") ->set_z("z"); Since version 0.55 these are permitted on any field type, but prior versions only allowed them on scalar fields. On arrays or hashes, the writer method takes a list of values to be assigned into the field, completely replacing any values previously there. :mutator, :mutator(NAME) Since version 0.27. Generates an lvalue mutator method to return or set the value of the field. These are only permitted for scalar fields. If no name is given, the name of the field is used. A single prefix character _ will be removed if present. has $field :mutator; # equivalent to has $field; method field :lvalue { $field } Since version 0.28 all of these generated accessor methods will include argument checking similar to that used by subroutine signatures, to ensure the correct number of arguments are passed - usually zero, but exactly one in the case of a :writer method. :accessor, :accessor(NAME) Since version 0.53. Generates a combined reader-writer accessor method to set or return the value of the field. These are only permitted for scalar fields. If no name is given, the name of the field is used. A prefix character _ will be removed if present. This method takes either zero or one additional arguments. If an argument is passed, the value of the field is set from this argument (even if it is undef). If no argument is passed (i.e. scalar @_ is false) then the field is not modified. In either case, the value of the field is then returned. has $field :accessor; # equivalent to has $field; method field { $field = shift if @_; return $field; } :weak Since version 0.44. Generated code which sets the value of this field will weaken it if it contains a reference. This applies to within the constructor if :param is given, and to a :writer accessor method. Note that this only applies to automatically generated code; not normal code written in regular method bodies. If you assign into the field variable you must remember to call Scalar::Util::weaken yourself. :param, :param(NAME) Since version 0.41. Sets this field to be initialised automatically in the generated constructor. This is only permitted on scalar fields. If no name is given, the name of the field is used. A single prefix character _ will be removed if present. Any field that has :param but does not have a default initialisation expression or block becomes a required argument to the constructor. Attempting to invoke the constructor without a named argument for this will throw an exception. In order to make a parameter optional, make sure to give it a default expression - even if that expression is undef: has $x :param; # this is required has $z :param = undef; # this is optional Any field that has a :param and an initialisation block will only run the code in the block if required by the constructor. If a named parameter is passed to the constructor for this field, then its code block will not be executed. Values for fields are assigned by the constructor before any BUILD blocks are invoked. method method NAME { ... } method NAME (SIGNATURE) { ... } method NAME :ATTRS... { ... } method NAME; Declares a new named method. This behaves similarly to the sub keyword, except that within the body of the method all of the member fields are also accessible. In addition, the method body will have a lexical called $self which contains the invocant object directly; it will already have been shifted from the @_ array. If the method has no body and is given simply as a name, this declares a required method for a role. Such a method must be provided by any class that implements the role. It will be a compiletime error to combine the role with a class that does not provide this. The signatures feature is automatically enabled for method declarations. In this case the signature does not have to account for the invocant instance; that is handled directly. method m ($one, $two) { say "$self invokes method on one=$one two=$two"; } ... $obj->m(1, 2); A list of attributes may be supplied as for sub. The most useful of these is :lvalue, allowing easy creation of read-write accessors for fields (but see also the :reader, :writer and :mutator field attributes). class Counter { has $count; method count :lvalue { $count } } my $c = Counter->new; $c->count++; Every method automatically gets the :method attribute applied, which suppresses warnings about ambiguous calls resolved to core functions if the name of a method matches a core function. The following additional attributes are recognised by Object::Pad directly: :override Since version 0.29. Marks that this method expects to override another of the same name from a superclass. It is an error at compiletime if the superclass does not provide such a method. method (lexical) method $var { ... } method $var :ATTRS... (SIGNATURE) { ... } Since version 0.59. Declares a new lexical method. Lexical methods are not visible via the package namespace, but instead are stored directly in a lexical variable (with the same scoping rules as regular my variables). These can be invoked by subsequent method code in the same block by using $self->$var(...) method call syntax. class WithPrivate { has $var; # Lexical methods can still see instance fields as normal method $inc_var { $var++; say "Var was incremented"; } method $dec_var { $var--; say "Var was decremented"; } method bump { $self->$inc_var; say "In the middle"; $self->$dec_var; } } my $obj = WithPrivate->new; $obj->bump; # Neither $inc_var nor $dec_var are visible here This effectively provides the ability to define private methods, as they are inaccessible from outside the block that defines the class. In addition, there is no chance of a name collision because lexical variables in different scopes are independent, even if they share the same name. This is particularly useful in roles, to create internal helper methods without letting those methods be visible to callers, or risking their names colliding with other named methods defined on the consuming class. BUILD BUILD { ... } BUILD (SIGNATURE) { ... } Since version 0.27. Declares the builder block for this component class. A builder block may use subroutine signature syntax, as for methods, to assist in unpacking its arguments. A build block is not a subroutine and thus is not permitted to use subroutine attributes (for example :lvalue). Note that a BUILD block is a named phaser block and not a method. Attempts to create a method named BUILD (i.e. with syntax method BUILD {...}) will fail with a compiletime error, to avoid this confusion. ADJUST ADJUST { ... } Since version 0.43. Declares an adjust block for this component class. This block of code runs within the constructor, after any BUILD blocks and automatic field value assignment. It can make any final adjustments to the instance (such as initialising fields from calculated values). No additional parameters are passed. An adjust block is not a subroutine and thus is not permitted to use subroutine attributes. Note that an ADJUST block is a named phaser block and not a method; it does not use the sub or method keyword. ADJUSTPARAMS ADJUSTPARAMS ( $params ) { # on perl 5.26 onwards ... } ADJUSTPARAMS { my $params = shift; ... } Since version 0.51. Declares an adjust block for this component class that receives the parameters hash reference. This block of code runs within the constructor at the same time as "ADJUST" blocks, but receives in addition a reference to the hash containing the current constructor parameters. This hash will not contain any constructor parameters already consumed by ":param" declarations on any fields, but only the leftovers once those are processed. The code in the block should delete from this hash any parameters it wishes to consume. Once all the ADJUSTPARAMS blocks have run, any remaining keys in the hash will be considered errors, subject to the ":strict(params)" check. requires requires NAME; Declares that this role requires a method of the given name from any class that implements it. It is an error at compiletime if the implementing class does not provide such a method. This form of declaring a required method is now vaguely discouraged, in favour of the bodyless method form described above. CREPT FEATURES While not strictly part of being an object system, this module has nevertheless gained a number of behaviours by feature creep, as they have been found useful. Implied Pragmata In order to encourage users to write clean, modern code, the body of the class block acts as if the following pragmata are in effect: use strict; use warnings; no indirect ':fatal'; # or no feature 'indirect' on perl 5.32 onwards use feature 'signatures'; This list may be extended in subsequent versions to add further restrictions and should not be considered exhaustive. Further additions will only be ones that remove "discouraged" or deprecated language features with the overall goal of enforcing a more clean modern style within the body. As long as you write code that is in a clean, modern style (and I fully accept that this wording is vague and subjective) you should not find any new restrictions to be majorly problematic. Either the code will continue to run unaffected, or you may have to make some small alterations to bring it into a conforming style. Yield True A class statement or block will yield a true boolean value. This means that it can be used directly inside a .pm file, avoiding the need to explicitly yield a true value from the end of it. SUBCLASSING CLASSIC PERL CLASSES There are a number of details specific to the case of deriving an Object::Pad class from an existing classic Perl class that is not implemented using Object::Pad. Storage of Instance Data Instances will pick either the :repr(HASH) or :repr(magic) storage type. Object State During Methods Invoked By Superclass Constructor It is common in classic Perl OO style to invoke methods on $self during the constructor. This is supported here since Object::Pad version 0.19. Note however that any methods invoked by the superclass constructor may not see the object in a fully consistent state. (This fact is not specific to using Object::Pad and would happen in classic Perl OO as well). The field initialisers will have been invoked but the BUILD blocks will not. For example; in the following package ClassicPerlBaseClass { sub new { my $self = bless {}, shift; say "Value seen by superconstructor is ", $self->get_value; return $self; } sub get_value { return "A" } } class DerivedClass :isa(ClassicPerlBaseClass) { has $_value = "B"; BUILD { $_value = "C"; } method get_value { return $_value } } my $obj = DerivedClass->new; say "Value seen by user is ", $obj->get_value; Until the ClassicPerlBaseClass::new superconstructor has returned the BUILD block will not have been invoked. The $_value field will still exist, but its value will be B during the superconstructor. After the superconstructor, the BUILD blocks are invoked before the completed object is returned to the user. The result will therefore be: Value seen by superconstructor is B Value seen by user is C STYLE SUGGESTIONS While in no way required, the following suggestions of code style should be noted in order to establish a set of best practices, and encourage consistency of code which uses this module. $VERSION declaration While it would be nice for CPAN and other toolchain modules to parse the embedded version declarations in class statements, the current state at time of writing (June 2020) is that none of them actually do. As such, it will still be necessary to make a once-per-file $VERSION declaration in syntax those modules can parse. Further note that these modules will also not parse the class declaration, so you will have to duplicate this with a package declaration as well as a class keyword. This does involve repeating the package name, so is slightly undesirable. It is hoped that eventually upstream toolchain modules will be adapted to accept the class syntax as being sufficient to declare a package and set its version. See also * https://github.com/Perl-Toolchain-Gang/Module-Metadata/issues/33 File Layout Begin the file with a use Object::Pad line; ideally including a minimum-required version. This should be followed by the toplevel package and class declarations for the file. As it is at toplevel there is no need to use the block notation; it can be a unit class. There is no need to use strict or apply other usual pragmata; these will be implied by the class keyword. use Object::Pad 0.16; package My::Classname 1.23; class My::Classname; # other use statements # has, methods, etc.. can go here Field Names Field names should follow similar rules to regular lexical variables in code - lowercase, name components separated by underscores. For tiny examples such as "dumb record" structures this may be sufficient. class Tag { has $name :mutator; has $value :mutator; } In larger examples with lots of non-trivial method bodies, it can get confusing to remember where the field variables come from (because we no longer have the $self->{ ... } visual clue). In these cases it is suggested to prefix the field names with a leading underscore, to make them more visually distinct. class Spudger { has $_grapefruit; ... method mangle { $_grapefruit->peel; # The leading underscore reminds us this is a field } } WITH OTHER MODULES Syntax::Keyword::Dynamically A cross-module integration test asserts that dynamically works correctly on object instance fields: use Object::Pad; use Syntax::Keyword::Dynamically; class Container { has $value = 1; method example { dynamically $value = 2; ,.. # value is restored to 1 on return from this method } } Future::AsyncAwait As of Future::AsyncAwait version 0.38 and Object::Pad version 0.15, both modules now use XS::Parse::Sublike to parse blocks of code. Because of this the two modules can operate together and allow class methods to be written as async subs which await expressions: use Future::AsyncAwait; use Object::Pad; class Example { async method perform ($block) { say "$self is performing code"; await $block->(); say "code finished"; } } These three modules combine; there is additionally a cross-module test to ensure that object instance fields can be dynamically set during a suspended async method. DESIGN TODOs The following points are details about the design of pad field-based object systems in general: * Is multiple inheritence actually required, if role composition is implemented including giving roles the ability to use private fields? * Consider the visibility of superclass fields to subclasses. Do subclasses even need to be able to see their superclass's fields, or are accessor methods always appropriate? Concrete example: The $self->{split_at} access that Tickit::Widget::HSplit makes of its parent class Tickit::Widget::LinearSplit. IMPLEMENTATION TODOs These points are more about this particular module's implementation: * Consider multiple inheritence of subclassing, if that is still considered useful after adding roles. * Work out why no indirect doesn't appear to work properly before perl 5.20. * Work out why we don't get a Subroutine new redefined at ... warning if we sub new { ... } * The local modifier does not work on field variables, because they appear to be regular lexicals to the parser at that point. A workaround is to use Syntax::Keyword::Dynamically instead: use Syntax::Keyword::Dynamically; has $loglevel; method quietly { dynamically $loglevel = LOG_ERROR; ... } FEEDBACK The following resources are useful forms of providing feedback, especially in the form of reports of what you find good or bad about the module, requests for new features, questions on best practice, etc... * The RT queue at https://rt.cpan.org/Dist/Display.html?Name=Object-Pad. * The #cor IRC channel on irc.perl.org. SPONSORS With thanks to the following sponsors, who have helped me be able to spend time working on this module and other perl features. * Oetiker+Partner AG https://www.oetiker.ch/en/ * Deriv http://deriv.com * Perl-Verein Schweiz https://www.perl-workshop.ch/ Additional details may be found at https://github.com/Ovid/Cor/wiki/Sponsors. AUTHOR Paul Evans Object-Pad-0.61/hax000755001750001750 014203242261 12645 5ustar00leoleo000000000000Object-Pad-0.61/hax/dumpers.c.inc000444001750001750 2705014203242261 15421 0ustar00leoleo000000000000/* vi: set ft=c : */ #define padlist_dump_depth(pl, depth) S_padlist_dump_depth(aTHX_ pl, depth) static void S_padlist_dump_depth(pTHX_ PADLIST *padlist, I32 depth) { fprintf(stderr, "PADLIST = %p / PAD[%d]", padlist, depth); PADNAMELIST *pnl = PadlistNAMES(padlist); PAD *pad = PadlistARRAY(padlist)[depth]; fprintf(stderr, " = %p\n", pad); PADOFFSET padix; for(padix = 0; padix <= PadnamelistMAX(pnl); padix++) { PADNAME *pn = PadnamelistARRAY(pnl)[padix]; fprintf(stderr, " %ld: %s", padix, padix == 0 ? "@_" : pn && PadnamePV(pn) ? PadnamePV(pn) : "(--)"); if(pn) { if(PadnameOUTER(pn)) fprintf(stderr, " *OUTER"); if(PadnameIsSTATE(pn)) fprintf(stderr, " *STATE"); if(PadnameLVALUE(pn)) fprintf(stderr, " *LV"); fprintf(stderr, " [%d..%d]", COP_SEQ_RANGE_LOW(pn), COP_SEQ_RANGE_HIGH(pn)); } fprintf(stderr, " = %p\n", PadARRAY(pad)[padix]); } } #define padlist_dump(pl) padlist_dump_depth(pl, 1) #define debug_sv_summary(sv) S_debug_sv_summary(aTHX_ sv) static void S_debug_sv_summary(pTHX_ const SV *sv) { const char *type; if(!sv) { fprintf(stderr, "NULL"); return; } if(sv == &PL_sv_undef) { fprintf(stderr, "SV=undef"); return; } if(sv == &PL_sv_no) { fprintf(stderr, "SV=false"); return; } if(sv == &PL_sv_yes) { fprintf(stderr, "SV=true"); return; } switch(SvTYPE(sv)) { case SVt_NULL: type = "NULL"; break; case SVt_IV: type = "IV"; break; case SVt_NV: type = "NV"; break; case SVt_PV: type = "PV"; break; case SVt_PVIV: type = "PVIV"; break; case SVt_PVNV: type = "PVNV"; break; case SVt_PVGV: type = "PVGV"; break; case SVt_PVAV: type = "PVAV"; break; case SVt_PVHV: type = "PVHV"; break; case SVt_PVCV: type = "PVCV"; break; default: { char buf[16]; sprintf(buf, "(%d)", SvTYPE(sv)); type = buf; break; } } if(SvROK(sv)) type = "RV"; fprintf(stderr, "SV{type=%s,refcnt=%d", type, SvREFCNT(sv)); if(SvTEMP(sv)) fprintf(stderr, ",TEMP"); if(SvOBJECT(sv)) fprintf(stderr, ",blessed=%s", HvNAME(SvSTASH(sv))); switch(SvTYPE(sv)) { case SVt_PVAV: fprintf(stderr, ",FILL=%d", AvFILL((AV *)sv)); break; default: /* regular scalars */ if(SvROK(sv)) fprintf(stderr, ",ROK"); else { if(SvIOK(sv)) fprintf(stderr, ",IV=%" IVdf, SvIVX(sv)); if(SvUOK(sv)) fprintf(stderr, ",UV=%" UVuf, SvUVX(sv)); if(SvPOK(sv)) { fprintf(stderr, ",PVX=\"%.10s\"", SvPVX((SV *)sv)); if(SvCUR(sv) > 10) fprintf(stderr, "..."); } } break; } fprintf(stderr, "}"); } #define debug_showstack(name) S_debug_showstack(aTHX_ name) static void S_debug_showstack(pTHX_ const char *name) { SV **sp; fprintf(stderr, "%s:\n", name ? name : "Stack"); PERL_CONTEXT *cx = CX_CUR(); I32 floor = cx->blk_oldsp; I32 *mark = PL_markstack + cx->blk_oldmarksp + 1; fprintf(stderr, " marks (TOPMARK=@%d):\n", TOPMARK - floor); for(; mark <= PL_markstack_ptr; mark++) fprintf(stderr, " @%d\n", *mark - floor); mark = PL_markstack + cx->blk_oldmarksp + 1; for(sp = PL_stack_base + floor + 1; sp <= PL_stack_sp; sp++) { fprintf(stderr, sp == PL_stack_sp ? "-> " : " "); fprintf(stderr, "%p = ", *sp); debug_sv_summary(*sp); while(mark <= PL_markstack_ptr && PL_stack_base + *mark == sp) fprintf(stderr, " [*M]"), mark++; fprintf(stderr, "\n"); } } #define savestack_dump() S_savestack_dump(aTHX) #if HAVE_PERL_VERSION(5, 30, 0) /* TODO: For older perls we'll have to look into it in more detail */ static struct { const char *name; const char *argspec; } saves[] = { [SAVEt_ALLOC] = { "ALLOC", "@" }, [SAVEt_CLEARPADRANGE] = { "CLEARPADRANGE", "r" }, [SAVEt_CLEARSV] = { "CLEARSV", "x" }, [SAVEt_REGCONTEXT] = { "REGCONTEXT", "@" }, [SAVEt_TMPSFLOOR] = { "TMPSFLOOR", " I" }, [SAVEt_BOOL] = { "BOOL", "b*" }, [SAVEt_COMPILE_WARNINGS] = { "COMPILE_WARNINGS", " p" }, [SAVEt_COMPPAD] = { "COMPPAD", " *" }, [SAVEt_FREECOPHH] = { "FREECOPHH", " *" }, [SAVEt_FREEOP] = { "FREEOP", " o" }, [SAVEt_FREEPV] = { "FREEPV", " p" }, [SAVEt_FREESV] = { "FREESV", " s" }, [SAVEt_I16] = { "I16", "i*" }, [SAVEt_I32_SMALL] = { "I32_SMALL", "i*" }, [SAVEt_I8] = { "I8", "i*" }, [SAVEt_INT_SMALL] = { "INT_SMALL", "i*" }, [SAVEt_MORTALIZESV] = { "MORTALIZESV", " s" }, [SAVEt_NSTAB] = { "NSTAB", " s" }, [SAVEt_OP] = { "OP", " *" }, [SAVEt_PARSER] = { "PARSER", " *" }, [SAVEt_STACK_POS] = { "STACK_POS", " i" }, [SAVEt_READONLY_OFF] = { "READONLY_OFF", " s" }, [SAVEt_FREEPADNAME] = { "FREEPADNAME", " *" }, #ifdef SAVEt_STRLEN_SMALL [SAVEt_STRLEN_SMALL] = { "STRLEN_SMALL", "i*" }, #endif [SAVEt_AV] = { "AV", " ga" }, [SAVEt_DESTRUCTOR] = { "DESTRUCTOR", " &*" }, [SAVEt_DESTRUCTOR_X] = { "DESTRUCTOR_X", " &*" }, [SAVEt_GENERIC_PVREF] = { "GENERIC_PVREF", " pP" }, [SAVEt_GENERIC_SVREF] = { "GENERIC_SVREF", " Ss" }, [SAVEt_GP] = { "GP", " g*" }, [SAVEt_GVSV] = { "GVSV", " gs" }, [SAVEt_HINTS] = { "HINTS", " T*" }, [SAVEt_HPTR] = { "HPTR", " sS" }, [SAVEt_HV] = { "HV", " gh" }, [SAVEt_I32] = { "I32", " i*" }, [SAVEt_INT] = { "INT", " ip" }, [SAVEt_ITEM] = { "ITEM", " ss" }, [SAVEt_IV] = { "IV", " I*" }, [SAVEt_LONG] = { "LONG", " *l" }, [SAVEt_PPTR] = { "PPTR", " pP" }, [SAVEt_SAVESWITCHSTACK] = { "SAVESWITCHSTACK", " aa" }, [SAVEt_SHARED_PVREF] = { "SHARED_PVREF", " Pp" }, [SAVEt_SPTR] = { "SPTR", " sS" }, [SAVEt_STRLEN] = { "STRLEN", " I*" }, [SAVEt_SV] = { "SV", " gs" }, [SAVEt_SVREF] = { "SVREF", " Ss" }, [SAVEt_VPTR] = { "VPTR", " **" }, [SAVEt_ADELETE] = { "ADELETE", " ia" }, [SAVEt_APTR] = { "APTR", " sS" }, [SAVEt_HELEM] = { "HELEM", " hss" }, [SAVEt_PADSV_AND_MORTALIZE] = { "PADSV_AND_MORTALIZE", " s*U" }, [SAVEt_SET_SVFLAGS] = { "SET_SVFLAGS", " suu" }, [SAVEt_GVSLOT] = { "GVSLOT", " gSs" }, [SAVEt_AELEM] = { "AELEM", " aIs" }, [SAVEt_DELETE] = { "DELETE", " pih" }, #ifdef SAVEt_HINTS_HH [SAVEt_HINTS_HH] = { "HINTS_HH", " T*h" }, #endif }; static void S_savestack_dump(pTHX) { fprintf(stderr, "PL_savestack begins at [idx=%d]:\n", PL_savestack_ix-1); I32 ix; for(ix = PL_savestack_ix-1; ix >= 0; /* */) { UV uv = PL_savestack[ix].any_uv; U8 type = uv & SAVE_MASK; if(type >= sizeof(saves)/sizeof(saves[0])) { fprintf(stderr, "ARGH: (save%d) unrecognised\n", type); return; } const char *argspec = saves[type].argspec; fprintf(stderr, " [%d] SAVEt_%s:", ix, saves[type].name); if(!argspec[0]) { croak("ARG argspec"); } switch(*(argspec++)) { case ' ': break; case '@': /* the UV explains how many additional stack slots are consumed as a * temporary buffer */ fprintf(stderr, " buf=<%ld>\n", (UV)(uv >> SAVE_TIGHT_SHIFT)); ix--; ix -= (UV)(uv >> SAVE_TIGHT_SHIFT); continue; case 'b': fprintf(stderr, " bool=%s", (uv >> 8) ? "true" : "false"); break; case 'r': fprintf(stderr, " padix=%ld count=%ld", (UV)(uv >> (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT)), (uv >> SAVE_TIGHT_SHIFT) & OPpPADRANGE_COUNTMASK); break; case 'i': fprintf(stderr, " i=%d", (I32)(uv >> SAVE_TIGHT_SHIFT)); break; case 'x': fprintf(stderr, " padix=%ld", (UV)(uv >> SAVE_TIGHT_SHIFT)); break; } int args = strlen(argspec); ix -= args; ANY *ap = &PL_savestack[ix]; ix--; I32 hints; while(*argspec) { switch(*(argspec++)) { case '&': fprintf(stderr, " fptr=%p", ap->any_ptr); break; case '*': fprintf(stderr, " ptr=%p", ap->any_ptr); break; case 'a': fprintf(stderr, " av=%p", ap->any_av); break; case 'g': fprintf(stderr, " gv=%p", ap->any_gv); break; case 'h': fprintf(stderr, " hv=%p", ap->any_hv); break; case 'i': fprintf(stderr, " i32=%d", ap->any_i32); break; case 'I': fprintf(stderr, " iv=%ld", ap->any_iv); break; case 'l': fprintf(stderr, " long=%ld", ap->any_long); break; case 'o': fprintf(stderr, " op=%p", ap->any_op); break; case 'p': fprintf(stderr, " pv=%p", ap->any_pv); break; case 'P': fprintf(stderr, " pvp=%p", ap->any_pv); break; case 's': fprintf(stderr, " sv=%p", ap->any_sv); break; case 'S': fprintf(stderr, " svp=%p", ap->any_svp); break; case 'T': /* The value of PL_hints in SAVEt_HINTS is i32 but we need to save it */ fprintf(stderr, " hints=0x%x", hints = ap->any_i32); if(hints & HINT_LOCALIZE_HH) fprintf(stderr, "+HH"); break; case 'u': fprintf(stderr, " u32=%lu", (unsigned long)ap->any_u32); break; case 'U': fprintf(stderr, " uv=%lu", ap->any_uv); break; } ap++; } if(type == SAVEt_HINTS && (hints & HINT_LOCALIZE_HH)) { /* In this case, the savestack will contain an extra pointer */ fprintf(stderr, " hv=%p", PL_savestack[ix--].any_sv); } fprintf(stderr, "\n"); } } #endif #define debug_print_cxstack() S_debug_print_cxstack(aTHX) static void S_debug_print_cxstack(pTHX) { int cxix; for(cxix = cxstack_ix; cxix; cxix--) { char *name = "?"; PERL_CONTEXT *cx = &cxstack[cxix]; switch(CxTYPE(cx)) { case CXt_SUB: name = "CXt_SUB"; break; case CXt_BLOCK: name = "CXt_BLOCK"; break; case CXt_EVAL: name = "CXt_EVAL"; break; case CXt_LOOP_PLAIN: name = "CXt_LOOP_PLAIN"; break; case CXt_LOOP_ARY: name = "CXt_LOOP_ARY"; break; default: fprintf(stderr, "[type=%d]", CxTYPE(cx)); break; } fprintf(stderr, " *-[%d] %s", cxix, name); switch(CxTYPE(cx)) { case CXt_SUB: { CV *cv = cx->blk_sub.cv; fprintf(stderr, "(&%s ret=%p)", SvPV_nolen(cv_name(cv, 0, 0)), cx->blk_sub.retop); } break; case CXt_EVAL: fprintf(stderr, "(%s)", cx->blk_eval.cur_top_env == PL_top_env ? "top" : "!TOP"); break; } fprintf(stderr, "\n"); } } Object-Pad-0.61/hax/forbid_outofblock_ops.c.inc000444001750001750 471214203242261 20277 0ustar00leoleo000000000000/* vi: set ft=c : */ enum { FORBID_LOOPEX_DEFAULT = (1<<0), }; static void walk_ops_forbid(pTHX_ OP *o, U32 flags, HV *permittedloops, const char *blockname) { bool is_loop = FALSE; SV *labelsv = NULL; switch(o->op_type) { case OP_NEXTSTATE: PL_curcop = (COP *)o; return; case OP_RETURN: goto forbid; case OP_GOTO: /* TODO: This might be safe, depending on the target */ goto forbid; case OP_NEXT: case OP_LAST: case OP_REDO: { /* OPf_SPECIAL means this is a default loopex */ if(o->op_flags & OPf_SPECIAL) { if(flags & FORBID_LOOPEX_DEFAULT) goto forbid; break; } /* OPf_STACKED means it's a dynamically computed label */ if(o->op_flags & OPf_STACKED) goto forbid; SV *target = newSVpv(cPVOPo->op_pv, strlen(cPVOPo->op_pv)); if(cPVOPo->op_private & OPpPV_IS_UTF8) SvUTF8_on(target); SAVEFREESV(target); if(hv_fetch_ent(permittedloops, target, FALSE, 0)) break; goto forbid; } case OP_LEAVELOOP: { STRLEN label_len; U32 label_flags; const char *label_pv = CopLABEL_len_flags(PL_curcop, &label_len, &label_flags); if(label_pv) { labelsv = newSVpvn(label_pv, label_len); if(label_flags & SVf_UTF8) SvUTF8_on(labelsv); SAVEFREESV(labelsv); sv_inc(HeVAL(hv_fetch_ent(permittedloops, labelsv, TRUE, 0))); } is_loop = TRUE; break; } forbid: croak("Can't \"%s\" out of %s", PL_op_name[o->op_type], blockname); default: break; } if(!(o->op_flags & OPf_KIDS)) return; OP *kid = cUNOPo->op_first; while(kid) { walk_ops_forbid(aTHX_ kid, flags, permittedloops, blockname); kid = OpSIBLING(kid); if(is_loop) { /* Now in the body of the loop; we can permit loopex default */ flags &= ~FORBID_LOOPEX_DEFAULT; } } if(is_loop && labelsv) { HE *he = hv_fetch_ent(permittedloops, labelsv, FALSE, 0); if(SvIV(HeVAL(he)) > 1) sv_dec(HeVAL(he)); else hv_delete_ent(permittedloops, labelsv, 0, 0); } } #define forbid_outofblock_ops(o, blockname) S_forbid_outofblock_ops(aTHX_ o, blockname) static void S_forbid_outofblock_ops(pTHX_ OP *o, const char *blockname) { ENTER; SAVEVPTR(PL_curcop); HV *looplabels = newHV(); SAVEFREESV((SV *)looplabels); walk_ops_forbid(aTHX_ o, FORBID_LOOPEX_DEFAULT, looplabels, blockname); LEAVE; } Object-Pad-0.61/hax/force_list_keeping_pushmark.c.inc000444001750001750 133114203242261 21461 0ustar00leoleo000000000000/* vi: set ft=c : */ #include "op_sibling_splice.c.inc" /* force_list_keeping_pushmark nulls out the OP_LIST itself but preserves * the OP_PUSHMARK inside it. This is essential or else op_contextualize() * will null out both of them and we lose the mark */ /* copypasta from core's op.c */ #define force_list_keeping_pushmark(o) S_force_list_keeping_pushmark(aTHX_ o) static OP *S_force_list_keeping_pushmark(pTHX_ OP *o) { if(!o || o->op_type != OP_LIST) { OP *rest = NULL; if(o) { rest = OpSIBLING(o); OpLASTSIB_set(o, NULL); } o = newLISTOP(OP_LIST, 0, o, NULL); if(rest) op_sibling_splice(o, cLISTOPo->op_last, 0, rest); } op_null(o); return op_contextualize(o, G_LIST); } Object-Pad-0.61/hax/lexer-additions.c.inc000444001750001750 1525314203242261 17037 0ustar00leoleo000000000000/* vi: set ft=c : */ /* Perls before 5.18 lack isIDCONT_uni, but baring minor differences of weird * Unicode characters, isALNUM_uni is close enough */ #ifndef isIDCONT_uni #define isIDCONT_uni(c) isALNUM_uni(c) #endif #define sv_cat_c(sv, c) MY_sv_cat_c(aTHX_ sv, c) static void MY_sv_cat_c(pTHX_ SV *sv, U32 c) { char ds[UTF8_MAXBYTES + 1], *d; d = (char *)uvchr_to_utf8((U8 *)ds, c); if (d - ds > 1) { sv_utf8_upgrade(sv); } sv_catpvn(sv, ds, d - ds); } #define lex_consume(s) MY_lex_consume(aTHX_ s) static int MY_lex_consume(pTHX_ char *s) { /* I want strprefix() */ size_t i; for(i = 0; s[i]; i++) { if(s[i] != PL_parser->bufptr[i]) return 0; } lex_read_to(PL_parser->bufptr + i); return i; } enum { LEX_IDENT_PACKAGENAME = (1<<0), }; #define lex_scan_ident( ) MY_lex_scan_ident(aTHX_ 0) #define lex_scan_packagename() MY_lex_scan_ident(aTHX_ LEX_IDENT_PACKAGENAME) static SV *MY_lex_scan_ident(pTHX_ int flags) { I32 c; bool at_start = TRUE; char *ident = PL_parser->bufptr; while((c = lex_peek_unichar(0))) { if(at_start ? isIDFIRST_uni(c) : isALNUM_uni(c)) at_start = FALSE; /* TODO: This sucks in the case of a false Foo:Bar match */ else if((flags & LEX_IDENT_PACKAGENAME) && (c == ':')) { lex_read_unichar(0); if(lex_read_unichar(0) != ':') croak("Expected colon to be followed by another in package name"); } else break; lex_read_unichar(0); } STRLEN len = PL_parser->bufptr - ident; if(!len) return NULL; SV *ret = newSVpvn(ident, len); if(lex_bufutf8()) SvUTF8_on(ret); return ret; } #define lex_scan_attrval_into(name, val) MY_lex_scan_attrval_into(aTHX_ name, val) static bool MY_lex_scan_attrval_into(pTHX_ SV *name, SV *val) { /* TODO: really want lex_scan_ident_into() */ SV *n = lex_scan_ident(); if(!n) return FALSE; sv_setsv(name, n); SvREFCNT_dec(n); if(name != val) SvPOK_off(val); /* Do not read space here as space is not allowed between NAME(ARGS) */ if(lex_peek_unichar(0) != '(') return TRUE; lex_read_unichar(0); if(name == val) sv_cat_c(val, '('); else sv_setpvs(val, ""); int count = 1; I32 c = lex_peek_unichar(0); while(count && c != -1) { if(c == '(') count++; if(c == ')') count--; if(c == '\\') { /* The next char does not bump count even if it is ( or ); * the \\ is still captured */ sv_cat_c(val, lex_read_unichar(0)); c = lex_peek_unichar(0); if(c == -1) goto unterminated; } /* Don't append final closing ')' on split name/val */ if(count || (name == val)) sv_cat_c(val, c); lex_read_unichar(0); c = lex_peek_unichar(0); } if(c == -1) return FALSE; return TRUE; unterminated: croak("Unterminated attribute parameter in attribute list"); } #define lex_scan_attr() MY_lex_scan_attr(aTHX) static SV *MY_lex_scan_attr(pTHX) { SV *ret = newSV(0); if(MY_lex_scan_attrval_into(aTHX_ ret, ret)) return ret; SvREFCNT_dec(ret); return NULL; } #define lex_scan_attrs(compcv) MY_lex_scan_attrs(aTHX_ compcv) static OP *MY_lex_scan_attrs(pTHX_ CV *compcv) { /* Attributes are supplied to newATTRSUB() as an OP_LIST containing * OP_CONSTs, one attribute in each as a plain SV. Note that we don't have * to parse inside the contents of the parens; that is handled by the * attribute handlers themselves */ OP *attrs = NULL; SV *attr; lex_read_space(0); while((attr = lex_scan_attr())) { lex_read_space(0); if(compcv && strEQ(SvPV_nolen(attr), "lvalue")) { CvLVALUE_on(compcv); } if(!attrs) attrs = newLISTOP(OP_LIST, 0, NULL, NULL); attrs = op_append_elem(OP_LIST, attrs, newSVOP(OP_CONST, 0, attr)); /* Accept additional colons to prefix additional attrs */ if(lex_peek_unichar(0) == ':') { lex_read_unichar(0); lex_read_space(0); } } return attrs; } #define lex_scan_lexvar() MY_lex_scan_lexvar(aTHX) static SV *MY_lex_scan_lexvar(pTHX) { int sigil = lex_peek_unichar(0); switch(sigil) { case '$': case '@': case '%': lex_read_unichar(0); break; default: croak("Expected a lexical variable"); } SV *ret = lex_scan_ident(); if(!ret) return NULL; /* prepend sigil - which we know to be a single byte */ SvGROW(ret, SvCUR(ret) + 1); Move(SvPVX(ret), SvPVX(ret) + 1, SvCUR(ret), char); SvPVX(ret)[0] = sigil; SvCUR(ret)++; SvPVX(ret)[SvCUR(ret)] = 0; return ret; } #define lex_scan_parenthesized() MY_lex_scan_parenthesized(aTHX) static SV *MY_lex_scan_parenthesized(pTHX) { I32 c; int parencount = 0; SV *ret = newSVpvs(""); if(lex_bufutf8()) SvUTF8_on(ret); c = lex_peek_unichar(0); while(c != -1) { sv_cat_c(ret, lex_read_unichar(0)); switch(c) { case '(': parencount++; break; case ')': parencount--; break; } if(!parencount) break; c = lex_peek_unichar(0); } if(SvCUR(ret)) return ret; SvREFCNT_dec(ret); return NULL; } #define lex_scan_version(flags) MY_lex_scan_version(aTHX_ flags) static SV *MY_lex_scan_version(pTHX_ int flags) { I32 c; SV *tmpsv = sv_2mortal(newSVpvs("")); /* scan_version() expects a version to end in linefeed, semicolon or * openbrace; gets confused if other keywords are fine. We'll have to * extract it first. * https://rt.cpan.org/Ticket/Display.html?id=132903 */ while((c = lex_peek_unichar(0))) { /* Allow a single leading v before accepting only digits, dot, underscore */ if((!SvCUR(tmpsv) && (c == 'v')) || strchr("0123456789._", c)) sv_cat_c(tmpsv, lex_read_unichar(0)); else break; } if(!SvCUR(tmpsv) && (flags & PARSE_OPTIONAL)) return NULL; SV *ret = newSV(0); scan_version(SvPVX(tmpsv), ret, FALSE); return ret; } #define parse_lexvar() MY_parse_lexvar(aTHX) static PADOFFSET MY_parse_lexvar(pTHX) { /* TODO: Rewrite this in terms of using lex_scan_lexvar() */ char *lexname = PL_parser->bufptr; if(lex_read_unichar(0) != '$') croak("Expected a lexical scalar at %s", lexname); if(!isIDFIRST_uni(lex_peek_unichar(0))) croak("Expected a lexical scalar at %s", lexname); lex_read_unichar(0); while(isIDCONT_uni(lex_peek_unichar(0))) lex_read_unichar(0); /* Forbid $_ */ if(PL_parser->bufptr - lexname == 2 && lexname[1] == '_') croak("Can't use global $_ in \"my\""); return pad_add_name_pvn(lexname, PL_parser->bufptr - lexname, 0, NULL, NULL); } #define parse_scoped_block(flags) MY_parse_scoped_block(aTHX_ flags) static OP *MY_parse_scoped_block(pTHX_ int flags) { OP *ret; I32 save_ix = block_start(TRUE); ret = parse_block(flags); return block_end(save_ix, ret); } Object-Pad-0.61/hax/make_argcheck_aux.c.inc000444001750001750 132314203242261 17336 0ustar00leoleo000000000000/* vi: set ft=c : */ #ifndef make_argcheck_aux #define make_argcheck_aux(params, opt_params, slurpy) S_make_argcheck_aux(aTHX_ params, opt_params, slurpy) static inline UNOP_AUX_item *S_make_argcheck_aux(pTHX_ UV params, UV opt_params, char slurpy) { # if HAVE_PERL_VERSION(5, 31, 5) struct op_argcheck_aux *aux = (struct op_argcheck_aux*) PerlMemShared_malloc(sizeof(struct op_argcheck_aux)); aux->params = params; aux->opt_params = opt_params; aux->slurpy = slurpy; return (UNOP_AUX_item *)aux; # else UNOP_AUX_item *aux = (UNOP_AUX_item *)PerlMemShared_malloc(sizeof(UNOP_AUX_item) * 3); aux[0].iv = params; aux[1].iv = opt_params; aux[2].iv = slurpy; return aux; # endif } #endif Object-Pad-0.61/hax/make_argcheck_ops.c.inc000444001750001750 553714203242261 17355 0ustar00leoleo000000000000/* vi: set ft=c : */ #define make_croak_op(message) S_make_croak_op(aTHX_ message) static OP *S_make_croak_op(pTHX_ SV *message) { #if HAVE_PERL_VERSION(5, 22, 0) sv_catpvs(message, " at %s line %d.\n"); /* die sprintf($message, (caller)[1,2]) */ return op_convert_list(OP_DIE, 0, op_convert_list(OP_SPRINTF, 0, op_append_list(OP_LIST, newSVOP(OP_CONST, 0, message), newSLICEOP(0, op_append_list(OP_LIST, newSVOP(OP_CONST, 0, newSViv(1)), newSVOP(OP_CONST, 0, newSViv(2))), newOP(OP_CALLER, 0))))); #else /* For some reason I can't work out, the above tree isn't correct. Attempts * to correct it still make OP_SPRINTF crash with "Out of memory!". For now * lets just avoid the sprintf */ sv_catpvs(message, "\n"); return newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0), newSVOP(OP_CONST, 0, message)); #endif } #if HAVE_PERL_VERSION(5, 26, 0) # define HAVE_OP_ARGCHECK # include "make_argcheck_aux.c.inc" #endif #define make_argcheck_ops(required, optional, slurpy, subname) S_make_argcheck_ops(aTHX_ required, optional, slurpy, subname) static OP *S_make_argcheck_ops(pTHX_ int required, int optional, char slurpy, SV *subname) { int params = required + optional; #ifdef HAVE_OP_ARGCHECK UNOP_AUX_item *aux = make_argcheck_aux(params, optional, slurpy); return op_prepend_elem(OP_LINESEQ, newSTATEOP(0, NULL, NULL), op_prepend_elem(OP_LINESEQ, newUNOP_AUX(OP_ARGCHECK, 0, NULL, aux), NULL)); #else /* Older perls lack the convenience of OP_ARGCHECK so we'll have to build an * optree ourselves. For now we only support required + optional, no slurpy * * This code heavily inspired by Perl_parse_subsignature() in toke.c from perl 5.24 */ OP *ret = NULL; if(required > 0) { SV *message = newSVpvf("Too few arguments for subroutine '%" SVf "'", subname); /* @_ >= required or die ... */ OP *checkop = newSTATEOP(0, NULL, newLOGOP(OP_OR, 0, newBINOP(OP_GE, 0, /* scalar @_ */ op_contextualize(newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv)), G_SCALAR), newSVOP(OP_CONST, 0, newSViv(required))), make_croak_op(message))); ret = op_append_list(OP_LINESEQ, ret, checkop); } if(!slurpy) { SV *message = newSVpvf("Too many arguments for subroutine '%" SVf "'", subname); /* @_ <= (required+optional) or die ... */ OP *checkop = newSTATEOP(0, NULL, newLOGOP(OP_OR, 0, newBINOP(OP_LE, 0, /* scalar @_ */ op_contextualize(newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv)), G_SCALAR), newSVOP(OP_CONST, 0, newSViv(params))), make_croak_op(message))); ret = op_append_list(OP_LINESEQ, ret, checkop); } /* TODO: If slurpy is % then maybe complain about odd number of leftovers */ return ret; #endif } Object-Pad-0.61/hax/newOP_CUSTOM.c.inc000444001750001750 612414203242261 16043 0ustar00leoleo000000000000/* vi: set ft=c : */ /* Before perl 5.22 under -DDEBUGGING, various new*OP() functions throw assert * failures on OP_CUSTOM. * https://rt.cpan.org/Ticket/Display.html?id=128562 */ #define newOP_CUSTOM(func, flags) S_newOP_CUSTOM(aTHX_ func, flags) #define newUNOP_CUSTOM(func, flags, first) S_newUNOP_CUSTOM(aTHX_ func, flags, first) #define newSVOP_CUSTOM(func, flags, sv) S_newSVOP_CUSTOM(aTHX_ func, flags, sv) #define newBINOP_CUSTOM(func, flags, first, last) S_newBINOP_CUSTOM(aTHX_ func, flags, first, last) #define newLOGOP_CUSTOM(func, flags, first, other) S_newLOGOP_CUSTOM(aTHX_ func, flags, first, other) static OP *S_newOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags) { OP *op = newOP(OP_CUSTOM, flags); op->op_ppaddr = func; return op; } static OP *S_newUNOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags, OP *first) { UNOP *unop; #if HAVE_PERL_VERSION(5,22,0) unop = (UNOP *)newUNOP(OP_CUSTOM, flags, first); #else NewOp(1101, unop, 1, UNOP); unop->op_type = (OPCODE)OP_CUSTOM; unop->op_first = first; unop->op_flags = (U8)(flags | OPf_KIDS); unop->op_private = (U8)(1 | (flags >> 8)); #endif unop->op_ppaddr = func; return (OP *)unop; } static OP *S_newSVOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags, SV *sv) { SVOP *svop; #if HAVE_PERL_VERSION(5,22,0) svop = (SVOP *)newSVOP(OP_CUSTOM, flags, sv); #else NewOp(1101, svop, 1, SVOP); svop->op_type = (OPCODE)OP_CUSTOM; svop->op_sv = sv; svop->op_next = (OP *)svop; svop->op_flags = 0; svop->op_private = 0; #endif svop->op_ppaddr = func; return (OP *)svop; } static OP *S_newBINOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags, OP *first, OP *last) { BINOP *binop; #if HAVE_PERL_VERSION(5,22,0) binop = (BINOP *)newBINOP(OP_CUSTOM, flags, first, last); #else NewOp(1101, binop, 1, BINOP); binop->op_type = (OPCODE)OP_CUSTOM; binop->op_first = first; first->op_sibling = last; binop->op_last = last; binop->op_flags = (U8)(flags | OPf_KIDS); binop->op_private = (U8)(2 | (flags >> 8)); #endif binop->op_ppaddr = func; return (OP *)binop; } static OP *S_newLOGOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags, OP *first, OP *other) { OP *o; #if HAVE_PERL_VERSION(5,22,0) o = newLOGOP(OP_CUSTOM, flags, first, other); #else /* Parts of this code copypasted from perl 5.20.0's op.c S_new_logop() */ LOGOP *logop; first = op_contextualize(first, G_SCALAR); NewOp(1101, logop, 1, LOGOP); logop->op_type = (OPCODE)OP_CUSTOM; logop->op_ppaddr = NULL; /* Because caller only overrides it anyway */ logop->op_first = first; logop->op_flags = (U8)(flags | OPf_KIDS); logop->op_other = LINKLIST(other); /* logop->op_private has nothing interesting for OP_CUSTOM */ /* Link in postfix order */ logop->op_next = LINKLIST(first); first->op_next = (OP *)logop; first->op_sibling = other; /* No CHECKOP for OP_CUSTOM */ o = newUNOP(OP_NULL, 0, (OP *)logop); other->op_next = o; #endif /* the returned op is actually an UNOP that's either NULL or NOT; the real * logop is the op_next of it */ cUNOPx(o)->op_first->op_ppaddr = func; return o; } Object-Pad-0.61/hax/op_sibling_splice.c.inc000444001750001750 167714203242261 17415 0ustar00leoleo000000000000/* vi: set ft=c : */ #ifndef op_sibling_splice # define op_sibling_splice(parent, start, del_count, insert) S_op_sibling_splice(aTHX_ parent, start, del_count, insert) static OP *S_op_sibling_splice(pTHX_ OP *parent, OP *start, int del_count, OP *insert) { OP *deleted = NULL; if(!insert && !del_count) return NULL; OP **prevp; if(start) prevp = &(start->op_sibling); else prevp = &(cLISTOPx(parent)->op_first); OP *after = *prevp; if(del_count) { croak("Back-compat op_sibling_splice with del_count != 0 not yet implemented"); /* THIS IS AS YET UNTESTED deleted = *prevp; OP *o = deleted; while(del_count > 1) o = o->op_sibling, del_count--; after = o->op_sibling; o->op_sibling = NULL; */ } if(insert) { *prevp = insert; OP *o = insert; while(o->op_sibling) o = o->op_sibling; o->op_sibling = after; } else *prevp = after; return deleted; } #endif Object-Pad-0.61/hax/optree-additions.c.inc000444001750001750 410714203242261 17172 0ustar00leoleo000000000000/* vi: set ft=c : */ #define newAELEMOP(flags, first, key) S_newAELEMOP(aTHX_ flags, first, key) static OP *S_newAELEMOP(pTHX_ U32 flags, OP *first, I32 key) { if(key >= -128 && key < 128 && first->op_type == OP_PADAV) { OP *o = newOP(OP_AELEMFAST_LEX, flags); o->op_private = (I8)key; o->op_targ = first->op_targ; op_free(first); return o; } return newBINOP(OP_AELEM, flags, first, newSVOP(OP_CONST, 0, newSViv(key))); } #define newPADxVOP(type, flags, padix) S_newPADxVOP(aTHX_ type, flags, padix) static OP *S_newPADxVOP(pTHX_ I32 type, I32 flags, PADOFFSET padix) { OP *op = newOP(type, flags); op->op_targ = padix; return op; } #if HAVE_PERL_VERSION(5, 22, 0) # define HAVE_UNOP_AUX #endif #ifndef HAVE_UNOP_AUX typedef struct UNOP_with_IV { UNOP baseop; IV iv; } UNOP_with_IV; #define newUNOP_with_IV(type, flags, first, iv) S_newUNOP_with_IV(aTHX_ type, flags, first, iv) static OP *S_newUNOP_with_IV(pTHX_ I32 type, I32 flags, OP *first, IV iv) { /* Cargoculted from perl's op.c:Perl_newUNOP() */ UNOP_with_IV *op = PerlMemShared_malloc(sizeof(UNOP_with_IV) * 1); NewOp(1101, op, 1, UNOP_with_IV); if(!first) first = newOP(OP_STUB, 0); UNOP *unop = (UNOP *)op; unop->op_type = (OPCODE)type; unop->op_first = first; unop->op_ppaddr = NULL; unop->op_flags = (U8)flags | OPf_KIDS; unop->op_private = (U8)(1 | (flags >> 8)); op->iv = iv; return (OP *)op; } #endif #define newMETHOD_REDIR_OP(rclass, methname, flags) S_newMETHOD_REDIR_OP(aTHX_ rclass, methname, flags) static OP *S_newMETHOD_REDIR_OP(pTHX_ SV *rclass, SV *methname, I32 flags) { #if HAVE_PERL_VERSION(5, 22, 0) OP *op = newMETHOP_named(OP_METHOD_REDIR, flags, methname); # ifdef USE_ITHREADS { /* cargoculted from S_op_relocate_sv() */ PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY); PAD_SETSV(ix, rclass); cMETHOPx(op)->op_rclass_targ = ix; } # else cMETHOPx(op)->op_rclass_sv = rclass; # endif #else OP *op = newUNOP(OP_METHOD, flags, newSVOP(OP_CONST, 0, newSVpvf("%" SVf "::%" SVf, rclass, methname))); #endif return op; } Object-Pad-0.61/hax/perl-additions.c.inc000444001750001750 1647414203242261 16670 0ustar00leoleo000000000000/* vi: set ft=c : */ #ifndef av_count # define av_count(av) (AvFILL(av) + 1) #endif #if HAVE_PERL_VERSION(5, 22, 0) # define PadnameIsNULL(pn) (!(pn)) #else # define PadnameIsNULL(pn) (!(pn) || (pn) == &PL_sv_undef) #endif #ifndef hv_deletes # define hv_deletes(hv, skey, flags) hv_delete((hv), ("" skey ""), (sizeof(skey) - 1), flags) #endif #if HAVE_PERL_VERSION(5, 22, 0) # define PadnameOUTER_off(pn) (PadnameFLAGS(pn) &= ~PADNAMEt_OUTER) #else /* PadnameOUTER is really the SvFAKE flag */ # define PadnameOUTER_off(pn) SvFAKE_off(pn) #endif #define save_strndup(s, l) S_save_strndup(aTHX_ s, l) static char *S_save_strndup(pTHX_ char *s, STRLEN l) { /* savepvn doesn't put anything on the save stack, despite its name */ char *ret = savepvn(s, l); SAVEFREEPV(ret); return ret; } static char *PL_savetype_name[] PERL_UNUSED_DECL = { /* These have been present since 5.16 */ [SAVEt_ADELETE] = "ADELETE", [SAVEt_AELEM] = "AELEM", [SAVEt_ALLOC] = "ALLOC", [SAVEt_APTR] = "APTR", [SAVEt_AV] = "AV", [SAVEt_BOOL] = "BOOL", [SAVEt_CLEARSV] = "CLEARSV", [SAVEt_COMPILE_WARNINGS] = "COMPILE_WARNINGS", [SAVEt_COMPPAD] = "COMPPAD", [SAVEt_DELETE] = "DELETE", [SAVEt_DESTRUCTOR] = "DESTRUCTOR", [SAVEt_DESTRUCTOR_X] = "DESTRUCTOR_X", [SAVEt_FREECOPHH] = "FREECOPHH", [SAVEt_FREEOP] = "FREEOP", [SAVEt_FREEPV] = "FREEPV", [SAVEt_FREESV] = "FREESV", [SAVEt_GENERIC_PVREF] = "GENERIC_PVREF", [SAVEt_GENERIC_SVREF] = "GENERIC_SVREF", [SAVEt_GP] = "GP", [SAVEt_GVSV] = "GVSV", [SAVEt_HELEM] = "HELEM", [SAVEt_HINTS] = "HINTS", [SAVEt_HPTR] = "HPTR", [SAVEt_HV] = "HV", [SAVEt_I16] = "I16", [SAVEt_I32] = "I32", [SAVEt_I32_SMALL] = "I32_SMALL", [SAVEt_I8] = "I8", [SAVEt_INT] = "INT", [SAVEt_INT_SMALL] = "INT_SMALL", [SAVEt_ITEM] = "ITEM", [SAVEt_IV] = "IV", [SAVEt_LONG] = "LONG", [SAVEt_MORTALIZESV] = "MORTALIZESV", [SAVEt_NSTAB] = "NSTAB", [SAVEt_OP] = "OP", [SAVEt_PADSV_AND_MORTALIZE] = "PADSV_AND_MORTALIZE", [SAVEt_PARSER] = "PARSER", [SAVEt_PPTR] = "PPTR", [SAVEt_REGCONTEXT] = "REGCONTEXT", [SAVEt_SAVESWITCHSTACK] = "SAVESWITCHSTACK", [SAVEt_SET_SVFLAGS] = "SET_SVFLAGS", [SAVEt_SHARED_PVREF] = "SHARED_PVREF", [SAVEt_SPTR] = "SPTR", [SAVEt_STACK_POS] = "STACK_POS", [SAVEt_SVREF] = "SVREF", [SAVEt_SV] = "SV", [SAVEt_VPTR] = "VPTR", #if HAVE_PERL_VERSION(5,18,0) [SAVEt_CLEARPADRANGE] = "CLEARPADRANGE", [SAVEt_GVSLOT] = "GVSLOT", #endif #if HAVE_PERL_VERSION(5,20,0) [SAVEt_READONLY_OFF] = "READONLY_OFF", [SAVEt_STRLEN] = "STRLEN", #endif #if HAVE_PERL_VERSION(5,22,0) [SAVEt_FREEPADNAME] = "FREEPADNAME", #endif #if HAVE_PERL_VERSION(5,24,0) [SAVEt_TMPSFLOOR] = "TMPSFLOOR", #endif #if HAVE_PERL_VERSION(5,34,0) [SAVEt_STRLEN_SMALL] = "STRLEN_SMALL", [SAVEt_HINTS_HH] = "HINTS_HH", #endif }; #define dKWARG(count) \ U32 kwargi = count; \ U32 kwarg; \ SV *kwval; \ /* TODO: complain about odd number of args */ #define KWARG_NEXT(args) \ S_kwarg_next(aTHX_ args, &kwargi, items, ax, &kwarg, &kwval) static bool S_kwarg_next(pTHX_ const char *args[], U32 *kwargi, U32 argc, U32 ax, U32 *kwarg, SV **kwval) { if(*kwargi >= argc) return FALSE; SV *argname = ST(*kwargi); (*kwargi)++; if(!SvOK(argname)) croak("Expected string for next argument name, got undef"); *kwarg = 0; while(args[*kwarg]) { if(strEQ(SvPV_nolen(argname), args[*kwarg])) { *kwval = ST(*kwargi); (*kwargi)++; return TRUE; } (*kwarg)++; } croak("Unrecognised argument name '%" SVf "'", SVfARG(argname)); } #define import_pragma(pragma, arg) S_import_pragma(aTHX_ pragma, arg) static void S_import_pragma(pTHX_ const char *pragma, const char *arg) { dSP; bool unimport = FALSE; if(pragma[0] == '-') { unimport = TRUE; pragma++; } SAVETMPS; EXTEND(SP, 2); PUSHMARK(SP); mPUSHp(pragma, strlen(pragma)); if(arg) mPUSHp(arg, strlen(arg)); PUTBACK; call_method(unimport ? "unimport" : "import", G_VOID); FREETMPS; } #define ensure_module_version(module, version) S_ensure_module_version(aTHX_ module, version) static void S_ensure_module_version(pTHX_ SV *module, SV *version) { dSP; ENTER; PUSHMARK(SP); PUSHs(module); PUSHs(version); PUTBACK; call_method("VERSION", G_VOID); LEAVE; } #define fetch_superclass_method_pv(stash, pv, len, level) S_fetch_superclass_method_pv(aTHX_ stash, pv, len, level) static CV *S_fetch_superclass_method_pv(pTHX_ HV *stash, const char *pv, STRLEN len, U32 level) { #if HAVE_PERL_VERSION(5, 18, 0) GV *gv = gv_fetchmeth_pvn(stash, pv, len, level, GV_SUPER); #else SV *superclassname = newSVpvf("%*s::SUPER", HvNAMELEN_get(stash), HvNAME_get(stash)); if(HvNAMEUTF8(stash)) SvUTF8_on(superclassname); SAVEFREESV(superclassname); HV *superstash = gv_stashsv(superclassname, GV_ADD); GV *gv = gv_fetchmeth_pvn(superstash, pv, len, level, 0); #endif if(!gv) return NULL; return GvCV(gv); } #define get_class_isa(stash) S_get_class_isa(aTHX_ stash) static AV *S_get_class_isa(pTHX_ HV *stash) { GV **gvp = (GV **)hv_fetchs(stash, "ISA", 0); if(!gvp || !GvAV(*gvp)) croak("Expected %s to have a @ISA list", HvNAME(stash)); return GvAV(*gvp); } #define find_cop_for_lvintro(padix, o, copp) S_find_cop_for_lvintro(aTHX_ padix, o, copp) static COP *S_find_cop_for_lvintro(pTHX_ PADOFFSET padix, OP *o, COP **copp) { for( ; o; o = OpSIBLING(o)) { if(OP_CLASS(o) == OA_COP) { *copp = (COP *)o; } else if(o->op_type == OP_PADSV && o->op_targ == padix && o->op_private & OPpLVAL_INTRO) { return *copp; } else if(o->op_flags & OPf_KIDS) { COP *ret = find_cop_for_lvintro(padix, cUNOPx(o)->op_first, copp); if(ret) return ret; } } return NULL; } #define lex_consume_unichar(c) MY_lex_consume_unichar(aTHX_ c) static bool MY_lex_consume_unichar(pTHX_ U32 c) { if(lex_peek_unichar(0) != c) return FALSE; lex_read_unichar(0); return TRUE; } #define sv_derived_from_hv(sv, hv) MY_sv_derived_from_hv(aTHX_ sv, hv) static bool MY_sv_derived_from_hv(pTHX_ SV *sv, HV *hv) { char *hvname = HvNAME(hv); if(!hvname) return FALSE; return sv_derived_from_pvn(sv, hvname, HvNAMELEN(hv), HvNAMEUTF8(hv) ? SVf_UTF8 : 0); } #define av_push_from_av_inc(dst, src) S_av_push_from_av(aTHX_ dst, src, TRUE) #define av_push_from_av_noinc(dst, src) S_av_push_from_av(aTHX_ dst, src, FALSE) static void S_av_push_from_av(pTHX_ AV *dst, AV *src, bool refcnt_inc) { SSize_t count = av_count(src); SSize_t i; av_extend(dst, av_count(dst) + count - 1); SV **vals = AvARRAY(src); for(i = 0; i < count; i++) { SV *sv = vals[i]; av_push(dst, refcnt_inc ? SvREFCNT_inc(sv) : sv); } } Object-Pad-0.61/hax/perl-backcompat.c.inc000444001750001750 730314203242261 16765 0ustar00leoleo000000000000/* vi: set ft=c : */ #define HAVE_PERL_VERSION(R, V, S) \ (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) #ifndef NOT_REACHED # define NOT_REACHED assert(0) #endif #ifndef SvTRUE_NN # define SvTRUE_NN(sv) SvTRUE(sv) #endif #ifndef G_LIST # define G_LIST G_ARRAY #endif #if !HAVE_PERL_VERSION(5, 18, 0) typedef AV PADNAMELIST; # define PadlistARRAY(pl) ((PAD **)AvARRAY(pl)) # define PadlistNAMES(pl) (*PadlistARRAY(pl)) typedef SV PADNAME; # define PadnamePV(pn) (SvPOKp(pn) ? SvPVX(pn) : NULL) # define PadnameLEN(pn) SvCUR(pn) # define PadnameOUTER(pn) (SvFAKE(pn) && !SvPAD_STATE(pn)) # define PadnamelistARRAY(pnl) AvARRAY(pnl) # define PadnamelistMAX(pnl) AvFILLp(pnl) # define PadARRAY(p) AvARRAY(p) # define PadMAX(pad) AvFILLp(pad) #endif #ifndef av_top_index # define av_top_index(av) AvFILL(av) #endif #ifndef block_end # define block_end(a,b) Perl_block_end(aTHX_ a,b) #endif #ifndef block_start # define block_start(a) Perl_block_start(aTHX_ a) #endif #ifndef cv_clone # define cv_clone(a) Perl_cv_clone(aTHX_ a) #endif #ifndef intro_my # define intro_my() Perl_intro_my(aTHX) #endif #ifndef pad_alloc # define pad_alloc(a,b) Perl_pad_alloc(aTHX_ a,b) #endif #ifndef CX_CUR # define CX_CUR() (&cxstack[cxstack_ix]) #endif #if HAVE_PERL_VERSION(5, 24, 0) # define OLDSAVEIX(cx) (cx->blk_oldsaveix) #else # define OLDSAVEIX(cx) (PL_scopestack[cx->blk_oldscopesp-1]) #endif #ifndef OpSIBLING # define OpSIBLING(op) ((op)->op_sibling) #endif #ifndef OpMORESIB_set # define OpMORESIB_set(op,sib) ((op)->op_sibling = (sib)) #endif #ifndef OpLASTSIB_set /* older perls don't need to store this at all */ # define OpLASTSIB_set(op,parent) #endif #ifndef op_convert_list # define op_convert_list(type, flags, o) S_op_convert_list(aTHX_ type, flags, o) static OP *S_op_convert_list(pTHX_ I32 type, I32 flags, OP *o) { /* A minimal recreation just for our purposes */ assert( /* A hardcoded list of the optypes we know this will work for */ type == OP_ENTERSUB || type == OP_JOIN || type == OP_PUSH || 0); o->op_type = type; o->op_flags |= flags; o->op_ppaddr = PL_ppaddr[type]; o = PL_check[type](aTHX_ o); /* op_std_init() */ if(PL_opargs[type] & OA_RETSCALAR) o = op_contextualize(o, G_SCALAR); if(PL_opargs[type] & OA_TARGET && !o->op_targ) o->op_targ = pad_alloc(type, SVs_PADTMP); return o; } #endif #ifndef newMETHOP_named # define newMETHOP_named(type, flags, name) newSVOP(type, flags, name) #endif #ifndef PARENT_PAD_INDEX_set # if HAVE_PERL_VERSION(5, 22, 0) # define PARENT_PAD_INDEX_set(pn,val) (PARENT_PAD_INDEX(pn) = val) # else /* stolen from perl-5.20.0's pad.c */ # define PARENT_PAD_INDEX_set(sv,val) \ STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END # endif #endif /* On Perl 5.14 this had a different name */ #ifndef pad_add_name_pvn #define pad_add_name_pvn(name, len, flags, typestash, ourstash) MY_pad_add_name(aTHX_ name, len, flags, typestash, ourstash) static PADOFFSET MY_pad_add_name(pTHX_ const char *name, STRLEN len, U32 flags, HV *typestash, HV *ourstash) { /* perl 5.14's Perl_pad_add_name requires a NUL-terminated name */ SV *namesv = sv_2mortal(newSVpvn(name, len)); return Perl_pad_add_name(aTHX_ SvPV_nolen(namesv), SvCUR(namesv), flags, typestash, ourstash); } #endif #if !HAVE_PERL_VERSION(5, 26, 0) # define isIDFIRST_utf8_safe(s, e) (PERL_UNUSED_ARG(e), isIDFIRST_utf8(s)) # define isIDCONT_utf8_safe(s, e) (PERL_UNUSED_ARG(e), isIDCONT_utf8(s)) #endif Object-Pad-0.61/hax/sv_setrv.c.inc000444001750001750 46114203242261 15552 0ustar00leoleo000000000000/* vi: set ft=c : */ #ifndef sv_setrv_noinc # define sv_setrv_noinc(sv, rv) S_sv_setrv(aTHX_ sv, rv) # define sv_setrv_inc(sv, rv) S_sv_setrv(aTHX_ sv, SvREFCNT_inc(rv)) #endif static void S_sv_setrv(pTHX_ SV *sv, SV *rv) { SV *tmp = newRV_noinc(rv); sv_setsv(sv, tmp); SvREFCNT_dec(tmp); } Object-Pad-0.61/include000755001750001750 014203242261 13510 5ustar00leoleo000000000000Object-Pad-0.61/include/class.h000444001750001750 1134114203242261 15143 0ustar00leoleo000000000000#ifndef __OBJECT_PAD__CLASS_H__ #define __OBJECT_PAD__CLASS_H__ #include "suspended_compcv.h" typedef struct AdjustBlock { unsigned int is_adjustparams : 1; CV *cv; } AdjustBlock; /* Metadata about a class or role */ struct ClassMeta { enum MetaType type : 8; enum ReprType repr : 8; unsigned int sealed : 1; unsigned int role_is_invokable : 1; unsigned int strict_params : 1; unsigned int has_adjustparams : 1; /* has at least one ADJUSTPARAMS block */ unsigned int has_superclass : 1; FIELDOFFSET start_fieldix; /* first field index of this partial within its instance */ FIELDOFFSET next_fieldix; /* 1 + final field index of this partial within its instance; includes fields in roles */ /* In the following, "MERGED" means the item includes elements merged from a * superclass if present, and any applied roles * "direct" means only the things added directly to this exact class/role */ SV *name; HV *stash; AV *pending_submeta; /* NULL, or AV containing raw ClassMeta pointers to subclasses pending seal */ AV *hooks; /* NULL, or AV of raw pointers directly to ClassHook structs */ AV *direct_fields; /* each elem is a raw pointer directly to a FieldMeta */ AV *direct_methods; /* each elem is a raw pointer directly to a MethodMeta */ HV *parammap; /* NULL, or each elem is a raw pointer directly at a ParamMeta (MERGED) */ AV *requiremethods; /* each elem is an SVt_PV giving a name */ CV *initfields; /* the INITFIELDS method body */ AV *buildblocks; /* the BUILD {} phaser blocks; each elem is a CV* directly (MERGED) */ AV *adjustblocks; /* the ADJUST {} phaser blocks; each elem is a AdjustBlock* (MERGED) */ AV *fieldhooks_initfield; /* NULL, or AV of struct FieldHook, all of whose ->funcs->post_initfield exist (MERGED) */ AV *fieldhooks_construct; /* NULL, or AV of struct FieldHook, all of whose ->funcs->post_construct exist (MERGED) */ COP *tmpcop; /* a COP to use during generated constructor */ CV *methodscope; /* a temporary CV used just during compilation of a `method` */ SuspendedCompCVBuffer initfields_compcv; /* temporary PL_compcv + associated state during initfields */ union { /* Things that only true classes have */ struct { ClassMeta *supermeta; /* superclass */ CV *foreign_new; /* superclass is not Object::Pad, here is the constructor */ CV *foreign_does; /* superclass is not Object::Pad, here is SUPER::DOES (which could be UNIVERSAL::DOES) */ AV *direct_roles; /* each elem is a raw pointer directly to a RoleEmbedding for roles directly applied to this class */ AV *embedded_roles; /* each elem is a raw pointer directly to a RoleEmbedding for all roles embedded (MERGED) */ } cls; /* not 'class' or C++ compilers get upset */ /* Things that only roles have */ struct { AV *superroles; /* each elem is a raw pointer directly to a ClassMeta whose type == METATYPE_ROLE */ HV *applied_classes; /* keyed by class name each elem is a raw pointer directly to a RoleEmbedding */ } role; }; }; /* Metadata about the embedding of a role into a class */ typedef struct RoleEmbedding { SV *embeddingsv; struct ClassMeta *rolemeta; struct ClassMeta *classmeta; PADOFFSET offset; } RoleEmbedding; struct MethodMeta { SV *name; ClassMeta *class; ClassMeta *role; /* set if inherited from a role */ /* We don't store the method body CV; leave that in the class stash */ }; typedef struct ParamMeta { SV *name; FieldMeta *field; FIELDOFFSET fieldix; } ParamMeta; #define MOP_CLASS_RUN_HOOKS(classmeta, func, ...) \ { \ U32 hooki; \ for(hooki = 0; classmeta->hooks && hooki < av_count(classmeta->hooks); hooki++) { \ struct ClassHook *h = (struct ClassHook *)AvARRAY(classmeta->hooks)[hooki]; \ if(*h->funcs->func) \ (*h->funcs->func)(aTHX_ classmeta, h->hookdata, h->funcdata, __VA_ARGS__); \ } \ } #define mop_class_get_direct_roles(class, embeddings) ObjectPad_mop_class_get_direct_roles(aTHX_ class, embeddings) RoleEmbedding **ObjectPad_mop_class_get_direct_roles(pTHX_ const ClassMeta *meta, U32 *nroles); #define mop_class_get_all_roles(class, embeddings) ObjectPad_mop_class_get_all_roles(aTHX_ class, embeddings) RoleEmbedding **ObjectPad_mop_class_get_all_roles(pTHX_ const ClassMeta *meta, U32 *nroles); void ObjectPad__boot_classes(void); #endif Object-Pad-0.61/include/field.h000444001750001750 372214203242261 15105 0ustar00leoleo000000000000#ifndef __OBJECT_PAD__FIELD_H__ #define __OBJECT_PAD__FIELD_H__ struct FieldMeta { SV *name; ClassMeta *class; SV *defaultsv; OP *defaultexpr; /* at most one of defaultsv or defaultexpr should be set */ FIELDOFFSET fieldix; SV *paramname; AV *hooks; /* NULL, or AV of raw pointers directly to FieldHook structs */ }; #define MOP_FIELD_RUN_HOOKS_NOARGS(fieldmeta, func) \ { \ U32 hooki; \ for(hooki = 0; fieldmeta->hooks && hooki < av_count(fieldmeta->hooks); hooki++) { \ struct FieldHook *h = (struct FieldHook *)AvARRAY(fieldmeta->hooks)[hooki]; \ if(*h->funcs->func) \ (*h->funcs->func)(aTHX_ fieldmeta, h->hookdata, h->funcdata); \ } \ } #define MOP_SLOT_RUN_HOOKS_NOARGS MOP_FIELD_RUN_HOOKS_NOARGS /* back-compat */ #define MOP_FIELD_RUN_HOOKS(fieldmeta, func, ...) \ { \ U32 hooki; \ for(hooki = 0; fieldmeta->hooks && hooki < av_count(fieldmeta->hooks); hooki++) { \ struct FieldHook *h = (struct FieldHook *)AvARRAY(fieldmeta->hooks)[hooki]; \ if(*h->funcs->func) \ (*h->funcs->func)(aTHX_ fieldmeta, h->hookdata, h->funcdata, __VA_ARGS__); \ } \ } #define MOP_SLOT_RUN_HOOKS MOP_FIELD_RUN_HOOKS /* back-compat */ void ObjectPad__boot_fields(pTHX); #endif Object-Pad-0.61/include/object_pad.h000444001750001750 2333014203242261 16131 0ustar00leoleo000000000000#ifndef __OBJECT_PAD__TYPES_H__ #define __OBJECT_PAD__TYPES_H__ #define OBJECTPAD_ABIVERSION_MINOR 57 #define OBJECTPAD_ABIVERSION_MAJOR 0 #define OBJECTPAD_ABIVERSION ((OBJECTPAD_ABIVERSION_MAJOR << 16) | (OBJECTPAD_ABIVERSION_MINOR)) /* A FIELDOFFSET is an offset within the AV of an object instance */ typedef IV FIELDOFFSET; typedef IV SLOTOFFSET; /* back-compat */ typedef struct ClassMeta ClassMeta; typedef struct FieldMeta FieldMeta; typedef struct FieldMeta SlotMeta; /* back-compat */ typedef struct MethodMeta MethodMeta; enum AccessorType { ACCESSOR, ACCESSOR_READER, ACCESSOR_WRITER, ACCESSOR_LVALUE_MUTATOR, ACCESSOR_COMBINED, }; struct AccessorGenerationCtx { PADOFFSET padix; OP *bodyop; /* OP_SASSIGN for :writer, empty for :reader, :mutator */ OP *post_bodyops; OP *retop; /* OP_RETURN */ }; enum { OBJECTPAD_FLAG_ATTR_NO_VALUE = (1<<0), OBJECTPAD_FLAG_ATTR_MUST_VALUE = (1<<1), }; struct ClassHookFuncs { U32 ver; /* caller must initialise to OBJECTPAD_VERSION */ U32 flags; const char *permit_hintkey; /* called immediately at apply time; return FALSE means it did its thing immediately, so don't store it */ bool (*apply)(pTHX_ ClassMeta *classmeta, SV *value, SV **hookdata_ptr, void *funcdata); /* called by mop_class_add_field() */ union { void (*post_add_field)(pTHX_ ClassMeta *classmeta, SV *hookdata, void *funcdata, FieldMeta *fieldmeta); void (*post_add_slot)(pTHX_ ClassMeta *classmeta, SV *hookdata, void *funcdata, FieldMeta *fieldmeta); /* back-compat */ }; }; struct ClassHook { const struct ClassHookFuncs *funcs; void *funcdata; SV *hookdata; }; struct FieldHookFuncs { U32 ver; /* caller must initialise to OBJECTPAD_VERSION */ U32 flags; const char *permit_hintkey; /* called immediately at apply time; return FALSE means it did its thing immediately, so don't store it */ bool (*apply)(pTHX_ FieldMeta *fieldmeta, SV *value, SV **hookdata_ptr, void *funcdata); /* called at the end of `has` statement compiletime */ void (*seal)(pTHX_ FieldMeta *fieldmeta, SV *hookdata, void *funcdata); /* called as part of accessor generation */ void (*gen_accessor_ops)(pTHX_ FieldMeta *fieldmeta, SV *hookdata, void *funcdata, enum AccessorType type, struct AccessorGenerationCtx *ctx); /* called by constructor */ void (*post_initfield)(pTHX_ FieldMeta *fieldmeta, SV *hookdata, void *funcdata, SV *field); void (*post_construct)(pTHX_ FieldMeta *fieldmeta, SV *hookdata, void *funcdata, SV *field); }; struct FieldHook { FIELDOFFSET fieldix; /* unused when in FieldMeta->hooks; used by ClassMeta->fieldhooks_* */ FieldMeta *fieldmeta; const struct FieldHookFuncs *funcs; void *funcdata; SV *hookdata; }; enum MetaType { METATYPE_CLASS, METATYPE_ROLE, }; enum ReprType { REPR_NATIVE, /* instances are in native format - blessed AV as backing */ REPR_HASH, /* instances are blessed HASHes; our backing lives in $self->{"Object::Pad/slots"} */ REPR_MAGIC, /* instances store backing AV via magic; superconstructor must be foreign */ REPR_AUTOSELECT, /* pick one of the above depending on foreign_new and SvTYPE()==SVt_PVHV */ }; /* Special pad indexes within `method` CVs */ enum { PADIX_SELF = 1, PADIX_SLOTS = 2, /* for role methods */ PADIX_EMBEDDING = 3, /* during initfields */ PADIX_INITFIELDS_PARAMS = 4, }; /* Function prototypes */ #define extend_pad_vars(meta) ObjectPad_extend_pad_vars(aTHX_ meta) void ObjectPad_extend_pad_vars(pTHX_ const ClassMeta *meta); #define newMETHSTARTOP(flags) ObjectPad_newMETHSTARTOP(aTHX_ flags) OP *ObjectPad_newMETHSTARTOP(pTHX_ U32 flags); /* op_private flags on FIELDPAD ops */ enum { OPpFIELDPAD_SV, /* has $x */ OPpFIELDPAD_AV, /* has @y */ OPpFIELDPAD_HV, /* has %z */ }; #define newFIELDPADOP(flags, padix, fieldix) ObjectPad_newFIELDPADOP(aTHX_ flags, padix, fieldix) OP *ObjectPad_newFIELDPADOP(pTHX_ U32 flags, PADOFFSET padix, FIELDOFFSET fieldix); #define get_obj_backingav(self, repr, create) ObjectPad_get_obj_backingav(aTHX_ self, repr, create) SV *ObjectPad_get_obj_backingav(pTHX_ SV *self, enum ReprType repr, bool create); /* Class API */ #define mop_create_class(type, name) ObjectPad_mop_create_class(aTHX_ type, name) ClassMeta *ObjectPad_mop_create_class(pTHX_ enum MetaType type, SV *name); #define mop_class_set_superclass(class, super) ObjectPad_mop_class_set_superclass(aTHX_ class, super) void ObjectPad_mop_class_set_superclass(pTHX_ ClassMeta *class, SV *superclassname); #define mop_class_begin(meta) ObjectPad_mop_class_begin(aTHX_ meta) void ObjectPad_mop_class_begin(pTHX_ ClassMeta *meta); #define mop_class_seal(meta) ObjectPad_mop_class_seal(aTHX_ meta) void ObjectPad_mop_class_seal(pTHX_ ClassMeta *meta); #define mop_class_load_and_add_role(class, rolename, rolever) ObjectPad_mop_class_load_and_add_role(aTHX_ class, rolename, rolever) void ObjectPad_mop_class_load_and_add_role(pTHX_ ClassMeta *class, SV *rolename, SV *rolever); #define mop_class_add_role(class, role) ObjectPad_mop_class_add_role(aTHX_ class, role) void ObjectPad_mop_class_add_role(pTHX_ ClassMeta *class, ClassMeta *role); #define mop_class_add_method(class, methodname) ObjectPad_mop_class_add_method(aTHX_ class, methodname) MethodMeta *ObjectPad_mop_class_add_method(pTHX_ ClassMeta *meta, SV *methodname); #define mop_class_add_field(class, fieldname) ObjectPad_mop_class_add_field(aTHX_ class, fieldname) FieldMeta *ObjectPad_mop_class_add_field(pTHX_ ClassMeta *meta, SV *fieldname); #define mop_class_add_BUILD(class, cv) ObjectPad_mop_class_add_BUILD(aTHX_ class, cv) void ObjectPad_mop_class_add_BUILD(pTHX_ ClassMeta *meta, CV *cv); #define mop_class_add_ADJUST(class, cv) ObjectPad_mop_class_add_ADJUST(aTHX_ class, cv) void ObjectPad_mop_class_add_ADJUST(pTHX_ ClassMeta *meta, CV *cv); #define mop_class_add_ADJUSTPARAMS(class, cv) ObjectPad_mop_class_add_ADJUSTPARAMS(aTHX_ class, cv) void ObjectPad_mop_class_add_ADJUSTPARAMS(pTHX_ ClassMeta *meta, CV *cv); #define mop_class_add_required_method(class, methodname) ObjectPad_mop_class_add_required_method(aTHX_ class, methodname) void ObjectPad_mop_class_add_required_method(pTHX_ ClassMeta *meta, SV *methodname); #define mop_class_apply_attribute(classmeta, name, value) ObjectPad_mop_class_apply_attribute(aTHX_ classmeta, name, value) void ObjectPad_mop_class_apply_attribute(pTHX_ ClassMeta *classmeta, const char *name, SV *value); #define register_class_attribute(name, funcs, funcdata) ObjectPad_register_class_attribute(aTHX_ name, funcs, funcdata) void ObjectPad_register_class_attribute(pTHX_ const char *name, const struct ClassHookFuncs *funcs, void *funcdata); /* Field API */ #define mop_create_field(fieldname, classmeta) ObjectPad_mop_create_field(aTHX_ fieldname, classmeta) FieldMeta *ObjectPad_mop_create_field(pTHX_ SV *fieldname, ClassMeta *classmeta); #define mop_field_seal(fieldmeta) ObjectPad_mop_field_seal(aTHX_ fieldmeta) void ObjectPad_mop_field_seal(pTHX_ FieldMeta *fieldmeta); #define mop_field_get_name(fieldmeta) ObjectPad_mop_field_get_name(aTHX_ fieldmeta) SV *ObjectPad_mop_field_get_name(pTHX_ FieldMeta *fieldmeta); #define mop_field_get_sigil(fieldmeta) ObjectPad_mop_field_get_sigil(aTHX_ fieldmeta) char ObjectPad_mop_field_get_sigil(pTHX_ FieldMeta *fieldmeta); #define mop_field_apply_attribute(fieldmeta, name, value) ObjectPad_mop_field_apply_attribute(aTHX_ fieldmeta, name, value) void ObjectPad_mop_field_apply_attribute(pTHX_ FieldMeta *fieldmeta, const char *name, SV *value); #define mop_field_get_attribute(fieldmeta, name) ObjectPad_mop_field_get_attribute(aTHX_ fieldmeta, name) struct FieldHook *ObjectPad_mop_field_get_attribute(pTHX_ FieldMeta *fieldmeta, const char *name); #define mop_field_get_default_sv(fieldmeta) ObjectPad_mop_field_get_default_sv(aTHX_ fieldmeta) SV *ObjectPad_mop_field_get_default_sv(pTHX_ FieldMeta *fieldmeta); #define mop_field_set_default_sv(fieldmeta, sv) ObjectPad_mop_field_set_default_sv(aTHX_ fieldmeta, sv) void ObjectPad_mop_field_set_default_sv(pTHX_ FieldMeta *fieldmeta, SV *sv); #define register_field_attribute(name, funcs, funcdata) ObjectPad_register_field_attribute(aTHX_ name, funcs, funcdata) void ObjectPad_register_field_attribute(pTHX_ const char *name, const struct FieldHookFuncs *funcs, void *funcdata); /* back-compat */ struct SlotHookFuncs { U32 ver; U32 flags; const char *permit_hintkey; bool (*apply)(pTHX_ FieldMeta *fieldmeta, SV *value, SV **hookdata_ptr, void *funcdata); void (*seal_slot)(pTHX_ FieldMeta *fieldmeta, SV *hookdata, void *funcdata); void (*gen_accessor_ops)(pTHX_ FieldMeta *fieldmeta, SV *hookdata, void *funcdata, enum AccessorType type, struct AccessorGenerationCtx *ctx); void (*post_initslot)(pTHX_ FieldMeta *fieldmeta, SV *hookdata, void *funcdata, SV *slot); void (*post_construct)(pTHX_ FieldMeta *fieldmeta, SV *hookdata, void *funcdata, SV *slot); }; #define get_obj_slotsav get_obj_backingav #define mop_class_add_slot mop_class_add_field #define mop_create_slot mop_create_field #define mop_slot_seal mop_field_seal #define mop_slot_get_name mop_field_get_name #define mop_slot_get_sigil mop_field_get_sigil #define mop_slot_apply_attribute mop_field_apply_attribute #define mop_slot_get_attribute mop_field_get_attribute #define mop_slot_get_default_sv mop_field_get_default_sv #define mop_slot_set_default_sv mop_field_set_default_sv /* Don't redirect this one to register_field_attribute, so we still get the * deprecation warning on newly-compiled code */ #define register_slot_attribute(name, funcs, funcdata) ObjectPad_register_slot_attribute(aTHX_ name, funcs, funcdata) void ObjectPad_register_slot_attribute(pTHX_ const char *name, const struct SlotHookFuncs *funcs, void *funcdata); #endif Object-Pad-0.61/include/suspended_compcv.h000444001750001750 120114203242261 17351 0ustar00leoleo000000000000#ifndef __SUSPENDED_COMPCV_H__ #define __SUSPENDED_COMPCV_H__ typedef struct { CV *compcv; STRLEN padix; #ifdef PL_constpadix STRLEN constpadix; #endif STRLEN comppad_name_fill, min_intro_pending, max_intro_pending; bool cv_has_eval, pad_reset_pending; } SuspendedCompCVBuffer; #define suspend_compcv(buffer) MY_suspend_compcv(aTHX_ buffer) void MY_suspend_compcv(pTHX_ SuspendedCompCVBuffer *buffer); #define resume_compcv(buffer) MY_resume_compcv(aTHX_ buffer, FALSE) #define resume_compcv_and_save(buffer) MY_resume_compcv(aTHX_ buffer, TRUE) void MY_resume_compcv(pTHX_ SuspendedCompCVBuffer *buffer, bool save); #endif Object-Pad-0.61/lib000755001750001750 014203242261 12633 5ustar00leoleo000000000000Object-Pad-0.61/lib/Object000755001750001750 014203242261 14041 5ustar00leoleo000000000000Object-Pad-0.61/lib/Object/Pad.pm000444001750001750 10627214203242261 15310 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2019-2022 -- leonerd@leonerd.org.uk package Object::Pad 0.61; use v5.14; use warnings; use Carp; sub dl_load_flags { 0x01 } require DynaLoader; __PACKAGE__->DynaLoader::bootstrap( our $VERSION ); our $XSAPI_VERSION = "0.48"; # So that feature->import will work in `class` require feature; if( $] >= 5.020 ) { require experimental; require indirect if $] < 5.031009; } require mro; require Object::Pad::MOP::Class; =head1 NAME C - a simple syntax for lexical field-based objects =head1 SYNOPSIS On perl version 5.26 onwards: use v5.26; use Object::Pad; class Point { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } method describe () { print "A point at ($x, $y)\n"; } } Point->new(x => 5, y => 10)->describe; Or, for older perls that lack signatures: use Object::Pad; class Point { has $x :param = 0; has $y :param = 0; method move { my ($dX, $dY) = @_; $x += $dX; $y += $dY; } method describe { print "A point at ($x, $y)\n"; } } Point->new(x => 5, y => 10)->describe; =head1 DESCRIPTION This module provides a simple syntax for creating object classes, which uses private variables that look like lexicals as object member fields. B This module is still experimental. The parts that currently exist do seem to work reliably but much of the design is still evolving, and many features and have yet to be implemented. I don't yet guarantee I won't have to change existing details in order to continue its development. Feel free to try it out in experimental or newly-developed code, but don't complain if a later version is incompatible with your current code and you'll have to change it. That all said, please do get in contact if you find the module overall useful. The more feedback you provide in terms of what features you are using, what you find works, and what doesn't, will help the ongoing development and hopefully eventual stability of the design. See the L section. =head2 Automatic Construction Classes are automatically provided with a constructor method, called C, which helps create the object instances. This may respond to passed arguments, automatically assigning values of fields, and invoking other blocks of code provided by the class. It proceeds in the following stages: =head3 The BUILDARGS phase If the class provides a C class method, that is used to mangle the list of arguments before the C blocks are called. Note this must be a class method not an instance method (and so implemented using C). It should perform any C chaining as may be required. @args = $class->BUILDARGS( @_ ) =head3 Field assignment If any field in the class has the C<:param> attribute, then the constructor will expect to receive its argmuents in an even-sized list of name/value pairs. This applies even to fields inherited from the parent class or applied roles. It is therefore a good idea to shape the parameters to the constructor in this way in roles, and in classes if you intend your class to be extended. The constructor will also check for required parameters (these are all the parameters for fields that do not have default initialisation expressions). If any of these are missing an exception is thrown. =head3 The BUILD phase As part of the construction process, the C block of every component class will be invoked, passing in the list of arguments the constructor was invoked with. Each class should perform its required setup behaviour, but does not need to chain to the C class first; this is handled automatically. =head3 The ADJUST phase Next, the C and C block of every component class is invoked. This happens after the fields are assigned their initial values and the C blocks have been run. Note also that both C and C blocks happen at the same time, in declaration order. The C blocks do not form their own separate phase. =head3 The strict-checking phase Finally, before the object is returned, if the L class attribute is present, then the constructor will throw an exception if there are any remaining named arguments left over after assigning them to fields as per C<:param> declarations, and running any C blocks. =head1 KEYWORDS =head2 class class Name :ATTRS... { ... } class Name :ATTRS...; Behaves similarly to the C keyword, but provides a package that defines a new class. Such a class provides an automatic constructor method called C. As with C, an optional block may be provided. If so, the contents of that block define the new class and the preceding package continues afterwards. If not, it sets the class as the package context of following keywords and definitions. As with C, an optional version declaration may be given. If so, this sets the value of the package's C<$VERSION> variable. class Name VERSION { ... } class Name VERSION; A single superclass is supported by the keyword C I class Name isa BASECLASS { ... } class Name isa BASECLASS BASEVER { ... } Prior to version 0.41 this was called C, which is currently recognised as a compatibility synonym. Both C and C keywords are now discouraged, in favour of the L attribute which is preferred because it follows a more standard grammar without this special-case. One or more roles can be composed into the class by the keyword C I class Name does ROLE, ROLE,... { ... } Prior to version 0.41 this was called C, which is currently recognised as a compatibility synonym. Both C and C keywords are now discouraged, in favour of the L attribute which is preferred because it follows a more standard grammar without this special-case. An optional list of attributes may be supplied in similar syntax as for subs or lexical variables. (These are annotations about the class itself; the concept should not be confused with per-object-instance data, which here is called "fields"). Whitespace is permitted within the value and is automatically trimmed, but as standard Perl parsing rules, no space is permitted between the attribute's name and the open parenthesis of its value: :attr( value here ) # is permitted :attr (value here) # not permitted The following class attributes are supported: =head3 :isa :isa(CLASS) :isa(CLASS CLASSVER) I Declares a superclass that this class extends. At most one superclass is supported. If the package providing the superclass does not exist, an attempt is made to load it by code equivalent to require CLASS (); and thus it must either already exist, or be locatable via the usual C<@INC> mechanisms. The superclass may or may not itself be implemented by C, but if it is not then see L for further detail on the semantics of how this operates. An optional version check can also be supplied; it performs the equivalent of BaseClass->VERSION( $ver ) =head3 :does :does(ROLE) :does(ROLE ROLEVER) I Composes a role into the class; optionally requiring a version check on the role package. This is a newer form of the C and C keywords and should be preferred for new code. Multiple roles can be composed by using multiple C<:does> attributes, one per role. The package will be loaded in a similar way to how the L attribute is handled. =head3 :repr(TYPE) Sets the representation type for instances of this class. Must be one of the following values: :repr(native) The native representation. This is an opaque representation type whose contents are not specified. It only works for classes whose entire inheritence hierarchy is built only from classes based on C. :repr(HASH) The representation will be a blessed hash reference. The instance data will be stored in an array referenced by a key called C, which is fairly unlikely to clash with existing storage on the instance. No other keys will be used; they are available for implementions and subclasses to use. The exact format of the value stored here is not specified and may change between module versions, though it can be relied on to be well-behaved as some kind of perl data structure for purposes of modules like L or serialisation into things like C or C. This representation type may be useful when converting existing classes into using C where there may be existing subclasses of it that presume a blessed hash for their own use. :repr(magic) The representation will use MAGIC to apply the instance data in a way that is invisible at the Perl level, and shouldn't get in the way of other things the instance is doing even in XS modules. This representation type is the only one that will work for subclassing existing classes that do not use blessed hashes. :repr(autoselect), :repr(default) I This representation will select one of the representations above depending on what is best for the situation. Classes not derived from a non-C base class will pick C, and classes derived from non-C bases will pick either the C or C forms depending on whether the instance is a blessed hash reference or some other kind. This achieves the best combination of DWIM while still allowing the common forms of hash reference to be inspected by C, etc. This is the default representation type, and does not have to be specifically requested. =head3 :strict(params) I Can only be applied to classes that contain no C blocks. If set, then the constructor will complain about any unrecognised named arguments passed to it (i.e. names that do not correspond to the C<:param> of any defined field and left unconsumed by any C block). Since C blocks can inspect the arguments arbitrarily, the presence of any such block means the constructor cannot determine which named arguments are not recognised. This attribute is a temporary stepping-stone for compatibility with existing code. It is recommended to enable this whenever possible, as a later version of this module will likely perform this behaviour unconditionally whenever no C blocks are present. =head2 role role Name :ATTRS... { ... } role Name :ATTRS...; I Similar to C, but provides a package that defines a new role. A role acts simliar to a class in some respects, and differently in others. Like a class, a role can have a version, and named methods. role Name VERSION { method a { ... } method b { ... } } A role does not provide a constructor, and instances cannot directly be constructed. A role cannot extend a class. A role can declare that it requires methods of given names from any class that implements the role. role Name { requires METHOD; } A role can provide instance fields. These are visible to any C blocks or methods provided by that role. I role Name { has $field; BUILD { $field = "a value" } method field { return $field } } I a role can declare that it provides another role: role Name :does(OTHERROLE) { ... } role Name :does(OTHERROLE OTHERVER) { ... } This will include all of the methods from the included role. Effectively this means that applying the "outer" role to a class will imply applying the other role as well. The following role attributes are supported: =head3 :compat(invokable) I Enables a form of backward-compatibility behaviour useful for gradually upgrading existing code from classical Perl inheritance or mixins into using roles. Normally, methods of a role cannot be directly invoked and the role must be applied to an L-based class in order to be used. This however presents a problem when gradually upgrading existing code that already uses techniques like roles, multiple inheritance or mixins when that code may be split across multiple distributions, or for some other reason cannot be upgraded all at once. Methods within a role that has the C<:compat(invokable)> attribute applied to it may be directly invoked on any object instance. This allows the creation of a role that can still provide code for existing classes written in classical Perl that has not yet been rewritten to use C. The tradeoff is that a C<:compat(invokable)> role may not create field data using the L keyword. Whatever behaviours the role wishes to perform must be provided only by calling other methods on C<$self>, or perhaps by making assumptions about the representation type of instances. It should be stressed again: This option is I intended for gradual upgrade of existing classical Perl code into using C. When all existing code is using C then this attribute can be removed from the role. =head2 has has $var; has @var; has %var; has $var :ATTR ATTR...; has $var = EXPR; has $var { BLOCK }; Declares that the instances of the class or role have a member field of the given name. This member field will be accessible as a lexical variable within any C declarations in the class. Array and hash members are permitted and behave as expected; you do not need to store references to anonymous arrays or hashes. Member fields are private to a class or role. They are not visible to users of the class, nor inherited by subclasses nor any class that a role is applied to. In order to provide access to them a class may wish to use L to create an accessor, or use the attributes such as L to get one generated. A scalar field may provide a expression that gives an initialisation value, which will be assigned into the field of every instance during the constructor before the C blocks are invoked. I this expression does not have to be a compiletime constant, though it is evaluated exactly once, at runtime, after the class definition has been parsed. It is not evaluated individually for every object instance of that class. I this is also permitted on array and hash fields. =head3 Field Initialiser Blocks I a deferred statement block is also permitted, on any field variable type. This is an B feature that permits code to be executed as part of the instance constructor, rather than running just once when the class is set up. Code in a field initialisation block is roughly equivalent to being placed in a C or C block. Control flow that attempts to leave a field initialiser block is not permitted. This includes any C expression, any C outside of a loop, with a dynamically-calculated label expression, or with a label that it doesn't appear in. C statements are also currently forbidden, though known-safe ones may be permitted in future. Loop control expressions that are known at compiletime to affect a loop that they appear within are permitted. has $field { foreach(@list) { next; } } # this is fine has $field { LOOP: while(1) { last LOOP; } } # this is fine too The following field attributes are supported: =head3 :reader, :reader(NAME) I Generates a reader method to return the current value of the field. If no name is given, the name of the field is used. A single prefix character C<_> will be removed if present. has $field :reader; # equivalent to has $field; method field { return $field } I these are permitted on any field type, but prior versions only allowed them on scalar fields. The reader method behaves identically to how a lexical variable would behave in the same context; namely returning a list of values from an array or key/value pairs from a hash when in list context, or the number of items or keys when in scalar context. has @items :reader; foreach my $item ( $obj->items ) { ... } # iterates the list of items my $count = $obj->items; # yields count of items =head3 :writer, :writer(NAME) I Generates a writer method to set a new value of the field from its arguments. If no name is given, the name of the field is used prefixed by C. A single prefix character C<_> will be removed if present. has $field :writer; # equivalent to has $field; method set_field { $field = shift; return $self } I a generated writer method will return the object invocant itself, allowing a chaining style. $obj->set_x("x") ->set_y("y") ->set_z("z"); I these are permitted on any field type, but prior versions only allowed them on scalar fields. On arrays or hashes, the writer method takes a list of values to be assigned into the field, completely replacing any values previously there. =head3 :mutator, :mutator(NAME) I Generates an lvalue mutator method to return or set the value of the field. These are only permitted for scalar fields. If no name is given, the name of the field is used. A single prefix character C<_> will be removed if present. has $field :mutator; # equivalent to has $field; method field :lvalue { $field } I all of these generated accessor methods will include argument checking similar to that used by subroutine signatures, to ensure the correct number of arguments are passed - usually zero, but exactly one in the case of a C<:writer> method. =head3 :accessor, :accessor(NAME) I Generates a combined reader-writer accessor method to set or return the value of the field. These are only permitted for scalar fields. If no name is given, the name of the field is used. A prefix character C<_> will be removed if present. This method takes either zero or one additional arguments. If an argument is passed, the value of the field is set from this argument (even if it is C). If no argument is passed (i.e. C is false) then the field is not modified. In either case, the value of the field is then returned. has $field :accessor; # equivalent to has $field; method field { $field = shift if @_; return $field; } =head3 :weak I Generated code which sets the value of this field will weaken it if it contains a reference. This applies to within the constructor if C<:param> is given, and to a C<:writer> accessor method. Note that this I applies to automatically generated code; not normal code written in regular method bodies. If you assign into the field variable you must remember to call C yourself. =head3 :param, :param(NAME) I Sets this field to be initialised automatically in the generated constructor. This is only permitted on scalar fields. If no name is given, the name of the field is used. A single prefix character C<_> will be removed if present. Any field that has C<:param> but does not have a default initialisation expression or block becomes a required argument to the constructor. Attempting to invoke the constructor without a named argument for this will throw an exception. In order to make a parameter optional, make sure to give it a default expression - even if that expression is C: has $x :param; # this is required has $z :param = undef; # this is optional Any field that has a C<:param> and an initialisation block will only run the code in the block if required by the constructor. If a named parameter is passed to the constructor for this field, then its code block will not be executed. Values for fields are assigned by the constructor before any C blocks are invoked. =head2 method method NAME { ... } method NAME (SIGNATURE) { ... } method NAME :ATTRS... { ... } method NAME; Declares a new named method. This behaves similarly to the C keyword, except that within the body of the method all of the member fields are also accessible. In addition, the method body will have a lexical called C<$self> which contains the invocant object directly; it will already have been shifted from the C<@_> array. If the method has no body and is given simply as a name, this declares a I method for a role. Such a method must be provided by any class that implements the role. It will be a compiletime error to combine the role with a class that does not provide this. The C feature is automatically enabled for method declarations. In this case the signature does not have to account for the invocant instance; that is handled directly. method m ($one, $two) { say "$self invokes method on one=$one two=$two"; } ... $obj->m(1, 2); A list of attributes may be supplied as for C. The most useful of these is C<:lvalue>, allowing easy creation of read-write accessors for fields (but see also the C<:reader>, C<:writer> and C<:mutator> field attributes). class Counter { has $count; method count :lvalue { $count } } my $c = Counter->new; $c->count++; Every method automatically gets the C<:method> attribute applied, which suppresses warnings about ambiguous calls resolved to core functions if the name of a method matches a core function. The following additional attributes are recognised by C directly: =head3 :override I Marks that this method expects to override another of the same name from a superclass. It is an error at compiletime if the superclass does not provide such a method. =head2 method (lexical) method $var { ... } method $var :ATTRS... (SIGNATURE) { ... } I Declares a new lexical method. Lexical methods are not visible via the package namespace, but instead are stored directly in a lexical variable (with the same scoping rules as regular C variables). These can be invoked by subsequent method code in the same block by using C<< $self->$var(...) >> method call syntax. class WithPrivate { has $var; # Lexical methods can still see instance fields as normal method $inc_var { $var++; say "Var was incremented"; } method $dec_var { $var--; say "Var was decremented"; } method bump { $self->$inc_var; say "In the middle"; $self->$dec_var; } } my $obj = WithPrivate->new; $obj->bump; # Neither $inc_var nor $dec_var are visible here This effectively provides the ability to define B methods, as they are inaccessible from outside the block that defines the class. In addition, there is no chance of a name collision because lexical variables in different scopes are independent, even if they share the same name. This is particularly useful in roles, to create internal helper methods without letting those methods be visible to callers, or risking their names colliding with other named methods defined on the consuming class. =head2 BUILD BUILD { ... } BUILD (SIGNATURE) { ... } I Declares the builder block for this component class. A builder block may use subroutine signature syntax, as for methods, to assist in unpacking its arguments. A build block is not a subroutine and thus is not permitted to use subroutine attributes (for example C<:lvalue>). Note that a C block is a named phaser block and not a method. Attempts to create a method named C (i.e. with syntax C) will fail with a compiletime error, to avoid this confusion. =head2 ADJUST ADJUST { ... } I Declares an adjust block for this component class. This block of code runs within the constructor, after any C blocks and automatic field value assignment. It can make any final adjustments to the instance (such as initialising fields from calculated values). No additional parameters are passed. An adjust block is not a subroutine and thus is not permitted to use subroutine attributes. Note that an C block is a named phaser block and not a method; it does not use the C or C keyword. =head2 ADJUSTPARAMS ADJUSTPARAMS ( $params ) { # on perl 5.26 onwards ... } ADJUSTPARAMS { my $params = shift; ... } I Declares an adjust block for this component class that receives the parameters hash reference. This block of code runs within the constructor at the same time as L blocks, but receives in addition a reference to the hash containing the current constructor parameters. This hash will not contain any constructor parameters already consumed by L declarations on any fields, but only the leftovers once those are processed. The code in the block should C from this hash any parameters it wishes to consume. Once all the C blocks have run, any remaining keys in the hash will be considered errors, subject to the L check. =head2 requires requires NAME; Declares that this role requires a method of the given name from any class that implements it. It is an error at compiletime if the implementing class does not provide such a method. This form of declaring a required method is now vaguely discouraged, in favour of the bodyless C form described above. =head1 CREPT FEATURES While not strictly part of being an object system, this module has nevertheless gained a number of behaviours by feature creep, as they have been found useful. =head2 Implied Pragmata In order to encourage users to write clean, modern code, the body of the C block acts as if the following pragmata are in effect: use strict; use warnings; no indirect ':fatal'; # or no feature 'indirect' on perl 5.32 onwards use feature 'signatures'; This list may be extended in subsequent versions to add further restrictions and should not be considered exhaustive. Further additions will only be ones that remove "discouraged" or deprecated language features with the overall goal of enforcing a more clean modern style within the body. As long as you write code that is in a clean, modern style (and I fully accept that this wording is vague and subjective) you should not find any new restrictions to be majorly problematic. Either the code will continue to run unaffected, or you may have to make some small alterations to bring it into a conforming style. =head2 Yield True A C statement or block will yield a true boolean value. This means that it can be used directly inside a F<.pm> file, avoiding the need to explicitly yield a true value from the end of it. =head1 SUBCLASSING CLASSIC PERL CLASSES There are a number of details specific to the case of deriving an C class from an existing classic Perl class that is not implemented using C. =head2 Storage of Instance Data Instances will pick either the C<:repr(HASH)> or C<:repr(magic)> storage type. =head2 Object State During Methods Invoked By Superclass Constructor It is common in classic Perl OO style to invoke methods on C<$self> during the constructor. This is supported here since C version 0.19. Note however that any methods invoked by the superclass constructor may not see the object in a fully consistent state. (This fact is not specific to using C and would happen in classic Perl OO as well). The field initialisers will have been invoked but the C blocks will not. For example; in the following package ClassicPerlBaseClass { sub new { my $self = bless {}, shift; say "Value seen by superconstructor is ", $self->get_value; return $self; } sub get_value { return "A" } } class DerivedClass :isa(ClassicPerlBaseClass) { has $_value = "B"; BUILD { $_value = "C"; } method get_value { return $_value } } my $obj = DerivedClass->new; say "Value seen by user is ", $obj->get_value; Until the C superconstructor has returned the C block will not have been invoked. The C<$_value> field will still exist, but its value will be C during the superconstructor. After the superconstructor, the C blocks are invoked before the completed object is returned to the user. The result will therefore be: Value seen by superconstructor is B Value seen by user is C =head1 STYLE SUGGESTIONS While in no way required, the following suggestions of code style should be noted in order to establish a set of best practices, and encourage consistency of code which uses this module. =head2 $VERSION declaration While it would be nice for CPAN and other toolchain modules to parse the embedded version declarations in C statements, the current state at time of writing (June 2020) is that none of them actually do. As such, it will still be necessary to make a once-per-file C<$VERSION> declaration in syntax those modules can parse. Further note that these modules will also not parse the C declaration, so you will have to duplicate this with a C declaration as well as a C keyword. This does involve repeating the package name, so is slightly undesirable. It is hoped that eventually upstream toolchain modules will be adapted to accept the C syntax as being sufficient to declare a package and set its version. See also =over 2 =item * L =back =head2 File Layout Begin the file with a C line; ideally including a minimum-required version. This should be followed by the toplevel C and C declarations for the file. As it is at toplevel there is no need to use the block notation; it can be a unit class. There is no need to C or apply other usual pragmata; these will be implied by the C keyword. use Object::Pad 0.16; package My::Classname 1.23; class My::Classname; # other use statements # has, methods, etc.. can go here =head2 Field Names Field names should follow similar rules to regular lexical variables in code - lowercase, name components separated by underscores. For tiny examples such as "dumb record" structures this may be sufficient. class Tag { has $name :mutator; has $value :mutator; } In larger examples with lots of non-trivial method bodies, it can get confusing to remember where the field variables come from (because we no longer have the C<< $self->{ ... } >> visual clue). In these cases it is suggested to prefix the field names with a leading underscore, to make them more visually distinct. class Spudger { has $_grapefruit; ... method mangle { $_grapefruit->peel; # The leading underscore reminds us this is a field } } =cut sub import { my $class = shift; my $caller = caller; $class->import_into( $caller, @_ ); } sub import_into { my $class = shift; my ( $caller, @syms ) = @_; @syms or @syms = qw( class role method has requires ); my %syms = map { $_ => 1 } @syms; delete $syms{$_} and $^H{"Object::Pad/$_"}++ for qw( class role method has requires ); croak "Unrecognised import symbols @{[ keys %syms ]}" if keys %syms; } sub begin_class { my $class = shift; my ( $name, %args ) = @_; Carp::carp "Object::Pad->begin_class is deprecated; use Object::Pad::MOP::Class->begin_class instead"; Object::Pad::MOP::Class->begin_class( $name, %args ); } # The universal base-class methods sub Object::Pad::UNIVERSAL::BUILDARGS { shift; # $class return @_; } # Back-compat wrapper sub Object::Pad::MOP::SlotAttr::register { shift; # $class carp "Object::Pad::MOP::SlotAttr->register is now deprecated; use Object::Pad::MOP::FieldAttr->register instead"; return Object::Pad::MOP::FieldAttr->register( @_ ); } =head1 WITH OTHER MODULES =head2 Syntax::Keyword::Dynamically A cross-module integration test asserts that C works correctly on object instance fields: use Object::Pad; use Syntax::Keyword::Dynamically; class Container { has $value = 1; method example { dynamically $value = 2; ,.. # value is restored to 1 on return from this method } } =head2 Future::AsyncAwait As of L version 0.38 and L version 0.15, both modules now use L to parse blocks of code. Because of this the two modules can operate together and allow class methods to be written as async subs which await expressions: use Future::AsyncAwait; use Object::Pad; class Example { async method perform ($block) { say "$self is performing code"; await $block->(); say "code finished"; } } These three modules combine; there is additionally a cross-module test to ensure that object instance fields can be C set during a suspended C. =head1 DESIGN TODOs The following points are details about the design of pad field-based object systems in general: =over 4 =item * Is multiple inheritence actually required, if role composition is implemented including giving roles the ability to use private fields? =item * Consider the visibility of superclass fields to subclasses. Do subclasses even need to be able to see their superclass's fields, or are accessor methods always appropriate? Concrete example: The C<< $self->{split_at} >> access that L makes of its parent class L. =back =head1 IMPLEMENTATION TODOs These points are more about this particular module's implementation: =over 4 =item * Consider multiple inheritence of subclassing, if that is still considered useful after adding roles. =item * Work out why C doesn't appear to work properly before perl 5.20. =item * Work out why we don't get a C warning if we sub new { ... } =item * The C modifier does not work on field variables, because they appear to be regular lexicals to the parser at that point. A workaround is to use L instead: use Syntax::Keyword::Dynamically; has $loglevel; method quietly { dynamically $loglevel = LOG_ERROR; ... } =back =cut =head1 FEEDBACK The following resources are useful forms of providing feedback, especially in the form of reports of what you find good or bad about the module, requests for new features, questions on best practice, etc... =over 4 =item * The RT queue at L. =item * The C<#cor> IRC channel on C. =back =cut =head1 SPONSORS With thanks to the following sponsors, who have helped me be able to spend time working on this module and other perl features. =over 4 =item * Oetiker+Partner AG L =item * Deriv L =item * Perl-Verein Schweiz L =back Additional details may be found at L. =cut =head1 AUTHOR Paul Evans =cut 0x55AA; Object-Pad-0.61/lib/Object/Pad.xs000444001750001750 11136514203242261 15325 0ustar00leoleo000000000000/* You may distribute under the terms of either the GNU General Public License * or the Artistic License (the same terms as Perl itself) * * (C) Paul Evans, 2019-2021 -- leonerd@leonerd.org.uk */ #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "XSParseKeyword.h" #include "XSParseSublike.h" #include "perl-backcompat.c.inc" #include "sv_setrv.c.inc" #ifdef HAVE_DMD_HELPER # include "DMD_helper.h" #endif #include "perl-additions.c.inc" #include "lexer-additions.c.inc" #include "forbid_outofblock_ops.c.inc" #include "force_list_keeping_pushmark.c.inc" #include "optree-additions.c.inc" #include "newOP_CUSTOM.c.inc" #if HAVE_PERL_VERSION(5, 26, 0) # define HAVE_PARSE_SUBSIGNATURE #endif #if HAVE_PERL_VERSION(5, 28, 0) # define HAVE_UNOP_AUX_PV #endif #include "object_pad.h" #include "class.h" #include "field.h" typedef void AttributeHandler(pTHX_ void *target, const char *value, void *data); struct AttributeDefinition { char *attrname; /* TODO: int flags */ AttributeHandler *apply; void *applydata; }; /********************************** * Class and Field Implementation * **********************************/ /* Empty role embedding that is applied to all invokable role methods */ static RoleEmbedding embedding_standalone = {}; void ObjectPad_extend_pad_vars(pTHX_ const ClassMeta *meta) { PADOFFSET padix; padix = pad_add_name_pvs("$self", 0, NULL, NULL); if(padix != PADIX_SELF) croak("ARGH: Expected that padix[$self] = 1"); /* Give it a name that isn't valid as a Perl variable so it can't collide */ padix = pad_add_name_pvs("@(Object::Pad/slots)", 0, NULL, NULL); if(padix != PADIX_SLOTS) croak("ARGH: Expected that padix[@slots] = 2"); if(meta->type == METATYPE_ROLE) { /* Don't give this a padname or Future::AsyncAwait will break it (RT137649) */ padix = pad_add_name_pvs("", 0, NULL, NULL); if(padix != PADIX_EMBEDDING) croak("ARGH: Expected that padix[(embedding)] = 3"); } } #define find_padix_for_field(fieldmeta) S_find_padix_for_field(aTHX_ fieldmeta) static PADOFFSET S_find_padix_for_field(pTHX_ FieldMeta *fieldmeta) { const char *fieldname = SvPVX(fieldmeta->name); #if HAVE_PERL_VERSION(5, 20, 0) const PADNAMELIST *nl = PadlistNAMES(CvPADLIST(PL_compcv)); PADNAME **names = PadnamelistARRAY(nl); PADOFFSET padix; for(padix = 1; padix <= PadnamelistMAXNAMED(nl); padix++) { PADNAME *name = names[padix]; if(!name || !PadnameLEN(name)) continue; const char *pv = PadnamePV(name); if(!pv) continue; /* field names are all OUTER vars. This is necessary so we don't get * confused by signatures params of the same name * https://rt.cpan.org/Ticket/Display.html?id=134456 */ if(!PadnameOUTER(name)) continue; if(!strEQ(pv, fieldname)) continue; /* TODO: for extra robustness we could compare the SV * in the pad itself */ return padix; } return NOT_IN_PAD; #else /* Before the new pad API, the best we can do is call pad_findmy_pv() * It won't get confused about signatures params because these perls are too * old for signatures anyway */ return pad_findmy_pv(fieldname, 0); #endif } static XOP xop_methstart; static OP *pp_methstart(pTHX) { SV *self = av_shift(GvAV(PL_defgv)); bool create = PL_op->op_flags & OPf_MOD; bool is_role = PL_op->op_flags & OPf_SPECIAL; if(!SvROK(self) || !SvOBJECT(SvRV(self))) croak("Cannot invoke method on a non-instance"); HV *classstash; FIELDOFFSET offset; RoleEmbedding *embedding = NULL; if(is_role) { /* Embedding info is stored in pad1; PAD_SVl() will look at CvDEPTH. We'll * have to grab it manually */ PAD *pad1 = PadlistARRAY(CvPADLIST(find_runcv(0)))[1]; SV *embeddingsv = PadARRAY(pad1)[PADIX_EMBEDDING]; if(embeddingsv && embeddingsv != &PL_sv_undef && (embedding = (RoleEmbedding *)SvPVX(embeddingsv))) { if(embedding == &embedding_standalone) { classstash = NULL; offset = 0; } else { classstash = embedding->classmeta->stash; offset = embedding->offset; } } else { croak("Cannot invoke a role method directly"); } } else { classstash = CvSTASH(find_runcv(0)); offset = 0; } if(classstash) { if(!HvNAME(classstash) || !sv_derived_from_hv(self, classstash)) croak("Cannot invoke foreign method on non-derived instance"); } save_clearsv(&PAD_SVl(PADIX_SELF)); sv_setsv(PAD_SVl(PADIX_SELF), self); SV *backingav; if(is_role) { if(embedding == &embedding_standalone) { backingav = NULL; } else { SV *instancedata = get_obj_backingav(self, embedding->classmeta->repr, create); if(create) { backingav = instancedata; SvREFCNT_inc(backingav); } else { backingav = (SV *)newAV(); /* MASSIVE CHEAT */ AvARRAY(backingav) = AvARRAY(instancedata) + offset; AvFILLp(backingav) = AvFILLp(instancedata) - offset; AvREAL_off(backingav); } } } else { /* op_private contains the repr type so we can extract backing */ backingav = get_obj_backingav(self, PL_op->op_private, create); SvREFCNT_inc(backingav); } if(backingav) { SAVESPTR(PAD_SVl(PADIX_SLOTS)); PAD_SVl(PADIX_SLOTS) = backingav; save_freesv(backingav); } return PL_op->op_next; } OP *ObjectPad_newMETHSTARTOP(pTHX_ U32 flags) { OP *op = newOP_CUSTOM(&pp_methstart, flags); op->op_private = (U8)(flags >> 8); return op; } static XOP xop_fieldpad; static OP *pp_fieldpad(pTHX) { #ifdef HAVE_UNOP_AUX FIELDOFFSET fieldix = PTR2IV(cUNOP_AUX->op_aux); #else UNOP_with_IV *op = (UNOP_with_IV *)PL_op; FIELDOFFSET fieldix = op->iv; #endif PADOFFSET targ = PL_op->op_targ; if(SvTYPE(PAD_SV(PADIX_SLOTS)) != SVt_PVAV) croak("ARGH: expected ARRAY of slots at PADIX_SLOTS"); AV *backingav = (AV *)PAD_SV(PADIX_SLOTS); if(fieldix > av_top_index(backingav)) croak("ARGH: instance does not have a field at index %ld", (long int)fieldix); SV **fieldsvs = AvARRAY(backingav); SV *sv = fieldsvs[fieldix]; SV *val; switch(PL_op->op_private) { case OPpFIELDPAD_SV: val = sv; break; case OPpFIELDPAD_AV: if(!SvROK(sv) || SvTYPE(val = SvRV(sv)) != SVt_PVAV) croak("ARGH: expected to find an ARRAY reference at field index %ld", (long int)fieldix); break; case OPpFIELDPAD_HV: if(!SvROK(sv) || SvTYPE(val = SvRV(sv)) != SVt_PVHV) croak("ARGH: expected to find a HASH reference at field index %ld", (long int)fieldix); break; default: croak("ARGH: unsure what to do with this field type"); } SAVESPTR(PAD_SVl(targ)); PAD_SVl(targ) = SvREFCNT_inc(val); save_freesv(val); return PL_op->op_next; } OP *ObjectPad_newFIELDPADOP(pTHX_ U32 flags, PADOFFSET padix, FIELDOFFSET fieldix) { #ifdef HAVE_UNOP_AUX OP *op = newUNOP_AUX(OP_CUSTOM, flags, NULL, NUM2PTR(UNOP_AUX_item *, fieldix)); #else OP *op = newUNOP_with_IV(OP_CUSTOM, flags, NULL, fieldix); #endif op->op_targ = padix; op->op_private = (U8)(flags >> 8); op->op_ppaddr = &pp_fieldpad; return op; } /* The metadata on the currently-compiling class */ #define compclassmeta S_compclassmeta(aTHX) static ClassMeta *S_compclassmeta(pTHX) { SV **svp = hv_fetchs(GvHV(PL_hintgv), "Object::Pad/compclassmeta", 0); if(!svp || !*svp || !SvOK(*svp)) return NULL; return (ClassMeta *)SvIV(*svp); } #define have_compclassmeta S_have_compclassmeta(aTHX) static bool S_have_compclassmeta(pTHX) { SV **svp = hv_fetchs(GvHV(PL_hintgv), "Object::Pad/compclassmeta", 0); if(!svp || !*svp) return false; if(SvOK(*svp) && SvIV(*svp)) return true; return false; } #define compclassmeta_set(meta) S_compclassmeta_set(aTHX_ meta) static void S_compclassmeta_set(pTHX_ ClassMeta *meta) { SV *sv = *hv_fetchs(GvHV(PL_hintgv), "Object::Pad/compclassmeta", GV_ADD); sv_setiv(sv, (IV)meta); } XS_INTERNAL(xsub_mop_class_seal) { dXSARGS; ClassMeta *meta = XSANY.any_ptr; PERL_UNUSED_ARG(items); if(!PL_parser) { /* We need to generate just enough of a PL_parser to keep newSTATEOP() * happy, otherwise it will SIGSEGV */ SAVEVPTR(PL_parser); Newxz(PL_parser, 1, yy_parser); SAVEFREEPV(PL_parser); PL_parser->copline = NOLINE; #if HAVE_PERL_VERSION(5, 20, 0) PL_parser->preambling = NOLINE; #endif } mop_class_seal(meta); } #define is_valid_ident_utf8(s) S_is_valid_ident_utf8(aTHX_ s) static bool S_is_valid_ident_utf8(pTHX_ const U8 *s) { const U8 *e = s + strlen((char *)s); if(!isIDFIRST_utf8_safe(s, e)) return false; s += UTF8SKIP(s); while(*s) { if(!isIDCONT_utf8_safe(s, e)) return false; s += UTF8SKIP(s); } return true; } void inplace_trim_whitespace(SV *sv) { if(!SvPOK(sv) || !SvCUR(sv)) return; char *dst = SvPVX(sv); char *src = dst; while(*src && isSPACE(*src)) src++; if(src > dst) { size_t offset = src - dst; Move(src, dst, SvCUR(sv) - offset, char); SvCUR(sv) -= offset; } src = dst + SvCUR(sv) - 1; while(src > dst && isSPACE(*src)) src--; SvCUR(sv) = src - dst + 1; dst[SvCUR(sv)] = 0; } static void S_check_method_override(pTHX_ struct XSParseSublikeContext *ctx, const char *val, void *_data) { if(!ctx->name) croak("Cannot apply :override to anonymous methods"); GV *gv = gv_fetchmeth_sv(compclassmeta->stash, ctx->name, 0, 0); if(gv && GvCV(gv)) return; croak("Superclass does not have a method named '%" SVf "'", SVfARG(ctx->name)); } static struct AttributeDefinition method_attributes[] = { { "override", (AttributeHandler *)&S_check_method_override, NULL }, { 0 } }; /******************* * Custom Keywords * *******************/ static int build_classlike(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata) { int argi = 0; SV *packagename = args[argi++]->sv; /* Grrr; XPK bug */ if(!packagename) croak("Expected a class name after 'class'"); enum MetaType type = (enum MetaType)hookdata; SV *packagever = args[argi++]->sv; SV *superclassname = NULL; if(args[argi++]->i) { /* extends */ if(!args[argi]->i) { warn("'extends' is deprecated; use :isa instead"); } argi++; /* ignore the XPK_CHOICE() integer; `extends` and `isa` are synonyms */ if(type != METATYPE_CLASS) croak("Only a class may extend another"); if(superclassname) croak("Multiple superclasses are not currently supported"); superclassname = args[argi++]->sv; if(!superclassname) croak("Expected a superclass name after 'isa'"); SV *superclassver = args[argi++]->sv; HV *superstash = gv_stashsv(superclassname, 0); if(!superstash || !hv_fetchs(superstash, "new", 0)) { /* Try to `require` the module then attempt a second time */ /* load_module() will modify the name argument and take ownership of it */ load_module(PERL_LOADMOD_NOIMPORT, newSVsv(superclassname), NULL, NULL); superstash = gv_stashsv(superclassname, 0); } if(!superstash) croak("Superclass %" SVf " does not exist", superclassname); if(superclassver) ensure_module_version(superclassname, superclassver); } ClassMeta *meta = mop_create_class(type, packagename); if(superclassname && SvOK(superclassname)) mop_class_set_superclass(meta, superclassname); int nimplements = args[argi++]->i; if(nimplements) { int i; for(i = 0; i < nimplements; i++) { if(!args[argi]->i) { warn("'implements' is deprecated; use :does instead"); } argi++; /* ignore the XPK_CHOICE() integer; `implements` and `does` are synonyms */ int nroles = args[argi++]->i; while(nroles--) { SV *rolename = args[argi++]->sv; if(!rolename) croak("Expected a role name after 'does'"); SV *rolever = args[argi++]->sv; mop_class_load_and_add_role(meta, rolename, rolever); } } } if(superclassname) SvREFCNT_dec(superclassname); int nattrs = args[argi++]->i; if(nattrs) { int i; for(i = 0; i < nattrs; i++) { SV *attrname = args[argi]->attr.name; SV *attrval = args[argi]->attr.value; inplace_trim_whitespace(attrval); mop_class_apply_attribute(meta, SvPVX(attrname), attrval); argi++; } } mop_class_begin(meta); /* At this point XS::Parse::Keyword has parsed all it can. From here we will * take over to perform the odd "block or statement" behaviour of `class` * keywords */ bool is_block; if(lex_consume_unichar('{')) { is_block = true; ENTER; } else if(lex_consume_unichar(';')) { is_block = false; } else croak("Expected a block or ';'"); import_pragma("strict", NULL); import_pragma("warnings", NULL); #if HAVE_PERL_VERSION(5, 31, 9) import_pragma("-feature", "indirect"); #else import_pragma("-indirect", ":fatal"); #endif #ifdef HAVE_PARSE_SUBSIGNATURE import_pragma("experimental", "signatures"); #endif /* CARGOCULT from perl/op.c:Perl_package() */ { SAVEGENERICSV(PL_curstash); save_item(PL_curstname); PL_curstash = (HV *)SvREFCNT_inc(meta->stash); sv_setsv(PL_curstname, packagename); PL_hints |= HINT_BLOCK_SCOPE; PL_parser->copline = NOLINE; } if(packagever) { /* stolen from op.c because Perl_package_version isn't exported */ U32 savehints = PL_hints; PL_hints &= ~HINT_STRICT_VARS; sv_setsv(GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), packagever); PL_hints = savehints; } if(is_block) { I32 save_ix = block_start(TRUE); compclassmeta_set(meta); OP *body = parse_stmtseq(0); body = block_end(save_ix, body); if(!lex_consume_unichar('}')) croak("Expected }"); mop_class_seal(meta); LEAVE; /* CARGOCULT from perl/perly.y:PACKAGE BAREWORD BAREWORD '{' */ /* a block is a loop that happens once */ *out = op_append_elem(OP_LINESEQ, newWHILEOP(0, 1, NULL, NULL, body, NULL, 0), newSVOP(OP_CONST, 0, &PL_sv_yes)); return KEYWORD_PLUGIN_STMT; } else { SAVEDESTRUCTOR_X(&ObjectPad_mop_class_seal, meta); SAVEHINTS(); compclassmeta_set(meta); *out = newSVOP(OP_CONST, 0, &PL_sv_yes); return KEYWORD_PLUGIN_STMT; } } static const struct XSParseKeywordPieceType pieces_classlike[] = { XPK_PACKAGENAME, XPK_VSTRING_OPT, XPK_OPTIONAL( XPK_CHOICE( XPK_LITERAL("extends"), XPK_LITERAL("isa") ), XPK_PACKAGENAME, XPK_VSTRING_OPT ), /* This should really a repeated (tagged?) choice of a number of things, but * right now there's only one thing permitted here anyway */ XPK_REPEATED( XPK_CHOICE( XPK_LITERAL("implements"), XPK_LITERAL("does") ), XPK_COMMALIST( XPK_PACKAGENAME, XPK_VSTRING_OPT ) ), XPK_ATTRIBUTES, {0} }; static const struct XSParseKeywordHooks kwhooks_class = { .permit_hintkey = "Object::Pad/class", .pieces = pieces_classlike, .build = &build_classlike, }; static const struct XSParseKeywordHooks kwhooks_role = { .permit_hintkey = "Object::Pad/role", .pieces = pieces_classlike, .build = &build_classlike, }; static void check_has(pTHX_ void *hookdata) { if(!have_compclassmeta) croak("Cannot 'has' outside of 'class'"); if(compclassmeta->role_is_invokable) croak("Cannot add field data to an invokable role"); if(!sv_eq(PL_curstname, compclassmeta->name)) croak("Current package name no longer matches current class (%" SVf " vs %" SVf ")", PL_curstname, compclassmeta->name); } static int build_has(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata) { int argi = 0; SV *name = args[argi++]->sv; char sigil = SvPV_nolen(name)[0]; FieldMeta *fieldmeta = mop_class_add_field(compclassmeta, name); SvREFCNT_dec(name); int nattrs = args[argi++]->i; if(nattrs) { SV *fieldmetasv = newSV(0); sv_setref_uv(fieldmetasv, "Object::Pad::MOP::Field", PTR2UV(fieldmeta)); SAVEFREESV(fieldmetasv); while(argi < (nattrs+2)) { SV *attrname = args[argi]->attr.name; SV *attrval = args[argi]->attr.value; inplace_trim_whitespace(attrval); mop_field_apply_attribute(fieldmeta, SvPVX(attrname), attrval); if(attrval) SvREFCNT_dec(attrval); argi++; } } /* It would be nice to just yield some OP to represent the has field here * and let normal parsing of normal scalar assignment accept it. But we can't * because scalar assignment tries to peephole far too deply into us and * everything breaks... :/ */ switch(args[argi++]->i) { case -1: /* no expr */ break; case 0: { OP *op = args[argi++]->op; SV *defaultsv = newSV(0); mop_field_set_default_sv(fieldmeta, defaultsv); /* An OP_CONST whose op_type is OP_CUSTOM. * This way we avoid the opchecker and finalizer doing bad things to our * defaultsv SV by setting it SvREADONLY_on(). */ OP *fieldop = newSVOP_CUSTOM(PL_ppaddr[OP_CONST], 0, SvREFCNT_inc(defaultsv)); OP *lhs, *rhs; switch(sigil) { case '$': *out = newBINOP(OP_SASSIGN, 0, op_contextualize(op, G_SCALAR), fieldop); break; case '@': sv_setrv_noinc(defaultsv, (SV *)newAV()); lhs = newUNOP(OP_RV2AV, OPf_MOD|OPf_REF, fieldop); goto field_array_hash_common; case '%': sv_setrv_noinc(defaultsv, (SV *)newHV()); lhs = newUNOP(OP_RV2HV, OPf_MOD|OPf_REF, fieldop); goto field_array_hash_common; field_array_hash_common: rhs = op_contextualize(op, G_LIST); *out = newBINOP(OP_AASSIGN, 0, force_list_keeping_pushmark(rhs), force_list_keeping_pushmark(lhs)); break; } } break; case 1: { OP *op = args[argi++]->op; U8 want = 0; forbid_outofblock_ops(op, "a field initialiser block"); switch(sigil) { case '$': want = G_SCALAR; break; case '@': case '%': want = G_LIST; break; } fieldmeta->defaultexpr = op_contextualize(op_scope(op), want); } break; } mop_field_seal(fieldmeta); return KEYWORD_PLUGIN_STMT; } static void setup_parse_has_initexpr(pTHX_ void *hookdata) { CV *was_compcv = PL_compcv; resume_compcv_and_save(&compclassmeta->initfields_compcv); /* Set up this new block as if the current compiler context were its scope */ if(CvOUTSIDE(PL_compcv)) SvREFCNT_dec(CvOUTSIDE(PL_compcv)); CvOUTSIDE(PL_compcv) = (CV *)SvREFCNT_inc(was_compcv); CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax; } static const struct XSParseKeywordHooks kwhooks_has = { .flags = XPK_FLAG_STMT|XPK_FLAG_AUTOSEMI, .permit_hintkey = "Object::Pad/has", .check = &check_has, .pieces = (const struct XSParseKeywordPieceType []){ XPK_LEXVARNAME(XPK_LEXVAR_ANY), XPK_ATTRIBUTES, XPK_CHOICE( XPK_SEQUENCE(XPK_EQUALS, XPK_TERMEXPR), XPK_PREFIXED_BLOCK_ENTERLEAVE(XPK_SETUP(&setup_parse_has_initexpr)), {0} ), {0} }, .build = &build_has, }; /* We use the method-like keyword parser to parse phaser blocks as well as * methods. In order to tell what is going on, hookdata will be an integer * set to one of the following */ enum PhaserType { PHASER_NONE, /* A normal `method`; i.e. not a phaser */ PHASER_BUILD, PHASER_ADJUST, PHASER_ADJUSTPARAMS, }; static const char *phasertypename[] = { [PHASER_BUILD] = "BUILD", [PHASER_ADJUST] = "ADJUST", [PHASER_ADJUSTPARAMS] = "ADJUSTPARAMS", }; static bool parse_permit(pTHX_ void *hookdata) { if(!have_compclassmeta) croak("Cannot 'method' outside of 'class'"); if(!sv_eq(PL_curstname, compclassmeta->name)) croak("Current package name no longer matches current class (%" SVf " vs %" SVf ")", PL_curstname, compclassmeta->name); return true; } static void parse_pre_subparse(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata) { enum PhaserType type = PTR2UV(hookdata); U32 i; AV *fields = compclassmeta->direct_fields; U32 nfields = av_count(fields); /* XS::Parse::Sublike doesn't support lexical `method $foo`, but we can hack * it up here */ if(type == PHASER_NONE && !ctx->name && lex_peek_unichar(0) == '$') { ctx->name = lex_scan_lexvar(); if(!ctx->name) croak("Expected a lexical variable name"); lex_read_space(0); hv_stores(ctx->moddata, "Object::Pad/method_varname", SvREFCNT_inc(ctx->name)); /* XPS should set a CV name */ ctx->actions |= XS_PARSE_SUBLIKE_ACTION_SET_CVNAME; /* XPS should not CVf_ANON, install a named symbol, or emit an anoncode expr */ ctx->actions &= ~(XS_PARSE_SUBLIKE_ACTION_CVf_ANON|XS_PARSE_SUBLIKE_ACTION_INSTALL_SYMBOL|XS_PARSE_SUBLIKE_ACTION_REFGEN_ANONCODE|XS_PARSE_SUBLIKE_ACTION_RET_EXPR); } switch(type) { case PHASER_NONE: if(ctx->name && strEQ(SvPVX(ctx->name), "BUILD")) croak("method BUILD is no longer supported; use a BUILD block instead"); break; case PHASER_BUILD: case PHASER_ADJUST: case PHASER_ADJUSTPARAMS: break; } if(type != PHASER_NONE) /* We need to fool start_subparse() into thinking this is a named function * so it emits a real CV and not a protosub */ ctx->actions &= ~XS_PARSE_SUBLIKE_ACTION_CVf_ANON; /* Save the methodscope for this subparse, in case of nested methods * (RT132321) */ SAVESPTR(compclassmeta->methodscope); /* While creating the new scope CV we need to ENTER a block so as not to * break any interpvars */ ENTER; SAVESPTR(PL_comppad); SAVESPTR(PL_comppad_name); SAVESPTR(PL_curpad); CV *methodscope = compclassmeta->methodscope = MUTABLE_CV(newSV_type(SVt_PVCV)); CvPADLIST(methodscope) = pad_new(padnew_SAVE); PL_comppad = PadlistARRAY(CvPADLIST(methodscope))[1]; PL_comppad_name = PadlistNAMES(CvPADLIST(methodscope)); PL_curpad = AvARRAY(PL_comppad); for(i = 0; i < nfields; i++) { FieldMeta *fieldmeta = (FieldMeta *)AvARRAY(fields)[i]; /* Skip the anonymous ones */ if(SvCUR(fieldmeta->name) < 2) continue; /* Claim these are all STATE variables just to quiet the "will not stay * shared" warning */ pad_add_name_sv(fieldmeta->name, padadd_STATE, NULL, NULL); } intro_my(); LEAVE; } static bool parse_filter_attr(pTHX_ struct XSParseSublikeContext *ctx, SV *attr, SV *val, void *hookdata) { struct AttributeDefinition *def; for(def = method_attributes; def->attrname; def++) { if(!strEQ(SvPVX(attr), def->attrname)) continue; /* TODO: We might want to wrap the CV in some sort of MethodMeta struct * but for now we'll just pass the XSParseSublikeContext context */ (*def->apply)(aTHX_ ctx, SvPOK(val) ? SvPVX(val) : NULL, def->applydata); return true; } /* No error, just let it fall back to usual attribute handling */ return false; } static void parse_post_blockstart(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata) { /* Splice in the field scope CV in */ CV *methodscope = compclassmeta->methodscope; if(CvANON(PL_compcv)) CvANON_on(methodscope); CvOUTSIDE (methodscope) = CvOUTSIDE (PL_compcv); CvOUTSIDE_SEQ(methodscope) = CvOUTSIDE_SEQ(PL_compcv); CvOUTSIDE(PL_compcv) = methodscope; extend_pad_vars(compclassmeta); if(compclassmeta->type == METATYPE_ROLE) { PAD *pad1 = PadlistARRAY(CvPADLIST(PL_compcv))[1]; if(compclassmeta->role_is_invokable) { SV *sv = PadARRAY(pad1)[PADIX_EMBEDDING]; sv_setpvn(sv, "", 0); SvPVX(sv) = (void *)&embedding_standalone; } else { SvREFCNT_dec(PadARRAY(pad1)[PADIX_EMBEDDING]); PadARRAY(pad1)[PADIX_EMBEDDING] = &PL_sv_undef; } } intro_my(); } static void parse_pre_blockend(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata) { enum PhaserType type = PTR2UV(hookdata); PADNAMELIST *fieldnames = PadlistNAMES(CvPADLIST(compclassmeta->methodscope)); I32 nfields = av_count(compclassmeta->direct_fields); PADNAME **snames = PadnamelistARRAY(fieldnames); PADNAME **padnames = PadnamelistARRAY(PadlistNAMES(CvPADLIST(PL_compcv))); OP *fieldops = NULL; /* If we have no ctx->body that means this was a bodyless method * declaration; a required method for a role */ if(ctx->body) { #if HAVE_PERL_VERSION(5, 22, 0) U32 cop_seq_low = COP_SEQ_RANGE_LOW(padnames[PADIX_SELF]); #endif { ENTER; SAVEVPTR(PL_curcop); /* See https://rt.cpan.org/Ticket/Display.html?id=132428 * https://github.com/Perl/perl5/issues/17754 */ PADOFFSET padix; for(padix = PADIX_SELF + 1; padix <= PadnamelistMAX(PadlistNAMES(CvPADLIST(PL_compcv))); padix++) { PADNAME *pn = padnames[padix]; if(PadnameIsNULL(pn) || !PadnameLEN(pn)) continue; const char *pv = PadnamePV(pn); if(!pv || !strEQ(pv, "$self")) continue; COP *padcop = NULL; if(find_cop_for_lvintro(padix, ctx->body, &padcop)) PL_curcop = padcop; warn("\"my\" variable $self masks earlier declaration in same scope"); } LEAVE; } fieldops = op_append_list(OP_LINESEQ, fieldops, newSTATEOP(0, NULL, NULL)); fieldops = op_append_list(OP_LINESEQ, fieldops, newMETHSTARTOP(0 | (compclassmeta->type == METATYPE_ROLE ? OPf_SPECIAL : 0) | (compclassmeta->repr << 8))); int i; for(i = 0; i < nfields; i++) { FieldMeta *fieldmeta = (FieldMeta *)AvARRAY(compclassmeta->direct_fields)[i]; PADNAME *fieldname = snames[i + 1]; if(!fieldname #if HAVE_PERL_VERSION(5, 22, 0) /* On perl 5.22 and above we can use PadnameREFCNT to detect which pad * slots are actually being used */ || PadnameREFCNT(fieldname) < 2 #endif ) continue; FIELDOFFSET fieldix = fieldmeta->fieldix; PADOFFSET padix = find_padix_for_field(fieldmeta); if(padix == NOT_IN_PAD) continue; U8 private = 0; switch(SvPV_nolen(fieldmeta->name)[0]) { case '$': private = OPpFIELDPAD_SV; break; case '@': private = OPpFIELDPAD_AV; break; case '%': private = OPpFIELDPAD_HV; break; } fieldops = op_append_list(OP_LINESEQ, fieldops, /* alias the padix from the field */ newFIELDPADOP(private << 8, padix, fieldix)); #if HAVE_PERL_VERSION(5, 22, 0) /* Unshare the padname so the one in the methodscope pad returns to refcount 1 */ PADNAME *newpadname = newPADNAMEpvn(PadnamePV(fieldname), PadnameLEN(fieldname)); PadnameREFCNT_dec(padnames[padix]); padnames[padix] = newpadname; /* Turn off OUTER and set a valid COP sequence range, so the lexical is * visible to eval(), PadWalker, perldb, etc.. */ PadnameOUTER_off(newpadname); COP_SEQ_RANGE_LOW(newpadname) = cop_seq_low; COP_SEQ_RANGE_HIGH(newpadname) = PL_cop_seqmax; #endif } ctx->body = op_append_list(OP_LINESEQ, fieldops, ctx->body); } compclassmeta->methodscope = NULL; /* Restore CvOUTSIDE(PL_compcv) back to where it should be */ { CV *outside = CvOUTSIDE(PL_compcv); PADNAMELIST *pnl = PadlistNAMES(CvPADLIST(PL_compcv)); PADNAMELIST *outside_pnl = PadlistNAMES(CvPADLIST(outside)); /* Lexical captures will need their parent pad index fixing * Technically these only matter for CvANON because they're only used when * reconstructing the parent pad captures by OP_ANONCODE. But we might as * well be polite and fix them for all CVs */ PADOFFSET padix; for(padix = 1; padix <= PadnamelistMAX(pnl); padix++) { PADNAME *pn = PadnamelistARRAY(pnl)[padix]; if(PadnameIsNULL(pn) || !PadnameOUTER(pn) || !PARENT_PAD_INDEX(pn)) continue; PADNAME *outside_pn = PadnamelistARRAY(outside_pnl)[PARENT_PAD_INDEX(pn)]; PARENT_PAD_INDEX_set(pn, PARENT_PAD_INDEX(outside_pn)); if(!PadnameOUTER(outside_pn)) PadnameOUTER_off(pn); } CvOUTSIDE(PL_compcv) = CvOUTSIDE(outside); CvOUTSIDE_SEQ(PL_compcv) = CvOUTSIDE_SEQ(outside); } if(type != PHASER_NONE) /* We need to remove the name now to stop newATTRSUB() from creating this * as a named symbol table entry */ ctx->actions &= ~XS_PARSE_SUBLIKE_ACTION_INSTALL_SYMBOL; } static void parse_post_newcv(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata) { enum PhaserType type = PTR2UV(hookdata); if(ctx->cv) CvMETHOD_on(ctx->cv); if(!ctx->cv) { /* This is a required method declaration for a role */ /* TODO: This was a pretty rubbish way to detect that. We should remember it * more reliably */ /* This already checks and complains if meta->type != METATYPE_ROLE */ mop_class_add_required_method(compclassmeta, ctx->name); return; } switch(type) { case PHASER_NONE: if(ctx->cv && ctx->name && (ctx->actions & XS_PARSE_SUBLIKE_ACTION_INSTALL_SYMBOL)) mop_class_add_method(compclassmeta, ctx->name); break; case PHASER_BUILD: mop_class_add_BUILD(compclassmeta, ctx->cv); /* steal CV */ break; case PHASER_ADJUST: mop_class_add_ADJUST(compclassmeta, ctx->cv); /* steal CV */ break; case PHASER_ADJUSTPARAMS: mop_class_add_ADJUSTPARAMS(compclassmeta, ctx->cv); /* steal CV */ break; } SV **varnamep; if((varnamep = hv_fetchs(ctx->moddata, "Object::Pad/method_varname", 0))) { PADOFFSET padix = pad_add_name_sv(*varnamep, 0, NULL, NULL); intro_my(); SV **svp = &PAD_SVl(padix); if(*svp) SvREFCNT_dec(*svp); *svp = newRV_inc((SV *)ctx->cv); SvREADONLY_on(*svp); } if(type != PHASER_NONE) /* Do not generate REFGEN/ANONCODE optree, do not yield expression */ ctx->actions &= ~(XS_PARSE_SUBLIKE_ACTION_REFGEN_ANONCODE|XS_PARSE_SUBLIKE_ACTION_RET_EXPR); } static struct XSParseSublikeHooks parse_method_hooks = { .flags = XS_PARSE_SUBLIKE_FLAG_FILTERATTRS | XS_PARSE_SUBLIKE_COMPAT_FLAG_DYNAMIC_ACTIONS | XS_PARSE_SUBLIKE_FLAG_BODY_OPTIONAL, .permit_hintkey = "Object::Pad/method", .permit = parse_permit, .pre_subparse = parse_pre_subparse, .filter_attr = parse_filter_attr, .post_blockstart = parse_post_blockstart, .pre_blockend = parse_pre_blockend, .post_newcv = parse_post_newcv, }; static struct XSParseSublikeHooks parse_phaser_hooks = { .flags = XS_PARSE_SUBLIKE_COMPAT_FLAG_DYNAMIC_ACTIONS, .skip_parts = XS_PARSE_SUBLIKE_PART_NAME|XS_PARSE_SUBLIKE_PART_ATTRS, /* no permit */ .pre_subparse = parse_pre_subparse, .post_blockstart = parse_post_blockstart, .pre_blockend = parse_pre_blockend, .post_newcv = parse_post_newcv, }; static int parse_phaser(pTHX_ OP **out, void *hookdata) { if(!have_compclassmeta) croak("Cannot '%s' outside of 'class'", phasertypename[PTR2UV(hookdata)]); lex_read_space(0); return xs_parse_sublike(&parse_phaser_hooks, hookdata, out); } static const struct XSParseKeywordHooks kwhooks_phaser = { .permit_hintkey = "Object::Pad/method", .parse = &parse_phaser, }; static void check_requires(pTHX_ void *hookdata) { if(!have_compclassmeta) croak("Cannot 'requires' outside of 'role'"); if(compclassmeta->type == METATYPE_CLASS) croak("A class may not declare required methods"); } static int build_requires(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata) { SV *mname = args[0]->sv; mop_class_add_required_method(compclassmeta, mname); *out = newOP(OP_NULL, 0); return KEYWORD_PLUGIN_STMT; } static const struct XSParseKeywordHooks kwhooks_requires = { .flags = XPK_FLAG_STMT|XPK_FLAG_AUTOSEMI, .permit_hintkey = "Object::Pad/requires", .check = &check_requires, .pieces = (const struct XSParseKeywordPieceType []){ XPK_IDENT, {0} }, .build = &build_requires, }; #ifdef HAVE_DMD_HELPER static int dump_fieldmeta(pTHX_ const SV *sv, FieldMeta *fieldmeta) { int ret = 0; /* Some trickery to generate dynamic labels */ const char *name = SvPVX(fieldmeta->name); SV *label = newSV(0); sv_setpvf(label, "the Object::Pad field %s name", name); ret += DMD_ANNOTATE_SV(sv, fieldmeta->name, SvPVX(label)); sv_setpvf(label, "the Object::Pad field %s default value", name); ret += DMD_ANNOTATE_SV(sv, mop_field_get_default_sv(fieldmeta), SvPVX(label)); SvREFCNT_dec(label); return ret; } static int dumppackage_class(pTHX_ const SV *sv) { int ret = 0; ClassMeta *meta = NUM2PTR(ClassMeta *, SvUV((SV *)sv)); ret += DMD_ANNOTATE_SV(sv, meta->name, "the Object::Pad class name"); ret += DMD_ANNOTATE_SV(sv, (SV *)meta->stash, "the Object::Pad stash"); if(meta->pending_submeta) ret += DMD_ANNOTATE_SV(sv, (SV *)meta->pending_submeta, "the Object::Pad pending submeta AV"); I32 i; for(i = 0; i < av_count(meta->direct_fields); i++) ret += dump_fieldmeta(aTHX_ sv, (FieldMeta *)AvARRAY(meta->direct_fields)[i]); ret += DMD_ANNOTATE_SV(sv, (SV *)meta->initfields, "the Object::Pad initfields CV"); ret += DMD_ANNOTATE_SV(sv, (SV *)meta->buildblocks, "the Object::Pad BUILD blocks AV"); ret += DMD_ANNOTATE_SV(sv, (SV *)meta->adjustblocks, "the Object::Pad ADJUST blocks AV"); ret += DMD_ANNOTATE_SV(sv, (SV *)meta->methodscope, "the Object::Pad temporary method scope"); switch(meta->type) { case METATYPE_CLASS: if(meta->cls.foreign_new) ret += DMD_ANNOTATE_SV(sv, (SV *)meta->cls.foreign_new, "the Object::Pad foreign superclass constructor CV"); if(meta->cls.direct_roles) ret += DMD_ANNOTATE_SV(sv, (SV *)meta->cls.direct_roles, "the Object::Pad direct roles AV"); break; case METATYPE_ROLE: ret += DMD_ANNOTATE_SV(sv, (SV *)meta->role.applied_classes, "the Object::Pad role applied classes HV"); break; } return ret; } #endif /********************* * Custom FieldHooks * *********************/ struct CustomFieldHookData { SV *apply_cb; }; static bool fieldhook_custom_apply(pTHX_ FieldMeta *fieldmeta, SV *value, SV **hookdata_ptr, void *_funcdata) { struct CustomFieldHookData *funcdata = _funcdata; SV *cb; if((cb = funcdata->apply_cb)) { dSP; ENTER; SAVETMPS; SV *fieldmetasv = sv_newmortal(); sv_setref_uv(fieldmetasv, "Object::Pad::MOP::Field", PTR2UV(fieldmeta)); PUSHMARK(SP); EXTEND(SP, 2); PUSHs(fieldmetasv); PUSHs(value); PUTBACK; call_sv(cb, G_SCALAR); SPAGAIN; SV *ret = POPs; *hookdata_ptr = SvREFCNT_inc(ret); FREETMPS; LEAVE; } return TRUE; } MODULE = Object::Pad PACKAGE = Object::Pad::MOP::Class INCLUDE: mop-class.xsi MODULE = Object::Pad PACKAGE = Object::Pad::MOP::Method INCLUDE: mop-method.xsi MODULE = Object::Pad PACKAGE = Object::Pad::MOP::Field INCLUDE: mop-field.xsi MODULE = Object::Pad PACKAGE = Object::Pad::MOP::FieldAttr void register(class, name, ...) SV *class SV *name CODE: { PERL_UNUSED_VAR(class); dKWARG(2); struct FieldHookFuncs *funcs; Newxz(funcs, 1, struct FieldHookFuncs); struct CustomFieldHookData *funcdata; Newxz(funcdata, 1, struct CustomFieldHookData); funcs->ver = OBJECTPAD_ABIVERSION; funcs->apply = &fieldhook_custom_apply; static const char *args[] = { "permit_hintkey", "apply", NULL, }; while(KWARG_NEXT(args)) { switch(kwarg) { case 0: /* permit_hintkey */ funcs->permit_hintkey = savepv(SvPV_nolen(kwval)); break; case 1: /* apply */ funcdata->apply_cb = newSVsv(kwval); break; } } register_field_attribute(savepv(SvPV_nolen(name)), funcs, funcdata); } BOOT: XopENTRY_set(&xop_methstart, xop_name, "methstart"); XopENTRY_set(&xop_methstart, xop_desc, "methstart()"); XopENTRY_set(&xop_methstart, xop_class, OA_BASEOP); Perl_custom_op_register(aTHX_ &pp_methstart, &xop_methstart); XopENTRY_set(&xop_fieldpad, xop_name, "fieldpad"); XopENTRY_set(&xop_fieldpad, xop_desc, "fieldpad()"); #ifdef HAVE_UNOP_AUX XopENTRY_set(&xop_fieldpad, xop_class, OA_UNOP_AUX); #else XopENTRY_set(&xop_fieldpad, xop_class, OA_UNOP); /* technically a lie */ #endif Perl_custom_op_register(aTHX_ &pp_fieldpad, &xop_fieldpad); CvLVALUE_on(get_cv("Object::Pad::MOP::Field::value", 0)); #ifdef HAVE_DMD_HELPER DMD_SET_PACKAGE_HELPER("Object::Pad::MOP::Class", &dumppackage_class); #endif boot_xs_parse_keyword(0.10); /* XPK_OPTIONAL(XPK_CHOICE...) */ register_xs_parse_keyword("class", &kwhooks_class, (void *)METATYPE_CLASS); register_xs_parse_keyword("role", &kwhooks_role, (void *)METATYPE_ROLE); register_xs_parse_keyword("has", &kwhooks_has, NULL); register_xs_parse_keyword("BUILD", &kwhooks_phaser, (void *)PHASER_BUILD); register_xs_parse_keyword("ADJUST", &kwhooks_phaser, (void *)PHASER_ADJUST); register_xs_parse_keyword("ADJUSTPARAMS", &kwhooks_phaser, (void *)PHASER_ADJUSTPARAMS); register_xs_parse_keyword("requires", &kwhooks_requires, NULL); boot_xs_parse_sublike(0.15); /* dymamic actions */ register_xs_parse_sublike("method", &parse_method_hooks, (void *)PHASER_NONE); ObjectPad__boot_classes(); ObjectPad__boot_fields(aTHX); Object-Pad-0.61/lib/Object/mop-class.xsi000444001750001750 2402214203242261 16641 0ustar00leoleo000000000000 SV * _create_class(pkg, name, ...) SV *pkg SV *name ALIAS: _create_class = METATYPE_CLASS _create_role = METATYPE_ROLE CODE: { PERL_UNUSED_ARG(pkg); dKWARG(2); SV *superclassname = NULL; bool set_compclassmeta = false; static const char *args[] = { "extends", "isa", "_set_compclassmeta", NULL }; while(KWARG_NEXT(args)) { switch(kwarg) { case 0: /* extends */ case 1: /* isa */ if(ix != METATYPE_CLASS) croak("Only a class may extend another"); superclassname = sv_mortalcopy(kwval); break; case 2: /* _set_compclassmeta */ set_compclassmeta = SvTRUE(kwval); break; } } ClassMeta *meta = mop_create_class(ix, name); if(superclassname && SvOK(superclassname)) mop_class_set_superclass(meta, superclassname); mop_class_begin(meta); RETVAL = newSV(0); sv_setref_uv(RETVAL, "Object::Pad::MOP::Class", PTR2UV(meta)); if(set_compclassmeta) { compclassmeta_set(meta); CV *cv = newXS(NULL, &xsub_mop_class_seal, __FILE__); CvXSUBANY(cv).any_ptr = meta; if(!PL_unitcheckav) PL_unitcheckav = newAV(); av_push(PL_unitcheckav, (SV *)cv); } } OUTPUT: RETVAL bool is_class(self) SV *self ALIAS: is_class = METATYPE_CLASS is_role = METATYPE_ROLE CODE: { ClassMeta *meta = NUM2PTR(ClassMeta *, SvUV(SvRV(self))); RETVAL = (meta->type == ix); } OUTPUT: RETVAL SV * name(self) SV *self CODE: { ClassMeta *meta = NUM2PTR(ClassMeta *, SvUV(SvRV(self))); RETVAL = SvREFCNT_inc(meta->name); } OUTPUT: RETVAL void superclasses(self) SV *self PPCODE: { ClassMeta *meta = NUM2PTR(ClassMeta *, SvUV(SvRV(self))); if(meta->type == METATYPE_CLASS && meta->cls.supermeta) { PUSHs(sv_newmortal()); sv_setref_uv(ST(0), "Object::Pad::MOP::Class", PTR2UV(meta->cls.supermeta)); XSRETURN(1); } XSRETURN(0); } void direct_roles(self) SV *self ALIAS: direct_roles = 0 all_roles = 1 PPCODE: { ClassMeta *meta = NUM2PTR(ClassMeta *, SvUV(SvRV(self))); U32 count = 0; /* TODO Consider recursion */ U32 i; switch(meta->type) { case METATYPE_CLASS: { U32 nroles; RoleEmbedding **embeddings = NULL; switch(ix) { case 0: embeddings = mop_class_get_direct_roles(meta, &nroles); break; case 1: embeddings = mop_class_get_all_roles(meta, &nroles); break; } for(i = 0; i < nroles; i++) { SV *sv = sv_newmortal(); sv_setref_uv(sv, "Object::Pad::MOP::Class", PTR2UV(embeddings[i]->rolemeta)); XPUSHs(sv); count++; } break; } case METATYPE_ROLE: break; } XSRETURN(count); } void add_role(self, role) SV *self SV *role ALIAS: compose_role = 0 CODE: { ClassMeta *meta = NUM2PTR(ClassMeta *, SvUV(SvRV(self))); ClassMeta *rolemeta = NULL; PERL_UNUSED_VAR(ix); if(SvROK(role)) { if(!sv_derived_from(role, "Object::Pad::MOP::Class")) croak("Expected a role name string or Object::Pad::MOP::Class; got %" SVf, SVfARG(role)); rolemeta = NUM2PTR(ClassMeta *, SvUV(SvRV(role))); } else { HV *rolestash = gv_stashsv(role, 0); /* Don't attempt to `require` it; that is caller's responsibilty */ if(!rolestash) croak("Role %" SVf " does not exist", SVfARG(role)); GV **metagvp = (GV **)hv_fetchs(rolestash, "META", 0); if(metagvp) rolemeta = NUM2PTR(ClassMeta *, SvUV(SvRV(GvSV(*metagvp)))); } if(!rolemeta || rolemeta->type != METATYPE_ROLE) croak("%" SVf " is not a role", SVfARG(role)); mop_class_add_role(meta, rolemeta); } void add_BUILD(self, code) SV *self CV *code CODE: { ClassMeta *meta = NUM2PTR(ClassMeta *, SvUV(SvRV(self))); mop_class_add_BUILD(meta, (CV *)SvREFCNT_inc((SV *)code)); } SV * add_method(self, mname, code) SV *self SV *mname CV *code CODE: { /* Take a copy now to run FETCH magic */ mname = sv_2mortal(newSVsv(mname)); ClassMeta *meta = NUM2PTR(ClassMeta *, SvUV(SvRV(self))); if(SvOK(mname) && SvPOK(mname) && strEQ(SvPVX(mname), "BUILD")) { croak("Adding a method called BUILD is not supported; use ->add_BUILD directly"); } MethodMeta *methodmeta = mop_class_add_method(meta, mname); I32 klen = SvCUR(mname); if(SvUTF8(mname)) klen = -klen; GV **gvp = (GV **)hv_fetch(meta->stash, SvPVX(mname), klen, GV_ADD); gv_init_sv(*gvp, meta->stash, mname, 0); GvMULTI_on(*gvp); GvCV_set(*gvp, (CV *)SvREFCNT_inc(code)); RETVAL = newSV(0); sv_setref_uv(RETVAL, "Object::Pad::MOP::Method", PTR2UV(methodmeta)); } OUTPUT: RETVAL void get_direct_method(self, methodname) SV *self SV *methodname ALIAS: get_method = 1 PPCODE: { ClassMeta *meta = NUM2PTR(ClassMeta *, SvUV(SvRV(self))); bool recurse = !!ix; do { AV *methods = meta->direct_methods; U32 nmethods = av_count(methods); U32 i; for(i = 0; i < nmethods; i++) { MethodMeta *methodmeta = (MethodMeta *)AvARRAY(methods)[i]; if(!sv_eq(methodmeta->name, methodname)) continue; ST(0) = sv_newmortal(); sv_setref_iv(ST(0), "Object::Pad::MOP::Method", PTR2UV(methodmeta)); XSRETURN(1); } if(meta->type == METATYPE_CLASS) meta = meta->cls.supermeta; else meta = NULL; } while(recurse && meta); croak("Class %" SVf " does not have a method called '%" SVf "'", meta->name, methodname); } void direct_methods(self) SV *self ALIAS: all_methods = 1 PPCODE: ClassMeta *meta = NUM2PTR(ClassMeta *, SvUV(SvRV(self))); bool recurse = !!ix; /* A hash to remove overrides */ HV *mnames = NULL; if(recurse) { mnames = newHV(); SAVEFREESV(mnames); } U32 retcount = 0; do { AV *methods = meta->direct_methods; U32 nmethods = av_count(methods); EXTEND(SP, retcount + nmethods); /* might be an overestimate but don't worry */ U32 i; for(i = 0; i < nmethods; i++) { MethodMeta *methodmeta = (MethodMeta *)AvARRAY(methods)[i]; if(mnames && hv_exists_ent(mnames, methodmeta->name, 0)) continue; ST(retcount) = sv_newmortal(); sv_setref_iv(ST(retcount), "Object::Pad::MOP::Method", PTR2UV(methodmeta)); retcount++; hv_store_ent(mnames, methodmeta->name, &PL_sv_yes, 0); } if(meta->type == METATYPE_CLASS) meta = meta->cls.supermeta; else meta = NULL; } while(recurse && meta); XSRETURN(retcount); void add_required_method(self, mname) SV *self SV *mname CODE: { ClassMeta *meta = NUM2PTR(ClassMeta *, SvUV(SvRV(self))); mop_class_add_required_method(meta, mname); } SV * add_field(self, fieldname, ...) SV *self SV *fieldname CODE: { dKWARG(2); ClassMeta *meta = NUM2PTR(ClassMeta *, SvUV(SvRV(self))); FieldMeta *fieldmeta = mop_class_add_field(meta, sv_mortalcopy(fieldname)); static const char *args[] = { "default", "param", "reader", "writer", "mutator", "accessor", "weak", NULL, }; while(KWARG_NEXT(args)) { switch(kwarg) { case 0: /* default */ if(fieldmeta->defaultsv) SvREFCNT_dec(fieldmeta->defaultsv); fieldmeta->defaultsv = newSVsv(kwval); break; case 1: /* param */ mop_field_apply_attribute(fieldmeta, "param", kwval); break; case 2: /* reader */ mop_field_apply_attribute(fieldmeta, "reader", kwval); break; case 3: /* writer */ mop_field_apply_attribute(fieldmeta, "writer", kwval); break; case 4: /* mutator */ mop_field_apply_attribute(fieldmeta, "mutator", kwval); break; case 5: /* accessor */ mop_field_apply_attribute(fieldmeta, "accessor", kwval); break; case 6: /* weak */ mop_field_apply_attribute(fieldmeta, "weak", NULL); break; } } mop_field_seal(fieldmeta); RETVAL = newSV(0); sv_setref_uv(RETVAL, "Object::Pad::MOP::Field", PTR2UV(fieldmeta)); } OUTPUT: RETVAL void get_field(self, fieldname) SV *self SV *fieldname PPCODE: { ClassMeta *meta = NUM2PTR(ClassMeta *, SvUV(SvRV(self))); AV *fields = meta->direct_fields; U32 nfields = av_count(fields); FIELDOFFSET i; for(i = 0; i < nfields; i++) { FieldMeta *fieldmeta = (FieldMeta *)AvARRAY(fields)[i]; if(!sv_eq(fieldmeta->name, fieldname)) continue; ST(0) = sv_newmortal(); sv_setref_iv(ST(0), "Object::Pad::MOP::Field", PTR2UV(fieldmeta)); XSRETURN(1); } croak("Class %" SVf " does not have a field called '%" SVf "'", meta->name, fieldname); } void fields(self) SV *self PPCODE: ClassMeta *meta = NUM2PTR(ClassMeta *, SvUV(SvRV(self))); AV *fields = meta->direct_fields; U32 nfields = av_count(fields); EXTEND(SP, nfields); FIELDOFFSET i; for(i = 0; i < nfields; i++) { FieldMeta *fieldmeta = (FieldMeta *)AvARRAY(fields)[i]; ST(i) = sv_newmortal(); sv_setref_iv(ST(i), "Object::Pad::MOP::Field", PTR2UV(fieldmeta)); } XSRETURN(nfields); void required_method_names(self) SV *self PPCODE: ClassMeta *meta = NUM2PTR(ClassMeta *, SvUV(SvRV(self))); if(meta->type != METATYPE_ROLE) croak("Can only call ->required_method_names on a metaclass for a role"); AV *required_methods = meta->requiremethods; U32 nmethods = av_count(required_methods); EXTEND(SP, nmethods); int i; for(i = 0; i < nmethods; i++) { ST(i) = sv_2mortal(newSVsv(AvARRAY(required_methods)[i])); } XSRETURN(nmethods); void seal(self) SV *self CODE: ClassMeta *meta = NUM2PTR(ClassMeta *, SvUV(SvRV(self))); mop_class_seal(meta); Object-Pad-0.61/lib/Object/mop-field.xsi000444001750001750 564014203242261 16604 0ustar00leoleo000000000000 SV * name(self) SV *self ALIAS: name = 0 sigil = 1 class = 2 CODE: { FieldMeta *meta = NUM2PTR(FieldMeta *, SvUV(SvRV(self))); switch(ix) { case 0: RETVAL = SvREFCNT_inc(meta->name); break; case 1: RETVAL = newSVpvn(SvPVX(meta->name), 1); break; case 2: RETVAL = newSV(0); sv_setref_uv(RETVAL, "Object::Pad::MOP::Class", PTR2UV(meta->class)); break; default: RETVAL = NULL; } } OUTPUT: RETVAL void value(self, obj) SV *self SV *obj PPCODE: { FieldMeta *meta = NUM2PTR(FieldMeta *, SvUV(SvRV(self))); ClassMeta *classmeta = meta->class; SV *objrv; if(!SvROK(obj) || !SvOBJECT(objrv = SvRV(obj))) croak("Cannot fetch field value of a non-instance"); AV *backingav; FIELDOFFSET fieldix; if(classmeta->type == METATYPE_ROLE) { HV *objstash = SvSTASH(objrv); const char *key = HvNAME(objstash); STRLEN klen = HvNAMELEN(objstash); if(HvNAMEUTF8(objstash)) klen = -klen; assert(key); SV **svp = hv_fetch(classmeta->role.applied_classes, key, klen, 0); if(!svp) croak("Cannot fetch role field value from a non-applied instance"); RoleEmbedding *embedding = (RoleEmbedding *)*svp; backingav = (AV *)get_obj_backingav(obj, embedding->classmeta->repr, true); fieldix = meta->fieldix + embedding->offset; } else { const char *stashname = HvNAME(classmeta->stash); if(!stashname || !sv_derived_from(obj, stashname)) croak("Cannot fetch field value from a non-derived instance"); backingav = (AV *)get_obj_backingav(obj, classmeta->repr, true); fieldix = meta->fieldix; } if(fieldix > av_top_index(backingav)) croak("ARGH: instance does not have a field at index %ld", (long int)fieldix); SV *value = AvARRAY(backingav)[fieldix]; /* We must prevent caller from assigning to non-scalar fields, in case * they break the SvTYPE of the value. We can't cancel the CvLVALUE but we * can yield a READONLY value in this case */ if(SvPV_nolen(meta->name)[0] != '$') { value = sv_mortalcopy(value); SvREADONLY_on(value); } /* stack does not contribute SvREFCNT */ ST(0) = value; XSRETURN(1); } bool has_attribute(self, name) SV *self SV *name CODE: { FieldMeta *meta = NUM2PTR(FieldMeta *, SvUV(SvRV(self))); const struct FieldHook *hook = mop_field_get_attribute(meta, SvPV_nolen(name)); RETVAL = !!hook; } OUTPUT: RETVAL SV * get_attribute_value(self, name) SV *self SV *name CODE: { FieldMeta *meta = NUM2PTR(FieldMeta *, SvUV(SvRV(self))); const struct FieldHook *hook = mop_field_get_attribute(meta, SvPV_nolen(name)); if(!hook) croak("Field does not have an attribute called %" SVf, SVfARG(name)); RETVAL = newSVsv(hook->hookdata); } OUTPUT: RETVAL Object-Pad-0.61/lib/Object/mop-method.xsi000444001750001750 63414203242261 16757 0ustar00leoleo000000000000 SV * name(self) SV *self ALIAS: name = 0 class = 1 CODE: { MethodMeta *meta = NUM2PTR(MethodMeta *, SvUV(SvRV(self))); switch(ix) { case 0: RETVAL = SvREFCNT_inc(meta->name); break; case 1: RETVAL = newSV(0); sv_setref_uv(RETVAL, "Object::Pad::MOP::Class", PTR2UV(meta->class)); break; default: RETVAL = NULL; } } OUTPUT: RETVAL Object-Pad-0.61/lib/Object/Pad000755001750001750 014203242261 14545 5ustar00leoleo000000000000Object-Pad-0.61/lib/Object/Pad/ExtensionBuilder.pm000444001750001750 437514203242261 20534 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2021 -- leonerd@leonerd.org.uk package Object::Pad::ExtensionBuilder 0.61; use v5.14; use warnings; =head1 NAME C - build-time support for extensions to C =head1 SYNOPSIS In F: use Object::Pad::ExtensionBuilder; my $build = Module::Build->new) ..., configure_requires => { 'Object::Pad::ExtensionBuilder' => 0, }, ); Object::Pad::ExtensionBuilder->extend_module_build( $build ); ... =head1 DESCRIPTION This module provides a build-time helper to assist authors writing XS modules that provide L extensions. It prepares a L-using distribution to be able to compile it. =cut require Object::Pad::ExtensionBuilder_data; =head1 METHODS =cut =head2 write_object_pad_h Object::Pad::ExtensionBuilder->write_object_pad_h Writes the F file to the current working directory. To cause the compiler to actually find this file, see L. =cut sub write_object_pad_h { shift; open my $out, ">", "object_pad.h" or die "Cannot open object_pad.h for writing - $!\n"; $out->print( Object::Pad::ExtensionBuilder_data->OBJECT_PAD_H ); } =head2 extra_compiler_flags @flags = Object::Pad::ExtensionBuilder->extra_compiler_flags Returns a list of extra flags that the build scripts should add to the compiler invocation. This enables the C compiler to find the F file. =cut sub extra_compiler_flags { shift; return "-I."; } =head2 extend_module_build Object::Pad::ExtensionBuilder->extend_module_build( $build ) A convenient shortcut for performing all the tasks necessary to make a L-based distribution use the helper. =cut sub extend_module_build { my $self = shift; my ( $build ) = @_; eval { $self->write_object_pad_h } or do { warn $@; return; }; # preserve existing flags my @flags = @{ $build->extra_compiler_flags }; push @flags, $self->extra_compiler_flags; $build->extra_compiler_flags( @flags ); } =head1 AUTHOR Paul Evans =cut 0x55AA; Object-Pad-0.61/lib/Object/Pad/ExtensionBuilder_data.pm.PL000444001750001750 132314203242261 22025 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2021 -- leonerd@leonerd.org.uk use v5.14; use warnings; open my $outh, ">", $ARGV[0] or die "Cannot write $ARGV[0] - $!\n"; local $/; $outh->print( scalar do { } ); $outh->print( scalar do { open my $in_h, "<", "include/object_pad.h" or die "Cannot open include/object_pad.h - $!"; <$in_h> } ); __DATA__ package Object::Pad::ExtensionBuilder_data 0.61; use v5.14; use warnings; # The contents of the "object_pad.h" file my $object_pad_h = do { local $/; readline DATA; }; sub OBJECT_PAD_H() { $object_pad_h } 0x55AA; __DATA__ Object-Pad-0.61/lib/Object/Pad/MOP000755001750001750 014203242261 15200 5ustar00leoleo000000000000Object-Pad-0.61/lib/Object/Pad/MOP/Class.pm000444001750001750 2463314203242261 16770 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2020-2022 -- leonerd@leonerd.org.uk package Object::Pad::MOP::Class 0.61; use v5.14; use warnings; use Carp; # This is an XS-implemented object type provided by Object::Pad itself require Object::Pad; =head1 NAME C - meta-object representation of a C class =head1 DESCRIPTION Instances of this class represent a class or role implemented by L. Accessors provide information about the class or role, and methods that can alter the class, typically by adding new elements to it, allow a program to extend existing classes. Where possible, this API is designed to be compatible with L. This API should be considered experimental even within the overall context in which C is expermental. =cut =head1 CONSTRUCTOR =head2 for_class $metaclass = Object::Pad::MOP::Class->for_class( $class ) I Returns the metaclass instance associated with the given class name. =cut sub for_class { shift; my ( $targetclass ) = @_; return $targetclass->META; } =head2 for_caller $metaclass = Object::Pad::MOP::Class->for_caller; I A convenient shortcut for obtaining the metaclass instance of the calling package scope. Often handy during C blocks of the class itself to perform adjustments or additions. class Some::Class::Here 1.234 { BEGIN { my $meta = Object::Pad::MOP::Class->for_caller; ... } } =cut sub for_caller { return shift->for_class( caller ); } =head2 create_class my $metaclass = Object::Pad::MOP::Class->create_class( $name, %args ) I Creates a new class of the given name and yields the metaclass for it. Takes the following additional named arguments: =over 4 =item extends => STRING =item isa => STRING An optional name of a superclass that this class will extend. These options are synonyms; new code should use C, as C will eventually be removed. =back Once created, this metaclass must be sealed using the L method before it can be used to actually construct object instances. =head2 create_role my $metaclass = Object::Pad::MOP::Class->create_role( $name, %args ) I As L but creates a role instead of a class. =cut sub create_class { shift->_create_class( shift, @_ ); } sub create_role { shift->_create_role ( shift, @_ ); } =head2 begin_class BEGIN { my $metaclass = Object::Pad::MOP::Class->begin_class( $name, %args ) ... } I A variant of L which sets the newly-created class as the current complication scope of the surrounding code, allowing it to accept C syntax forms such as C and C. This must be done during C time because of this compiletime effect. It additionally creates a deferred code block at C time of its surrounding scope, which is used to finalise the constructed class. In this case you do not need to remember to call L on it; this happens automatically. =head2 begin_role I As L but creates a role instead of a class. =cut sub begin_class { shift->_create_class( shift, _set_compclassmeta => 1, @_ ); } sub begin_role { shift->_create_role ( shift, _set_compclassmeta => 1, @_ ); } =head1 METHODS =head2 is_class =head2 is_role $bool = $metaclass->is_class $bool = $metaclass->is_role Exactly one of these methods will return true, depending on whether this metaclass instance represents a true C, or a C. =head2 name $name = $metaclass->name Returns the name of the class, as a plain string. =head2 superclasses @classes = $metaclass->superclasses Returns a list of superclasses, as L instances. Because C does not support multiple superclasses, this list will contain at most one item. =head2 direct_roles @roles = $metaclass->direct_roles Returns a list of the roles introduced by this class (i.e. added by `does` declarations but not inherited from the superclass), as L instances. This method is also aliased as C. =head2 all_roles @roles = $metaclass->all_roles I Returns a list of all the roles implemented by this class (i.e. including those inherited from the superclass), as L instances. =head2 add_role $metaclass->add_role( $rolename ) $metaclass->add_role( $rolemeta ) I Adds a new role to the list of those implemented by the class. The new role can be specified either as a plain string giving its name, or as an C meta instance directly. Before version 0.56 this was called C. =head2 add_BUILD $metaclass->add_BUILD( $code ) Adds a new C block to the class, as a CODE reference. =head2 add_method $metamethod = $metaclass->add_method( $name, $code ) Adds a new named method to the class under the given name, as CODE reference. Returns an instance of L to represent it. =head2 get_direct_method $metamethod = $metaclass->get_direct_method( $name ) Returns an instance of L to represent the method of the given name, if one exists. If not an exception is thrown. This can only see directly-applied methods; that is, methods created by the C keyword on the class itself, or added via L. This will not see other names in the package stash, even if they contain a C slot, nor will it see methods inherited from a superclass. This is also aliased as C for compatibility with the L interface. =head2 get_method $metamethod = $metaclass->get_method( $name ) I Returns an instance of L to represent the method of the given name, if one exists. If not an exception is thrown. This will additionally search superclasses, and may return a method belonging to a parent class. =head2 direct_methods @metamethods = $metaclass->direct_methods I Returns a list of L instances to represent all the direct methods of the class. This list may be empty. =head2 all_methods @metamethods = $metaclass->all_methods I Returns a list of L instances to represent all the methods of the class, including those inherited from superclasses. This list may be empty. =head2 add_field $metafield = $metaclass->add_field( $name, %args ) I Adds a new field to the class, using the given name (which must begin with the sigil character C<$>, C<@> or C<%>). Recognises the following additional named arguments: =over 4 =item default => SCALAR I Provides a default value for the field; similar to using the syntax has $field = SCALAR; This value may be C, to set the value as being optional if it additionally has a parameter name. =item param => STRING I Provides a parameter name for the field; similar to setting it using the C<:param> attribute. This parameter will be required unless a default value is set (such value may still be C). =item reader => STRING =item writer => STRING =item mutator => STRING I =item accessor => STRING I Provides method names for generated reader, writer, lvalue-mutator or reader+writer accessor methods, similar to setting them via the C<:reader>, C<:writer>, C<:mutator> or C<:accessor> attributes. =item weak => BOOL I If true, reference values assigned into the field by the constructor or accessor methods will be weakened, similar to setting the C<:weak> attribute. =back Returns an instance of L to represent it. =head2 add_slot $metafield = $metaclass->add_slot( $name, %args ) I Back-compatibility alias for C. =cut sub add_slot { my $self = shift; carp "->add_slot is now deprecated; use ->add_field instead"; return $self->add_field( @_ ); } =head2 get_field $metafield = $metaclass->get_field( $name ) I Returns an instance of L to represent the field of the given name, if one exists. If not an exception is thrown. =head2 get_slot $metafield = $metaclass->get_slot( $name ) I Back-compatibility alias for C. =cut sub get_slot { my $self = shift; carp "->get_slot is now deprecated; use ->get_field instead"; return $self->get_field( @_ ); } =head2 fields @metafields = $metaclass->fields I Returns a list of L instances to represent all the fields of the class. This list may be empty. =head2 slots @metafields = $metaclass->slots I Back-compatibility alias for C. =cut sub slots { my $self = shift; carp "->slots is now deprecated; use ->fields instead"; return $self->fields; } *roles = \&direct_roles; *get_own_method = \&get_direct_method; =head2 add_required_method $metaclass->add_required_method( $name ) I Adds a new required method to the role, whose name is given as a plain string. Currently returns nothing. This should be considered temporary, as eventually a metatype for required methods will be added, at which point this method can return instances of it. It may also take additional parameters to define the required method with. Currently extra parameters are not permitted. =head2 required_method_names @names = $metaclass->required_method_names I Returns a list names of required methods for the role, as plain strings. This should be considered a temporary method. Currently there is no metatype for required methods, so they are represented as plain strings. Eventually a type may be defined and a C method will be added. =cut =head2 seal $metaclass->seal I If the metaclass was created by L or L, this method must be called once everything has been added into it, as the class will not yet be ready to construct actual object instances before this is done. =head1 AUTHOR Paul Evans =cut 0x55AA; Object-Pad-0.61/lib/Object/Pad/MOP/Field.pm000444001750001750 501214203242261 16714 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2020-2022 -- leonerd@leonerd.org.uk package Object::Pad::MOP::Field 0.61; use v5.14; use warnings; # This is an XS-implemented object type provided by Object::Pad itself require Object::Pad; =head1 NAME C - meta-object representation of data field of a C class =head1 DESCRIPTION Instances of this class represent a data field of a class implemented by L. Accessors provide information about the field. The special C method allows access to the value of the given field on instances of its class, letting the meta-object be used as a proxy to it. This API should be considered experimental even within the overall context in which C is expermental. =cut =head1 METHODS =head2 name $name = $metafield->name Returns the name of the field, as a plain string including the leading sigil character. =head2 sigil $sigil = $metafield->sigil I Returns the first character of the field name, giving just its leading sigil. =head2 class $metaclass = $metafield->class Returns the L instance representing the class of which this field is a member. =head2 value $current = $metafield->value( $instance ) @current = $metafield->value( $instance ) %current = $metafield->value( $instance ) An accessor method which returns the current value of the field from an object instance. $metafield->value( $instance ) = $new On scalar fields, this method can also act as an lvalue mutator allowing a new value to be set. =head2 has_attribute $exists = $metafield->has_attribute( $name ) I Returns a boolean indicating whether the named attribute has been attached to the field. The attribute name should not include the leading colon (C<:>) character. =head2 get_attribute_value $value = $metafield->get_attribute_value( $name ) I Returns the stored value of an attached attribute, if one exists. If the attribute has not been attached then an exception is thrown. Note that most core-defined attributes will either store no data at all, or a method name string. This accessor method is provided largely for the benefit of obtaining data defined by third-party attributes, which may more clearly define how that data is generated and used. =cut =head1 AUTHOR Paul Evans =cut 0x55AA; Object-Pad-0.61/lib/Object/Pad/MOP/FieldAttr.pm000444001750001750 464014203242261 17555 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2021-2022 -- leonerd@leonerd.org.uk package Object::Pad::MOP::FieldAttr 0.61; use v5.14; use warnings; # This is an XS-implemented object type provided by Object::Pad itself require Object::Pad; =head1 NAME C - meta-object representation of a field attribute for C =head1 DESCRIPTION This API provides a way for pure-perl implementations of field attributes to be provided. Pure-perl attributes cannot currently add new I to the way that fields work, but they do provide a means for class authors to annotate extra metadata onto fields, that can be queried by other code. Primilarily this is done by using the L accessor method on a field metadata instance. =cut =head1 METHODS =cut =head2 register Object::Pad::MOP::FieldAttr->register( $name, %args ) I Creates a new field attribute of the given name. The name must begin with a capital letter, in order to distinguish this from any of the built-in core attributes, whose names are lowercase. The attribute is only available if the hints hash contains a key of the name given by the attribute's C argument. This would typically be set in the hints hash by the C method of the module implementing it, and would be named based on the name of the module providing the attribute: sub import { $^H{"Some::Package::Name/Attrname"} } Takes the following additional named arguments: =over 4 =item permit_hintkey => STRING Required. A string giving a key that must be found in the hints hash (C<%^H>) for this attribute name to be visible. =item apply => CODE An optional code reference for a callback function to invoke when the attribute is applied to a field. If present, it is passed the field metadata instance as a L reference, and a string containing the contents of the attribute's parenthesized value. The return value of the callback will be stored as the attribute's value and can be accessed by the C method on the field metadata. $result = $apply->( $fieldmeta, $value ) If the C callback is absent then the string value itself is stored. =back =cut =head1 AUTHOR Paul Evans =cut 0x55AA; Object-Pad-0.61/lib/Object/Pad/MOP/Method.pm000444001750001750 201614203242261 17112 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2020 -- leonerd@leonerd.org.uk package Object::Pad::MOP::Method 0.61; use v5.14; use warnings; # This is an XS-implemented object type provided by Object::Pad itself require Object::Pad; =head1 NAME C - meta-object representation of a method of a C class =head1 DESCRIPTION Instances of this class represent a method of a class implemented by L. Accessors provide information about the method. This API should be considered experimental even within the overall context in which C is expermental. =cut =head1 METHODS =head2 name $name = $metamethod->name Returns the name of the method, as a plain string. =head2 class Returns the L instance representing the class of which this method is a member. =cut =head1 AUTHOR Paul Evans =cut 0x55AA; Object-Pad-0.61/src000755001750001750 014203242261 12654 5ustar00leoleo000000000000Object-Pad-0.61/src/class.c000444001750001750 15111214203242261 14323 0ustar00leoleo000000000000/* vi: set ft=xs : */ #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "object_pad.h" #include "class.h" #include "field.h" #undef register_class_attribute #include "perl-backcompat.c.inc" #include "sv_setrv.c.inc" #include "perl-additions.c.inc" #include "force_list_keeping_pushmark.c.inc" #include "optree-additions.c.inc" #include "newOP_CUSTOM.c.inc" #ifdef DEBUGGING # define DEBUG_OVERRIDE_PLCURCOP # define DEBUG_SET_CURCOP_LINE(line) CopLINE_set(PL_curcop, line) #else # undef DEBUG_OVERRIDE_PLCURCOP # define DEBUG_SET_CURCOP_LINE(line) #endif #define need_PLparser() S_need_PLparser(aTHX) static void S_need_PLparser(pTHX) { if(!PL_parser) { /* We need to generate just enough of a PL_parser to keep newSTATEOP() * happy, otherwise it will SIGSEGV (RT133258) */ SAVEVPTR(PL_parser); Newxz(PL_parser, 1, yy_parser); SAVEFREEPV(PL_parser); PL_parser->copline = NOLINE; #if HAVE_PERL_VERSION(5, 20, 0) PL_parser->preambling = NOLINE; #endif } } /* Empty MGVTBL simply for locating instance backing AV */ static MGVTBL vtbl_backingav = {}; typedef struct ClassAttributeRegistration ClassAttributeRegistration; struct ClassAttributeRegistration { ClassAttributeRegistration *next; const char *name; STRLEN permit_hintkeylen; const struct ClassHookFuncs *funcs; void *funcdata; }; static ClassAttributeRegistration *classattrs = NULL; static void register_class_attribute(const char *name, const struct ClassHookFuncs *funcs, void *funcdata) { ClassAttributeRegistration *reg; Newx(reg, 1, struct ClassAttributeRegistration); reg->name = name; reg->funcs = funcs; reg->funcdata = funcdata; if(funcs->permit_hintkey) reg->permit_hintkeylen = strlen(funcs->permit_hintkey); else reg->permit_hintkeylen = 0; reg->next = classattrs; classattrs = reg; } void ObjectPad_register_class_attribute(pTHX_ const char *name, const struct ClassHookFuncs *funcs, void *funcdata) { if(funcs->ver < 57) croak("Mismatch in third-party class attribute ABI version field: module wants %d, we require >= 57\n", funcs->ver); if(funcs->ver > OBJECTPAD_ABIVERSION) croak("Mismatch in third-party class attribute ABI version field: attribute supplies %d, module wants %d\n", funcs->ver, OBJECTPAD_ABIVERSION); if(!name || !(name[0] >= 'A' && name[0] <= 'Z')) croak("Third-party class attribute names must begin with a capital letter"); if(!funcs->permit_hintkey) croak("Third-party class attributes require a permit hinthash key"); register_class_attribute(name, funcs, funcdata); } void ObjectPad_mop_class_apply_attribute(pTHX_ ClassMeta *classmeta, const char *name, SV *value) { HV *hints = GvHV(PL_hintgv); if(value && (!SvPOK(value) || !SvCUR(value))) value = NULL; ClassAttributeRegistration *reg; for(reg = classattrs; reg; reg = reg->next) { if(!strEQ(name, reg->name)) continue; if(reg->funcs->permit_hintkey && (!hints || !hv_fetch(hints, reg->funcs->permit_hintkey, reg->permit_hintkeylen, 0))) continue; if((reg->funcs->flags & OBJECTPAD_FLAG_ATTR_NO_VALUE) && value) croak("Attribute :%s does not permit a value", name); if((reg->funcs->flags & OBJECTPAD_FLAG_ATTR_MUST_VALUE) && !value) croak("Attribute :%s requires a value", name); SV *hookdata = value; if(reg->funcs->apply) { if(!(*reg->funcs->apply)(aTHX_ classmeta, value, &hookdata, reg->funcdata)) return; } if(!classmeta->hooks) classmeta->hooks = newAV(); struct ClassHook *hook; Newx(hook, 1, struct ClassHook); hook->funcs = reg->funcs; hook->funcdata = reg->funcdata; hook->hookdata = hookdata; av_push(classmeta->hooks, (SV *)hook); if(value && value != hookdata) SvREFCNT_dec(value); return; } croak("Unrecognised class attribute :%s", name); } /* TODO: get attribute */ #define get_classmeta_for(self) S_get_classmeta_for(aTHX_ self) static ClassMeta *S_get_classmeta_for(pTHX_ SV *self) { HV *selfstash = SvSTASH(SvRV(self)); GV **gvp = (GV **)hv_fetchs(selfstash, "META", 0); if(!gvp) croak("Unable to find ClassMeta for %" SVf, SVfARG(HvNAME(selfstash))); return NUM2PTR(ClassMeta *, SvUV(SvRV(GvSV(*gvp)))); } #define make_instance_fields(classmeta, backingav, roleoffset) S_make_instance_fields(aTHX_ classmeta, backingav, roleoffset) static void S_make_instance_fields(pTHX_ const ClassMeta *classmeta, AV *backingav, FIELDOFFSET roleoffset) { assert(classmeta->type == METATYPE_ROLE || roleoffset == 0); if(classmeta->start_fieldix) { /* Superclass actually has some fields */ assert(classmeta->type == METATYPE_CLASS); assert(classmeta->cls.supermeta->sealed); make_instance_fields(classmeta->cls.supermeta, backingav, 0); } AV *fields = classmeta->direct_fields; I32 nfields = av_count(fields); av_extend(backingav, classmeta->next_fieldix - 1 + roleoffset); I32 i; for(i = 0; i < nfields; i++) { FieldMeta *fieldmeta = (FieldMeta *)AvARRAY(fields)[i]; char sigil = SvPV_nolen(fieldmeta->name)[0]; assert(av_count(backingav) == fieldmeta->fieldix + roleoffset); switch(sigil) { case '$': av_push(backingav, newSV(0)); break; case '@': av_push(backingav, newRV_noinc((SV *)newAV())); break; case '%': av_push(backingav, newRV_noinc((SV *)newHV())); break; default: croak("ARGH: not sure how to handle a slot sigil %c\n", sigil); } } if(classmeta->type == METATYPE_CLASS) { U32 nroles; RoleEmbedding **embeddings = mop_class_get_direct_roles(classmeta, &nroles); assert(classmeta->type == METATYPE_CLASS || nroles == 0); for(i = 0; i < nroles; i++) { RoleEmbedding *embedding = embeddings[i]; ClassMeta *rolemeta = embedding->rolemeta; assert(rolemeta->sealed); make_instance_fields(rolemeta, backingav, embedding->offset); } } } SV *ObjectPad_get_obj_backingav(pTHX_ SV *self, enum ReprType repr, bool create) { SV *rv = SvRV(self); switch(repr) { case REPR_NATIVE: if(SvTYPE(rv) != SVt_PVAV) croak("Not an ARRAY reference"); return rv; case REPR_HASH: case_REPR_HASH: { if(SvTYPE(rv) != SVt_PVHV) croak("Not a HASH reference"); SV **backingsvp = hv_fetchs((HV *)rv, "Object::Pad/slots", create); if(create && !SvOK(*backingsvp)) sv_setrv_noinc(*backingsvp, (SV *)newAV()); /* A method invoked during a superclass constructor of a classic perl * class might encounter $self without fields. If this is the case we'll * have to create the fields now * https://rt.cpan.org/Ticket/Display.html?id=132263 */ if(!backingsvp) { struct ClassMeta *classmeta = get_classmeta_for(self); AV *backingav = newAV(); make_instance_fields(classmeta, backingav, 0); backingsvp = hv_fetchs((HV *)rv, "Object::Pad/slots", TRUE); sv_setrv_noinc(*backingsvp, (SV *)backingav); } if(!SvROK(*backingsvp) || SvTYPE(SvRV(*backingsvp)) != SVt_PVAV) croak("Expected $self->{\"Object::Pad/slots\"} to be an ARRAY reference"); return SvRV(*backingsvp); } case REPR_MAGIC: case_REPR_MAGIC: { MAGIC *mg = mg_findext(rv, PERL_MAGIC_ext, &vtbl_backingav); if(!mg && create) mg = sv_magicext(rv, (SV *)newAV(), PERL_MAGIC_ext, &vtbl_backingav, NULL, 0); if(!mg) croak("Expected to find backing AV magic extension"); return mg->mg_obj; } case REPR_AUTOSELECT: if(SvTYPE(rv) == SVt_PVHV) goto case_REPR_HASH; goto case_REPR_MAGIC; } croak("ARGH unhandled repr type"); } #define embed_cv(cv, embedding) S_embed_cv(aTHX_ cv, embedding) static CV *S_embed_cv(pTHX_ CV *cv, RoleEmbedding *embedding) { assert(cv); assert(CvOUTSIDE(cv)); CV *embedded_cv = cv_clone(cv); SV *embeddingsv = embedding->embeddingsv; assert(SvTYPE(embeddingsv) == SVt_PV && SvLEN(embeddingsv) >= sizeof(RoleEmbedding)); PAD *pad1 = PadlistARRAY(CvPADLIST(embedded_cv))[1]; PadARRAY(pad1)[PADIX_EMBEDDING] = SvREFCNT_inc(embeddingsv); return embedded_cv; } RoleEmbedding **ObjectPad_mop_class_get_direct_roles(pTHX_ const ClassMeta *meta, U32 *nroles) { assert(meta->type == METATYPE_CLASS); AV *roles = meta->cls.direct_roles; *nroles = av_count(roles); return (RoleEmbedding **)AvARRAY(roles); } RoleEmbedding **ObjectPad_mop_class_get_all_roles(pTHX_ const ClassMeta *meta, U32 *nroles) { assert(meta->type == METATYPE_CLASS); AV *roles = meta->cls.embedded_roles; *nroles = av_count(roles); return (RoleEmbedding **)AvARRAY(roles); } MethodMeta *ObjectPad_mop_class_add_method(pTHX_ ClassMeta *meta, SV *methodname) { AV *methods = meta->direct_methods; if(meta->sealed) croak("Cannot add a new method to an already-sealed class"); if(!methodname || !SvOK(methodname) || !SvCUR(methodname)) croak("methodname must not be undefined or empty"); U32 i; for(i = 0; i < av_count(methods); i++) { MethodMeta *methodmeta = (MethodMeta *)AvARRAY(methods)[i]; if(sv_eq(methodmeta->name, methodname)) { if(methodmeta->role) croak("Method '%" SVf "' clashes with the one provided by role %" SVf, SVfARG(methodname), SVfARG(methodmeta->role->name)); else croak("Cannot add another method named %" SVf, methodname); } } MethodMeta *methodmeta; Newx(methodmeta, 1, MethodMeta); methodmeta->name = SvREFCNT_inc(methodname); methodmeta->class = meta; methodmeta->role = NULL; av_push(methods, (SV *)methodmeta); return methodmeta; } FieldMeta *ObjectPad_mop_class_add_field(pTHX_ ClassMeta *meta, SV *fieldname) { AV *fields = meta->direct_fields; if(meta->next_fieldix == -1) croak("Cannot add a new field to a class that is not yet begun"); if(meta->sealed) croak("Cannot add a new field to an already-sealed class"); if(!fieldname || !SvOK(fieldname) || !SvCUR(fieldname)) croak("fieldname must not be undefined or empty"); switch(SvPV_nolen(fieldname)[0]) { case '$': case '@': case '%': break; default: croak("fieldname must begin with a sigil"); } U32 i; for(i = 0; i < av_count(fields); i++) { FieldMeta *fieldmeta = (FieldMeta *)AvARRAY(fields)[i]; if(SvCUR(fieldmeta->name) < 2) continue; if(sv_eq(fieldmeta->name, fieldname)) croak("Cannot add another field named %" SVf, fieldname); } FieldMeta *fieldmeta = mop_create_field(fieldname, meta); av_push(fields, (SV *)fieldmeta); meta->next_fieldix++; MOP_CLASS_RUN_HOOKS(meta, post_add_field, fieldmeta); return fieldmeta; } void ObjectPad_mop_class_add_BUILD(pTHX_ ClassMeta *meta, CV *cv) { if(meta->sealed) croak("Cannot add a BUILD block to an already-sealed class"); if(meta->strict_params) croak("Cannot add a BUILD block to a class with :strict(params)"); if(!meta->buildblocks) meta->buildblocks = newAV(); av_push(meta->buildblocks, (SV *)cv); } void ObjectPad_mop_class_add_ADJUST(pTHX_ ClassMeta *meta, CV *cv) { if(meta->sealed) croak("Cannot add an ADJUST block to an already-sealed class"); if(!meta->adjustblocks) meta->adjustblocks = newAV(); AdjustBlock *block; Newx(block, 1, struct AdjustBlock); block->is_adjustparams = false; block->cv = cv; av_push(meta->adjustblocks, (SV *)block); } void ObjectPad_mop_class_add_ADJUSTPARAMS(pTHX_ ClassMeta *meta, CV *cv) { if(meta->sealed) croak("Cannot add an ADJUSTPARAMS block to an already-sealed class"); if(!meta->adjustblocks) meta->adjustblocks = newAV(); AdjustBlock *block; Newx(block, 1, struct AdjustBlock); block->is_adjustparams = true; block->cv = cv; meta->has_adjustparams = true; av_push(meta->adjustblocks, (SV *)block); } void ObjectPad_mop_class_add_required_method(pTHX_ ClassMeta *meta, SV *methodname) { if(meta->type != METATYPE_ROLE) croak("Can only add a required method to a role"); if(meta->sealed) croak("Cannot add a new required method to an already-sealed class"); av_push(meta->requiremethods, SvREFCNT_inc(methodname)); } #define mop_class_implements_role(meta, rolemeta) S_mop_class_implements_role(aTHX_ meta, rolemeta) static bool S_mop_class_implements_role(pTHX_ ClassMeta *meta, ClassMeta *rolemeta) { U32 i, n; switch(meta->type) { case METATYPE_CLASS: { RoleEmbedding **embeddings = mop_class_get_all_roles(meta, &n); for(i = 0; i < n; i++) if(embeddings[i]->rolemeta == rolemeta) return true; break; } case METATYPE_ROLE: { ClassMeta **roles = (ClassMeta **)AvARRAY(meta->role.superroles); U32 n = av_count(meta->role.superroles); /* TODO: this isn't super-efficient in deep cross-linked heirarchies */ for(i = 0; i < n; i++) { if(roles[i] == rolemeta) return true; if(mop_class_implements_role(roles[i], rolemeta)) return true; } break; } } return false; } #define embed_role(class, role) S_embed_role(aTHX_ class, role) static RoleEmbedding *S_embed_role(pTHX_ ClassMeta *classmeta, ClassMeta *rolemeta) { U32 i; if(classmeta->type != METATYPE_CLASS) croak("Can only apply to a class"); if(rolemeta->type != METATYPE_ROLE) croak("Can only apply a role to a class"); HV *srcstash = rolemeta->stash; HV *dststash = classmeta->stash; SV *embeddingsv = newSV(sizeof(RoleEmbedding)); assert(SvTYPE(embeddingsv) == SVt_PV && SvLEN(embeddingsv) >= sizeof(RoleEmbedding)); RoleEmbedding *embedding = (RoleEmbedding *)SvPVX(embeddingsv); embedding->embeddingsv = embeddingsv; embedding->rolemeta = rolemeta; embedding->classmeta = classmeta; embedding->offset = -1; av_push(classmeta->cls.embedded_roles, (SV *)embedding); hv_store_ent(rolemeta->role.applied_classes, classmeta->name, (SV *)embedding, 0); U32 nbuilds = rolemeta->buildblocks ? av_count(rolemeta->buildblocks) : 0; for(i = 0; i < nbuilds; i++) { CV *buildblock = (CV *)AvARRAY(rolemeta->buildblocks)[i]; CV *embedded_buildblock = embed_cv(buildblock, embedding); if(!classmeta->buildblocks) classmeta->buildblocks = newAV(); av_push(classmeta->buildblocks, (SV *)embedded_buildblock); } U32 nadjusts = rolemeta->adjustblocks ? av_count(rolemeta->adjustblocks) : 0; for(i = 0; i < nadjusts; i++) { AdjustBlock *block = (AdjustBlock *)AvARRAY(rolemeta->adjustblocks)[i]; CV *embedded_cv = embed_cv(block->cv, embedding); if(block->is_adjustparams) mop_class_add_ADJUSTPARAMS(classmeta, embedded_cv); else mop_class_add_ADJUST(classmeta, embedded_cv); } if(rolemeta->has_adjustparams) classmeta->has_adjustparams = true; U32 nmethods = av_count(rolemeta->direct_methods); for(i = 0; i < nmethods; i++) { MethodMeta *methodmeta = (MethodMeta *)AvARRAY(rolemeta->direct_methods)[i]; SV *mname = methodmeta->name; HE *he = hv_fetch_ent(srcstash, mname, 0, 0); if(!he || !HeVAL(he) || !GvCV((GV *)HeVAL(he))) croak("ARGH expected to find CODE called %" SVf " in package %" SVf, SVfARG(mname), SVfARG(rolemeta->name)); { MethodMeta *dstmethodmeta = mop_class_add_method(classmeta, mname); dstmethodmeta->role = rolemeta; } GV **gvp = (GV **)hv_fetch(dststash, SvPVX(mname), SvCUR(mname), GV_ADD); gv_init_sv(*gvp, dststash, mname, 0); GvMULTI_on(*gvp); if(GvCV(*gvp)) croak("Method '%" SVf "' clashes with the one provided by role %" SVf, SVfARG(mname), SVfARG(rolemeta->name)); CV *newcv; GvCV_set(*gvp, newcv = embed_cv(GvCV((GV *)HeVAL(he)), embedding)); CvGV_set(newcv, *gvp); } nmethods = av_count(rolemeta->requiremethods); for(i = 0; i < nmethods; i++) { av_push(classmeta->requiremethods, SvREFCNT_inc(AvARRAY(rolemeta->requiremethods)[i])); } return embedding; } void ObjectPad_mop_class_add_role(pTHX_ ClassMeta *dstmeta, ClassMeta *rolemeta) { if(dstmeta->sealed) croak("Cannot add a role to an already-sealed class"); /* Can't currently do this as it breaks t/77mop-create-role.t if(!rolemeta->sealed) croak("Cannot add a role that is not yet sealed"); */ if(mop_class_implements_role(dstmeta, rolemeta)) return; switch(dstmeta->type) { case METATYPE_CLASS: { U32 nroles; if((nroles = av_count(rolemeta->role.superroles)) > 0) { ClassMeta **roles = (ClassMeta **)AvARRAY(rolemeta->role.superroles); U32 i; for(i = 0; i < nroles; i++) mop_class_add_role(dstmeta, roles[i]); } RoleEmbedding *embedding = embed_role(dstmeta, rolemeta); av_push(dstmeta->cls.direct_roles, (SV *)embedding); return; } case METATYPE_ROLE: av_push(dstmeta->role.superroles, (SV *)rolemeta); return; } } void ObjectPad_mop_class_load_and_add_role(pTHX_ ClassMeta *meta, SV *rolename, SV *rolever) { HV *rolestash = gv_stashsv(rolename, 0); if(!rolestash || !hv_fetchs(rolestash, "META", 0)) { /* Try to`require` the module then attempt a second time */ load_module(PERL_LOADMOD_NOIMPORT, newSVsv(rolename), NULL, NULL); rolestash = gv_stashsv(rolename, 0); } if(!rolestash) croak("Role %" SVf " does not exist", SVfARG(rolename)); if(rolever && SvOK(rolever)) ensure_module_version(rolename, rolever); GV **metagvp = (GV **)hv_fetchs(rolestash, "META", 0); ClassMeta *rolemeta = NULL; if(metagvp) rolemeta = NUM2PTR(ClassMeta *, SvUV(SvRV(GvSV(*metagvp)))); if(!rolemeta || rolemeta->type != METATYPE_ROLE) croak("%" SVf " is not a role", SVfARG(rolename)); mop_class_add_role(meta, rolemeta); } #define embed_fieldhook(roleh, offset) S_embed_fieldhook(aTHX_ roleh, offset) static struct FieldHook *S_embed_fieldhook(pTHX_ struct FieldHook *roleh, FIELDOFFSET offset) { struct FieldHook *classh; Newx(classh, 1, struct FieldHook); classh->fieldix = roleh->fieldix + offset; classh->fieldmeta = roleh->fieldmeta; classh->funcs = roleh->funcs; classh->hookdata = roleh->hookdata; return classh; } #define mop_class_apply_role(embedding) S_mop_class_apply_role(aTHX_ embedding) static void S_mop_class_apply_role(pTHX_ RoleEmbedding *embedding) { ClassMeta *classmeta = embedding->classmeta; ClassMeta *rolemeta = embedding->rolemeta; if(classmeta->type != METATYPE_CLASS) croak("Can only apply to a class"); if(rolemeta->type != METATYPE_ROLE) croak("Can only apply a role to a class"); assert(embedding->offset == -1); embedding->offset = classmeta->next_fieldix; if(rolemeta->parammap) { HV *src = rolemeta->parammap; if(!classmeta->parammap) classmeta->parammap = newHV(); HV *dst = classmeta->parammap; hv_iterinit(src); HE *iter; while((iter = hv_iternext(src))) { STRLEN klen = HeKLEN(iter); void *key = HeKEY(iter); if(klen < 0 ? hv_exists_ent(dst, (SV *)key, HeHASH(iter)) : hv_exists(dst, (char *)key, klen)) croak("Named parameter '%" SVf "' clashes with the one provided by role %" SVf, SVfARG(HeSVKEY_force(iter)), SVfARG(rolemeta->name)); ParamMeta *roleparammeta = (ParamMeta *)HeVAL(iter); ParamMeta *classparammeta; Newx(classparammeta, 1, struct ParamMeta); classparammeta->field = roleparammeta->field; classparammeta->fieldix = roleparammeta->fieldix + embedding->offset; if(klen < 0) hv_store_ent(dst, HeSVKEY(iter), (SV *)classparammeta, HeHASH(iter)); else hv_store(dst, HeKEY(iter), klen, (SV *)classparammeta, HeHASH(iter)); } } if(rolemeta->fieldhooks_initfield) { if(!classmeta->fieldhooks_initfield) classmeta->fieldhooks_initfield = newAV(); U32 i; for(i = 0; i < av_count(rolemeta->fieldhooks_initfield); i++) { struct FieldHook *roleh = (struct FieldHook *)AvARRAY(rolemeta->fieldhooks_initfield)[i]; av_push(classmeta->fieldhooks_initfield, (SV *)embed_fieldhook(roleh, embedding->offset)); } } if(rolemeta->fieldhooks_construct) { if(!classmeta->fieldhooks_construct) classmeta->fieldhooks_construct = newAV(); U32 i; for(i = 0; i < av_count(rolemeta->fieldhooks_construct); i++) { struct FieldHook *roleh = (struct FieldHook *)AvARRAY(rolemeta->fieldhooks_construct)[i]; av_push(classmeta->fieldhooks_construct, (SV *)embed_fieldhook(roleh, embedding->offset)); } } classmeta->next_fieldix += av_count(rolemeta->direct_fields); /* TODO: Run an APPLY block if the role has one */ } static void S_apply_roles(pTHX_ ClassMeta *dstmeta, ClassMeta *srcmeta) { U32 nroles; RoleEmbedding **arr = mop_class_get_direct_roles(srcmeta, &nroles); U32 i; for(i = 0; i < nroles; i++) { mop_class_apply_role(arr[i]); } } static OP *pp_alias_params(pTHX) { dSP; PADOFFSET padix = PADIX_INITFIELDS_PARAMS; SV *params = POPs; if(SvTYPE(params) != SVt_PVHV) RETURN; SAVESPTR(PAD_SVl(padix)); PAD_SVl(padix) = SvREFCNT_inc(params); save_freesv(params); RETURN; } static OP *pp_croak_from_constructor(pTHX) { dSP; /* Walk up the caller stack to find the COP of the first caller; i.e. the * first one that wasn't in src/class.c */ I32 count = 0; const PERL_CONTEXT *cx; while((cx = caller_cx(count, NULL))) { const char *copfile = CopFILE(cx->blk_oldcop); if(!copfile|| strNE(copfile, "src/class.c")) { PL_curcop = cx->blk_oldcop; break; } count++; } croak_sv(POPs); } static void S_generate_initfields_method(pTHX_ ClassMeta *meta) { OP *ops = NULL; int i; ENTER; need_PLparser(); I32 floor_ix = PL_savestack_ix; { SAVEI32(PL_subline); save_item(PL_subname); resume_compcv(&meta->initfields_compcv); } SAVEFREESV(PL_compcv); I32 save_ix = block_start(TRUE); #ifdef DEBUG_OVERRIDE_PLCURCOP SAVESPTR(PL_curcop); PL_curcop = meta->tmpcop; CopLINE_set(PL_curcop, __LINE__); #endif ops = op_append_list(OP_LINESEQ, ops, newSTATEOP(0, NULL, NULL)); /* A more optimised implementation of this method would be able to generate * a @self lexical and OP_REFASSIGN it, but that would only work on newer * perls. For now we'll take the small performance hit of RV2AV every time */ enum ReprType repr = meta->repr; ops = op_append_list(OP_LINESEQ, ops, newMETHSTARTOP(0 | (meta->type == METATYPE_ROLE ? OPf_SPECIAL : 0) | (repr << 8)) ); ops = op_append_list(OP_LINESEQ, ops, newUNOP_CUSTOM(&pp_alias_params, 0, newOP(OP_SHIFT, OPf_SPECIAL))); /* TODO: Icky horrible implementation; if our fieldoffset > 0 then * we must be a subclass */ if(meta->start_fieldix) { struct ClassMeta *supermeta = meta->cls.supermeta; assert(supermeta->sealed); assert(supermeta->initfields); DEBUG_SET_CURCOP_LINE(__LINE__); ops = op_append_list(OP_LINESEQ, ops, newSTATEOP(0, NULL, NULL)); /* Build an OP_ENTERSUB for supermeta's initfields */ OP *op = NULL; op = op_append_list(OP_LIST, op, newPADxVOP(OP_PADSV, 0, PADIX_SELF)); op = op_append_list(OP_LIST, op, newPADxVOP(OP_PADHV, OPf_REF, PADIX_INITFIELDS_PARAMS)); op = op_append_list(OP_LIST, op, newSVOP(OP_CONST, 0, (SV *)supermeta->initfields)); ops = op_append_list(OP_LINESEQ, ops, op_convert_list(OP_ENTERSUB, OPf_WANT_VOID|OPf_STACKED, op)); } AV *fields = meta->direct_fields; I32 nfields = av_count(fields); { for(i = 0; i < nfields; i++) { FieldMeta *fieldmeta = (FieldMeta *)AvARRAY(fields)[i]; char sigil = SvPV_nolen(fieldmeta->name)[0]; OP *op = NULL; SV *defaultsv; switch(sigil) { case '$': { DEBUG_SET_CURCOP_LINE(__LINE__); OP *valueop = NULL; if(fieldmeta->defaultexpr) { valueop = fieldmeta->defaultexpr; } else if((defaultsv = mop_field_get_default_sv(fieldmeta))) { /* An OP_CONST whose op_type is OP_CUSTOM. * This way we avoid the opchecker and finalizer doing bad things * to our defaultsv SV by setting it SvREADONLY_on() */ valueop = newSVOP_CUSTOM(PL_ppaddr[OP_CONST], 0, defaultsv); } if(fieldmeta->paramname) { SV *paramname = fieldmeta->paramname; if(!valueop) valueop = newUNOP_CUSTOM(&pp_croak_from_constructor, 0, newSVOP(OP_CONST, 0, newSVpvf("Required parameter '%" SVf "' is missing for %" SVf " constructor", SVfARG(paramname), SVfARG(meta->name)))); valueop = newCONDOP(0, /* exists $params{$paramname} */ newUNOP(OP_EXISTS, 0, newBINOP(OP_HELEM, 0, newPADxVOP(OP_PADHV, OPf_REF, PADIX_INITFIELDS_PARAMS), newSVOP(OP_CONST, 0, SvREFCNT_inc(paramname)))), /* ? delete $params{$paramname} */ newUNOP(OP_DELETE, 0, newBINOP(OP_HELEM, 0, newPADxVOP(OP_PADHV, OPf_REF, PADIX_INITFIELDS_PARAMS), newSVOP(OP_CONST, 0, SvREFCNT_inc(paramname)))), /* : valueop or die */ valueop); } if(valueop) op = newBINOP(OP_SASSIGN, 0, valueop, /* $fields[$idx] */ newAELEMOP(OPf_MOD, newPADxVOP(OP_PADAV, OPf_MOD|OPf_REF, PADIX_SLOTS), fieldmeta->fieldix)); break; } case '@': case '%': { DEBUG_SET_CURCOP_LINE(__LINE__); OP *valueop = NULL; U16 coerceop = (sigil == '%') ? OP_RV2HV : OP_RV2AV; if(fieldmeta->defaultexpr) { valueop = fieldmeta->defaultexpr; } else if((defaultsv = mop_field_get_default_sv(fieldmeta))) { valueop = newUNOP(coerceop, 0, newSVOP_CUSTOM(PL_ppaddr[OP_CONST], 0, defaultsv)); } if(valueop) { /* $fields[$idx]->@* or ->%* */ OP *lhs = force_list_keeping_pushmark(newUNOP(coerceop, OPf_MOD|OPf_REF, newAELEMOP(0, newPADxVOP(OP_PADAV, OPf_MOD|OPf_REF, PADIX_SLOTS), fieldmeta->fieldix))); op = newBINOP(OP_AASSIGN, 0, force_list_keeping_pushmark(valueop), lhs); } break; } default: croak("ARGH: not sure how to handle a field sigil %c\n", sigil); } if(!op) continue; /* TODO: grab a COP at the initexpr time */ ops = op_append_list(OP_LINESEQ, ops, newSTATEOP(0, NULL, NULL)); ops = op_append_list(OP_LINESEQ, ops, op); } } if(meta->type == METATYPE_CLASS) { U32 nroles; RoleEmbedding **embeddings = mop_class_get_direct_roles(meta, &nroles); for(i = 0; i < nroles; i++) { RoleEmbedding *embedding = embeddings[i]; ClassMeta *rolemeta = embedding->rolemeta; if(!rolemeta->sealed) mop_class_seal(rolemeta); assert(rolemeta->sealed); assert(rolemeta->initfields); DEBUG_SET_CURCOP_LINE(__LINE__); ops = op_append_list(OP_LINESEQ, ops, newSTATEOP(0, NULL, NULL)); OP *op = NULL; op = op_append_list(OP_LIST, op, newPADxVOP(OP_PADSV, 0, PADIX_SELF)); op = op_append_list(OP_LIST, op, newPADxVOP(OP_PADHV, OPf_REF, PADIX_INITFIELDS_PARAMS)); op = op_append_list(OP_LIST, op, newSVOP(OP_CONST, 0, (SV *)embed_cv(rolemeta->initfields, embedding))); ops = op_append_list(OP_LINESEQ, ops, op_convert_list(OP_ENTERSUB, OPf_WANT_VOID|OPf_STACKED, op)); } } SvREFCNT_inc(PL_compcv); ops = block_end(save_ix, ops); /* newATTRSUB will capture PL_curstash */ SAVESPTR(PL_curstash); PL_curstash = meta->stash; meta->initfields = newATTRSUB(floor_ix, NULL, NULL, NULL, ops); assert(meta->initfields); assert(CvOUTSIDE(meta->initfields)); LEAVE; } void ObjectPad_mop_class_seal(pTHX_ ClassMeta *meta) { if(meta->sealed) /* idempotent */ return; if(meta->type == METATYPE_CLASS && meta->cls.supermeta && !meta->cls.supermeta->sealed) { /* Must defer sealing until superclass is sealed first * (RT133190) */ ClassMeta *supermeta = meta->cls.supermeta; if(!supermeta->pending_submeta) supermeta->pending_submeta = newAV(); av_push(supermeta->pending_submeta, (SV *)meta); return; } if(meta->type == METATYPE_CLASS) S_apply_roles(aTHX_ meta, meta); if(meta->type == METATYPE_CLASS) { U32 nmethods = av_count(meta->requiremethods); U32 i; for(i = 0; i < nmethods; i++) { SV *mname = AvARRAY(meta->requiremethods)[i]; GV *gv = gv_fetchmeth_sv(meta->stash, mname, 0, 0); if(gv && GvCV(gv)) continue; croak("Class %" SVf " does not provide a required method named '%" SVf "'", SVfARG(meta->name), SVfARG(mname)); } } if(meta->strict_params && meta->buildblocks) croak("Class %" SVf " cannot be :strict(params) because it has BUILD blocks", SVfARG(meta->name)); { U32 i; for(i = 0; i < av_count(meta->direct_fields); i++) { FieldMeta *fieldmeta = (FieldMeta *)AvARRAY(meta->direct_fields)[i]; U32 hooki; for(hooki = 0; fieldmeta->hooks && hooki < av_count(fieldmeta->hooks); hooki++) { struct FieldHook *h = (struct FieldHook *)AvARRAY(fieldmeta->hooks)[hooki]; if(*h->funcs->post_initfield) { if(!meta->fieldhooks_initfield) meta->fieldhooks_initfield = newAV(); struct FieldHook *fasth; Newx(fasth, 1, struct FieldHook); fasth->fieldix = fieldmeta->fieldix; fasth->fieldmeta = fieldmeta; fasth->funcs = h->funcs; fasth->funcdata = h->funcdata; fasth->hookdata = h->hookdata; av_push(meta->fieldhooks_initfield, (SV *)fasth); } if(*h->funcs->post_construct) { if(!meta->fieldhooks_construct) meta->fieldhooks_construct = newAV(); struct FieldHook *fasth; Newx(fasth, 1, struct FieldHook); fasth->fieldix = fieldmeta->fieldix; fasth->fieldmeta = fieldmeta; fasth->funcs = h->funcs; fasth->funcdata = h->funcdata; fasth->hookdata = h->hookdata; av_push(meta->fieldhooks_construct, (SV *)fasth); } } } } S_generate_initfields_method(aTHX_ meta); meta->sealed = true; if(meta->pending_submeta) { int i; SV **arr = AvARRAY(meta->pending_submeta); for(i = 0; i < av_count(meta->pending_submeta); i++) { ClassMeta *submeta = (ClassMeta *)arr[i]; arr[i] = &PL_sv_undef; mop_class_seal(submeta); } SvREFCNT_dec(meta->pending_submeta); meta->pending_submeta = NULL; } } XS_INTERNAL(injected_constructor); XS_INTERNAL(injected_constructor) { dXSARGS; const ClassMeta *meta = XSANY.any_ptr; SV *class = ST(0); SV *self = NULL; assert(meta->type == METATYPE_CLASS); if(!meta->sealed) croak("Cannot yet invoke '%" SVf "' constructor before the class is complete", SVfARG(class)); #ifdef DEBUG_OVERRIDE_PLCURCOP COP *prevcop = PL_curcop; PL_curcop = meta->tmpcop; CopLINE_set(PL_curcop, __LINE__); #endif /* An AV storing the @_ args to pass to foreign constructor and all the * build blocks * This does not include $self */ AV *args = newAV(); SAVEFREESV(args); { /* @args = $class->BUILDARGS(@_) */ ENTER; SAVETMPS; #ifdef DEBUG_OVERRIDE_PLCURCOP SAVEVPTR(PL_curcop); PL_curcop = prevcop; #endif /* Splice in an extra copy of `class` so we get one there for the foreign * constructor */ EXTEND(SP, 1); SV **argstart = SP - items + 2; PUSHMARK(argstart - 1); SV **svp; for(svp = SP; svp >= argstart; svp--) *(svp+1) = *svp; *argstart = class; SP++; PUTBACK; I32 nargs = call_method("BUILDARGS", G_ARRAY); SPAGAIN; for(svp = SP - nargs + 1; svp <= SP; svp++) av_push(args, SvREFCNT_inc(*svp)); FREETMPS; LEAVE; } bool need_makefields = true; if(!meta->cls.foreign_new) { HV *stash = gv_stashsv(class, 0); if(!stash) croak("Unable to find stash for class %" SVf, class); switch(meta->repr) { case REPR_NATIVE: case REPR_AUTOSELECT: DEBUG_SET_CURCOP_LINE(__LINE__); self = sv_2mortal(newRV_noinc((SV *)newAV())); sv_bless(self, stash); break; case REPR_HASH: DEBUG_SET_CURCOP_LINE(__LINE__); self = sv_2mortal(newRV_noinc((SV *)newHV())); sv_bless(self, stash); break; case REPR_MAGIC: croak("ARGH cannot use :repr(magic) without a foreign superconstructor"); break; } } else { DEBUG_SET_CURCOP_LINE(__LINE__); { ENTER; SAVETMPS; PUSHMARK(SP); EXTEND(SP, 1 + AvFILL(args)); SV **argstart = SP - AvFILL(args) - 1; SV **argtop = SP; SV **svp; mPUSHs(newSVsv(class)); /* Push a copy of the args in case the (foreign) constructor mutates * them. We still need them for BUILDALL */ for(svp = argstart + 1; svp <= argtop; svp++) PUSHs(*svp); PUTBACK; assert(meta->cls.foreign_new); call_sv((SV *)meta->cls.foreign_new, G_SCALAR); SPAGAIN; self = SvREFCNT_inc(POPs); PUTBACK; FREETMPS; LEAVE; } if(!SvROK(self) || !SvOBJECT(SvRV(self))) { #ifdef DEBUG_OVERRIDE_PLCURCOP PL_curcop = prevcop; #endif croak("Expected %" SVf "->SUPER::new to return a blessed reference", class); } SV *rv = SvRV(self); /* It's possible a foreign superclass constructor invoked a `method` and * thus initfields has already been called. Check here and set * need_makefields false if so. */ switch(meta->repr) { case REPR_NATIVE: croak("ARGH shouldn't ever have REPR_NATIVE with foreign_new"); case REPR_HASH: case_REPR_HASH: if(SvTYPE(rv) != SVt_PVHV) { #ifdef DEBUG_OVERRIDE_PLCURCOP PL_curcop = prevcop; #endif croak("Expected %" SVf "->SUPER::new to return a blessed HASH reference", class); } need_makefields = !hv_exists(MUTABLE_HV(rv), "Object::Pad/slots", 17); break; case REPR_MAGIC: case_REPR_MAGIC: /* Anything goes */ need_makefields = !mg_findext(rv, PERL_MAGIC_ext, &vtbl_backingav); break; case REPR_AUTOSELECT: if(SvTYPE(rv) == SVt_PVHV) goto case_REPR_HASH; goto case_REPR_MAGIC; } sv_2mortal(self); } AV *backingav; if(need_makefields) { backingav = (AV *)get_obj_backingav(self, meta->repr, TRUE); make_instance_fields(meta, backingav, 0); } else { backingav = (AV *)get_obj_backingav(self, meta->repr, FALSE); } SV **fieldsvs = AvARRAY(backingav); if(meta->fieldhooks_initfield || meta->fieldhooks_construct) { /* We need to set up a fake pad so these hooks can still get PADIX_SELF / PADIX_SLOTS */ /* This MVP is just sufficient enough to let PAD_SVl(PADIX_SELF) work */ SAVEVPTR(PL_curpad); Newx(PL_curpad, 3, SV *); SAVEFREEPV(PL_curpad); PAD_SVl(PADIX_SELF) = self; PAD_SVl(PADIX_SLOTS) = (SV *)backingav; } if(meta->fieldhooks_initfield) { DEBUG_SET_CURCOP_LINE(__LINE__); AV *fieldhooks = meta->fieldhooks_initfield; U32 i; for(i = 0; i < av_count(fieldhooks); i++) { struct FieldHook *h = (struct FieldHook *)AvARRAY(fieldhooks)[i]; FIELDOFFSET fieldix = h->fieldix; (*h->funcs->post_initfield)(aTHX_ h->fieldmeta, h->hookdata, h->funcdata, fieldsvs[fieldix]); } } HV *paramhv = NULL; if(meta->parammap || meta->has_adjustparams || meta->strict_params) { paramhv = newHV(); SAVEFREESV((SV *)paramhv); if(av_count(args) % 2) warn("Odd-length list passed to %" SVf " constructor", class); /* TODO: I'm sure there's an newHV_from_AV() around somewhere */ SV **argsv = AvARRAY(args); IV idx; for(idx = 0; idx < av_count(args); idx += 2) { SV *name = argsv[idx]; SV *value = idx < av_count(args)-1 ? argsv[idx+1] : &PL_sv_undef; hv_store_ent(paramhv, name, SvREFCNT_inc(value), 0); } } { /* Run initfields */ ENTER; #ifdef DEBUG_OVERRIDE_PLCURCOP SAVEVPTR(PL_curcop); PL_curcop = prevcop; #endif EXTEND(SP, 2); PUSHMARK(SP); PUSHs(self); if(paramhv) PUSHs((SV *)paramhv); else PUSHs(&PL_sv_undef); PUTBACK; assert(meta->initfields); call_sv((SV *)meta->initfields, G_VOID); LEAVE; } if(meta->buildblocks) { DEBUG_SET_CURCOP_LINE(__LINE__); AV *buildblocks = meta->buildblocks; SV **argsvs = AvARRAY(args); int i; for(i = 0; i < av_count(buildblocks); i++) { CV *buildblock = (CV *)AvARRAY(buildblocks)[i]; ENTER; SAVETMPS; SPAGAIN; EXTEND(SP, 1 + AvFILL(args)); PUSHMARK(SP); PUSHs(self); int argi; for(argi = 0; argi <= AvFILL(args); argi++) PUSHs(argsvs[argi]); PUTBACK; assert(buildblock); call_sv((SV *)buildblock, G_VOID); FREETMPS; LEAVE; } } if(meta->adjustblocks) { DEBUG_SET_CURCOP_LINE(__LINE__); AV *adjustblocks = meta->adjustblocks; U32 i; for(i = 0; i < av_count(adjustblocks); i++) { AdjustBlock *block = (AdjustBlock *)AvARRAY(adjustblocks)[i]; ENTER; SAVETMPS; SPAGAIN; EXTEND(SP, 1 + !!paramhv); PUSHMARK(SP); PUSHs(self); if(paramhv && block->is_adjustparams) mPUSHs(newRV_inc((SV *)paramhv)); PUTBACK; assert(block->cv); call_sv((SV *)block->cv, G_VOID); FREETMPS; LEAVE; } } if(meta->strict_params && hv_iterinit(paramhv) > 0) { HE *he = hv_iternext(paramhv); /* Concat all the param names, in no particular order * TODO: consider sorting them but that's quite expensive and tricky in XS */ SV *params = newSVsv(HeSVKEY_force(he)); SAVEFREESV(params); while((he = hv_iternext(paramhv))) sv_catpvf(params, ", %" SVf, SVfARG(HeSVKEY_force(he))); #ifdef DEBUG_OVERRIDE_PLCURCOP PL_curcop = prevcop; #endif croak("Unrecognised parameters for %" SVf " constructor: %" SVf, SVfARG(meta->name), SVfARG(params)); } if(meta->fieldhooks_construct) { DEBUG_SET_CURCOP_LINE(__LINE__); AV *fieldhooks = meta->fieldhooks_construct; U32 i; for(i = 0; i < av_count(fieldhooks); i++) { struct FieldHook *h = (struct FieldHook *)AvARRAY(fieldhooks)[i]; FIELDOFFSET fieldix = h->fieldix; (*h->funcs->post_construct)(aTHX_ h->fieldmeta, h->hookdata, h->funcdata, fieldsvs[fieldix]); } } #ifdef DEBUG_OVERRIDE_PLCURCOP PL_curcop = prevcop; #endif ST(0) = self; XSRETURN(1); } XS_INTERNAL(injected_DOES) { dXSARGS; const ClassMeta *meta = XSANY.any_ptr; SV *self = ST(0); SV *wantrole = ST(1); PERL_UNUSED_ARG(items); CV *cv_does = NULL; while(meta != NULL) { AV *roles = meta->type == METATYPE_CLASS ? meta->cls.direct_roles : NULL; I32 nroles = roles ? av_count(roles) : 0; if(!cv_does && meta->cls.foreign_does) cv_does = meta->cls.foreign_does; if(sv_eq(meta->name, wantrole)) { XSRETURN_YES; } int i; for(i = 0; i < nroles; i++) { RoleEmbedding *embedding = (RoleEmbedding *)AvARRAY(roles)[i]; if(sv_eq(embedding->rolemeta->name, wantrole)) { XSRETURN_YES; } } meta = meta->type == METATYPE_CLASS ? meta->cls.supermeta : NULL; } if (cv_does) { /* return $self->DOES(@_); */ dSP; ENTER; SAVETMPS; PUSHMARK(SP); EXTEND(SP, 2); PUSHs(self); PUSHs(wantrole); PUTBACK; int count = call_sv((SV*)cv_does, G_SCALAR); SPAGAIN; bool ret = false; if (count) ret = POPi; FREETMPS; LEAVE; if(ret) XSRETURN_YES; } else { /* We need to also respond to Object::Pad::UNIVERSAL and UNIVERSAL */ if(sv_derived_from_sv(self, wantrole, 0)) XSRETURN_YES; } XSRETURN_NO; } ClassMeta *ObjectPad_mop_create_class(pTHX_ enum MetaType type, SV *name) { assert(type == METATYPE_CLASS || type == METATYPE_ROLE); ClassMeta *meta; Newx(meta, 1, ClassMeta); meta->type = type; meta->name = SvREFCNT_inc(name); HV *stash = meta->stash = gv_stashsv(name, GV_ADD); meta->sealed = false; meta->role_is_invokable = false; meta->strict_params = false; meta->has_adjustparams = false; meta->has_superclass = false; meta->start_fieldix = 0; meta->next_fieldix = -1; meta->hooks = NULL; meta->direct_fields = newAV(); meta->direct_methods = newAV(); meta->parammap = NULL; meta->requiremethods = newAV(); meta->repr = REPR_AUTOSELECT; meta->pending_submeta = NULL; meta->buildblocks = NULL; meta->adjustblocks = NULL; meta->initfields = NULL; meta->fieldhooks_initfield = NULL; meta->fieldhooks_construct = NULL; switch(type) { case METATYPE_CLASS: meta->cls.supermeta = NULL; meta->cls.foreign_new = NULL; meta->cls.foreign_does = NULL; meta->cls.direct_roles = newAV(); meta->cls.embedded_roles = newAV(); break; case METATYPE_ROLE: meta->role.superroles = newAV(); meta->role.applied_classes = newHV(); break; } need_PLparser(); /* Prepare meta->initfields for containing a CV parsing operation */ { if(!PL_compcv) { /* We require the initfields CV to have a CvOUTSIDE, or else cv_clone() * will segv when we compose role fields. Any class dynamically generated * by string eval() will likely not get one, because it won't inherit a * PL_compcv here. We'll fake it up * See also https://rt.cpan.org/Ticket/Display.html?id=137952 */ SAVEVPTR(PL_compcv); PL_compcv = find_runcv(0); assert(PL_compcv); } I32 floor_ix = start_subparse(FALSE, 0); extend_pad_vars(meta); /* Skip padix==3 so we're aligned again */ if(meta->type != METATYPE_ROLE) pad_add_name_pvs("", 0, NULL, NULL); PADOFFSET padix = pad_add_name_pvs("%params", 0, NULL, NULL); if(padix != PADIX_INITFIELDS_PARAMS) croak("ARGH: Expected that padix[%%params] = 4"); intro_my(); suspend_compcv(&meta->initfields_compcv); LEAVE_SCOPE(floor_ix); } meta->tmpcop = (COP *)newSTATEOP(0, NULL, NULL); CopFILE_set(meta->tmpcop, __FILE__); meta->methodscope = NULL; { /* Inject the constructor */ SV *newname = newSVpvf("%" SVf "::new", name); SAVEFREESV(newname); CV *newcv = newXS_flags(SvPV_nolen(newname), injected_constructor, __FILE__, NULL, SvFLAGS(newname) & SVf_UTF8); CvXSUBANY(newcv).any_ptr = meta; } { SV *doesname = newSVpvf("%" SVf "::DOES", name); SAVEFREESV(doesname); CV *doescv = newXS_flags(SvPV_nolen(doesname), injected_DOES, __FILE__, NULL, SvFLAGS(doesname) & SVf_UTF8); CvXSUBANY(doescv).any_ptr = meta; } { GV **gvp = (GV **)hv_fetchs(stash, "META", GV_ADD); GV *gv = *gvp; gv_init_pvn(gv, stash, "META", 4, 0); GvMULTI_on(gv); SV *sv; sv_setref_uv(sv = GvSVn(gv), "Object::Pad::MOP::Class", PTR2UV(meta)); newCONSTSUB(meta->stash, "META", sv); } return meta; } void ObjectPad_mop_class_set_superclass(pTHX_ ClassMeta *meta, SV *superclassname) { assert(meta->type == METATYPE_CLASS); if(meta->has_superclass) croak("Class already has a superclass, cannot add another"); AV *isa; { SV *isaname = newSVpvf("%" SVf "::ISA", meta->name); SAVEFREESV(isaname); isa = get_av(SvPV_nolen(isaname), GV_ADD | (SvFLAGS(isaname) & SVf_UTF8)); } av_push(isa, SvREFCNT_inc(superclassname)); ClassMeta *supermeta = NULL; HV *superstash = gv_stashsv(superclassname, 0); GV **metagvp = (GV **)hv_fetchs(superstash, "META", 0); if(metagvp) supermeta = NUM2PTR(ClassMeta *, SvUV(SvRV(GvSV(*metagvp)))); if(supermeta) { /* A subclass of an Object::Pad class */ if(supermeta->type != METATYPE_CLASS) croak("%" SVf " is not a class", SVfARG(superclassname)); /* If it isn't yet sealed (e.g. because we're an inner class of it), * seal it now */ if(!supermeta->sealed) mop_class_seal(supermeta); meta->start_fieldix = supermeta->next_fieldix; meta->repr = supermeta->repr; meta->cls.foreign_new = supermeta->cls.foreign_new; if(supermeta->buildblocks) { if(!meta->buildblocks) meta->buildblocks = newAV(); av_push_from_av_noinc(meta->buildblocks, supermeta->buildblocks); } if(supermeta->adjustblocks) { if(!meta->adjustblocks) meta->adjustblocks = newAV(); av_push_from_av_noinc(meta->adjustblocks, supermeta->adjustblocks); } if(supermeta->fieldhooks_initfield) { if(!meta->fieldhooks_initfield) meta->fieldhooks_initfield = newAV(); av_push_from_av_noinc(meta->fieldhooks_initfield, supermeta->fieldhooks_initfield); } if(supermeta->fieldhooks_construct) { if(!meta->fieldhooks_construct) meta->fieldhooks_construct = newAV(); av_push_from_av_noinc(meta->fieldhooks_construct, supermeta->fieldhooks_construct); } if(supermeta->parammap) { HV *old = supermeta->parammap; HV *new = meta->parammap = newHV(); hv_iterinit(old); HE *iter; while((iter = hv_iternext(old))) { STRLEN klen = HeKLEN(iter); /* Don't SvREFCNT_inc() the values because they aren't really SV *s */ /* Subclasses *DIRECTLY SHARE* their param metas because the * information in them is directly compatible */ if(klen < 0) hv_store_ent(new, HeSVKEY(iter), HeVAL(iter), HeHASH(iter)); else hv_store(new, HeKEY(iter), klen, HeVAL(iter), HeHASH(iter)); } } if(supermeta->has_adjustparams) meta->has_adjustparams = true; U32 nroles; RoleEmbedding **embeddings = mop_class_get_all_roles(supermeta, &nroles); if(nroles) { U32 i; for(i = 0; i < nroles; i++) { RoleEmbedding *embedding = embeddings[i]; ClassMeta *rolemeta = embedding->rolemeta; av_push(meta->cls.embedded_roles, (SV *)embedding); hv_store_ent(rolemeta->role.applied_classes, meta->name, (SV *)embedding, 0); } } } else { /* A subclass of a foreign class */ meta->cls.foreign_new = fetch_superclass_method_pv(meta->stash, "new", 3, -1); if(!meta->cls.foreign_new) croak("Unable to find SUPER::new for %" SVf, superclassname); meta->cls.foreign_does = fetch_superclass_method_pv(meta->stash, "DOES", 4, -1); av_push(isa, newSVpvs("Object::Pad::UNIVERSAL")); } meta->has_superclass = true; meta->cls.supermeta = supermeta; } void ObjectPad_mop_class_begin(pTHX_ ClassMeta *meta) { SV *isaname = newSVpvf("%" SVf "::ISA", meta->name); SAVEFREESV(isaname); AV *isa = get_av(SvPV_nolen(isaname), GV_ADD | (SvFLAGS(isaname) & SVf_UTF8)); if(!av_count(isa)) av_push(isa, newSVpvs("Object::Pad::UNIVERSAL")); if(meta->type == METATYPE_CLASS && meta->repr == REPR_AUTOSELECT && !meta->cls.foreign_new) meta->repr = REPR_NATIVE; meta->next_fieldix = meta->start_fieldix; } /******************* * Attribute hooks * *******************/ #ifndef isSPACE_utf8_safe /* this isn't really safe but it's the best we can do */ # define isSPACE_utf8_safe(p, e) (PERL_UNUSED_ARG(e), isSPACE_utf8(p)) #endif #define split_package_ver(value, pkgname, pkgversion) S_split_package_ver(aTHX_ value, pkgname, pkgversion) static const char *S_split_package_ver(pTHX_ SV *value, SV *pkgname, SV *pkgversion) { const char *start = SvPVX(value), *p = start, *end = start + SvCUR(value); while(*p && !isSPACE_utf8_safe(p, end)) p += UTF8SKIP(p); sv_setpvn(pkgname, start, p - start); if(SvUTF8(value)) SvUTF8_on(pkgname); while(*p && isSPACE_utf8_safe(p, end)) p += UTF8SKIP(p); if(*p) { /* scan_version() gets upset about trailing content. We need to extract * exactly what it wants */ start = p; if(*p == 'v') p++; while(*p && strchr("0123456789._", *p)) p++; SV *tmpsv = newSVpvn(start, p - start); SAVEFREESV(tmpsv); scan_version(SvPVX(tmpsv), pkgversion, FALSE); } while(*p && isSPACE_utf8_safe(p, end)) p += UTF8SKIP(p); return p; } /* :isa */ static bool classhook_isa_apply(pTHX_ ClassMeta *classmeta, SV *value, SV **hookdata_ptr, void *_funcdata) { SV *superclassname = newSV(0), *superclassver = newSV(0); SAVEFREESV(superclassname); SAVEFREESV(superclassver); const char *end = split_package_ver(value, superclassname, superclassver); if(*end) croak("Unexpected characters while parsing :isa() attribute: %s", end); if(classmeta->type != METATYPE_CLASS) croak("Only a class may extend another"); HV *superstash = gv_stashsv(superclassname, 0); if(!superstash || !hv_fetchs(superstash, "new", 0)) { /* Try to `require` the module then attempt a second time */ /* load_module() will modify the name argument and take ownership of it */ load_module(PERL_LOADMOD_NOIMPORT, newSVsv(superclassname), NULL, NULL); superstash = gv_stashsv(superclassname, 0); } if(!superstash) croak("Superclass %" SVf " does not exist", superclassname); if(superclassver && SvOK(superclassver)) ensure_module_version(superclassname, superclassver); mop_class_set_superclass(classmeta, superclassname); return FALSE; } static const struct ClassHookFuncs classhooks_isa = { .ver = OBJECTPAD_ABIVERSION, .flags = OBJECTPAD_FLAG_ATTR_MUST_VALUE, .apply = &classhook_isa_apply, }; /* :does */ static bool classhook_does_apply(pTHX_ ClassMeta *classmeta, SV *value, SV **hookdata_ptr, void *_funcdata) { SV *rolename = newSV(0), *rolever = newSV(0); SAVEFREESV(rolename); SAVEFREESV(rolever); const char *end = split_package_ver(value, rolename, rolever); if(*end) croak("Unexpected characters while parsing :does() attribute: %s", end); mop_class_load_and_add_role(classmeta, rolename, rolever); return FALSE; } static const struct ClassHookFuncs classhooks_does = { .ver = OBJECTPAD_ABIVERSION, .flags = OBJECTPAD_FLAG_ATTR_MUST_VALUE, .apply = &classhook_does_apply, }; /* :repr */ static bool classhook_repr_apply(pTHX_ ClassMeta *classmeta, SV *value, SV **hookdata_ptr, void *_funcdata) { char *val = SvPV_nolen(value); /* all comparisons are ASCII */ if(strEQ(val, "native")) { if(classmeta->type == METATYPE_CLASS && classmeta->cls.foreign_new) croak("Cannot switch a subclass of a foreign superclass type to :repr(native)"); classmeta->repr = REPR_NATIVE; } else if(strEQ(val, "HASH")) classmeta->repr = REPR_HASH; else if(strEQ(val, "magic")) { if(classmeta->type != METATYPE_CLASS || !classmeta->cls.foreign_new) croak("Cannot switch to :repr(magic) without a foreign superclass"); classmeta->repr = REPR_MAGIC; } else if(strEQ(val, "default") || strEQ(val, "autoselect")) classmeta->repr = REPR_AUTOSELECT; else croak("Unrecognised class representation type %" SVf, SVfARG(value)); return FALSE; } static const struct ClassHookFuncs classhooks_repr = { .ver = OBJECTPAD_ABIVERSION, .flags = OBJECTPAD_FLAG_ATTR_MUST_VALUE, .apply = &classhook_repr_apply, }; /* :compat */ static bool classhook_compat_apply(pTHX_ ClassMeta *classmeta, SV *value, SV **hookdata_ptr, void *_funcdata) { if(strEQ(SvPV_nolen(value), "invokable")) { if(classmeta->type != METATYPE_ROLE) croak(":compat(invokable) only applies to a role"); classmeta->role_is_invokable = true; } else croak("Unrecognised class compatibility argument %" SVf, SVfARG(value)); return FALSE; } static const struct ClassHookFuncs classhooks_compat = { .ver = OBJECTPAD_ABIVERSION, .flags = OBJECTPAD_FLAG_ATTR_MUST_VALUE, .apply = &classhook_compat_apply, }; /* :strict */ static bool classhook_strict_apply(pTHX_ ClassMeta *classmeta, SV *value, SV **hookdata_ptr, void *_funcdata) { if(strEQ(SvPV_nolen(value), "params")) classmeta->strict_params = TRUE; else croak("Unrecognised class strictness type %" SVf, SVfARG(value)); return FALSE; } static const struct ClassHookFuncs classhooks_strict = { .ver = OBJECTPAD_ABIVERSION, .flags = OBJECTPAD_FLAG_ATTR_MUST_VALUE, .apply = &classhook_strict_apply, }; void ObjectPad__boot_classes(void) { register_class_attribute("isa", &classhooks_isa, NULL); register_class_attribute("does", &classhooks_does, NULL); register_class_attribute("repr", &classhooks_repr, NULL); register_class_attribute("compat", &classhooks_compat, NULL); register_class_attribute("strict", &classhooks_strict, NULL); } /* back-compat */ SV *ObjectPad_get_obj_slotsav(pTHX_ SV *self, enum ReprType repr, bool create) { return ObjectPad_get_obj_backingav(aTHX_ self, repr, create); } FieldMeta *ObjectPad_mop_class_add_slot(pTHX_ ClassMeta *meta, SV *fieldname) { return ObjectPad_mop_class_add_field(aTHX_ meta, fieldname); } Object-Pad-0.61/src/field.c000444001750001750 4214514203242261 14266 0ustar00leoleo000000000000/* vi: set ft=xs : */ #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "object_pad.h" #include "class.h" #include "field.h" #undef register_field_attribute #include "perl-backcompat.c.inc" #include "perl-additions.c.inc" #include "force_list_keeping_pushmark.c.inc" #include "optree-additions.c.inc" #include "make_argcheck_ops.c.inc" #include "newOP_CUSTOM.c.inc" FieldMeta *ObjectPad_mop_create_field(pTHX_ SV *fieldname, ClassMeta *classmeta) { FieldMeta *fieldmeta; Newx(fieldmeta, 1, FieldMeta); assert(classmeta->next_fieldix > -1); fieldmeta->name = SvREFCNT_inc(fieldname); fieldmeta->class = classmeta; fieldmeta->fieldix = classmeta->next_fieldix; fieldmeta->defaultsv = NULL; fieldmeta->defaultexpr = NULL; fieldmeta->paramname = NULL; fieldmeta->hooks = NULL; return fieldmeta; } SV *ObjectPad_mop_field_get_name(pTHX_ FieldMeta *fieldmeta) { return fieldmeta->name; } char ObjectPad_mop_field_get_sigil(pTHX_ FieldMeta *fieldmeta) { return (SvPVX(fieldmeta->name))[0]; } #define mop_field_set_param(fieldmeta, paramname) S_mop_field_set_param(aTHX_ fieldmeta, paramname) static void S_mop_field_set_param(pTHX_ FieldMeta *fieldmeta, SV *paramname) { ClassMeta *classmeta = fieldmeta->class; if(!classmeta->parammap) classmeta->parammap = newHV(); HV *parammap = classmeta->parammap; HE *he; if((he = hv_fetch_ent(parammap, paramname, 0, 0))) { ParamMeta *colliding_parammeta = (ParamMeta *)HeVAL(he); if(colliding_parammeta->field->class != classmeta) croak("Already have a named constructor parameter called '%" SVf "' inherited from %" SVf, SVfARG(paramname), SVfARG(colliding_parammeta->field->class->name)); else croak("Already have a named constructor parameter called '%" SVf "'", SVfARG(paramname)); } ParamMeta *parammeta; Newx(parammeta, 1, struct ParamMeta); parammeta->name = SvREFCNT_inc(paramname); parammeta->field = fieldmeta; parammeta->fieldix = fieldmeta->fieldix; fieldmeta->paramname = SvREFCNT_inc(paramname); hv_store_ent(parammap, paramname, (SV *)parammeta, 0); } SV *ObjectPad_mop_field_get_default_sv(pTHX_ FieldMeta *fieldmeta) { return fieldmeta->defaultsv; } void ObjectPad_mop_field_set_default_sv(pTHX_ FieldMeta *fieldmeta, SV *sv) { if(fieldmeta->defaultsv) SvREFCNT_dec(fieldmeta->defaultsv); fieldmeta->defaultsv = sv; } typedef struct FieldAttributeRegistration FieldAttributeRegistration; struct FieldAttributeRegistration { FieldAttributeRegistration *next; const char *name; STRLEN permit_hintkeylen; const struct FieldHookFuncs *funcs; void *funcdata; }; static FieldAttributeRegistration *fieldattrs = NULL; static void register_field_attribute(const char *name, const struct FieldHookFuncs *funcs, void *funcdata) { FieldAttributeRegistration *reg; Newx(reg, 1, struct FieldAttributeRegistration); reg->name = name; reg->funcs = funcs; reg->funcdata = funcdata; if(funcs->permit_hintkey) reg->permit_hintkeylen = strlen(funcs->permit_hintkey); else reg->permit_hintkeylen = 0; reg->next = fieldattrs; fieldattrs = reg; } void ObjectPad_mop_field_apply_attribute(pTHX_ FieldMeta *fieldmeta, const char *name, SV *value) { HV *hints = GvHV(PL_hintgv); if(value && (!SvPOK(value) || !SvCUR(value))) value = NULL; FieldAttributeRegistration *reg; for(reg = fieldattrs; reg; reg = reg->next) { if(!strEQ(name, reg->name)) continue; if(reg->funcs->permit_hintkey && (!hints || !hv_fetch(hints, reg->funcs->permit_hintkey, reg->permit_hintkeylen, 0))) continue; if((reg->funcs->flags & OBJECTPAD_FLAG_ATTR_NO_VALUE) && value) croak("Attribute :%s does not permit a value", name); if((reg->funcs->flags & OBJECTPAD_FLAG_ATTR_MUST_VALUE) && !value) croak("Attribute :%s requires a value", name); SV *hookdata = value; if(reg->funcs->apply) { if(!(*reg->funcs->apply)(aTHX_ fieldmeta, value, &hookdata, reg->funcdata)) return; } if(hookdata && hookdata == value) SvREFCNT_inc(hookdata); if(!fieldmeta->hooks) fieldmeta->hooks = newAV(); struct FieldHook *hook; Newx(hook, 1, struct FieldHook); hook->funcs = reg->funcs; hook->hookdata = hookdata; hook->funcdata = reg->funcdata; av_push(fieldmeta->hooks, (SV *)hook); return; } croak("Unrecognised field attribute :%s", name); } struct FieldHook *ObjectPad_mop_field_get_attribute(pTHX_ FieldMeta *fieldmeta, const char *name) { COPHH *cophh = CopHINTHASH_get(PL_curcop); /* First, work out what hookfuncs the name maps to */ FieldAttributeRegistration *reg; for(reg = fieldattrs; reg; reg = reg->next) { if(!strEQ(name, reg->name)) continue; if(reg->funcs->permit_hintkey && !cophh_fetch_pvn(cophh, reg->funcs->permit_hintkey, reg->permit_hintkeylen, 0, 0)) continue; break; } if(!reg) return NULL; /* Now lets see if fieldmeta has one */ if(!fieldmeta->hooks) return NULL; U32 hooki; for(hooki = 0; hooki < av_count(fieldmeta->hooks); hooki++) { struct FieldHook *hook = (struct FieldHook *)AvARRAY(fieldmeta->hooks)[hooki]; if(hook->funcs == reg->funcs) return hook; } return NULL; } void ObjectPad_mop_field_seal(pTHX_ FieldMeta *fieldmeta) { MOP_FIELD_RUN_HOOKS_NOARGS(fieldmeta, seal); } /******************* * Attribute hooks * *******************/ /* :weak */ static void fieldhook_weak_post_construct(pTHX_ FieldMeta *fieldmeta, SV *_hookdata, void *_funcdata, SV *field) { sv_rvweaken(field); } static XOP xop_weaken; static OP *pp_weaken(pTHX) { dSP; sv_rvweaken(POPs); return NORMAL; } static void fieldhook_weak_gen_accessor(pTHX_ FieldMeta *fieldmeta, SV *hookdata, void *_funcdata, enum AccessorType type, struct AccessorGenerationCtx *ctx) { if(type != ACCESSOR_WRITER) return; ctx->post_bodyops = op_append_list(OP_LINESEQ, ctx->post_bodyops, newUNOP_CUSTOM(&pp_weaken, 0, newPADxVOP(OP_PADSV, 0, ctx->padix))); } static struct FieldHookFuncs fieldhooks_weak = { .flags = OBJECTPAD_FLAG_ATTR_NO_VALUE, .post_construct = &fieldhook_weak_post_construct, .gen_accessor_ops = &fieldhook_weak_gen_accessor, }; /* :param */ static bool fieldhook_param_apply(pTHX_ FieldMeta *fieldmeta, SV *value, SV **hookdata_ptr, void *_funcdata) { if(SvPVX(fieldmeta->name)[0] != '$') croak("Can only add a named constructor parameter for scalar fields"); char *paramname = value ? SvPVX(value) : NULL; U32 flags = 0; if(value && SvUTF8(value)) flags |= SVf_UTF8; if(!paramname) { paramname = SvPVX(fieldmeta->name) + 1; if(paramname[0] == '_') paramname++; if(SvUTF8(fieldmeta->name)) flags |= SVf_UTF8; } SV *namesv = newSVpvn_flags(paramname, strlen(paramname), flags); mop_field_set_param(fieldmeta, namesv); *hookdata_ptr = namesv; return TRUE; } static struct FieldHookFuncs fieldhooks_param = { .ver = OBJECTPAD_ABIVERSION, .apply = &fieldhook_param_apply, }; /* :reader */ static SV *make_accessor_mnamesv(pTHX_ FieldMeta *fieldmeta, SV *mname, const char *fmt) { /* if(mname && !is_valid_ident_utf8((U8 *)mname)) croak("Invalid accessor method name"); */ if(mname && SvPOK(mname)) return SvREFCNT_inc(mname); const char *pv; if(SvPVX(fieldmeta->name)[1] == '_') pv = SvPVX(fieldmeta->name) + 2; else pv = SvPVX(fieldmeta->name) + 1; mname = newSVpvf(fmt, pv); if(SvUTF8(fieldmeta->name)) SvUTF8_on(mname); return mname; } static void S_generate_field_accessor_method(pTHX_ FieldMeta *fieldmeta, SV *mname, int type) { ENTER; ClassMeta *classmeta = fieldmeta->class; char sigil = SvPVX(fieldmeta->name)[0]; SV *mname_fq = newSVpvf("%" SVf "::%" SVf, classmeta->name, mname); I32 floor_ix = start_subparse(FALSE, 0); SAVEFREESV(PL_compcv); I32 save_ix = block_start(TRUE); extend_pad_vars(classmeta); struct AccessorGenerationCtx ctx = { 0 }; ctx.padix = pad_add_name_sv(fieldmeta->name, 0, NULL, NULL); intro_my(); OP *ops = op_append_list(OP_LINESEQ, NULL, newSTATEOP(0, NULL, NULL)); ops = op_append_list(OP_LINESEQ, ops, newMETHSTARTOP(0 | (classmeta->type == METATYPE_ROLE ? OPf_SPECIAL : 0) | (classmeta->repr << 8))); int req_args = 0; int opt_args = 0; int slurpy_arg = 0; switch(type) { case ACCESSOR_WRITER: if(sigil == '$') req_args = 1; else slurpy_arg = sigil; break; case ACCESSOR_COMBINED: opt_args = 1; break; } ops = op_append_list(OP_LINESEQ, ops, make_argcheck_ops(req_args, opt_args, slurpy_arg, mname_fq)); U32 flags = 0; switch(sigil) { case '$': flags = OPpFIELDPAD_SV << 8; break; case '@': flags = OPpFIELDPAD_AV << 8; break; case '%': flags = OPpFIELDPAD_HV << 8; break; } ops = op_append_list(OP_LINESEQ, ops, newFIELDPADOP(flags, ctx.padix, fieldmeta->fieldix)); MOP_FIELD_RUN_HOOKS(fieldmeta, gen_accessor_ops, type, &ctx); if(ctx.bodyop) ops = op_append_list(OP_LINESEQ, ops, ctx.bodyop); if(ctx.post_bodyops) ops = op_append_list(OP_LINESEQ, ops, ctx.post_bodyops); if(!ctx.retop) croak("Require ctx.retop"); ops = op_append_list(OP_LINESEQ, ops, ctx.retop); SvREFCNT_inc(PL_compcv); ops = block_end(save_ix, ops); CV *cv = newATTRSUB(floor_ix, newSVOP(OP_CONST, 0, mname_fq), NULL, NULL, ops); CvMETHOD_on(cv); mop_class_add_method(classmeta, mname); LEAVE; } static bool fieldhook_reader_apply(pTHX_ FieldMeta *fieldmeta, SV *value, SV **hookdata_ptr, void *_funcdata) { *hookdata_ptr = make_accessor_mnamesv(aTHX_ fieldmeta, value, "%s"); return TRUE; } static void fieldhook_reader_seal(pTHX_ FieldMeta *fieldmeta, SV *hookdata, void *_funcdata) { S_generate_field_accessor_method(aTHX_ fieldmeta, hookdata, ACCESSOR_READER); } static void fieldhook_gen_reader_ops(pTHX_ FieldMeta *fieldmeta, SV *hookdata, void *_funcdata, enum AccessorType type, struct AccessorGenerationCtx *ctx) { if(type != ACCESSOR_READER) return; OPCODE optype = 0; switch(SvPVX(fieldmeta->name)[0]) { case '$': optype = OP_PADSV; break; case '@': optype = OP_PADAV; break; case '%': optype = OP_PADHV; break; } ctx->retop = newLISTOP(OP_RETURN, 0, newOP(OP_PUSHMARK, 0), newPADxVOP(optype, 0, ctx->padix)); } static struct FieldHookFuncs fieldhooks_reader = { .ver = OBJECTPAD_ABIVERSION, .apply = &fieldhook_reader_apply, .seal = &fieldhook_reader_seal, .gen_accessor_ops = &fieldhook_gen_reader_ops, }; /* :writer */ static bool fieldhook_writer_apply(pTHX_ FieldMeta *fieldmeta, SV *value, SV **hookdata_ptr, void *_funcdata) { *hookdata_ptr = make_accessor_mnamesv(aTHX_ fieldmeta, value, "set_%s"); return TRUE; } static void fieldhook_writer_seal(pTHX_ FieldMeta *fieldmeta, SV *hookdata, void *_funcdata) { S_generate_field_accessor_method(aTHX_ fieldmeta, hookdata, ACCESSOR_WRITER); } static void fieldhook_gen_writer_ops(pTHX_ FieldMeta *fieldmeta, SV *hookdata, void *_funcdata, enum AccessorType type, struct AccessorGenerationCtx *ctx) { if(type != ACCESSOR_WRITER) return; switch(SvPVX(fieldmeta->name)[0]) { case '$': ctx->bodyop = newBINOP(OP_SASSIGN, 0, newOP(OP_SHIFT, 0), newPADxVOP(OP_PADSV, 0, ctx->padix)); break; case '@': ctx->bodyop = newBINOP(OP_AASSIGN, 0, force_list_keeping_pushmark(newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv))), force_list_keeping_pushmark(newPADxVOP(OP_PADAV, OPf_MOD|OPf_REF, ctx->padix))); break; case '%': ctx->bodyop = newBINOP(OP_AASSIGN, 0, force_list_keeping_pushmark(newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv))), force_list_keeping_pushmark(newPADxVOP(OP_PADHV, OPf_MOD|OPf_REF, ctx->padix))); break; } ctx->retop = newLISTOP(OP_RETURN, 0, newOP(OP_PUSHMARK, 0), newPADxVOP(OP_PADSV, 0, PADIX_SELF)); } static struct FieldHookFuncs fieldhooks_writer = { .ver = OBJECTPAD_ABIVERSION, .apply = &fieldhook_writer_apply, .seal = &fieldhook_writer_seal, .gen_accessor_ops = &fieldhook_gen_writer_ops, }; /* :mutator */ static bool fieldhook_mutator_apply(pTHX_ FieldMeta *fieldmeta, SV *value, SV **hookdata_ptr, void *_funcdata) { if(SvPVX(fieldmeta->name)[0] != '$') /* TODO: A reader for an array or hash field should also be fine */ croak("Can only generate accessors for scalar fields"); *hookdata_ptr = make_accessor_mnamesv(aTHX_ fieldmeta, value, "%s"); return TRUE; } static void fieldhook_mutator_seal(pTHX_ FieldMeta *fieldmeta, SV *hookdata, void *_funcdata) { S_generate_field_accessor_method(aTHX_ fieldmeta, hookdata, ACCESSOR_LVALUE_MUTATOR); } static void fieldhook_gen_mutator_ops(pTHX_ FieldMeta *fieldmeta, SV *hookdata, void *_funcdata, enum AccessorType type, struct AccessorGenerationCtx *ctx) { if(type != ACCESSOR_LVALUE_MUTATOR) return; CvLVALUE_on(PL_compcv); ctx->retop = newLISTOP(OP_RETURN, 0, newOP(OP_PUSHMARK, 0), newPADxVOP(OP_PADSV, 0, ctx->padix)); } static struct FieldHookFuncs fieldhooks_mutator = { .ver = OBJECTPAD_ABIVERSION, .apply = &fieldhook_mutator_apply, .seal = &fieldhook_mutator_seal, .gen_accessor_ops = &fieldhook_gen_mutator_ops, }; /* :accessor */ static void fieldhook_accessor_seal(pTHX_ FieldMeta *fieldmeta, SV *hookdata, void *_funcdata) { S_generate_field_accessor_method(aTHX_ fieldmeta, hookdata, ACCESSOR_COMBINED); } static void fieldhook_gen_accessor_ops(pTHX_ FieldMeta *fieldmeta, SV *hookdata, void *_funcdata, enum AccessorType type, struct AccessorGenerationCtx *ctx) { if(type != ACCESSOR_COMBINED) return; /* $field = shift if @_ */ ctx->bodyop = newLOGOP(OP_AND, 0, /* scalar @_ */ op_contextualize(newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv)), G_SCALAR), /* $field = shift */ newBINOP(OP_SASSIGN, 0, newOP(OP_SHIFT, 0), newPADxVOP(OP_PADSV, 0, ctx->padix))); ctx->retop = newLISTOP(OP_RETURN, 0, newOP(OP_PUSHMARK, 0), newPADxVOP(OP_PADSV, 0, ctx->padix)); } static struct FieldHookFuncs fieldhooks_accessor = { .ver = OBJECTPAD_ABIVERSION, .apply = &fieldhook_mutator_apply, /* generate method name the same as :mutator */ .seal = &fieldhook_accessor_seal, .gen_accessor_ops = &fieldhook_gen_accessor_ops, }; void ObjectPad_register_field_attribute(pTHX_ const char *name, const struct FieldHookFuncs *funcs, void *funcdata) { if(funcs->ver < 57) croak("Mismatch in third-party field attribute ABI version field: module wants %d, we require >= 57\n", funcs->ver); if(funcs->ver > OBJECTPAD_ABIVERSION) croak("Mismatch in third-party field attribute ABI version field: attribute supplies %d, module wants %d\n", funcs->ver, OBJECTPAD_ABIVERSION); if(!name || !(name[0] >= 'A' && name[0] <= 'Z')) croak("Third-party field attribute names must begin with a capital letter"); if(!funcs->permit_hintkey) croak("Third-party field attributes require a permit hinthash key"); register_field_attribute(name, funcs, funcdata); } void ObjectPad__boot_fields(pTHX) { XopENTRY_set(&xop_weaken, xop_name, "weaken"); XopENTRY_set(&xop_weaken, xop_desc, "weaken an RV"); XopENTRY_set(&xop_weaken, xop_class, OA_UNOP); Perl_custom_op_register(aTHX_ &pp_weaken, &xop_weaken); register_field_attribute("weak", &fieldhooks_weak, NULL); register_field_attribute("param", &fieldhooks_param, NULL); register_field_attribute("reader", &fieldhooks_reader, NULL); register_field_attribute("writer", &fieldhooks_writer, NULL); register_field_attribute("mutator", &fieldhooks_mutator, NULL); register_field_attribute("accessor", &fieldhooks_accessor, NULL); } /* back-compat */ FieldMeta *ObjectPad_mop_create_slot(pTHX_ SV *fieldname, ClassMeta *classmeta) { return ObjectPad_mop_create_field(aTHX_ fieldname, classmeta); } void ObjectPad_mop_slot_seal(pTHX_ FieldMeta *fieldmeta) { return ObjectPad_mop_field_seal(aTHX_ fieldmeta); } SV *ObjectPad_mop_slot_get_name(pTHX_ FieldMeta *fieldmeta) { return ObjectPad_mop_field_get_name(aTHX_ fieldmeta); } char ObjectPad_mop_slot_get_sigil(pTHX_ FieldMeta *fieldmeta) { return ObjectPad_mop_field_get_sigil(aTHX_ fieldmeta); } void ObjectPad_mop_slot_apply_attribute(pTHX_ FieldMeta *fieldmeta, const char *name, SV *value) { ObjectPad_mop_field_apply_attribute(aTHX_ fieldmeta, name, value); } struct FieldHook *ObjectPad_mop_slot_get_attribute(pTHX_ FieldMeta *fieldmeta, const char *name) { return ObjectPad_mop_field_get_attribute(aTHX_ fieldmeta, name); } SV *ObjectPad_mop_slot_get_default_sv(pTHX_ FieldMeta *fieldmeta) { return ObjectPad_mop_field_get_default_sv(aTHX_ fieldmeta); } void ObjectPad_mop_slot_set_default_sv(pTHX_ FieldMeta *fieldmeta, SV *sv) { ObjectPad_mop_field_set_default_sv(aTHX_ fieldmeta, sv); } void ObjectPad_register_slot_attribute(pTHX_ const char *name, const struct SlotHookFuncs *funcs, void *funcdata) { Perl_warn(aTHX_ "register_slot_attribute() is now deprecated; use register_field_attribute() instead"); ObjectPad_register_field_attribute(aTHX_ name, (const struct FieldHookFuncs *)funcs, funcdata); } Object-Pad-0.61/src/suspended_compcv.c000444001750001750 361314203242261 16521 0ustar00leoleo000000000000/* vi: set ft=xs : */ #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "suspended_compcv.h" #define HAVE_PERL_VERSION(R, V, S) \ (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) #ifndef SAVESTRLEN # if HAVE_PERL_VERSION(5,26,0) # define SAVESTRLEN(i) Perl_save_strlen(aTHX_ (STRLEN *)&(i)) # else /* perls before 5.26.0 had no STRLEN and used simply I32 here */ # define SAVESTRLEN(i) SAVEI32(i) # endif #endif void MY_suspend_compcv(pTHX_ SuspendedCompCVBuffer *buffer) { buffer->compcv = PL_compcv; buffer->padix = PL_padix; #ifdef PL_constpadix buffer->constpadix = PL_constpadix; #endif buffer->comppad_name_fill = PL_comppad_name_fill; buffer->min_intro_pending = PL_min_intro_pending; buffer->max_intro_pending = PL_max_intro_pending; buffer->cv_has_eval = PL_cv_has_eval; buffer->pad_reset_pending = PL_pad_reset_pending; } void MY_resume_compcv(pTHX_ SuspendedCompCVBuffer *buffer, bool save) { SAVESPTR(PL_compcv); PL_compcv = buffer->compcv; PAD_SET_CUR(CvPADLIST(PL_compcv), 1); SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(CvPADLIST(PL_compcv)); SAVESTRLEN(PL_padix); PL_padix = buffer->padix; #ifdef PL_constpadix SAVESTRLEN(PL_constpadix); PL_constpadix = buffer->constpadix; #endif SAVESTRLEN(PL_comppad_name_fill); PL_comppad_name_fill = buffer->comppad_name_fill; SAVESTRLEN(PL_min_intro_pending); PL_min_intro_pending = buffer->min_intro_pending; SAVESTRLEN(PL_max_intro_pending); PL_max_intro_pending = buffer->max_intro_pending; SAVEBOOL(PL_cv_has_eval); PL_cv_has_eval = buffer->cv_has_eval; SAVEBOOL(PL_pad_reset_pending); PL_pad_reset_pending = buffer->pad_reset_pending; if(save) SAVEDESTRUCTOR_X(&MY_suspend_compcv, buffer); } Object-Pad-0.61/t000755001750001750 014203242261 12330 5ustar00leoleo000000000000Object-Pad-0.61/t/00use.t000444001750001750 21714203242261 13566 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use_ok( "Object::Pad" ); use_ok( "Object::Pad::ExtensionBuilder" ); done_testing; Object-Pad-0.61/t/01method.t000444001750001750 307514203242261 14300 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Test::Refcount; use Object::Pad; class Point { BUILD { @$self = @_; } method where { sprintf "(%d,%d)", @$self } } { my $p = Point->new( 10, 20 ); is_oneref( $p, '$p has refcount 1 initially' ); is( $p->where, "(10,20)", '$p->where' ); is_oneref( $p, '$p has refcount 1 after method' ); } # anon methods { class Point3 { BUILD { @$self = @_; } our $clearer = method { @$self = ( 0 ) x 3; }; } my $p = Point3->new( 1, 2, 3 ); $p->$Point3::clearer(); is_deeply( [ @$p ], [ 0, 0, 0 ], 'anon method' ); } # nested anon method (RT132321) SKIP: { skip "This causes SEGV on perl 5.16 (RT132321)", 1 if $] lt "5.018"; class RT132321 { has $_genvalue; BUILD { $_genvalue = method { 123 }; } method value { $self->$_genvalue() } } my $obj = RT132321->new; is( $obj->value, 123, '$obj->value from BUILD-generated anon method' ); } # method warns about redeclared $self (RT132428) { class RT132428 { BEGIN { my $warnings = ""; local $SIG{__WARN__} = sub { $warnings .= join "", @_; }; ::ok( defined eval <<'EOPERL', method test { my $self = shift; } 1; EOPERL 'method compiles OK' ); ::like( $warnings, qr/^"my" variable \$self masks earlier declaration in same scope at \(eval \d+\) line 2\./, 'warning from redeclared $self comes from correct line' ); } } } done_testing; Object-Pad-0.61/t/02fields.t000444001750001750 675714203242261 14301 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Test::Refcount; use Object::Pad; use constant HAVE_DATA_DUMP => defined eval { require Data::Dump; }; class Counter { has $count = 0; method inc { $count++ }; method describe { "Count is now $count" } } { my $counter = Counter->new; $counter->inc; $counter->inc; $counter->inc; is( $counter->describe, "Count is now 3", '$counter->describe after $counter->inc x 3' ); # BEGIN-time initialised fields get private storage my $counter2 = Counter->new; is( $counter2->describe, "Count is now 0", '$counter2 has its own $count' ); } { use Data::Dumper; class AllTheTypes { has $scalar = 123; has @array = ( 45, 67 ); has %hash = ( 89 => 10 ); method test { Test::More::is( $scalar, 123, '$scalar field' ); Test::More::is_deeply( \@array, [ 45, 67 ], '@array field' ); Test::More::is_deeply( \%hash, { 89 => 10 }, '%hash field' ); } } my $instance = AllTheTypes->new; $instance->test; # The exact output of this test is fragile as it depends on the internal # representation of the instance, which we do not document and is not part # of the API guarantee. We're not really checking that it has exactly this # output, just that Data::Dumper itself doesn't crash. If a later version # changes the representation so that the output here differs, just change # the test as long as it is something sensible. is( Dumper($instance) =~ s/\s+//gr, q($VAR1=bless([123,[45,67],{'89'=>10}],'AllTheTypes');), 'Dumper($instance) sees field data' ); HAVE_DATA_DUMP and is( Data::Dump::pp($instance), q(bless([123, [45, 67], { 89 => 10 }], "AllTheTypes")), 'pp($instance) sees field data' ); } { class AllTheTypesByBlock { has $scalar { "one" }; has @array { "two", "three" }; has %hash { four => "five" }; method test { Test::More::is( $scalar, "one", '$scalar field' ); Test::More::is_deeply( \@array, [qw( two three )], '@array field' ); Test::More::is_deeply( \%hash, { four => "five" }, '%hash field' ); } } AllTheTypesByBlock->new->test; } # Variant of RT132228 about individual field lexicals class Holder { has $field; method field :lvalue { $field } } { my $datum = []; is_oneref( $datum, '$datum initially' ); my $holder = Holder->new; $holder->field = $datum; is_refcount( $datum, 2, '$datum while held by Holder' ); undef $holder; is_oneref( $datum, '$datum finally' ); } # Sequencing order of expressions { my @order; sub seq { push @order, $_[0]; return $_[0]; } seq("start"); class Sequencing { has $at_BEGIN = "BEGIN"; has $at_class = ::seq("class"); has $at_construct { ::seq("construct") }; method test { ::is( $at_BEGIN, "BEGIN", '$at_BEGIN set correctly' ); ::is( $at_class, "class", '$at_class set correctly' ); ::is( $at_construct, "construct", '$at_construct set correctly' ); } } seq("new"); Sequencing->new->test; is_deeply( \@order, [qw( start class new construct )], 'seq() calls happened in the correct order' ); } Sequencing->new->test; # Fields are visible to string-eval() { class Evil { has $field; method test { $field = "the value"; ::is( eval '$field', "the value", 'fields are visible to string eval()' ); } } Evil->new->test; } done_testing; Object-Pad-0.61/t/03create.t000444001750001750 676114203242261 14272 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Scalar::Util qw( reftype ); use Object::Pad; class Point { has $x = 0; has $y = 0; BUILD { ( $x, $y ) = @_; } method where { sprintf "(%d,%d)", $x, $y } } { my $p = Point->new( 10, 20 ); is( $p->where, "(10,20)", '$p->where' ); } my @buildargs; my @build; class WithBuildargs { sub BUILDARGS { @buildargs = @_; return ( 4, 5, 6 ); } BUILD { @build = @_; } } { WithBuildargs->new( 1, 2, 3 ); is_deeply( \@buildargs, [qw( WithBuildargs 1 2 3 )], '@_ to BUILDARGS' ); is_deeply( \@build, [qw( 4 5 6 )], '@_ to BUILD' ); } { my @called; class WithAdjust { BUILD { push @called, "BUILD"; } ADJUST { push @called, "ADJUST"; } } WithAdjust->new; is_deeply( \@called, [qw( BUILD ADJUST )], 'ADJUST invoked after BUILD' ); } { my @called; my $paramsref; class WithAdjustParams { ADJUST { push @called, "ADJUST"; } ADJUSTPARAMS { my ( $href ) = @_; push @called, "ADJUSTPARAMS"; $paramsref = $href; } ADJUST { push @called, "ADJUST"; Test::More::ok( !scalar @_, 'ADJUST block received no arguments' ); } } WithAdjustParams->new( key => "val" ); is_deeply( \@called, [qw( ADJUST ADJUSTPARAMS ADJUST )], 'ADJUST and ADJUSTPARAMS invoked together' ); is_deeply( $paramsref, { key => "val" }, 'ADJUSTPARAMS received HASHref' ); } { my $paramvalue; class StrictlyWithParams :strict(params) { ADJUSTPARAMS { my ($href) = @_; $paramvalue = delete $href->{param}; } } StrictlyWithParams->new( param => "thevalue" ); is( $paramvalue, "thevalue", 'ADJUSTPARAMS captured the value' ); ok( !defined eval { StrictlyWithParams->new( unknown => "name" ) }, ':strict(params) complains about unrecognised param' ); like( $@, qr/^Unrecognised parameters for StrictlyWithParams constructor: unknown at /, 'message from unrecognised param to constructor' ); } # RT140314 { class NoParamsAtAll :strict(params) { } ok( !defined eval { NoParamsAtAll->new( unknown => 1 ) }, ':strict(params) complains even with no ADJUSTPARAMS block' ); like( $@, qr/^Unrecognised parameters for NoParamsAtAll constructor: unknown at /, 'message from unrecognised param to constructor' ); } { my $newarg_destroyed; my $buildargs_result_destroyed; package DestroyWatch { sub new { bless [ $_[1] ], $_[0] } sub DESTROY { ${ $_[0][0] }++ } } class RefcountTest { sub BUILDARGS { return DestroyWatch->new( \$buildargs_result_destroyed ) } } RefcountTest->new( DestroyWatch->new( \$newarg_destroyed ) ); is( $newarg_destroyed, 1, 'argument to ->new destroyed' ); is( $buildargs_result_destroyed, 1, 'result of BUILDARGS destroyed' ); } # Create a base class with HASH representation { class NativelyHash :repr(HASH) { has $field = "value"; method field { $field } } my $o = NativelyHash->new; is( reftype $o, "HASH", 'NativelyHash is natively a HASH reference' ); is( $o->field, "value", 'native HASH objects still support fields' ); } # Subclasses without BUILD shouldn't double-invoke superclass { my $BUILD_invoked; class One { BUILD { $BUILD_invoked++ } } class Two :isa(One) {} Two->new; is( $BUILD_invoked, 1, 'One::BUILD invoked only once for Two->new' ); } done_testing; Object-Pad-0.61/t/04extend-classical.t000444001750001750 55414203242261 16225 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; class BaseClass { has $data = 123; } package ExtendedClass { use base qw( BaseClass ); sub moremethod { return 456 } } my $obj = ExtendedClass->new; isa_ok( $obj, "ExtendedClass", '$obj' ); is( $obj->moremethod, 456, '$obj has methods from ExtendedClass' ); done_testing; Object-Pad-0.61/t/05subclass.t000444001750001750 313414203242261 14637 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; class Animal 1.23 { has $legs; method legs { $legs }; BUILD { ( $legs ) = @_; } } is( $Animal::VERSION, 1.23, 'Versioned class has $VERSION' ); class Spider 4.56 :isa(Animal) { sub BUILDARGS { my $self = shift; return $self->SUPER::BUILDARGS( 8 ); } method describe { "An animal with " . $self->legs . " legs"; } } is( $Spider::VERSION, 4.56, 'Versioned subclass has $VERSION' ); { my $spider = Spider->new; is( $spider->describe, "An animal with 8 legs", 'Subclassed instances work' ); } { ok( !eval <<'EOPERL', class Antelope :isa(Animal 2.34); EOPERL ':isa insufficient version fails' ); like( $@, qr/^Animal version 2.34 required--this is only version 1.23 /, 'message from insufficient version' ); } # Extend before base class is sealed (RT133190) { class BaseClass { has $_afield; class SubClass :isa(BaseClass) { method one { 1 } } } pass( 'Did not SEGV while compiling inner derived class' ); is( SubClass->new->one, 1, 'Inner derived subclass instances can be constructed' ); } # Make sure that ADJUSTPARAMS still works via trivial subclasses { my $param; class WithAdjustParams { ADJUSTPARAMS { my ( $href ) = @_; $param = delete $href->{param}; } } # Test whitespace trimming class TrivialSubclass :isa( WithAdjustParams ) {} TrivialSubclass->new( param => "value" ); is( $param, "value", 'ADJUSTPARAMS still invoked on superclass' ); } done_testing; Object-Pad-0.61/t/06subclass-foreign-HASH.t000444001750001750 1005414203242261 17027 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Test::Fatal; use Object::Pad; package Base::Class { sub new { my $class = shift; my ( $ok ) = @_; Test::More::is( $ok, "ok", '@_ to Base::Class::new' ); Test::More::is( scalar @_, 1, 'scalar @_ to Base::Class::new' ); return bless { base_field => 123 }, $class; } sub fields { my $self = shift; return "base_field=$self->{base_field}" } } my @BUILDS_INVOKED; class Derived::Class :isa(Base::Class) { has $derived_field = 456; BUILD { my @args = @_; Test::More::is_deeply( \@args, [ "ok" ], '@_ to Derived::Class::BUILD' ); push @BUILDS_INVOKED, __PACKAGE__; } method fields { return $self->SUPER::fields . ",derived_field=$derived_field"; } } { my $obj = Derived::Class->new( "ok" ); is( $obj->fields, "base_field=123,derived_field=456", '$obj->fields' ); is_deeply( \@BUILDS_INVOKED, [qw( Derived::Class )], 'BUILD invoked correctly' ); # We don't mind what the output here is but it should be well-behaved # and not crash the dumper use Data::Dumper; local $Data::Dumper::Sortkeys = 1; is( Dumper($obj) =~ s/\s+//gr, q($VAR1=bless({'Object::Pad/slots'=>[456],'base_field'=>123},'Derived::Class');), 'Dumper($obj) of Object::Pad-extended foreign HASH class' ); } @BUILDS_INVOKED = (); # Ensure that double-derived classes still chain down to foreign new { class DoubleDerived :isa(Derived::Class) { BUILD { push @BUILDS_INVOKED, __PACKAGE__; } method fields { return $self->SUPER::fields . ",doubled=yes"; } } is( DoubleDerived->new( "ok" )->fields, "base_field=123,derived_field=456,doubled=yes", 'Double-derived from foreign still invokes base constructor' ); is_deeply( \@BUILDS_INVOKED, [qw( Derived::Class DoubleDerived )], 'BUILD invoked correctly for double-derived class' ); } # Various RT132263 test cases { package RT132263::Parent; sub new { my $class = shift; my $self = bless {}, $class; $self->{result} = $self->example_method; return $self; } } # Test case one - no field access in example_method { class RT132263::Child1 :isa(RT132263::Parent) { method example_method { 1 } } my $e; ok( !defined( $e = exception { RT132263::Child1->new } ), 'RT132263 case 1 constructs OK' ) or diag( "Exception was $e" ); } # Test case two - read from an initialised field { class RT132263::Child2 :isa(RT132263::Parent) { has $value = 456; method example_method { $value } } my $obj; my $e; ok( !defined( $e = exception { $obj = RT132263::Child2->new } ), 'RT132263 case 2 constructs OK' ) or diag( "Exception was $e" ); { local our $TODO = "field initialisers no longer run during foreign superconstructor"; $obj and is( $obj->{result}, 456, '$obj->{result} has correct value' ); } # gutwrench into internals is( scalar @{ $obj->{'Object::Pad/slots'} }, 1, 'slots ARRAY contains correct number of elements' ); } # Check we are not allowed to switch the representation type back to native { like( exception { eval( "class SwitchedToNative :isa(Base::Class) :repr(native) { }" ) or die $@; }, qr/^Cannot switch a subclass of a foreign superclass type to :repr\(native\) at /, 'Exception from switching a foreign derived class back to native representation' ); } { my $newarg_destroyed; my $buildargs_result_destroyed; package DestroyWatch { sub new { bless [ $_[1] ], $_[0] } sub DESTROY { ${ $_[0][0] }++ } } package RefcountTest::Base { sub new { bless {}, shift } } class RefcountTest :isa(RefcountTest::Base) { sub BUILDARGS { return DestroyWatch->new( \$buildargs_result_destroyed ) } } RefcountTest->new( DestroyWatch->new( \$newarg_destroyed ) ); is( $newarg_destroyed, 1, 'argument to ->new destroyed' ); is( $buildargs_result_destroyed, 1, 'result of BUILDARGS destroyed' ); } done_testing; Object-Pad-0.61/t/07subclass-foreign-ARRAY.t000444001750001750 223314203242261 17143 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Test::Fatal; use Object::Pad; package Base::Class { sub new { my $class = shift; my ( $ok ) = @_; Test::More::is( $ok, "ok", '@_ to Base::Class::new' ); Test::More::is( scalar @_, 1, 'scalar @_ to Base::Class::new' ); return bless [ 123 ], $class; } sub fields { my $self = shift; return "base_field=$self->[0]" } } class Derived::Class :isa(Base::Class) { has $derived_field = 456; BUILD { my @args = @_; Test::More::is_deeply( \@args, [ "ok" ], '@_ to Derived::Class::BUILD' ); } method fields { return $self->SUPER::fields . ",derived_field=$derived_field"; } } { my $obj = Derived::Class->new( "ok" ); is( $obj->fields, "base_field=123,derived_field=456", '$obj->fields' ); # We don't mind what the output here is but it should be well-behaved # and not crash the dumper use Data::Dumper; local $Data::Dumper::Sortkeys = 1; is( Dumper($obj) =~ s/\s+//gr, q($VAR1=bless([123],'Derived::Class');), 'Dumper($obj) of Object::Pad-extended blessed ARRAY class' ); } done_testing; Object-Pad-0.61/t/08subclass-Moo.t000444001750001750 165614203242261 15401 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; BEGIN { plan skip_all => "Moo is not available" unless eval { require Moo }; } use Object::Pad; my $moocount; package Base::Class { use Moo; sub BUILD { my ( $self, $args ) = @_; Test::More::is_deeply( $args, { arg => "value" }, '@_ to Base::Class::BUILD' ); $moocount++; } } my $opcount; class Derived::Class :isa(Base::Class) { has $field; BUILD { my ( $args ) = @_; Test::More::is_deeply( $args, { arg => "value" }, '@_ to Derived::Class BUILD' ); $field = 345; $opcount++; } method field { $field } } { my $obj = Derived::Class->new( arg => "value" ); is( $obj->field, 345, 'field value' ); } # Ensure the BUILD blocks don't collide with Moo's BUILD methods is( $moocount, 1, 'Moo BUILD method invoked only once' ); is( $opcount, 1, 'Object::Pad BUILD block invoked only once' ); done_testing; Object-Pad-0.61/t/10method-attrs.t000444001750001750 124614203242261 15431 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; use attributes (); class Counter { has $count = 0; method count :lvalue { $count } method inc { $count++ }; } # Counter::count has both :lvalue :method attrs { is_deeply( [ sort +attributes::get( \&Counter::count ) ], [ 'lvalue', 'method' ], 'attributes of &Counter::count' ); } { my $counter = Counter->new; is( $counter->count, 0, 'count is initially 0'); $counter->count = 4; $counter->inc; is( $counter->count, 5, 'count is 5' ); } class TwiceCounter :isa(Counter) { method inc :override { $self->SUPER::inc; $self->SUPER::inc; } } done_testing; Object-Pad-0.61/t/11method-signatures.t000444001750001750 140314203242261 16454 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; BEGIN { $] >= 5.026000 or plan skip_all => "No parse_subsignature()"; } use Object::Pad; class List { has @values; method push ( @more ) { push @values, @more } method nshift ( $n ) { splice @values, 0, $n } } { my $l = List->new; $l->push(qw( a b c d )); is_deeply( [ $l->nshift( 2 ) ], [qw( a b )], '$l->nshift yields values' ); } class Greeter { has $_who; BUILD ( %args ) { $_who = $args{who}; } method greet ( $message = "Hello, $_who" ) { return $message; } } { my $g = Greeter->new(who => "unit test"); is( $g->greet, "Hello, unit test", 'subroutine signature default exprs can see instance fields' ); } done_testing; Object-Pad-0.61/t/12method-private.t000444001750001750 113214203242261 15742 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; class AClass { has $data :param; my $priv = method { "data<$data>"; }; method m { return $self->$priv } } { my $obj = AClass->new( data => "value" ); is( $obj->m, "data", 'method can invoke captured method ref' ); } class BClass { has $data :param; method $priv { "data<$data>"; } method m { return $self->$priv } } { my $obj = BClass->new( data => "second" ); is( $obj->m, "data", 'method can invoke private lexical method' ); } done_testing; Object-Pad-0.61/t/20fields-private.t000444001750001750 100014203242261 15721 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; class Base::Class { has $data; method data { $data } BUILD { $data = "base data" } } class Derived::Class :isa(Base::Class) { has $data; method data { $data } BUILD { $data = "derived data"; } } { my $c = Derived::Class->new; is( $c->data, "derived data", 'subclass wins methods' ); is( $c->Base::Class::data, "base data", 'base class still accessible' ); } done_testing; Object-Pad-0.61/t/21fields-capture.t000444001750001750 125714203242261 15731 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; class Counter { has $count; method inc { $count++ }; method make_incrsub { return sub { $count++ }; } method count { $count } } { my $counter = Counter->new; my $inc = $counter->make_incrsub; $inc->(); $inc->(); is( $counter->count, 2, '->count after invoking incrsub' ); } # RT132249 { class Widget { has $_menu; method popup_menu { my $on_activate = sub { undef $_menu }; } method on_mouse { } } # If we got to here without crashing then the test passed pass( 'RT132249 did not cause a crash' ); } done_testing; Object-Pad-0.61/t/22fields-accesssors.t000444001750001750 557114203242261 16442 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; my $MATCH_ARGCOUNT = # Perl since 5.33.6 adds got-vs-expected counts to croak message $] >= 5.033006 ? qr/ \(got \d+; expected \d+\)/ : ""; class Colour { has $red :reader :writer; has $green :reader(get_green) :writer; has $blue :mutator; has $white :accessor; BUILD { ( $red, $green, $blue, $white ) = @_; } method rgbw { ( $red, $green, $blue, $white ); } } # readers { my $col = Colour->new(50, 60, 70, 80); is( $col->red, 50, '$col->red' ); is( $col->get_green, 60, '$col->get_green' ); is( $col->blue, 70, '$col->blue' ); is( $col->white, 80, '$col->white' ); # Reader complains if given any arguments my $LINE = __LINE__+1; ok( !defined eval { $col->red(55); 1 }, 'reader method complains if given any arguments' ); like( $@, qr/^Too many arguments for subroutine 'Colour::red'$MATCH_ARGCOUNT(?: at \S+ line $LINE\.)?$/, 'exception message from too many arguments to reader' ); class AllTheTypesReader { has @av :reader; has %hv :reader; ADJUST { @av = qw( one two three ); %hv = (one => 1, two => 2); } } my $allthetypes = AllTheTypesReader->new; is_deeply( [ $allthetypes->av ], [qw( one two three )], ':reader on array field' ); is_deeply( { $allthetypes->hv }, { one => 1, two => 2 }, ':reader on hash field' ); is( scalar $allthetypes->av, 3, ':reader on array field in scalar context' ); # On perl 5.26 onwards this yields the number of keys; before that it # stringifies to something like "2/8" but that's not terribly reliable, so # don't bother testing that is( scalar $allthetypes->hv, 2, ':reader on hash field in scalar context' ) if $] >= 5.028; } # writers { my $col = Colour->new; $col->set_red( 80 ); is( $col->set_green( 90 ), $col, '->set_* writer returns invocant' ); $col->blue = 100; $col->white( 110 ); is_deeply( [ $col->rgbw ], [ 80, 90, 100, 110 ], '$col->rgbw after writers' ); # Writer complains if not given enough arguments my $LINE = __LINE__+1; ok( !defined eval { $col->set_red; 1 }, 'writer method complains if given no argument' ); like( $@, qr/^Too few arguments for subroutine 'Colour::set_red'$MATCH_ARGCOUNT(?: at \S+ line $LINE\.)?$/, 'exception message from too few arguments to writer' ); class AllTheTypesWriter { has @av :writer; has %hv :writer; method test { Test::More::is_deeply( \@av, [qw( four five six )], ':writer on array field' ); Test::More::is_deeply( \%hv, { three => 3, four => 4 }, ':writer on hash field' ); } } my $allthetypes = AllTheTypesWriter->new; $allthetypes->set_av(qw( four five six )); $allthetypes->set_hv( three => 3, four => 4 ); $allthetypes->test; } done_testing; Object-Pad-0.61/t/23fields-signatures.t000444001750001750 65514203242261 16435 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; BEGIN { $] >= 5.026000 or plan skip_all => "No parse_subsignature()"; } use Object::Pad; # See also # https://rt.cpan.org/Ticket/Display.html?id=134456 class C { has $x = "initial"; method m ( $x = $x ) { $x; } } package main; my $obj = C->new; is( $obj->m, "initial", 'initial'); is( $obj->m( "new" ), "new", 'new value'); done_testing; Object-Pad-0.61/t/24fields-constructor.t000444001750001750 264714203242261 16662 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; class Point { has $x :param; has $y :param = 0; method pos { return ( $x, $y ); } } { my $point = Point->new( x => 10 ); is_deeply( [ $point->pos ], [ 10, 0 ], 'Point with default y' ); } { my $point = Point->new( x => 30, y => 40 ); is_deeply( [ $point->pos ], [ 30, 40 ], 'Point fully specified' ); } class Point3D :isa(Point) { has $z :param = 0; method pos { return ( $self->next::method, $z ) } } { my $point = Point3D->new( x => 50, y => 60, z => 70 ); is_deeply( [ $point->pos ], [ 50, 60, 70 ], 'Point3D inherits params' ); } # Required params checking { my $LINE = __LINE__+1; ok( !defined eval { Point->new(); 1 }, 'constructor complains about missing required params' ); like( $@, qr/^Required parameter 'x' is missing for Point constructor at \S+ line $LINE\./, 'exception message from missing parameter' ); } # Strict params checking { class Colour :strict(params) { has $red :param = 0; has $green :param = 0; has $blue :param = 0; } my $LINE = __LINE__+1; ok( !defined eval { Colour->new( yellow => 1 ); 1 }, 'constructor complains about unrecognised param name' ); like( $@, qr/^Unrecognised parameters for Colour constructor: yellow at \S+ line $LINE\./, 'exception message from unrecognised parameter' ); } done_testing; Object-Pad-0.61/t/25fields-weak.t000444001750001750 210014203242261 15205 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Test::Refcount; use Object::Pad; my $arr = []; class WithWeak { has $one = 1; has $field :writer :param :weak; has $two = 2; } is_oneref( $arr, '$arr has one reference before we start' ); { my $obj = WithWeak->new( field => $arr ); is_oneref( $arr, '$arr has one reference after WithWeak construction' ); } { my $obj = WithWeak->new( field => [] ); $obj->set_field( $arr ); is_oneref( $arr, '$arr has one reference after WithWeak mutator' ); } # RT139665 { class subWithWeak :isa(WithWeak) { has $three = 3; } my $obj = subWithWeak->new( field => $arr ); is_oneref( $arr, '$arr has one reference after subWithWeak construction' ); } { class WithInnerHelper { has $field :writer :param :weak; class InnerHelperClass :isa(WithInnerHelper) {} } my $obj = InnerHelperClass->new( field => $arr ); is_oneref( $arr, '$arr has one reference after InnerHelperClass construction' ); } is_oneref( $arr, '$arr has one reference before EOF' ); done_testing; Object-Pad-0.61/t/26fields-initexpr.t000444001750001750 263214203242261 16133 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; # initexprs can capture regular class-level lexicals { class SerialNumbered { my $next_seq = 1; has $seq :reader { $next_seq++ }; } is( SerialNumbered->new->seq, 1, 'first instance 1' ); is( SerialNumbered->new->seq, 2, 'second instance 2' ); } # state works correctly inside them { class SerialNumberedByState { has $seq :reader { state $next = 1; $next++ } } is( SerialNumberedByState->new->seq, 1, 'first instance 1 by state' ); is( SerialNumberedByState->new->seq, 2, 'second instance 2 by state' ); } # initexprs run in declared order { my @inited; class WithThreeFields { has $x { push @inited, "x" }; has $y { push @inited, "y" }; has $z { push @inited, "z" }; } WithThreeFields->new; is_deeply( \@inited, [qw( x y z )], 'initexprs run in declared order' ); } # :param overrides initexpr { my %init_called; class WithParams { has $one :param :reader { $init_called{one} = 1 }; has $two :param :reader { $init_called{two} = 2 }; } my $obj = WithParams->new( one => 11 ); is( $obj->one, 11, ':param overrode initexpr' ); ok( !exists $init_called{one}, ':param stopped initexpr running' ); is( $obj->two, 2, 'unpassed :param still used initexpr' ); is( $init_called{two}, 2, 'unpassed :param still ran initexpr' ); } done_testing; Object-Pad-0.61/t/30unit-class.t000444001750001750 45014203242261 15056 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; class Counter; has $count = 0; method count :lvalue { $count } method inc { $count++ } package main; { my $counter = Counter->new; $counter->inc; is( $counter->count, 1, 'Count is now 1' ); } done_testing; Object-Pad-0.61/t/31pad-outside.t000444001750001750 156614203242261 15244 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; { class Counter { has $count; my $allcount = 0; method inc { $count++; $allcount++ } method count { $count } sub allcount { $allcount } } my $countA = Counter->new; my $countB = Counter->new; $countA->inc; $countB->inc; is( $countA->count, 1, '$countA->count' ); is( Counter->allcount, 2, 'Counter->allcount' ); } # anon methods can capture lexicals (RT132178) { class Generated { foreach my $letter (qw( x y z )) { my $code = method { return uc $letter; }; no strict 'refs'; *$letter = $code; } } my $g = Generated->new; is( $g->x, "X", 'generated anon method' ); is( $g->y, "Y", 'generated anon method' ); is( $g->z, "Z", 'generated anon method' ); } done_testing; Object-Pad-0.61/t/40role.t000444001750001750 324114203242261 13757 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; role ARole { method one { return 1 } method own_cvname { return +(caller(0))[3]; } } class AClass :does(ARole) { } { my $obj = AClass->new; isa_ok( $obj, "AClass", '$obj' ); is( $obj->one, 1, 'AClass has a ->one method' ); is( $obj->own_cvname, "AClass::own_cvname", '->own_cvname sees correct subname' ); } role BRole { method two { return 2 } } class BClass :does(ARole) :does(BRole) { } { my $obj = BClass->new; is( $obj->one, 1, 'BClass has a ->one method' ); is( $obj->two, 2, 'BClass has a ->two method' ); is( $obj->own_cvname, "BClass::own_cvname", '->own_cvname sees correct subname' ); } role CRole { method three; } class CClass :does(CRole) { method three { return 3 } } pass( 'CClass compiled OK' ); # Because we store embedding info in the pad of a method CV, we should check # that recursion and hence CvDEPTH > 1 works fine { role RecurseRole { method recurse { my ( $x ) = @_; return $x ? $self->recurse( $x - 1 ) + 1 : 0; } } class RecurseClass :does(RecurseRole) {} is( RecurseClass->new->recurse( 5 ), 5, 'role methods can be reëntrant' ); } role DRole :does(BRole) { method four { return 4 } } class DClass :does(DRole) { } { my $obj = DClass->new; is( $obj->four, 4, 'DClass has DRole method' ); is( $obj->two, 2, 'DClass inherited BRole method' ); } role ERole :does(ARole) :does(BRole) { } class EClass :does(ERole) { } { my $obj = EClass->new; is( $obj->one, 1, 'EClass has a ->one method' ); is( $obj->two, 2, 'EClass has a ->two method' ); } done_testing; Object-Pad-0.61/t/41role-repr.t000444001750001750 105414203242261 14726 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; role ARole { method one { return 1 } } package Base::HASH { sub new { bless {}, shift } } class Derived::HASH :isa(Base::HASH) :does(ARole) { } { my $obj = Derived::HASH->new; is( $obj->one, 1, 'Derived::HASH has a ->one method' ); } package Base::ARRAY { sub new { bless [], shift } } class Derived::ARRAY :isa(Base::ARRAY) :does(ARole) { } { my $obj = Derived::ARRAY->new; is( $obj->one, 1, 'Derived::ARRAY has a ->one method' ); } done_testing; Object-Pad-0.61/t/42role-BUILD.t000444001750001750 146214203242261 14621 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; my @BUILD; my @ADJUST; role ARole { BUILD { push @BUILD, "ARole" } ADJUST { push @ADJUST, "ARole" } } class AClass :does(ARole) { BUILD { push @BUILD, "AClass" } ADJUST { push @ADJUST, "AClass" } } { undef @BUILD; undef @ADJUST; AClass->new; is_deeply( \@BUILD, [qw( ARole AClass )], 'Roles are built before their implementing classes' ); is_deeply( \@ADJUST, [qw( ARole AClass )], 'Roles are adjusted before their implementing classes' ); } class BClass :isa(AClass) :does(ARole) { BUILD { push @BUILD, "BClass" } } { undef @BUILD; BClass->new; is_deeply( \@BUILD, [qw( ARole AClass BClass )], 'Roles are built once only even if implemented multiple times' ); } done_testing; Object-Pad-0.61/t/43role-fields.t000444001750001750 331014203242261 15223 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Test::Refcount; use Object::Pad; role ARole { has $one = 1; method one { $one } } class AClass :does(ARole) { has $two = 2; method two { $two } } { my $obj = AClass->new; isa_ok( $obj, "AClass", '$obj' ); is( $obj->one, 1, 'AClass has a ->one method' ); is( $obj->two, 2, 'AClass has a ->two method' ); } class BClass :isa(AClass) { has $three = 3; method three { $three } } { my $obj = BClass->new; is( $obj->one, 1, 'BClass has a ->one method' ); is( $obj->two, 2, 'BClass has a ->two method' ); is( $obj->three, 3, 'BClass has a ->three method' ); } role CRole :does(ARole) { has $three = 3; method three { $three } } class CClass :does(CRole) {} # role fields via composition { my $obj = CClass->new; is( $obj->one, 1, 'CClass has a ->one method' ); is( $obj->three, 3, 'CClass has a ->three method' ); } # diamond inheritence scenario { role DRole { has $field = 1; ADJUST { $field++ } method field { $field } } role D1Role :does(DRole) {} role D2Role :does(DRole) {} role DxRole :does(D1Role) :does(D2Role) {} class DClass :does(D1Role) :does(D2Role) {} my $obj1 = DClass->new; is( $obj1->field, 2, 'DClass->field is 2 via diamond' ); class DxClass :does(DxRole) {} my $obj2 = DxClass->new; is( $obj2->field, 2, 'DxClass->field is 2 via diamond' ); } # RT139665 { my $arr = []; role WithWeakRole { has $field :param :weak; } class implWithWeak :does(WithWeakRole) {} my $obj = implWithWeak->new( field => $arr ); is_oneref( $arr, '$arr has one reference after implWithWeak constructor' ); } done_testing; Object-Pad-0.61/t/44role-accessors.t000444001750001750 67114203242261 15732 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; role ARole { has $one :reader = 1; } class AClass :does(ARole) { } # RT136507 { my $obj = AClass->new; is( $obj->one, 1, '$obj->one is visible' ); } role BRole { has $data :reader :param; } class BClass :does(BRole) { } { my $obj = BClass->new( data => 123 ); is( $obj->data, 123, 'BClass constructor takes role params' ); } done_testing; Object-Pad-0.61/t/45role-does.t000444001750001750 366414203242261 14725 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; role ARole { } class AClass :does(ARole) { } { my $obj = AClass->new; ok( $obj->DOES( "ARole" ), 'AClass::DOES ARole' ); ok( $obj->DOES( "AClass" ), 'AClass::DOES AClass' ); ok( AClass->DOES( "ARole" ), 'DOES works as a class method' ); } role BRole { } class BClass :does(ARole) :does(BRole) { } { my $obj = BClass->new; ok( $obj->DOES( "ARole" ), 'BClass::DOES ARole' ); ok( $obj->DOES( "BRole" ), 'BClass::DOES BRole' ); } role CRole { } class CClass :does(CRole) { } { my $obj = CClass->new; ok( $obj->DOES( "CRole" ), 'CClass::DOES CRole' ); ok( !$obj->DOES( "ARole" ), 'CClass::DOES NOT ARole' ); ok( !$obj->DOES( "BRole" ), 'CClass::DOES NOT BRole' ); } class ABase :does(ARole) { } class ADerived :isa(ABase) { } { ok( ABase->DOES( "ARole" ), 'Sanity?' ); ok( ADerived->DOES( "ARole" ), 'Derived class DOES base class roles' ); ok( ABase->DOES( "ABase" ), 'Classes are also roles' ); ok( ADerived->DOES( "ABase" ), 'DOES implies isa' ); } package FBaseOne { sub new { return bless {}, shift; } } class FClassOne :isa(FBaseOne) :does(CRole) { } { ok( FClassOne->DOES( "CRole" ), 'Our role on a class with foreign base' ); ok( FClassOne->DOES( "FBaseOne" ), 'Foreign base class itself' ); } package FBaseTwo { sub new { return bless {}, shift; } sub DOES { my $self = shift; my $role = shift; if( $role =~ m/^FakeRole\d+/ ) { return 1; } return $self->SUPER::DOES( $role ); } } class FClassTwo :isa(FBaseTwo) :does(ARole) { } { ok( FClassTwo->DOES( "ARole" ), 'Our role on a class with foreign base' ); ok( FClassTwo->DOES( "FakeRole42" ), 'Foreign base class DOES method' ); } role DRole :does(ARole) { } class DClass :does(DRole) { } { ok( DClass->DOES( "DRole" ), 'Sanity?' ); ok( DClass->DOES( "ARole" ), 'Class does role inherited by role' ); } done_testing; Object-Pad-0.61/t/49role-compat.t000444001750001750 75514203242261 15240 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; role ARole :compat(invokable) { method one { return 1 } method redir { return $self->two } } # A classical perl class package AClass { use base 'ARole'; sub new { bless [], shift } sub two { return 2 } } { my $obj = AClass->new; isa_ok( $obj, "AClass", '$obj' ); is( $obj->one, 1, 'AClass has a ->one method' ); is( $obj->redir, 2, 'AClass has a ->redir method' ); } done_testing; Object-Pad-0.61/t/50croak-method.t000444001750001750 107314203242261 15375 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; class Point { has $x; method clear { $x = 0 } } { ok( !eval { Point->clear }, 'method on non-instance fails' ); like( $@, qr/^Cannot invoke method on a non-instance /, 'message from method on non-instance' ); } { my $obj = bless [], "DifferentClass"; ok( !eval { $obj->Point::clear }, 'method on wrong class fails' ); like( $@, qr/^Cannot invoke foreign method on non-derived instance /, 'message from method on wrong class' ); } done_testing; Object-Pad-0.61/t/51pragmata.t000444001750001750 346214203242261 14621 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; { no strict; $abc = $abc; # to demostrate strict is off ok( !eval <<'EOPERL', class TestStrict { sub x { $def = $def; } } EOPERL 'class scope implies use strict' ); like( $@, qr/^Global symbol "\$def" requires explicit package name /, 'message from failure of use strict' ); } { my $warnings = ""; local $SIG{__WARN__} = sub { $warnings .= join "", @_; }; ok( defined eval <<'EOPERL', no warnings; class TestWarnings { my $str = undef . "boo"; } EOPERL 'class scope compiles for warnings test' ); like( $warnings, qr/^Use of uninitialized value in concatenation \(\.\) or string at /, 'warning from uninitialized value test' ); } SKIP: { # TODO: Work out why and fix it skip "'no indirect' doesn't appear to work on this perl", 2 if $] < 5.020; my $warnings = ""; local $SIG{__WARN__} = sub { $warnings .= join "", @_; }; ok( !eval <<'EOPERL', class TestIndirect { sub x { foo Test->new(1,2,3) } } 1; EOPERL 'class scope implies no indirect' ); my $e = $@; if( $] >= 5.031009 ) { # On perl 5.31.9 onwards we use core's no feature 'indirect' which has # different error semantics. It gives a generic "syntax error" plus # warnings like( $warnings, qr/^Bareword found where operator expected at \(eval /, 'warnings from failure of no feature "indirect"' ); like( $e, qr/^syntax error at \(eval /, 'error result from failure of no feature "indirect"' ); } else { like( $e, qr/^Indirect call of method "foo" on object "Test" /, 'message from failure of no indirect' ); } } done_testing; Object-Pad-0.61/t/52croak-scope.t000444001750001750 122714203242261 15231 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; { ok( !eval <<'EOPERL', has $field; EOPERL 'has outside class fails' ); like( $@, qr/^Cannot 'has' outside of 'class' at /, 'message from failure of has' ); } # RT132337 { ok( !eval <<'EOPERL', class AClass { } has $field; EOPERL 'has after closed class block fails' ); like( $@, qr/^Cannot 'has' outside of 'class' at /); } { ok( !eval <<'EOPERL', method m() { } EOPERL 'method outside class fails' ); like( $@, qr/^Cannot 'method' outside of 'class' at /, 'message from failure of method' ); } done_testing; Object-Pad-0.61/t/53croak-override.t000444001750001750 55714203242261 15725 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; { ok( !eval <<'EOPERL', class Example { method thing :override { } } EOPERL 'method :override without matching superclass method fails' ); like( $@, qr/^Superclass does not have a method named 'thing'/, 'message from failure of :override' ); } done_testing; Object-Pad-0.61/t/54croak-role.t000444001750001750 227314203242261 15065 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; { role ARole { method m {} } my $warnings; $SIG{__WARN__} = sub { $warnings .= join "", @_ }; ok( !eval <<'EOPERL', class AClass does ARole { method m {} } EOPERL 'class with clashing method name fails' ); like( $@, qr/^Method 'm' clashes with the one provided by role ARole /, 'message from failure of clashing method' ); ok( !eval { ( bless {}, "ARole" )->m() }, 'direct invoke on role method fails' ); like( $@, qr/^Cannot invoke a role method directly /, 'message from failure to directly invoke role method' ); } { role BRole { requires bmeth; } ok( !eval <<'EOPERL', class BClass does BRole { } EOPERL 'class with missing required method fails' ); like( $@, qr/^Class BClass does not provide a required method named 'bmeth' /, 'message from failure of missing method' ); } { ok( !eval <<'EOPERL', role CRole :compat(invokable) { has $field; } EOPERL 'invokable role with field fails' ); like( $@, qr/^Cannot add field data to an invokable role /, 'message from failure of invokable role with field' ); } done_testing; Object-Pad-0.61/t/60mop-class.t000444001750001750 124214203242261 14715 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; class Example { } my $meta = Object::Pad::MOP::Class->for_class( "Example" ); is( $meta->name, "Example", '$meta->name' ); ok( $meta->is_class, '$meta->is_class true' ); ok( !$meta->is_role, '$meta->is_role false' ); is_deeply( [ $meta->superclasses ], [], '$meta->superclasses' ); is_deeply( [ $meta->direct_roles ], [], '$meta->direct_roles' ); is_deeply( [ $meta->all_roles ], [], '$meta->all_roles' ); class Example2 :isa(Example) {} is_deeply( [ Object::Pad::MOP::Class->for_class( "Example2" )->superclasses ], [ $meta ], '$meta->superclasses on subclass' ); done_testing; Object-Pad-0.61/t/61mop-create-class.t000444001750001750 162014203242261 16157 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; { package AClass { BEGIN { Object::Pad->import_into( "AClass" ); my $classmeta = Object::Pad::MOP::Class->begin_class( "AClass" ); ::is( $classmeta->name, "AClass", '$classmeta->name' ); } method message { return "Hello" } } is( AClass->new->message, "Hello", '->begin_class can create a class' ); } class Parent { has $thing = "parent"; } { package Child { BEGIN { Object::Pad->import_into( "Child" ); my $classmeta = Object::Pad::MOP::Class->begin_class( "Child", isa => "Parent" ); ::is( $classmeta->name, "Child", '$classmeta->name for Child' ); } has $other = "child"; method other { return $other } } is( Child->new->other, "child", '->begin_class can extend superclasses' ); } done_testing; Object-Pad-0.61/t/62mop-field.t000444001750001750 532014203242261 14676 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Test::Fatal; use Object::Pad; class Example { has $field :mutator :param(initial_field) = undef; } my $classmeta = Object::Pad::MOP::Class->for_class( "Example" ); my $fieldmeta = $classmeta->get_field( '$field' ); is( $fieldmeta->name, "\$field", '$fieldmeta->name' ); is( $fieldmeta->sigil, "\$", '$fieldmeta->sigil' ); is( $fieldmeta->class->name, "Example", '$fieldmeta->class gives class' ); ok( $fieldmeta->has_attribute( "mutator" ), '$fieldmeta has "mutator" attribute' ); is( $fieldmeta->get_attribute_value( "mutator" ), "field", 'value of $fieldmeta "mutator" attribute' ); is( $fieldmeta->get_attribute_value( "param" ), "initial_field", 'value of $fieldmeta "param" attribute' ); is_deeply( [ $classmeta->fields ], [ $fieldmeta ], '$classmeta->fields' ); # $fieldmeta->value as accessor { my $obj = Example->new; $obj->field = "the value"; is( $fieldmeta->value( $obj ), "the value", '$fieldmeta->value as accessor' ); } # $fieldmeta->value as mutator { my $obj = Example->new; $fieldmeta->value( $obj ) = "a new value"; is( $obj->field, "a new value", '$obj->field after $fieldmeta->value as mutator' ); } # fieldmeta on roles (RT138927) { role ARole { has $data = 42; } my $fieldmeta = Object::Pad::MOP::Class->for_class( 'ARole' )->get_field( '$data' ); is( $fieldmeta->name, '$data', '$fieldmeta->name for field of role' ); class AClass :does(ARole) { has $data = 21; } my $obja = AClass->new; is( $fieldmeta->value( $obja ), 42, '$fieldmeta->value as accessor on role instance fetches correct field' ); class BClass :isa(AClass) { has $data = 63; } my $objb = BClass->new; is( $fieldmeta->value( $objb ), 42, '$fieldmeta->value as accessor on role instance subclass fetches correct field' ); } # RT136869 { class A { has @arr; BUILD { @arr = (1,2,3) } method m { @arr } } role R { has $data :param; } class B :isa(A) :does(R) {} is_deeply( [ B->new( data => 456 )->m ], [ 1, 2, 3 ], 'Role params are embedded correctly' ); } # Forbid writing to non-scalar fields via ->value { class List { has @values; } my $arrayfieldmeta = Object::Pad::MOP::Class->for_class( "List" ) ->get_field( '@values' ); like( exception { no warnings; $arrayfieldmeta->value( List->new ) = [] }, qr/^Modification of a read-only value attempted at /, 'Attempt to set value of list field fails' ); my $e; ok( !defined( $e = exception { @{ $arrayfieldmeta->value( List->new ) } = (1,2,3) } ), '->value accessor still works fine' ) or diag( "Exception was $e" ); } done_testing; Object-Pad-0.61/t/63mop-create-field.t000444001750001750 436714203242261 16152 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; class AClass { use Test::More; use Test::Fatal; BEGIN { # Most of this test has to happen at BEGIN time before AClass gets # sealed my $classmeta = Object::Pad::MOP::Class->for_caller; my $fieldmeta = $classmeta->add_field( '$field', default => 100, param => "field", ); is( $fieldmeta->name, "\$field", '$fieldmeta->name' ); like( exception { $classmeta->add_field( undef ) }, qr/^fieldname must not be undefined or empty /, 'Failure from ->add_field undef' ); like( exception { $classmeta->add_field( "" ) }, qr/^fieldname must not be undefined or empty /, 'Failure from ->add_field on empty string' ); like( exception { $classmeta->add_field( "foo" ) }, qr/^fieldname must begin with a sigil /, 'Failure from ->add_field without sigil' ); like( exception { $classmeta->add_field( '$field' ) }, qr/^Cannot add another field named \$field /, 'Failure from ->add_field duplicate' ); ok( *field = eval( 'method :lvalue { $field }' ), 'Can compile method with lexical $field' ); my $anonfield = $classmeta->add_field( '$' ); *anonfield = sub :lvalue { $anonfield->value( shift ) }; ok( !exception { $classmeta->add_field( '$' ) }, 'Can add a second anonymous field' ); { '$magic' =~ m/^(.*)$/; my $fieldmeta = $classmeta->add_field( $1 ); 'different' =~ m/^(.*)$/; is( $fieldmeta->name, '$magic', '->add_field captures FETCH magic' ); } $classmeta->add_field( '$field_with_accessors', reader => "get_swa", writer => "set_swa", ); } } { my $obj = AClass->new; is( $obj->field, 100, '->field default value' ); $obj->field = 10; is( $obj->field, 10, '->field accessor works' ); $obj->anonfield = 20; is( $obj->anonfield, 20, '->anonfield accessor works' ); $obj->set_swa( 30 ); is( $obj->get_swa, 30, '->get_swa sees value to ->set_swa' ); } # param name to constructor { my $obj = AClass->new( field => 50 ); is( $obj->field, 50, 'field was initialised from named param' ); } done_testing; Object-Pad-0.61/t/64mop-method.t000444001750001750 207014203242261 15074 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Test::Fatal; use Object::Pad; class Example { method m { } } my $classmeta = Object::Pad::MOP::Class->for_class( "Example" ); my $methodmeta = $classmeta->get_direct_method( 'm' ); is( $methodmeta->name, "m", '$methodmeta->name' ); is( $methodmeta->class->name, "Example", '$methodmeta->class gives class' ); is( $classmeta->get_method( 'm' )->name, "m", '$classmeta->get_method' ); is_deeply( [ $classmeta->direct_methods ], [ $methodmeta ], '$classmeta->direct_methods' ); is_deeply( [ $classmeta->all_methods ], [ $methodmeta ], '$classmeta->all_methods' ); class SubClass :isa(Example) {} ok( defined Object::Pad::MOP::Class->for_class( "SubClass" )->get_method( 'm' ), 'Subclass can ->get_method' ); # subclass with overridden method { class WithOverride :isa(Example) { method m { "different" } } my @methodmetas = Object::Pad::MOP::Class->for_class( "WithOverride" )->all_methods; is( scalar @methodmetas, 1, 'overridden method is not duplicated' ); } done_testing; Object-Pad-0.61/t/65mop-create-method.t000444001750001750 244014203242261 16337 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; class AClass { use Test::More; use Test::Fatal; BEGIN { # Most of this test has to happen at BEGIN time before AClass gets # sealed my $classmeta = Object::Pad::MOP::Class->for_caller; my $methodmeta = $classmeta->add_method( 'method', sub { return "result"; } ); is( $methodmeta->name, "method", '$methodmeta->name' ); like( exception { $classmeta->add_method( undef, sub {} ) }, qr/^methodname must not be undefined or empty /, 'Failure from ->add_method undef' ); like( exception { $classmeta->add_method( "", sub {} ) }, qr/^methodname must not be undefined or empty /, 'Failure from ->add_method on empty string' ); like( exception { $classmeta->add_method( 'method', sub {} ) }, qr/^Cannot add another method named method /, 'Failure from ->add_method duplicate' ); { 'magic' =~ m/^(.*)$/; my $methodmeta = $classmeta->add_method( $1, sub {} ); 'different' =~ m/^(.*)$/; is( $methodmeta->name, 'magic', '->add_method captures FETCH magic' ); } } } { my $obj = AClass->new; is( $obj->method, "result", '->method works' ); } done_testing; Object-Pad-0.61/t/66mop-role.t000444001750001750 224414203242261 14562 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; role Example { method a_method; requires b_method; } my $meta = Object::Pad::MOP::Class->for_class( "Example" ); is( $meta->name, "Example", '$meta->name' ); ok( $meta->is_role, '$meta->is_role true' ); ok( !$meta->is_class, '$meta->is_class false' ); is_deeply( [ $meta->required_method_names ], [qw( a_method b_method )], '$meta->required_method_names' ); class Implementor :does(Example) { method a_method {} method b_method {} } is_deeply( [ Object::Pad::MOP::Class->for_class( "Implementor" )->direct_roles ], [ $meta ], '$meta->direct_roles on implementing class' ); is_deeply( [ Object::Pad::MOP::Class->for_class( "Implementor" )->all_roles ], [ $meta ], '$meta->all_roles on implementing class' ); class Inheritor :isa(Implementor) {} # Roles via subclass { is_deeply( [ Object::Pad::MOP::Class->for_class( "Inheritor" )->direct_roles ], [], '$meta->direct_roles on inheriting class' ); is_deeply( [ Object::Pad::MOP::Class->for_class( "Inheritor" )->all_roles ], [ $meta ], '$meta->all_roles on inheriting class' ); } done_testing; Object-Pad-0.61/t/67mop-create-role.t000444001750001750 157214203242261 16027 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; { package ARole { BEGIN { Object::Pad->import_into( "ARole" ); my $rolemeta = Object::Pad::MOP::Class->begin_role( "ARole" ); $rolemeta->add_field( '$field', param => "role_field", reader => "get_role_field", ); $rolemeta->add_required_method( 'some_method' ); } } } { class AClass :does(ARole) { method some_method {} } my $obj = AClass->new( role_field => "the field value" ); is( $obj->get_role_field, "the field value", 'instance field accessible via role' ); } { ok( !eval "class BClass :does(ARole) { }", 'BClass does not compile' ); like( $@, qr/^Class BClass does not provide a required method named 'some_method' at /, 'message from failure to compile BClass' ); } done_testing; Object-Pad-0.61/t/68mop-compose-role.t000444001750001750 152614203242261 16231 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; role TheRole { method m {} } { class AClass { BEGIN { Object::Pad::MOP::Class->for_caller->compose_role( "TheRole" ); } } my $ameta = Object::Pad::MOP::Class->for_class( "AClass" ); is_deeply( [ map { $_->name } $ameta->direct_roles ], [qw( TheRole )], 'AClass meta ->direct_roles' ); can_ok( AClass->new, qw( m ) ); } { class BClass { BEGIN { Object::Pad::MOP::Class->for_caller->compose_role( Object::Pad::MOP::Class->for_class( "TheRole" ) ); } } my $bmeta = Object::Pad::MOP::Class->for_class( "BClass" ); is_deeply( [ map { $_->name } $bmeta->direct_roles ], [qw( TheRole )], 'BClass meta ->direct_roles' ); can_ok( BClass->new, qw( m ) ); } done_testing; Object-Pad-0.61/t/69mop-generated.t000444001750001750 153114203242261 15560 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; # An attempt to programmatically generate everything BEGIN { # we don't need `package Point` here any more my $classmeta = Object::Pad::MOP::Class->create_class( "Point" ); my $xfieldmeta = $classmeta->add_field( '$x' ); my $yfieldmeta = $classmeta->add_field( '$y' ); $classmeta->add_BUILD( sub { my $self = shift; my ( $x, $y ) = @_; $xfieldmeta->value($self) = $x; $yfieldmeta->value($self) = $y; } ); $classmeta->add_method( describe => sub { my $self = shift; return sprintf "Point(%d, %d)", $xfieldmeta->value($self), $yfieldmeta->value($self); } ); $classmeta->seal; } { my $point = Point->new( 10, 20 ); is( $point->describe, "Point(10, 20)", '$point->describe' ); } done_testing; Object-Pad-0.61/t/70mop-custom-fieldattr.t000444001750001750 174614203242261 17110 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; Object::Pad::MOP::FieldAttr->register( SomeAttr => permit_hintkey => "t/SomeAttr", apply => sub { my ( $fieldmeta, $value ) = @_; ::is( $value, "the value", '$value passed to apply callback' ); return "stored result"; }, ); ok( defined eval <<'EOPERL', BEGIN { $^H{"t/SomeAttr"}++ } class MyClass { has $x; has $y :SomeAttr(the value); } EOPERL 'class using field attribute can be compiled' ) or diag( "Failure was $@" ); { # SomeAttr needs to be lexically in scope for lookups to find it BEGIN { $^H{"t/SomeAttr"}++ } my $classmeta = Object::Pad::MOP::Class->for_class( "MyClass" ); my $fieldmeta = $classmeta->get_field( '$y' ); ok( $fieldmeta->has_attribute( "SomeAttr" ), '$y field has :SomeAttr' ); is( $fieldmeta->get_attribute_value( "SomeAttr" ), "stored result", 'stored value for :SomeAttr' ); } done_testing; Object-Pad-0.61/t/80async-method.t000444001750001750 406414203242261 15421 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Test::Refcount; BEGIN { plan skip_all => "Future is not available" unless eval { require Future }; plan skip_all => "Future::AsyncAwait >= 0.45 is not available" unless eval { require Future::AsyncAwait; Future::AsyncAwait->VERSION( '0.45' ) }; plan skip_all => "Object::Pad >= 0.41 is not available" unless eval { require Object::Pad; Object::Pad->VERSION( '0.41' ) }; Future::AsyncAwait->import; Object::Pad->import; diag( "Future::AsyncAwait $Future::AsyncAwait::VERSION, " . "Object::Pad $Object::Pad::VERSION" ); } # async method { class Thunker { has $_times_thunked = 0; method count { $_times_thunked } async method thunk { my ( $f ) = @_; await $f; $_times_thunked++; return "result"; } } my $thunker = Thunker->new; is_oneref( $thunker, 'after ->new' ); my $f1 = Future->new; my $fret = $thunker->thunk( $f1 ); is_refcount( $thunker, 3, 'during async sub' ); # +1 because $self, +1 because of @(Object::Pad/slots) pseudolexical is( $thunker->count, 0, 'count is 0 before $f1->done' ); $f1->done; is_oneref( $thunker, 'after ->done' ); is( $thunker->count, 1, 'count is 1 after $f1->done' ); is( $fret->get, "result", '$fret for await in async method' ); } # RT133564 { # Hard to test this one but running the test itself shouldn't produce any # warnings of "Attempt to free unreferenced scalar ..." my $thunker = Thunker->new; eval { my $f = $thunker->thunk( Future->new ); die "Oopsie\n"; }; ok( 1, "No segfault for RT133564 test" ); } # RT137649 { my $waitf; role Role { async method m { await $waitf = Future->new } } class Class :does(Role) {} my $obj = Class->new; my $f1 = $obj->m; $waitf->done( "first" ); is( await $f1, "first", 'First call OK' ); my $f2 = $obj->m; $waitf->done( "second" ); is( await $f2, "second", 'Second call OK' ); } done_testing; Object-Pad-0.61/t/80dynamically+Object-Pad.t000444001750001750 135514203242261 17240 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; BEGIN { plan skip_all => "Syntax::Keyword::Dynamically is not available" unless eval { require Syntax::Keyword::Dynamically }; plan skip_all => "Object::Pad is not available" unless eval { require Object::Pad }; Syntax::Keyword::Dynamically->import; Object::Pad->import; } class Datum { has $value = 1; method value { $value } method test { Test::More::is( $self->value, 1, 'value is 1 initially' ); { dynamically $value = 2; Test::More::is( $self->value, 2, 'value is 2 inside dynamically-assigned block' ); } Test::More::is( $self->value, 1, 'value is 1 finally' ); } } Datum->new->test; done_testing; Object-Pad-0.61/t/81async-method+dynamically.t000444001750001750 336114203242261 17723 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; BEGIN { plan skip_all => "Future is not available" unless eval { require Future }; plan skip_all => "Future::AsyncAwait >= 0.40 is not available" unless eval { require Future::AsyncAwait; Future::AsyncAwait->VERSION( '0.40' ) }; plan skip_all => "Object::Pad >= 0.15 is not available" unless eval { require Object::Pad; Object::Pad->VERSION( '0.15' ) }; plan skip_all => "Syntax::Keyword::Dynamically >= 0.04 is not available" unless eval { require Syntax::Keyword::Dynamically; Syntax::Keyword::Dynamically->VERSION( '0.04' ) }; Future::AsyncAwait->import; Object::Pad->import; Syntax::Keyword::Dynamically->import; diag( "Future::AsyncAwait $Future::AsyncAwait::VERSION, " . "Object::Pad $Object::Pad::VERSION, " . "Syntax::Keyword::Dynamically $Syntax::Keyword::Dynamically::VERSION" ); } # dynamically inside an async method { my $after_level; class Logger { has $_level = 1; method level { $_level } async method verbosely { my ( $code ) = @_; dynamically $_level = $_level + 1; await $code->(); $after_level = $_level; } } my $logger = Logger->new; is( $logger->level, 1, '$logger->level initially' ); my $during_level; my $f1 = Future->new; my $fret = $logger->verbosely(async sub { $during_level = $logger->level; await $f1; }); is( $logger->level, 1, '$logger->level while verbosely suspended' ); is( $during_level, 2, '$during_level' ); $f1->done; is( $after_level, 2, '$after_level' ); is( $logger->level, 1, '$logger->level finally' ); } done_testing; Object-Pad-0.61/t/90leak.t000444001750001750 124214203242261 13736 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; BEGIN { plan skip_all => "Test::MemoryGrowth is not available" unless defined eval { require Test::MemoryGrowth }; Test::MemoryGrowth->import; } use Object::Pad; # RT132332 { class Example { # Needs at least one field member to trigger failures has $thing; # ... and we need to refer to it in a method as well BUILD { $thing } } no_growth { Example->new }; } { class WithContainerFields { has @array; has %hash; BUILD { @array = (); %hash = (); } } no_growth { WithContainerFields->new }; } done_testing; Object-Pad-0.61/t/92legacy-class-keywords.t000444001750001750 175014203242261 17244 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Object::Pad; role ARole { method rolem { "ARole" } } class AClass { method classm { "AClass" } } my $warnings = ""; BEGIN { $SIG{__WARN__} = sub { $warnings .= $_[0] }; } class BClass extends AClass implements ARole {} { my $obj = BClass->new; isa_ok( $obj, "BClass", '$obj' ); is( $obj->rolem, "ARole", 'BClass has ->rolem' ); is( $obj->classm, "AClass", 'BClass has ->classm' ); } BEGIN { like( $warnings, qr/^'extends' is deprecated; use :isa instead /m, 'extends keyword provokes deprecation warnings' ); like( $warnings, qr/^'implements' is deprecated; use :does instead /m, 'implements keyword provokes deprecation warnings' ); undef $SIG{__WARN__}; } class CClass isa AClass does ARole {} { my $obj = CClass->new; isa_ok( $obj, "CClass", '$obj' ); is( $obj->rolem, "ARole", 'CClass has ->rolem' ); is( $obj->classm, "AClass", 'CClass has ->classm' ); } done_testing; Object-Pad-0.61/t/95utf8.t000444001750001750 250414203242261 13717 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use utf8; BEGIN { binmode STDOUT, ":encoding(UTF-8)" } use Test::More; use Object::Pad; # A bunch of test cases with non-ASCII, non-Latin1. Esperanto is good for that # as the accented characters are not in Latin1. my $manĝis; class Sandviĉon { method manĝu { $manĝis++ } has $tranĉaĵoj :param :reader :writer = undef; } my $s = Sandviĉon->new; isa_ok( $s, "Sandviĉon", '$s' ); my $classmeta = Object::Pad::MOP::Class->for_class( "Sandviĉon" ); ok( $classmeta, 'Can obtain classmeta for UTF-8 class name' ); is( $classmeta->name, "Sandviĉon", '$classmeta->name' ); # methods { $s->manĝu; ok( $manĝis, 'UTF-8 method name works' ); my $methodmeta = $classmeta->get_own_method( "manĝu" ); ok( $methodmeta, 'Can obtain methodmeta for UTF-8 method name' ); is( $methodmeta->name, "manĝu", '$methodmeta->name' ); } # fields { # accessors $s->set_tranĉaĵoj( 3 ); is( $s->tranĉaĵoj, 3, 'Can obtain value from field via accessor' ); my $fieldmeta = $classmeta->get_field( '$tranĉaĵoj' ); ok( $fieldmeta, 'Can obtain fieldmeta for UTF-8 field name' ); is( $fieldmeta->name, '$tranĉaĵoj', '$fieldmeta->name' ); # params is( Sandviĉon->new( tranĉaĵoj => 2 )->tranĉaĵoj, 2, 'Can construct with UTF-8 param' ); } done_testing; Object-Pad-0.61/t/99pod.t000444001750001750 25614203242261 13601 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok();