Object-Pad-0.810000755001750001750 014655674547 12202 5ustar00leoleo000000000000Object-Pad-0.810/.editorconfig000444001750001750 5314655674547 14752 0ustar00leoleo000000000000root = true [*.{pm,pl,t}] indent_size = 3 Object-Pad-0.810/Build.PL000444001750001750 416114655674547 13635 0ustar00leoleo000000000000use v5; use strict; use warnings; use Module::Build; use XS::Parse::Keyword::Builder; use XS::Parse::Sublike::Builder; my @extra_compiler_flags = qw( -Ishare/include -Iinclude -Ihax ); # Perl 5.36 made -std=c99 standard; before then we'll have to request it specially push @extra_compiler_flags, qw( -std=c99 ) if $^V lt v5.36.0; push @extra_compiler_flags, qw( -DDEBUGGING=-ggdb3 ) 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.39', 'XS::Parse::Sublike' => '0.15', }, test_requires => { 'Test2::V0' => '0.000148', }, configure_requires => { 'Module::Build' => '0.4004', # test_requires 'XS::Parse::Keyword::Builder' => '0.39', 'XS::Parse::Sublike::Builder' => '0.15', }, share_dir => { module => { 'Object::Pad' => [ 'share' ] }, }, 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 and Devel::MAT::Dumper::Helper->VERSION( '0.45' ) } ) { Devel::MAT::Dumper::Helper->extend_module_build( $build ); } if( $^X =~ m|/debugperl| ) { # We need to tell gcc not to optimise away lots of things we want to see in # the debugger. It'd be nice if M::B had a nicer way to do this... $build->add_property( 'optimize' ); $build->config( optimize => '-ggdb3' ); } $build->create_build_script; Object-Pad-0.810/Changes000444001750001750 10251314655674547 13674 0ustar00leoleo000000000000Revision history for Object-Pad 0.810 2024-08-10 [CHANGES] * Use `File::ShareDir` for storing .h include file, rather than storing the contents in the `__DATA__` section of the build helper * Added field hook function `gen_valueassert_op` * Warn when enabling all experiments at once with an unqualified `:experimental` import [BUGFIXES] * Don't attempt to reserve the embedding slot in the pad twice when making roles under composed_adjust (RT154494) * Ensure that field variables are not visible at compiletime of :common methods (RT154639) 0.809 2024-07-14 [CHANGES] * Experimental attempt at supporting anonymous `class` syntax * Add an extra debugging aid in the form of "linnets", canary-like values added to every struct and checked on pointer casts [BUGFIXES] * Do not create a `new` constructor method for roles, only classes * Ensure perl doesn't attempt to free() a non-malloced pointer when deleting a method of an invokable role (RT152793) * Ensure that `Object::Pad::MOP::Class->for_class` is not confused by non-OP subclasses * Make sure not to embed CVs of `:common` methods because that will upset any lexical or pad temporary at pad index 3 0.808 2023-12-28 [CHANGES] * Added `Object::Pad::MOP::Class->try_for_class` * Nicer error message when calling `->for_class` on a package not implemented using Object::Pad [BUGFIXES] * Avoid adding `Object::Pad::UNIVERSAL` to the `@ISA` array more than once (RT150794) 0.807 2023-12-11 [CHANGES] * Added `inherit` and `apply` keywords in an attempt to make subclassing and role-application more flexible in future * Experimental new ability to "import" fields from superclasses into subclasses, permitting subclasses to interact with base class fields directly * Allow setting the `OBJECTPAD_FLAG_ATTR_*_VALUE` flags when registering a custom attribute via the Perl-level MOP API 0.806 2023-11-14 [CHANGES] * Allow field initialiser expressions to see the values of other fields already declared 0.805 2023-10-20 [CHANGES] * Added an experimental feature to compose all ADJUST blocks into a single CV * Removed experimental warning from `ADJUST :params` [BUGFIXES] * Don't crash the `Devel::MAT::Dumper` helper if a class does not have a parammap (RT150151) 0.804 2023-10-04 [CHANGES] * Add `:repr(pvobj)` for Perl 5.38+ * Much internal code adjustment to support instances not backed by `SVt_PVAV` [BUGFIXES] * Fix the METHSTART_CONTAINS_FIELD_BINDINGS optimisation that had been recently broken, restoring its performance gains 0.803 2023-09-20 [CHANGES] * Add `:repr(keys)` to use one hash key per field * Performance improvements to constructor: + Use `av_*_simple()` functions when operating on internal AVs + Don't bother calling the universal `->BUILDARGS` method if the class doesn't override it + Calculate the argument count just once 0.802 2023-08-22 [CHANGES] * Internal XS-level changes: + Generate the basic accessor ops directly before invoking the gen_accessor_ops chain, ensuring more reliable ordering + Renamed the `post_initfields` field hook to `post_makefields` to better reflect when it actually runs * Removed the special-case warning about `method BUILD` * Added docs to point out that `ADJUST` blocks see method-like field lexicals 0.801 2023-08-10 [CHANGES] * Warn at compiletime if `ADJUST` blocks perform out-of-block control flow. This warning will become a compiletime error in a later version * Added `mop_class_get_attribute()` and `mop_class_get_attribute_values()` to C-level API * Removed the old `ClassHook->hookdata` and `FieldHook->hookdata` variable aliases [BUGFIXES] * A better `sub VERSION` that works as a more transparent wrapper (RT149357) 0.800 2023-08-09 [CHANGES] * Switched to three-digit version numbering * Removed experimental warnings from non-constant field initialiser expressions * Emit deprecation warnings at compiletime from `has` keyword * Expanded documentation about the implied pragmata changes, which will likely be removed entirely in a later version. * Emit a warning if implied strict/warnings was enabled, conditional on `use Object::Pad` with this version number or later. 0.79 2023-05-09 [CHANGES] * Swap all unit tests from `Test::More` to `Test2::V0` * Support `goto LABEL` entirely within a field initialiser block [BUGFIXES] * Docs fix for implied method names to match names of fields (RT146092) * Hide bleadperl's suspended compcv macros when redefining our own of the same name 0.78 2023-01-12 [BUGFIXES] * Don't complain about empty-list field initialisers being non-constant (related to RT145618) * Define more configuration options for `Feature::Compat::Class` 0.77 2022-12-19 [BUGFIXES] * Fix C compiler errors and warnings + Neater handling of OP_NULL in optrees; avoids error of a case label applied to a declaration, which upsets non-gcc compilers + Use PTR2UV / NUM2PTR pairs instead of plain casting 0.76 2022-12-16 [CHANGES] * No longer consider `field VAR = CONST` experimental for constant expressions * Make field assignment and `ADJUST :params` slightly more efficient by stealing new OP_HELEMEXISTSOR op from upcoming perl version * Defined new ABI version 0.76 + Adds `pre_seal` and `post_seal` functions for class hooks 0.75 2022-12-14 [CHANGES] * Support fields using `//=` and `||=` defaulting operators, to match the core perl `class` feature * Define more configuration options for `Feature::Compat::Class` 0.74 2022-12-04 [BUGFIXES] * Ensure that all struct fields are initialised after Newx(), by using a C99-style struct assignment, ensuring no uninitialised behaviour (RT145289) 0.73 2022-12-03 [CHANGES] * Accept `field VAR = EXPR;` syntax; evaluated within constructor similarly to block form * Generally prefer `field` over `has` in docs, unit tests, etc... * Long-deprecated `extends` and `implements` keywords are now immediate compile-time failures * Extended the C-level extension API + Added `get_compclassmeta()` + Added `mop_class_add_method_cv()` and `mop_class_get_name()` + Optional integration with XS::Parse::Keyword via the addition of the `OPXKP_*` macros [BUGFIXES] * Account for bleadperl's slightly changed warning message of "bareword found ..." 0.72 2022-11-30 [CHANGES] * Accept `//=` and `||=` in named signature-like syntax for `ADJUST :params` blocks * Added `__CLASS__` * Deprecate use of params hashref in `ADJUST` blocks; needs to be written as `ADJUSTPARAMS`, which is not longer exactly synonymous with `ADJUST` 0.71 2022-11-01 [CHANGES] * Add a =head2 heading to docs on `ADJUST :params` for ease of linking * Support latest blead-perl which adds the xV_FROM_REF macros [BUGFIXES] * Make sure to deref the CODE reference to ->add_method before stuffing it into the GV (RT144975) * Avoid C99-style for() loop variable, to keep older MSWin32 compilers happy 0.70 2022-10-29 [CHANGES] * Added `ADJUST :params`, which permits named parameters to ADJUST blocks (currently experimental) 0.69 2022-10-25 [CHANGES] * Internal tidying to the way the initfields stage of the constructor works * Support for Feature::Compat::Class to enable the :isa class attribute alone 0.68 2022-08-13 [BUGFIXES] * Wording fix in new Object::Pad::MetaFunctions docs * Avoid label at end of compound statement (RT144005) 0.67 2022-08-12 [CHANGES] * Added `Object::Pad::MetaFunctions` to contain some introspection and reflection helper functions * Avoid writing the rather silly-sounding `field $field` in docs; use single-letter field names like `$x` or `$f` instead 0.66 2022-07-07 [CHANGES] * Improved performance on perl 5.22 onwards, by merging the operation of the individual pp_fieldpad ops into the main pp_methstart op * Prepare compatibility with core's `use feature 'class'`: + Support `field` keyword as a synonym of `has`, though without immediate EXPR version + Merge meaning of `ADJUST` and `ADJUSTPARAMS`; give all such blocks a params hashref. `ADJUSTPARAMS` is now just a synonym * Print "discouraged" warnings on `requires` keyword * Print deprecation warnings on `isa` and `does` subkeywords * Added list-returning ->get_attribute_values() accessor to Object::Pad::MOP::Field * Deleted legacy XS symbols relating to "slot" from before it was renamed to "field" 0.65 2022-05-10 [CHANGES] * Document the required version for :experimental tags * Mention the new Devel::MAT::Tool::Object::Pad in docs [BUGFIXES] * Update cv_copy_flags() for SvPADTMP fix; related to RT142468 0.64 2022-04-02 [CHANGES] * Improvements to `:experimental` import tag (RT141801): + Support multiple experiments at once + Make sure to still enable the default keywords * Much better integration with `Devel::MAT::Dumper`: + Export complete C-level structures and magic VTBL root * Adjusted wording of "MOP API is experimental" so it doesn't refer to a package that doesn't actually exist (RT141801) 0.63 2022-03-07 [CHANGES] * Deleted long-deprecated Object::Pad->begin_class * No longer declare the entire module as "experimental" * Add experimental warnings to still-experimental features; recognise `:experimental` import tags to silence them [BUGFIXES] * Ensure that generated accessors work correctly regardless of the prevailing package when they were generated (RT141599) * Ensure that classes and accessors can be generated entirely outside of a BEGIN block (RT141677) 0.62 2022-03-01 [CHANGES] * Add "common" methods: + Implement `:common` attribute for methods + Take 'common' argument to `$metaclass->add_method` + Added `$metamethod->is_common` accessor * Don't require a terminating semicolon after `has $field { EXPR }` [BUGFIXES] * Better handling of role method embeddings that include lexical captures (RT141483) 0.61 2022-02-16 [CHANGES] * Added Object::Pad::MOP::Class->create_{class,role} * Added $metaclass->seal (RT141294) * 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 (RT141293) 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.810/LICENSE000444001750001750 4653414655674547 13400 0ustar00leoleo000000000000This software is copyright (c) 2024 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) 2024 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 Perl Artistic License 1.0 --- This software is Copyright (c) 2024 by Paul Evans . This is free software, licensed under: The Perl 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 as specified below. "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 uunet.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) give non-standard executables non-standard names, and clearly document 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. You may embed this Package's interpreter within an executable of yours (by linking); this shall be construed as a mere form of aggregation, provided that the complete Standard Version of the interpreter is so embedded. 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 whoever generated them, and may be sold commercially, and may be aggregated with this Package. If such scripts or library files are aggregated with this Package via the so-called "undump" or "unexec" methods of producing a binary executable image, then distribution of such an image shall neither be construed as a distribution of this Package nor shall it fall under the restrictions of Paragraphs 3 and 4, provided that you do not represent such an executable image as a Standard Version of this Package. 7. C subroutines (or comparably compiled subroutines in other languages) supplied by you and linked into this Package in order to emulate subroutines and variables of the language defined by this Package shall not be considered part of this Package, but are the equivalent of input as in Paragraph 6, provided these subroutines do not change the language in any way that would cause it to fail the regression tests for the language. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 10. 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.810/MANIFEST000444001750001750 415714655674547 13477 0ustar00leoleo000000000000.editorconfig Build.PL Changes hax/cv_copy_flags.c.inc hax/dumpers.c.inc hax/exec_optree.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_HELEMEXISTSOR.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/linnet.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/MetaFunctions.pm 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 share/include/object_pad.h src/class.c src/field.c src/suspended_compcv.c t/00use.t t/01method.t t/02fields.t t/03create.t t/04adjust.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/32threads.t t/33class-anon.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/55croak-params.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/75metafunctions.t t/77repr-pvobj.t t/80async-method.t t/80dynamically+Object-Pad.t t/80extended+Object-Pad.t t/81async-method+dynamically.t t/82devel-mat-dumper-helper.t t/90leak.t t/91rt141483.t t/92legacy.t t/93legacy-has.t t/93legacy-pragmata.t t/94experimental.t t/95utf8.t t/99pod.t t/lib/91rt141483Role.pm Object-Pad-0.810/META.json000444001750001750 412514655674547 13762 0ustar00leoleo000000000000{ "abstract" : "a simple syntax for lexical field-based objects", "author" : [ "Paul Evans " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4234", "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.39", "XS::Parse::Sublike::Builder" : "0.15" } }, "runtime" : { "requires" : { "File::ShareDir" : "1.00", "XS::Parse::Keyword" : "0.39", "XS::Parse::Sublike" : "0.15", "perl" : "5.018" } }, "test" : { "requires" : { "Test2::V0" : "0.000148" } } }, "provides" : { "Object::Pad" : { "file" : "lib/Object/Pad.pm", "version" : "0.810" }, "Object::Pad::ExtensionBuilder" : { "file" : "lib/Object/Pad/ExtensionBuilder.pm", "version" : "0.810" }, "Object::Pad::MOP::Class" : { "file" : "lib/Object/Pad/MOP/Class.pm", "version" : "0.810" }, "Object::Pad::MOP::Field" : { "file" : "lib/Object/Pad/MOP/Field.pm", "version" : "0.810" }, "Object::Pad::MOP::FieldAttr" : { "file" : "lib/Object/Pad/MOP/FieldAttr.pm", "version" : "0.810" }, "Object::Pad::MOP::Method" : { "file" : "lib/Object/Pad/MOP/Method.pm", "version" : "0.810" }, "Object::Pad::MetaFunctions" : { "file" : "lib/Object/Pad/MetaFunctions.pm", "version" : "0.810" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.810", "x_serialization_backend" : "JSON::PP version 4.16" } Object-Pad-0.810/META.yml000444001750001750 254714655674547 13620 0ustar00leoleo000000000000--- abstract: 'a simple syntax for lexical field-based objects' author: - 'Paul Evans ' build_requires: ExtUtils::CBuilder: '0' Test2::V0: '0.000148' configure_requires: Module::Build: '0.4004' XS::Parse::Keyword::Builder: '0.39' XS::Parse::Sublike::Builder: '0.15' dynamic_config: 1 generated_by: 'Module::Build version 0.4234, 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.810' Object::Pad::ExtensionBuilder: file: lib/Object/Pad/ExtensionBuilder.pm version: '0.810' Object::Pad::MOP::Class: file: lib/Object/Pad/MOP/Class.pm version: '0.810' Object::Pad::MOP::Field: file: lib/Object/Pad/MOP/Field.pm version: '0.810' Object::Pad::MOP::FieldAttr: file: lib/Object/Pad/MOP/FieldAttr.pm version: '0.810' Object::Pad::MOP::Method: file: lib/Object/Pad/MOP/Method.pm version: '0.810' Object::Pad::MetaFunctions: file: lib/Object/Pad/MetaFunctions.pm version: '0.810' requires: File::ShareDir: '1.00' XS::Parse::Keyword: '0.39' XS::Parse::Sublike: '0.15' perl: '5.018' resources: license: http://dev.perl.org/licenses/ version: '0.810' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Object-Pad-0.810/README000444001750001750 14645214655674547 13273 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 { field $x :param = 0; field $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 { field $x :param = 0; field $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. While most of this module has evolved into a stable state in practice, parts remain experimental because the design is still evolving, and many features and ideas have yet to 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. Experimental Features Since version 0.63. Some of the features of this module are currently marked as experimental. They will provoke warnings in the experimental category, unless silenced. You can silence this with no warnings 'experimental' but then that will silence every experimental warning, which may hide others unintentionally. For a more fine-grained approach you can instead use the import line for this module to only silence the module's warnings selectively: use Object::Pad ':experimental(mop)'; use Object::Pad ':experimental(custom_field_attr)'; use Object::Pad ':experimental(composed_adjust)'; use Object::Pad ':experimental(inherit_field)'; use Object::Pad ':experimental(:all)'; # all of the above Since version 0.64. Multiple experimental features can be enabled at once by giving multiple names in the parens, separated by spaces: use Object::Pad ':experimental(mop custom_field_attr)'; Since version 0.810 attempting to request all of the experiments at once by using an empty :experimental() is currently accepted, but yields a warning. This may be removed in future. 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 block of every component class is invoked. This happens after the fields are assigned their initial values and the BUILD blocks have been run. 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 ADJUST 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; 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. 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 inheritance 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. :repr(keys) Since version 0.803. The representation will be a blessed hash reference. The instance data will be stored in individual keys of the hash, named after the class and the field variable name, separated by a / symbol. Objects in this representation should behave predictably with data printing modules like Data::Dumper or serialisation via YAML or JSON. These two hash-based representation types 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(pvobj) Since version 0.804. The representation will be the SVt_PVOBJ type newly added to Perl, which offers more efficient storage for object instances. This is only available on Perl version 5.38.0 onwards. This is also newly-added and may not be fully tested and reliable yet. Once it has more real-world testing and has proven reliable it may become the default instance representation on versions of Perl where it is available. :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 ADJUST 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. class (anon) my $class = class :ATTRS... { ... }; Since version 0.809. If a class keyword is not followed by a package name, it creates an anonymous class expression. This is an expression that yields a value suitable to use as a constructor invocant for creating instances of that class, without specifying what its package name will actually be. This is useful for creating small one-off instances inline in expressions, such as in unit tests. Since it still accepts the usual attributes and inner body statements, it can be useful for creating one-off instances of roles, with required methods being applied. my $testobj = (class { apply Role::Under::Test; method required { return "a useful value"; } })->new; Due to limitations on how classes work in Perl, anonymous classes are still backed by long-lived named classes in the global symbol table, unlike true anonymous functions which can go out of scope and be reclaimed once no references to them remain in existence. This means that anonymous classes will retain references to any variables captured within them, even if the class expression itself goes out of scope and any instances created by it no longer remain. 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 similar 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 ADJUST blocks or methods provided by that role. Since version 0.33. role Name { field $f; ADJUST { $f = "a value"; } method f { return $f; } } 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 "field" 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. inherit inherit Classname; inherit Classname VER; inherit Classname LIST...; inherit Classname VER LIST...; Declares a superclass that this class extends. At most one superclass is supported. If present, this declaration must come before any methods or fields are declared, or any roles applied. (Other compile-time declarations such as use statements that import utility functions or other behaviours may be permitted before this, however, provided that they do not interact with the class structure in any way). This is a newer form of the :isa attribute intended to be more flexible if import arguments or other features are added at a later time. If the package providing the superclass does not exist, an attempt is made to load it by code equivalent to require Classname; and thus it must either already exist, or be locatable via the usual @INC mechanisms. An optional version check can also be supplied; it performs the equivalent of Classname->VERSION( $ver ) Experimentally since version 0.807, an optional list of arguments can also be provided, in similar syntax to those in a use statement. Currently this list of arguments must be names of fields to be inherited. Only fields in the base class that are annotated with the :inheritable attribute may be inherited. Once a field is inherited, methods and other expressions in the class body can use that field identically to any fields defined by that class itself. class Class1 { field $x :inheritable = 123; } class Class2 { inherit Class1 '$x'; field $y = 456; method describe { say "Class2(x=$x,y=$y)" } } Class2->new->describe; apply apply Rolename; apply Rolename VER; Since version 0.807. Composes a role into the class; optionally requiring a version check on the role package. This is a newer form of the :does attribute intended to be more flexible if import arguments or other features are added at a later time. Multiple roles can be composed by using multiple :does attributes, one per role. apply statements can be freely mixed with other statements inside the body of the class. In particular, an apply statement that adds fields or methods may appear before or after the class has defined some of its own. It is not required that they appear first. field field $var; field @var; field %var; field $var :ATTR ATTR...; field $var = EXPR; field $var //= EXPR; field $var ||= EXPR; field $var { BLOCK } Since version 0.66. 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 and ADJUST blocks 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. 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. field $x :reader; # equivalent to field $x; method x { return $x } 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. field @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. field $x :writer; # equivalent to field $x; method set_x { $x = 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. field $x :mutator; # equivalent to field $x; method x :lvalue { $x } 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. field $x :accessor; # equivalent to field $x; method x { $x = shift if @_; return $x; } :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 (or builtin::weaken on Perl 5.36 or above) 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: field $x :param; # this is required field $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. :inheritable Experimentally since version 0.807 fields may be optionally inherited when deriving a subclass from another. Not every field is allowed to be inherited. This attribute marks a field as being available for subclasses to inherit. Field Initialiser Expressions Since version 0.54 a deferred statement block is also permitted, on any field variable type. This 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. Since version 0.73 this may also be written as a plain expression introduced by an equals symbol (=). This is equivalent to using a block. Note carefully: the equals symbol is part of the field syntax; it is not simply a runtime assignment operator that happens once at the time the class is declared. Just like the block form describe above, the expression is evaluated during the constructor of every instance. Since version 0.74 this expression may also be written using a defined-or or logical-or assignment operator (//= or ||=). In these case, the default expression will be evaluated and assigned if the caller did not pass a value to the constructor at all, or if the value passed was undef (for //=) or false (for ||=). For most scalar parameters, where undef is not a valid value, you probably wanted to use //= to assign defaults. class Action { field $timeout :param //= 20; ... } # The default of 20 will apply here too my $act = Action->new( timeout => $opts{timeout} ); Note that $self is specifically not visible during an initialiser expression. This is because the object is not yet fully constructed, so it would be dangerous to allow access to it while in this state. However, the __CLASS__ keyword is available, so initialiser expressions can make use of class-based dispatch to invoke class-level methods to help provide values. Field initialier expressions were originally experimental, but since version 0.800 no longer emit experimental warnings. Since version 0.806 fields already declared in a class are visible during the initialisation expression of later fields, and their assigned value can be used here. If the earlier field had a :param declaration, it will have been assigned from the value passed to the constructor. Note however that all ADJUST blocks happen after field initialisation expressions, so any modified values set in such blocks will not be visible at this time. Control flow that attempts to leave a field initialiser expression or 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. field $x { foreach(@list) { next; } } # this is fine field $x { LOOP: while(1) { last LOOP; } } # this is fine too has has $var; has @var; has %var; has $var = EXPR; has $var { BLOCK } A now-deprecated older version of the "field" keyword. This generally behaves like field, except that inline expressions are evaluated immediately, once, during class declaration time. These are not stored to be evaluated for each constructor. Because of the one-shot immediate nature of these initialisation expressions (and a bunch of other reasons), the has keyword is now discouraged for use and will emit compile-time warnings in the deprecated category. Use the field keyword instead. If you need to evaluate an expression exactly once during the class declaration and assign its now-constant value to every instace, store it in a regular my variable instead: my $default_var = EXPR; field $var = $default_var; 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 { field $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. :common Since version 0.62. Marks that this method is a class-common method, instead of a regular instance method. A class-common method may be invoked on class names instead of instances. Within the method body there is a lexical $class available, rather than $self. Because it is not associated with a particular object instance, a class-common method cannot see instance fields. 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 { field $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). An adjust block is not a subroutine and thus is not permitted to use subroutine attributes (except see below). Note that an ADJUST block is a named phaser block and not a method; it does not use the sub or method keyword. But, like with method, the member fields are accessible within the code body, as is the special $self lexical. Currently, an ADJUST block receives a reference to the hash containing the current constructor arguments, as per "ADJUSTPARAMS" (see below). This was added in version 0.66 but will be removed again as it conflicts with the more flexible and generally nicer named-parameter ADJUST :params syntax (see below). Such uses should be considered deprecated. A warning will be printed to indicate this whenever an ADJUST block uses a signature. This warning can be quieted by using ADJUSTPARAMS instead. Additionally, a warning may be printed on code that attempts to access the params hashref via the @_ array. Since version 0.801 in a future version of this module, ADJUST blocks may be implemented as true blocks and will not permit out-of-block control flow. At present, they are implemented as one full CV per block, but a warning is emitted if out-of-block control flow is attempted. ADJUST { return; } Using return to leave an ADJUST block is discouraged and will be removed in a later version at FILE line LINE. Since version 0.805 an experimental feature can be enabled that puts all the ADJUST blocks into a single CV, rather than creating one CV for every block. This is currently being tested for stability, and may become the default behaviour in a future version. For now it must be requested specially: use Object::Pad ':experimental(composed_adjust)'; ADJUST :params ADJUST :params ( :$var1, :$var2, ... ) { ... } ADJUST :params ( :$var1, :$var2, ..., %varN ) { ... } Since version 0.70. An ADJUST block can marked with a :params attribute, meaning that it consumes additional constructor parameters by assigning them into lexical variables. Before the block itself, a list of lexical variables are introduced, inside parentheses. The name of each one is preceeded by a colon, and consumes a constructor parameter of the same name. These parameters are considered "consumed" for the purposes of a :strict(params) check. A named parameter may be provided with default expression, which is evaluated if no matching named argument is provided to the constructor. As with fields, if a named parameter has no defaulting expression it becomes a required argument to the constructor; an exception is thrown by the constructor if it absent. For example, ADJUST :params ( :$x, :$y = "default", :$z ) { ... } Note here that x and z are required parameters for the constructor of a class containing this block, but y is an optional parameter whose value will be filled in by the expression if not provided. Because these parameters are named and not positional, there is no ordering constraint; required and optional parameters can be freely mixed. Optional parameters can also use the //= and ||= operators to provide a default expression. In these cases, the default will be applied if the caller did not provide the named argument at all, or if the provided value was not defined (for //=) or not true (for ||=). ADJUST :params ( :$name //= "unnamed" ) { ... } Like with subroutine signature parameters, every declared named parameter is visible to the defaulting expression of all the later ones. This permits values to be calculated based on other ones. For example, ADJUST :params ( :$thing = undef, :$things = [ $thing ] ) { # Here, @$things is a list of values } This permits the caller to pass a list of values via an array reference in the things parameter, or a single value in thing. The final element may be a regular hash variable. This requests that all remaining named parameters are made available inside it. The code in the block should delete from this hash any parameters it wishes to consume, as with the earlier case above. It is unspecified whether named fields or parameters for subclasses yet to be processed are visible to hashes of earlier superclasses. In the current implementation they are, but code should not rely on this fact. Note also that there must be a space between the :params attribute and the parentheses holding the named parameters. If this space is not present, perl will parse the parentheses as if they are the value to the :params() attribute, and this will fail to parse as intended. As with other attributes and subroutine signatures, this whitespace is significant. (This notation is borrowed from a plan to add named parameter support to perl's subroutine signature syntax). ADJUSTPARAMS Since version 0.51. ADJUSTPARAMS ( $params ) { # on perl 5.26 onwards ... } ADJUST { my $params = shift; ... } A variant of an ADJUST block that receives 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 ADJUST blocks have run, any remaining keys in the hash will be considered errors, subject to the ":strict(params)" check. __CLASS__ my $classname = __CLASS__; Since version 0.72. Only valid within the body (or signature) of a method, an ADJUST block, or the initialising expression of a field. Yields the class name of the instance that the method, block or expression is invoked on. This is similar to the core perl __PACKAGE__ constant, except that it cares about the dynamic class of the actual instance, not the static class the code belongs to. When invoked by a subclass instance that inherited code from its superclass it yields the name of the class of the instance regardless of which class defined the code. For example, class BaseClass { ADJUST { say "Constructing an instance of " . __CLASS__; } } class DerivedClass :isa(BaseClass) { } my $obj = DerivedClass->new; Will produce the following output Constructing an instance of DerivedClass This is particularly useful in field initialisers for invoking (constant) methods on the invoking class to provide default values for fields. This way a subclass could provide a different value. class Timer { use constant DEFAULT_DURATION => 60; field $duration = __CLASS__->DEFAULT_DURATION; } class ThreeMinuteTimer :isa(Timer) { use constant DEFAULT_DURATION => 3 * 60; } 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 The following behaviour is likely to be removed in a later version of this module. In order to encourage users to write clean, modern code, the body of the class block currently 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 behaviour was designed early around the original "line-0" version of the Perl 7 plan, which has subsequently been found to be a bad design and abandoned. That leaves this module in an unfortunate situation, because its behaviour here does not match the plans for core perl; where the recently-added class keyword does none of this, although the method keyword always behaves as if signatures were enabled anyway. It is eventually planned that this behaviour will be removed from Object::Pad entirely (except for enabling the signatures feature). While that won't in itself break any existing code, it would mean that code which previously ran with the protection of strict and warnings would now not be. A satisfactory solution to this problem has not yet been found, but until then it is suggested that code using this module remembers to explicitly enable this set of pragmata before using the class keyword. A handy way to do this is to use the use VERSION syntax; v5.36 or later will already perform all of the pragmata listed above. use v5.36; If you import this module with a module version number of 0.800 or higher it will enable a warning if you forget to enable strict and warnings before using the class or roll keywords: use Object::Pad 0.800; class X { ... } class keyword enabled 'use strict' but this will be removed in a later version at FILE line 3. class keyword enabled 'use warnings' but this will be removed in a later version at FILE line 3. Yield True The following behaviour is likely to be removed in a later version of this module. 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. As with the implied pragmata above, this behaviour has also been found to be a bad design and will likely be removed soon. For now it is suggested not to rely on it and instead either use the new module_true feature already part of the use v5.38 pragma, or on older perls simply remember to put an explicit true value at the end of the file. 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 and ADJUST 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) { field $_value = "B"; ADJUST { $_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 ADJUST 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 and ADJUST 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 # field, 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 { field $name :mutator; field $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 { field $_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 { field $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. Devel::MAT When using Devel::MAT to help analyse or debug memory issues with programs that use Object::Pad, you will likely want to additionally install the module Devel::MAT::Tool::Object::Pad. This will provide new commands and extend existing ones to better assist with analysing details related to Object::Pad classes and instances of them. pmat> fields 0x55d7c173d4b8 The field AV ARRAY(3)=NativeClass at 0x55d7c173d4b8 Ix Field Value 0 $sfield SCALAR(UV) at 0x55d7c173d938 = 123 ... pmat> identify 0x55d7c17606d8 REF() at 0x55d7c17606d8 is: └─the %hfield field of ARRAY(3)=NativeClass at 0x55d7c173d4b8, which is: ... DESIGN TODOs The following points are details about the design of pad field-based object systems in general: * Is multiple inheritance 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 inheritance 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; field $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.810/hax000755001750001750 014655674547 12762 5ustar00leoleo000000000000Object-Pad-0.810/hax/OP_HELEMEXISTSOR.c.inc000444001750001750 357414655674547 16475 0ustar00leoleo000000000000/* vi: set ft=c : */ #define newHELEMEXISTSOROP(flags, helem, other) S_newHELEMEXISTSOROP(aTHX_ flags, helem, other) #if defined(OPpHELEMEXISTSOR_DELETE) /* For now this is not in any Perl release but hopefully soon; maybe in time * for 5.37.7 * https://github.com/Perl/perl5/pull/20598 */ static OP *S_newHELEMEXISTSOROP(pTHX_ U32 flags, OP *helem, OP *other) { return newLOGOP(OP_HELEMEXISTSOR, flags, helem, other); } #else enum { OPpHELEMEXISTSOR_DELETE = (1<<7), }; static OP *pp_helemexistsor(pTHX) { dSP; SV *keysv = POPs; HV *hv = MUTABLE_HV(POPs); bool is_delete = PL_op->op_private & OPpHELEMEXISTSOR_DELETE; assert(SvTYPE(hv) == SVt_PVHV); bool hv_is_magical = UNLIKELY(SvMAGICAL(hv)); SV *val = NULL; /* For magical HVs we have to ensure we invoke the EXISTS method first. For * regular HVs we can just skip this and use the "pointer or NULL" result * of the real hv_* functions */ if(hv_is_magical && !hv_exists_ent(hv, keysv, 0)) goto other; if(is_delete) { val = hv_delete_ent(hv, keysv, 0, 0); } else { HE *he = hv_fetch_ent(hv, keysv, 0, 0); val = he ? HeVAL(he) : NULL; /* A magical HV hasn't yet actually invoked the FETCH method. We must ask * it to do so now */ if(hv_is_magical && val) SvGETMAGIC(val); } if(!val) { other: PUTBACK; return cLOGOP->op_other; } PUSHs(val); RETURN; } static OP *S_newHELEMEXISTSOROP(pTHX_ U32 flags, OP *helem, OP *other) { assert(helem->op_type == OP_HELEM); OP *o = newLOGOP_CUSTOM(&pp_helemexistsor, flags, helem, other); OP *hvop = cBINOPx(helem)->op_first; OP *keyop = OpSIBLING(hvop); helem->op_targ = helem->op_type; helem->op_type = OP_NULL; helem->op_ppaddr = PL_ppaddr[OP_NULL]; /* o is actually the structural-containing OP_NULL */ OP *real_o = cUNOPo->op_first; keyop->op_next = real_o; return o; } #endif Object-Pad-0.810/hax/cv_copy_flags.c.inc000444001750001750 1230214655674547 16667 0ustar00leoleo000000000000/* vi: set ft=c : */ #define padname_is_normal_lexical(pname) MY_padname_is_normal_lexical(aTHX_ pname) static bool MY_padname_is_normal_lexical(pTHX_ PADNAME *pname) { /* PAD slots without names are certainly not lexicals */ if(PadnameIsNULL(pname) || !PadnameLEN(pname)) return FALSE; /* Outer lexical captures are not lexicals */ if(PadnameOUTER(pname)) return FALSE; /* state variables are not lexicals */ if(PadnameIsSTATE(pname)) return FALSE; /* Protosubs for closures are not lexicals */ if(PadnamePV(pname)[0] == '&') return FALSE; /* anything left is a normal lexical */ return TRUE; } enum { CV_COPY_NULL_LEXICALS = (1<<0), /* regular lexicals end up NULL */ }; #define cv_copy_flags(orig, flags) MY_cv_copy_flags(aTHX_ orig, flags) static CV *MY_cv_copy_flags(pTHX_ CV *orig, U32 flags) { /* Parts of this code stolen from S_cv_clone() in pad.c */ CV *new = MUTABLE_CV(newSV_type(SVt_PVCV)); CvFLAGS(new) = CvFLAGS(orig) & ~CVf_CVGV_RC; CvFILE(new) = CvDYNFILE(orig) ? savepv(CvFILE(orig)) : CvFILE(orig); #if HAVE_PERL_VERSION(5, 18, 0) if(CvNAMED(orig)) { /* Perl core uses CvNAME_HEK_set() here, but that involves a call to a * non-public function unshare_hek(). The latter is only needed in the * case where an old value needs to be removed, but since we've only just * created the CV we know it will be empty, so we can just set the field * directly */ ((XPVCV*)MUTABLE_PTR(SvANY(new)))->xcv_gv_u.xcv_hek = share_hek_hek(CvNAME_HEK(orig)); CvNAMED_on(new); } else #endif CvGV_set(new, CvGV(orig)); CvSTASH_set(new, CvSTASH(orig)); { OP_REFCNT_LOCK; CvROOT(new) = OpREFCNT_inc(CvROOT(orig)); OP_REFCNT_UNLOCK; } CvSTART(new) = CvSTART(orig); CvOUTSIDE(new) = MUTABLE_CV(SvREFCNT_inc(CvOUTSIDE(orig))); CvOUTSIDE_SEQ(new) = CvOUTSIDE_SEQ(orig); /* No need to bother with SvPV slot because that's the prototype, and it's * too late for that here */ /* TODO: Consider what to do about SvPVX */ { ENTER_with_name("cv_copy_flags"); SAVESPTR(PL_compcv); PL_compcv = new; SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(CvPADLIST(orig)); CvPADLIST_set(new, pad_new(padnew_CLONE|padnew_SAVE)); #if HAVE_PERL_VERSION(5, 22, 0) CvPADLIST(new)->xpadl_id = CvPADLIST(orig)->xpadl_id; #endif PADNAMELIST *padnames = PadlistNAMES(CvPADLIST(orig)); const PADOFFSET fnames = PadnamelistMAX(padnames); const PADOFFSET fpad = AvFILLp(PadlistARRAY(CvPADLIST(orig))[1]); int depth = CvDEPTH(orig); if(!depth) depth = 1; SV **origpad = AvARRAY(PadlistARRAY(CvPADLIST(orig))[depth]); #if !HAVE_PERL_VERSION(5, 18, 0) /* Perls before 5.18.0 didn't copy the padnameslist */ SvREFCNT_dec(PadlistNAMES(CvPADLIST(new))); PadlistNAMES(CvPADLIST(new)) = (PADNAMELIST *)SvREFCNT_inc(PadlistNAMES(CvPADLIST(orig))); #endif av_fill(PL_comppad, fpad); PL_curpad = AvARRAY(PL_comppad); PADNAME **pnames = PadnamelistARRAY(padnames); PADOFFSET padix; /* TODO: What about padix 0? */ for(padix = 1; padix <= fpad; padix++) { PADNAME *pname = (padix <= fnames) ? pnames[padix] : NULL; SV *newval = NULL; if(padname_is_normal_lexical(pname)) { if(flags & CV_COPY_NULL_LEXICALS) continue; switch(PadnamePV(pname)[0]) { case '$': newval = newSV(0); break; case '@': newval = MUTABLE_SV(newAV()); break; case '%': newval = MUTABLE_SV(newHV()); break; default: croak("ARGH unsure how to handle pname=<%s> in cv_copy_flags\n", PadnamePV(pname)); break; } } else if(!origpad[padix]) newval = NULL; else if(SvPADTMP(origpad[padix])) { /* We still have to copy the value, in case it is live. Also core perl * is known to set SvPADTMP on non-temporaries, like folded constants * https://rt.cpan.org/Ticket/Display.html?id=142468 */ newval = newSVsv(origpad[padix]); SvPADTMP_on(newval); } else { #if !HAVE_PERL_VERSION(5, 18, 0) /* Before perl 5.18.0, inner anon subs didn't find the right CvOUTSIDE * at runtime, so we'll have to patch them up here */ CV *origproto; if(pname && PadnamePV(pname)[0] == '&' && CvOUTSIDE(origproto = MUTABLE_CV(origpad[padix])) == orig) { /* quiet any "Variable $FOO is not available" warnings about lexicals * yet to be introduced */ ENTER_with_name("find_cv_outside"); SAVEINT(CvDEPTH(origproto)); CvDEPTH(origproto) = 1; CV *newproto = cv_copy_flags(origproto, flags); CvPADLIST_set(newproto, CvPADLIST(origproto)); CvSTART(newproto) = CvSTART(origproto); SvREFCNT_dec(CvOUTSIDE(newproto)); CvOUTSIDE(newproto) = MUTABLE_CV(SvREFCNT_inc_simple_NN(new)); LEAVE_with_name("find_cv_outside"); newval = MUTABLE_SV(newproto); } else #endif if(origpad[padix]) newval = SvREFCNT_inc_NN(origpad[padix]); } PL_curpad[padix] = newval; } LEAVE_with_name("cv_copy_flags"); } return new; } Object-Pad-0.810/hax/dumpers.c.inc000444001750001750 3344714655674547 15545 0ustar00leoleo000000000000/* vi: set ft=c : */ #define svflags_dump(sv) S_svflags_dump(aTHX_ sv) static const char *svtypes[SVt_LAST] = { [SVt_NULL] = "NULL", [SVt_IV] = "IV", [SVt_NV] = "NV", [SVt_PV] = "PV", [SVt_PVIV] = "PVIV", [SVt_PVNV] = "PVNV", [SVt_PVMG] = "PVMG", [SVt_REGEXP] = "REGEXP", [SVt_PVGV] = "PVGV", [SVt_PVLV] = "PVLV", [SVt_PVAV] = "PVAV", [SVt_PVHV] = "PVHV", [SVt_PVCV] = "PVCV", [SVt_PVFM] = "PVFM", [SVt_PVIO] = "PVIO", }; static struct { const char *name; U32 bits; } svflag[] = { /* common flags */ { "IOK", SVf_IOK }, /* 0x00000100 */ { "NOK", SVf_NOK }, { "POK", SVf_POK }, { "ROK", SVf_ROK }, { "pIOK", SVp_IOK }, { "pNOK", SVp_NOK }, { "pPOK", SVp_POK }, { "PROTECT", SVf_PROTECT }, /* 0x00010000 */ { "PADTMP", SVs_PADTMP }, { "PADSTALE", SVs_PADSTALE }, { "TEMP", SVs_TEMP }, { "OBJECT", SVs_OBJECT }, { "GMG", SVs_GMG }, { "SMG", SVs_SMG }, { "RMG", SVs_RMG }, { "FAKE", SVf_FAKE }, /* 0x01000000 */ { "OOK", SVf_OOK }, { "BREAK", SVf_BREAK }, { "READONLY", SVf_READONLY }, { NULL, 0 }, }; static void S_svflags_dump(pTHX_ SV *sv) { U32 flags = SvFLAGS(sv); U8 type = SvTYPE(sv); flags &= ~SVTYPEMASK; if(type < SVt_LAST && svtypes[type]) fprintf(stderr, "SvTYPE=%s", svtypes[type]); else fprintf(stderr, "SvTYPE=(%02X)", type); for(int i = 0; svflag[i].name; i++) { U32 bits = svflag[i].bits; if(!(flags & bits)) continue; fprintf(stderr, ",%s", svflag[i].name); flags &= ~bits; } if(flags) fprintf(stderr, ",%04X", flags); } #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 HAVE_PERL_VERSION(5, 22, 0) if(PadnameLVALUE(pn)) fprintf(stderr, " *LV"); #endif #if !HAVE_PERL_VERSION(5, 22, 0) /* before Perl 5.22's PADNAME structure, padix==0 does not have COP_SEQ */ if(padix > 0) #endif fprintf(stderr, " [%d..%d]", COP_SEQ_RANGE_LOW(pn), COP_SEQ_RANGE_HIGH(pn)); } if(PadnameFLAGS(pn)) fprintf(stderr, " {PadnameFLAGS=%04X}", PadnameFLAGS(pn)); SV *sv; fprintf(stderr, " = %p\n", sv = PadARRAY(pad)[padix]); if(sv && SvFLAGS(sv)) { fprintf(stderr, " {"); svflags_dump(sv); fprintf(stderr, "}\n"); } } } #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=%zd", 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\",CUR=%zd", SvPVX((SV *)sv), SvCUR(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 #if HAVE_PERL_VERSION(5, 24, 0) #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 in ", cxix, name); switch(cx->blk_gimme) { case G_VOID: fprintf(stderr, "G_VOID "); break; case G_SCALAR: fprintf(stderr, "G_SCALAR "); break; case G_ARRAY: fprintf(stderr, "G_LIST "); break; } 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"); } } #endif Object-Pad-0.810/hax/exec_optree.c.inc000444001750001750 104614655674547 16336 0ustar00leoleo000000000000/* vi: set ft=c : */ #define exec_optree_list(o) S_exec_optree_list(aTHX_ o) static AV *S_exec_optree_list(pTHX_ OP *o) { dSP; ENTER; SAVETMPS; SAVEVPTR(PL_op); PL_op = LINKLIST(o); o->op_next = NULL; PUSHMARK(SP); CALLRUNOPS(aTHX); SPAGAIN; I32 nargs = SP - PL_stack_base - TOPMARK; AV *ret = NULL; if(nargs) { SV **argsvs = SP - nargs + 1; ret = newAV_alloc_x(nargs); for(I32 i = 0; i < nargs; i++) { av_store_simple(ret, i, newSVsv(argsvs[i])); } } FREETMPS; LEAVE; return ret; } Object-Pad-0.810/hax/forbid_outofblock_ops.c.inc000444001750001750 1060514655674547 20432 0ustar00leoleo000000000000/* vi: set ft=c : */ #if !HAVE_PERL_VERSION(5, 16, 0) # define CopLABEL_len_flags(c,len,flags) Perl_fetch_cop_label(aTHX_ (c), len, flags) #endif static void walk_ops_find_labels(pTHX_ OP *o, HV *gotolabels) { switch(o->op_type) { case OP_NEXTSTATE: case OP_DBSTATE: { STRLEN label_len; U32 label_flags; const char *label_pv = CopLABEL_len_flags((COP *)o, &label_len, &label_flags); if(!label_pv) break; SV *labelsv = newSVpvn_flags(label_pv, label_len, label_flags); SAVEFREESV(labelsv); sv_inc(HeVAL(hv_fetch_ent(gotolabels, labelsv, TRUE, 0))); break; } } if(!(o->op_flags & OPf_KIDS)) return; OP *kid = cUNOPo->op_first; while(kid) { walk_ops_find_labels(aTHX_ kid, gotolabels); kid = OpSIBLING(kid); } } enum { FORBID_LOOPEX_DEFAULT = (1<<0), }; static OPCODE walk_ops_forbid(pTHX_ OP *o, U32 flags, HV *permittedloops, HV *permittedgotos) { bool is_loop = FALSE; SV *labelsv = NULL; switch(o->op_type) { case OP_NEXTSTATE: case OP_DBSTATE: PL_curcop = (COP *)o; return 0; case OP_RETURN: goto forbid; case OP_GOTO: { /* OPf_STACKED means either dynamically computed label or `goto &sub` */ if(o->op_flags & OPf_STACKED) goto forbid; SV *target = newSVpv(cPVOPo->op_pv, strlen(cPVOPo->op_pv)); #if HAVE_PERL_VERSION(5, 16, 0) if(cPVOPo->op_private & OPpPV_IS_UTF8) SvUTF8_on(target); #endif SAVEFREESV(target); if(hv_fetch_ent(permittedgotos, target, FALSE, 0)) break; 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 HAVE_PERL_VERSION(5, 16, 0) if(cPVOPo->op_private & OPpPV_IS_UTF8) SvUTF8_on(target); #endif 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_flags(label_pv, label_len, label_flags); SAVEFREESV(labelsv); sv_inc(HeVAL(hv_fetch_ent(permittedloops, labelsv, TRUE, 0))); } is_loop = TRUE; break; } forbid: return o->op_type; default: break; } if(!(o->op_flags & OPf_KIDS)) return 0; OP *kid = cUNOPo->op_first; while(kid) { OPCODE ret = walk_ops_forbid(aTHX_ kid, flags, permittedloops, permittedgotos); if(ret) return ret; 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); } return 0; } #ifndef forbid_outofblock_ops # 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); HV *gotolabels = newHV(); SAVEFREESV((SV *)gotolabels); walk_ops_find_labels(aTHX_ o, gotolabels); OPCODE forbidden = walk_ops_forbid(aTHX_ o, FORBID_LOOPEX_DEFAULT, looplabels, gotolabels); if(forbidden) croak("Can't \"%s\" out of %s", PL_op_name[forbidden], blockname); LEAVE; } #endif #ifndef warn_outofblock_ops # define warn_outofblock_ops(o, fmt) S_warn_outofblock_ops(aTHX_ o, fmt) static void S_warn_outofblock_ops(pTHX_ OP *o, const char *fmt) { ENTER; SAVEVPTR(PL_curcop); HV *looplabels = newHV(); SAVEFREESV((SV *)looplabels); HV *gotolabels = newHV(); SAVEFREESV((SV *)gotolabels); walk_ops_find_labels(aTHX_ o, gotolabels); OPCODE forbidden = walk_ops_forbid(aTHX_ o, FORBID_LOOPEX_DEFAULT, looplabels, gotolabels); if(forbidden) warn(fmt, PL_op_name[forbidden]); LEAVE; } #endif Object-Pad-0.810/hax/force_list_keeping_pushmark.c.inc000444001750001750 133114655674547 21576 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.810/hax/lexer-additions.c.inc000444001750001750 1525314655674547 17154 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.810/hax/make_argcheck_aux.c.inc000444001750001750 132314655674547 17453 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.810/hax/make_argcheck_ops.c.inc000444001750001750 553714655674547 17472 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.810/hax/newOP_CUSTOM.c.inc000444001750001750 610214655674547 16154 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 = (U8)(1 | (flags >> 8)); /* 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.810/hax/op_sibling_splice.c.inc000444001750001750 167714655674547 17532 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.810/hax/optree-additions.c.inc000444001750001750 516314655674547 17312 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 HAVE_PERL_VERSION(5,16,0) 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; } #endif return newBINOP(OP_AELEM, flags, first, newSVOP(OP_CONST, 0, newSViv(key))); } #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; } /* If `@_` is called "snail", then elements of it can be called "slugs"; i.e. * snails without their container */ #define newSLUGOP(idx) S_newSLUGOP(aTHX_ idx) static OP *S_newSLUGOP(pTHX_ int idx) { OP *op = newGVOP(OP_AELEMFAST, 0, PL_defgv); op->op_private = idx; return op; } #ifndef newLISTOPn /* newLISTOPn was added in 5.39.3 */ # define newLISTOPn(type, flags, ...) S_newLISTOPn(aTHX_ type, flags, __VA_ARGS__) static OP *S_newLISTOPn(pTHX_ OPCODE type, U32 flags, ...) { va_list args; va_start(args, flags); OP *o = newLISTOP(OP_LIST, 0, NULL, NULL); OP *kid; while((kid = va_arg(args, OP *))) o = op_append_elem(OP_LIST, o, kid); va_end(args); return op_convert_list(type, flags, o); } #endif Object-Pad-0.810/hax/perl-additions.c.inc000444001750001750 1640614655674547 17000 0ustar00leoleo000000000000/* vi: set ft=c : */ #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 #ifndef gv_fetchmeth_pvs # define gv_fetchmeth_pvs(stash, name, level, flags) gv_fetchmeth_pvn((stash), ("" name ""), (sizeof(name) - 1), level, 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; } #if HAVE_PERL_VERSION(5, 16, 0) /* TODO: perl 5.14 lacks HvNAMEUTF8, gv_fetchmeth_pvn() */ # 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); } #endif /* HAVE_PERL_VERSION(5, 16, 0) */ #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 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.810/hax/perl-backcompat.c.inc000444001750001750 1453114655674547 17123 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 PadnameIsSTATE(pn) (!!SvPAD_STATE(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 #if !HAVE_PERL_VERSION(5, 22, 0) # define CvPADLIST_set(cv, padlist) (CvPADLIST(cv) = padlist) # define newPADNAMEpvn(p,n) S_newPADNAMEpvn(aTHX_ p,n) static PADNAME *S_newPADNAMEpvn(pTHX_ const char *pv, STRLEN n) { PADNAME *pn = newSVpvn(pv, n); /* PADNAMEs need to be at least SVt_PVNV in order to store the COP_SEQ_* * fields */ sv_upgrade(pn, SVt_PVNV); return pn; } # define PadnameREFCNT_dec(pn) SvREFCNT_dec(pn) #endif #ifndef av_count # define av_count(av) (AvFILL(av) + 1) #endif #ifndef av_fetch_simple # define av_fetch_simple(av, idx, lval) av_fetch(av, idx, lval) #endif #ifndef av_push_simple # define av_push_simple(av, sv) av_push(av, sv) #endif #ifndef av_store_simple # define av_store_simple(av, key, sv) av_store(av, key, sv) #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 cophh_exists_pvs # define cophh_exists_pvs(a,b,c) cBOOL(cophh_fetch_pvs(a,b,c)) #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 OpHAS_SIBLING # define OpHAS_SIBLING(op) (cBOOL(OpSIBLING(op))) #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 #ifndef CXp_EVALBLOCK /* before perl 5.34 this was called CXp_TRYBLOCK */ # define CXp_EVALBLOCK CXp_TRYBLOCK #endif #if !HAVE_PERL_VERSION(5, 26, 0) # define sv_set_undef(sv) sv_setsv(sv, &PL_sv_undef) #endif #ifndef newAVav # define newAVav(av) S_newAVav(aTHX_ av) static AV *S_newAVav(pTHX_ AV *av) { AV *ret = newAV(); U32 count = av_count(av); U32 i; for(i = 0; i < count; i++) av_push(ret, newSVsv(AvARRAY(av)[i])); return ret; } #endif #ifndef newAV_alloc_x # define newAV_alloc_x(n) S_newAV_alloc_x(aTHX_ n) static AV *S_newAV_alloc_x(pTHX_ SSize_t n) { AV *av = newAV(); av_extend(av, n-1); return av; } #endif #if !defined(sv_derived_from_hv) && HAVE_PERL_VERSION(5, 16, 0) # 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); } #endif #ifndef xV_FROM_REF # ifdef PERL_USE_GCC_BRACE_GROUPS # define xV_FROM_REF(XV, ref) \ ({ SV *_ref = ref; assert(SvROK(_ref)); assert(SvTYPE(SvRV(_ref)) == SVt_PV ## XV); (XV *)(SvRV(_ref)); }) # else # define xV_FROM_REF(XV, ref) ((XV *)SvRV(ref)) # endif # define AV_FROM_REF(ref) xV_FROM_REF(AV, ref) # define CV_FROM_REF(ref) xV_FROM_REF(CV, ref) # define HV_FROM_REF(ref) xV_FROM_REF(HV, ref) #endif #ifndef newPADxVOP # 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; } #endif Object-Pad-0.810/hax/sv_setrv.c.inc000444001750001750 46114655674547 15667 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.810/include000755001750001750 014655674547 13625 5ustar00leoleo000000000000Object-Pad-0.810/include/class.h000444001750001750 2352614655674547 15270 0ustar00leoleo000000000000#ifndef __OBJECT_PAD__CLASS_H__ #define __OBJECT_PAD__CLASS_H__ #include "suspended_compcv.h" #include "linnet.h" /* Metadata about a class or role */ #define LINNET_VAL_CLASSMETA 0x4F50434D /* "OPCM" */ #define MUST_CLASSMETA(ptr) LINNET_CHECK_CAST(ptr, ClassMeta *, LINNET_VAL_CLASSMETA) struct ClassMeta { LINNET_FIELD enum MetaType type : 8; enum ReprType repr : 8; unsigned int begun : 1; unsigned int sealed : 1; unsigned int role_is_invokable : 1; unsigned int strict_params : 1; unsigned int has_adjust : 1; /* has at least one ADJUST(PARAMS) block */ unsigned int composed_adjust : 1; /* all ADJUST blocks are true blocks, composed into initfields */ unsigned int has_superclass : 1; unsigned int has_buildargs : 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 *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 *buildcvs; /* the BUILD {} phaser blocks; each elem is a CV* directly (MERGED) */ AV *adjustcvs; /* the ADJUST {} phaser blocks; each elem is a CV* directly (MERGED) */ AV *fieldhooks_makefield; /* NULL, or AV of struct FieldHook, all of whose ->funcs->post_makefield 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` */ U32 methodscope_seq; /* PL_cop_seqmax at the time methodscope was created */ SuspendedCompCVBuffer initfields_compcv; /* temporary PL_compcv + associated state during initfields */ OP *initfields_lines; /* temporary OP_LINESEQ to contain the initfield ops */ U32 next_field_for_initfields; /* how many fields have we seen so far? (offset into direct_fields, !NOT! fieldix) */ SuspendedCompCVBuffer adjust_compcv; /* temporary PL_compcv + associated state during true-block ADJUSTs */ CV *adjust_methodscope; /* temporary CV used during compilation of ADJUST blocks */ AV *adjust_params; /* temporary AV of the params used by true-block ADJUST :params */ OP *adjust_lines; /* temporary OP_LINESEQ to contain true-block ADJUSTs */ U32 next_field_for_adjust; /* how many fields have we seen so far? (offset into direct_fields; !NOT! fieldix) */ 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 */ #define LINNET_VAL_ROLEEMBEDDING 0x4F505245 /* "OPRE" */ #define MUST_ROLEEMBEDDING(ptr) LINNET_CHECK_CAST(ptr, RoleEmbedding *, LINNET_VAL_ROLEEMBEDDING) typedef struct RoleEmbedding { LINNET_FIELD SV *embeddingsv; struct ClassMeta *rolemeta; struct ClassMeta *classmeta; PADOFFSET offset; } RoleEmbedding; #define LINNET_VAL_METHODMETA 0x4F504D4D /* "OPMM" */ #define MUST_METHODMETA(ptr) LINNET_CHECK_CAST(ptr, MethodMeta *, LINNET_VAL_METHODMETA) struct MethodMeta { LINNET_FIELD 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 */ unsigned int is_common : 1; }; #define LINNET_VAL_PARAMMETA 0x4F50504D /* "OPPM" */ #define MUST_PARAMMETA(ptr) LINNET_CHECK_CAST(ptr, ParamMeta *, LINNET_VAL_PARAMMETA) typedef struct ParamMeta { LINNET_FIELD SV *name; ClassMeta *class; enum { PARAM_FIELD, PARAM_ADJUST, } type; union { struct { FieldMeta *fieldmeta; FIELDOFFSET fieldix; } field; struct { /* TODO: store the block itself sometime?? */ PADOFFSET padix; OP *defexpr; unsigned int def_if_undef : 1; unsigned int def_if_false : 1; } adjust; }; } ParamMeta; #define MOP_CLASS_RUN_HOOKS_NOARGS(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->attrdata, h->funcdata); \ } \ } #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->attrdata, 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); #define prepare_method_parse(meta) ObjectPad__prepare_method_parse(aTHX_ meta) void ObjectPad__prepare_method_parse(pTHX_ ClassMeta *meta); #define add_fields_to_pad(meta, since_field) ObjectPad__add_fields_to_pad(aTHX_ meta, since_field) void ObjectPad__add_fields_to_pad(pTHX_ ClassMeta *meta, U32 since_field); #define start_method_parse(meta, is_common) ObjectPad__start_method_parse(aTHX_ meta, is_common) void ObjectPad__start_method_parse(pTHX_ ClassMeta *meta, bool is_common); #define finish_method_parse(meta, is_common, body) ObjectPad__finish_method_parse(aTHX_ meta, is_common, body) OP *ObjectPad__finish_method_parse(pTHX_ ClassMeta *meta, bool is_common, OP *body); #define prepare_adjust_params(meta) ObjectPad__prepare_adjust_params(aTHX_ meta) void ObjectPad__prepare_adjust_params(pTHX_ ClassMeta *meta); #define parse_adjust_params(meta, params) ObjectPad__parse_adjust_params(aTHX_ meta, params) void ObjectPad__parse_adjust_params(pTHX_ ClassMeta *meta, AV *params); #define finish_adjust_params(meta, params, body) ObjectPad__finish_adjust_params(aTHX_ meta, params, body) OP *ObjectPad__finish_adjust_params(pTHX_ ClassMeta *meta, AV *params, OP *body); #define newop_croak_from_constructor(message) ObjectPad__newop_croak_from_constructor(aTHX_ message) OP *ObjectPad__newop_croak_from_constructor(pTHX_ SV *message); #define check_colliding_param(classmeta, paramname) ObjectPad__check_colliding_param(aTHX_ classmeta, paramname) void ObjectPad__check_colliding_param(pTHX_ ClassMeta *classmeta, SV *paramname); #define get_embedding_from_pad() ObjectPad__get_embedding_from_pad(aTHX) RoleEmbedding *ObjectPad__get_embedding_from_pad(pTHX); void ObjectPad__boot_classes(pTHX); /* Empty role embedding that is applied to all invokable role methods */ extern struct RoleEmbedding ObjectPad__embedding_standalone; #ifdef HAVE_UNOP_AUX # define METHSTART_CONTAINS_FIELD_BINDINGS /* We'll reserve the top two bits of a UV for storing the `type` value for a * fieldpad operation; the remainder stores the fieldix itself */ # define UVBITS (UVSIZE*8) # define FIELDIX_TYPE_SHIFT (UVBITS-2) # define FIELDIX_MASK ((1LL<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->attrdata, h->funcdata); \ } \ } #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->attrdata, h->funcdata, __VA_ARGS__); \ } \ } void ObjectPad__boot_fields(pTHX); #endif Object-Pad-0.810/include/linnet.h000444001750001750 164314655674547 15430 0ustar00leoleo000000000000#ifndef __LINNET_H__ #define __LINNET_H__ /* A linnet is a bird in the finch family, similar to a canary. */ /* Here, a linnet a debugging feature. We put a field at the start of every * kind of struct, which is always initialised to a unique static value per * type. Whenever we cast a pointer to this type, we also assert that the * linnet field has the right value. In this way we hope to detect invalid * pointer accesses. */ #ifdef DEBUGGING # define DEBUG_LINNETS #endif #ifdef DEBUG_LINNETS # define LINNET_FIELD U32 debug_linnet; # define LINNET_INIT(val) .debug_linnet = (val), # define LINNET_CHECK_CAST(ptr, type, val) \ ({ type castptr = (type)ptr; assert(castptr->debug_linnet == val), castptr;}) #else # define LINNET_FIELD # define LINNET_INIT(val) # define LINNET_CHECK_CAST(ptr, type, val) \ ((type)ptr) #endif #endif Object-Pad-0.810/include/suspended_compcv.h000444001750001750 147614655674547 17504 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; /* perl 5.37.9 defined a set of these but they will collide with ours. we * should keep ours separate for now */ #undef suspend_compcv #undef resume_compcv #undef resume_compcv_and_save #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.810/lib000755001750001750 014655674547 12750 5ustar00leoleo000000000000Object-Pad-0.810/lib/Object000755001750001750 014655674547 14156 5ustar00leoleo000000000000Object-Pad-0.810/lib/Object/Pad.pm000444001750001750 15046514655674547 15430 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-2024 -- leonerd@leonerd.org.uk package Object::Pad 0.810; 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; =encoding UTF-8 =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 { field $x :param = 0; field $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 { field $x :param = 0; field $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. While most of this module has evolved into a stable state in practice, parts remain B because the design is still evolving, and many features and ideas have yet to 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 Experimental Features I Some of the features of this module are currently marked as experimental. They will provoke warnings in the C category, unless silenced. You can silence this with C but then that will silence every experimental warning, which may hide others unintentionally. For a more fine-grained approach you can instead use the import line for this module to only silence the module's warnings selectively: use Object::Pad ':experimental(mop)'; use Object::Pad ':experimental(custom_field_attr)'; use Object::Pad ':experimental(composed_adjust)'; use Object::Pad ':experimental(inherit_field)'; use Object::Pad ':experimental(:all)'; # all of the above I Multiple experimental features can be enabled at once by giving multiple names in the parens, separated by spaces: use Object::Pad ':experimental(mop custom_field_attr)'; I attempting to request all of the experiments at once by using an empty C<:experimental()> is currently accepted, but yields a warning. This may be removed in future. =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 block of every component class is invoked. This happens after the fields are assigned their initial values and the C blocks have been run. =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; 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. 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 inheritance 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. :repr(keys) I The representation will be a blessed hash reference. The instance data will be stored in individual keys of the hash, named after the class and the field variable name, separated by a C symbol. Objects in this representation should behave predictably with data printing modules like L or serialisation via C or C. These two hash-based representation types 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(pvobj) I The representation will be the C type newly added to Perl, which offers more efficient storage for object instances. This is only available on Perl version 5.38.0 onwards. This is also newly-added and may not be fully tested and reliable yet. Once it has more real-world testing and has proven reliable it may become the default instance representation on versions of Perl where it is available. :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 class (anon) my $class = class :ATTRS... { ... }; I If a C keyword is not followed by a package name, it creates an anonymous class expression. This is an expression that yields a value suitable to use as a constructor invocant for creating instances of that class, without specifying what its package name will actually be. This is useful for creating small one-off instances inline in expressions, such as in unit tests. Since it still accepts the usual attributes and inner body statements, it can be useful for creating one-off instances of roles, with required methods being applied. my $testobj = (class { apply Role::Under::Test; method required { return "a useful value"; } })->new; Due to limitations on how classes work in Perl, anonymous classes are still backed by long-lived named classes in the global symbol table, unlike true anonymous functions which can go out of scope and be reclaimed once no references to them remain in existence. This means that anonymous classes will retain references to any variables captured within them, even if the class expression itself goes out of scope and any instances created by it no longer remain. =head2 role role Name :ATTRS... { ... } role Name :ATTRS...; I Similar to C, but provides a package that defines a new role. A role acts similar 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 { field $f; ADJUST { $f = "a value"; } method f { return $f; } } 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 inherit inherit Classname; inherit Classname VER; inherit Classname LIST...; inherit Classname VER LIST...; Declares a superclass that this class extends. At most one superclass is supported. If present, this declaration must come before any methods or fields are declared, or any roles applied. (Other compile-time declarations such as C statements that import utility functions or other behaviours may be permitted before this, however, provided that they do not interact with the class structure in any way). This is a newer form of the C<:isa> attribute intended to be more flexible if import arguments or other features are added at a later time. If the package providing the superclass does not exist, an attempt is made to load it by code equivalent to require Classname; and thus it must either already exist, or be locatable via the usual C<@INC> mechanisms. An optional version check can also be supplied; it performs the equivalent of Classname->VERSION( $ver ) Experimentally I, an optional list of arguments can also be provided, in similar syntax to those in a C statement. Currently this list of arguments must be names of fields to be inherited. Only fields in the base class that are annotated with the C<:inheritable> attribute may be inherited. Once a field is inherited, methods and other expressions in the class body can use that field identically to any fields defined by that class itself. class Class1 { field $x :inheritable = 123; } class Class2 { inherit Class1 '$x'; field $y = 456; method describe { say "Class2(x=$x,y=$y)" } } Class2->new->describe; =head2 apply apply Rolename; apply Rolename VER; I Composes a role into the class; optionally requiring a version check on the role package. This is a newer form of the C<:does> attribute intended to be more flexible if import arguments or other features are added at a later time. Multiple roles can be composed by using multiple C<:does> attributes, one per role. C statements can be freely mixed with other statements inside the body of the class. In particular, an C statement that adds fields or methods may appear before or after the class has defined some of its own. It is not required that they appear first. =head2 field field $var; field @var; field %var; field $var :ATTR ATTR...; field $var = EXPR; field $var //= EXPR; field $var ||= EXPR; field $var { BLOCK } I 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 and C blocks 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. 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. field $x :reader; # equivalent to field $x; method x { return $x } 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. field @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. field $x :writer; # equivalent to field $x; method set_x { $x = 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. field $x :mutator; # equivalent to field $x; method x :lvalue { $x } 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. field $x :accessor; # equivalent to field $x; method x { $x = shift if @_; return $x; } =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 (or C on Perl 5.36 or above) 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: field $x :param; # this is required field $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. =head3 :inheritable Experimentally I fields may be optionally inherited when deriving a subclass from another. Not every field is allowed to be inherited. This attribute marks a field as being available for subclasses to inherit. =head3 Field Initialiser Expressions I a deferred statement block is also permitted, on any field variable type. This 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. I this may also be written as a plain expression introduced by an equals symbol (C<=>). This is equivalent to using a block. Note carefully: the equals symbol is part of the C syntax; it is I simply a runtime assignment operator that happens once at the time the class is declared. Just like the block form describe above, the expression is evaluated during the constructor of every instance. I this expression may also be written using a defined-or or logical-or assignment operator (C or C<||=>). In these case, the default expression will be evaluated and assigned if the caller did not pass a value to the constructor at all, or if the value passed was undef (for C) or false (for C<||=>). For most scalar parameters, where C is not a valid value, you probably wanted to use C to assign defaults. class Action { field $timeout :param //= 20; ... } # The default of 20 will apply here too my $act = Action->new( timeout => $opts{timeout} ); Note that C<$self> is specifically I visible during an initialiser expression. This is because the object is not yet fully constructed, so it would be dangerous to allow access to it while in this state. However, the C<__CLASS__> keyword is available, so initialiser expressions can make use of class-based dispatch to invoke class-level methods to help provide values. Field initialier expressions were originally experimental, but I no longer emit experimental warnings. I fields already declared in a class are visible during the initialisation expression of later fields, and their assigned value can be used here. If the earlier field had a C<:param> declaration, it will have been assigned from the value passed to the constructor. Note however that all C blocks happen I field initialisation expressions, so any modified values set in such blocks will not be visible at this time. Control flow that attempts to leave a field initialiser expression or 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. field $x { foreach(@list) { next; } } # this is fine field $x { LOOP: while(1) { last LOOP; } } # this is fine too =head2 has has $var; has @var; has %var; has $var = EXPR; has $var { BLOCK } A now-deprecated older version of the L keyword. This generally behaves like C, except that inline expressions are evaluated immediately, once, during class declaration time. These are I stored to be evaluated for each constructor. Because of the one-shot immediate nature of these initialisation expressions (and a bunch of other reasons), the C keyword is now discouraged for use and will emit compile-time warnings in the C category. Use the C keyword instead. If you need to evaluate an expression exactly once during the class declaration and assign its now-constant value to every instace, store it in a regular C variable instead: my $default_var = EXPR; field $var = $default_var; =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 { field $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. =head3 :common I Marks that this method is a class-common method, instead of a regular instance method. A class-common method may be invoked on class names instead of instances. Within the method body there is a lexical C<$class> available, rather than C<$self>. Because it is not associated with a particular object instance, a class-common method cannot see instance fields. =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 { field $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). An adjust block is not a subroutine and thus is not permitted to use subroutine attributes (except see below). Note that an C block is a named phaser block and not a method; it does not use the C or C keyword. But, like with C, the member fields are accessible within the code body, as is the special C<$self> lexical. Currently, an C block receives a reference to the hash containing the current constructor arguments, as per L (see below). This was added in version 0.66 but will be removed again as it conflicts with the more flexible and generally nicer named-parameter C syntax (see below). Such uses should be considered deprecated. A warning will be printed to indicate this whenever an C block uses a signature. This warning can be quieted by using C instead. Additionally, a warning may be printed on code that attempts to access the params hashref via the C<@_> array. I in a future version of this module, C blocks may be implemented as true blocks and will not permit out-of-block control flow. At present, they are implemented as one full CV per block, but a warning is emitted if out-of-block control flow is attempted. ADJUST { return; } Using return to leave an ADJUST block is discouraged and will be removed in a later version at FILE line LINE. I an experimental feature can be enabled that puts all the C blocks into a single CV, rather than creating one CV for every block. This is currently being tested for stability, and may become the default behaviour in a future version. For now it must be requested specially: use Object::Pad ':experimental(composed_adjust)'; =head2 ADJUST :params ADJUST :params ( :$var1, :$var2, ... ) { ... } ADJUST :params ( :$var1, :$var2, ..., %varN ) { ... } I An C block can marked with a C<:params> attribute, meaning that it consumes additional constructor parameters by assigning them into lexical variables. Before the block itself, a list of lexical variables are introduced, inside parentheses. The name of each one is preceeded by a colon, and consumes a constructor parameter of the same name. These parameters are considered "consumed" for the purposes of a C<:strict(params)> check. A named parameter may be provided with default expression, which is evaluated if no matching named argument is provided to the constructor. As with fields, if a named parameter has no defaulting expression it becomes a required argument to the constructor; an exception is thrown by the constructor if it absent. For example, ADJUST :params ( :$x, :$y = "default", :$z ) { ... } Note here that C and C are required parameters for the constructor of a class containing this block, but C is an optional parameter whose value will be filled in by the expression if not provided. Because these parameters are named and not positional, there is no ordering constraint; required and optional parameters can be freely mixed. Optional parameters can also use the C and C<||=> operators to provide a default expression. In these cases, the default will be applied if the caller did not provide the named argument at all, or if the provided value was not defined (for C) or not true (for C<||=>). ADJUST :params ( :$name //= "unnamed" ) { ... } Like with subroutine signature parameters, every declared named parameter is visible to the defaulting expression of all the later ones. This permits values to be calculated based on other ones. For example, ADJUST :params ( :$thing = undef, :$things = [ $thing ] ) { # Here, @$things is a list of values } This permits the caller to pass a list of values via an array reference in the C parameter, or a single value in C. The final element may be a regular hash variable. This requests that all remaining named parameters are made available inside it. The code in the block should C from this hash any parameters it wishes to consume, as with the earlier case above. It is I whether named fields or parameters for subclasses yet to be processed are visible to hashes of earlier superclasses. In the current implementation they are, but code should not rely on this fact. Note also that there must be a space between the C<:params> attribute and the parentheses holding the named parameters. If this space is not present, perl will parse the parentheses as if they are the value to the C<:params()> attribute, and this will fail to parse as intended. As with other attributes and subroutine signatures, this whitespace B significant. (This notation is borrowed from a plan to add named parameter support to perl's subroutine signature syntax). =head2 ADJUSTPARAMS I ADJUSTPARAMS ( $params ) { # on perl 5.26 onwards ... } ADJUST { my $params = shift; ... } A variant of an C block that receives 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 __CLASS__ my $classname = __CLASS__; I Only valid within the body (or signature) of a C, an C block, or the initialising expression of a C. Yields the class name of the instance that the method, block or expression is invoked on. This is similar to the core perl C<__PACKAGE__> constant, except that it cares about the dynamic class of the actual instance, not the static class the code belongs to. When invoked by a subclass instance that inherited code from its superclass it yields the name of the class of the instance regardless of which class defined the code. For example, class BaseClass { ADJUST { say "Constructing an instance of " . __CLASS__; } } class DerivedClass :isa(BaseClass) { } my $obj = DerivedClass->new; Will produce the following output Constructing an instance of DerivedClass This is particularly useful in field initialisers for invoking (constant) methods on the invoking class to provide default values for fields. This way a subclass could provide a different value. class Timer { use constant DEFAULT_DURATION => 60; field $duration = __CLASS__->DEFAULT_DURATION; } class ThreeMinuteTimer :isa(Timer) { use constant DEFAULT_DURATION => 3 * 60; } =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 B In order to encourage users to write clean, modern code, the body of the C block currently 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 behaviour was designed early around the original "line-0" version of the Perl 7 plan, which has subsequently been found to be a bad design and abandoned. That leaves this module in an unfortunate situation, because its behaviour here does not match the plans for core perl; where the recently-added C keyword does none of this, although the C keyword always behaves as if signatures were enabled anyway. It is eventually planned that this behaviour will be removed from C entirely (except for enabling the C feature). While that won't in itself break any existing code, it would mean that code which previously ran with the protection of C and C would now not be. A satisfactory solution to this problem has not yet been found, but until then it is suggested that code using this module remembers to explicitly enable this set of pragmata before using the C keyword. A handy way to do this is to use the C syntax; v5.36 or later will already perform all of the pragmata listed above. use v5.36; If you import this module with a module version number of C<0.800> or higher it will enable a warning if you forget to enable C and C before using the C or C keywords: use Object::Pad 0.800; class X { ... } Z<> class keyword enabled 'use strict' but this will be removed in a later version at FILE line 3. class keyword enabled 'use warnings' but this will be removed in a later version at FILE line 3. =head2 Yield True B 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. As with the implied pragmata above, this behaviour has also been found to be a bad design and will likely be removed soon. For now it is suggested not to rely on it and instead either use the new C feature already part of the C pragma, or on older perls simply remember to put an explicit true value at the end of the file. =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 and 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) { field $_value = "B"; ADJUST { $_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 and 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 # field, 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 { field $name :mutator; field $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 { field $_grapefruit; ... method mangle { $_grapefruit->peel; # The leading underscore reminds us this is a field } } =cut sub VERSION { my $pkg = shift; my $ret = $pkg->SUPER::VERSION( @_ ); if( @_ ) { my $ver = version->parse( @_ ); # Only bother to store it if it's >= v0.800 $^H{"Object::Pad/imported-version"} = $ver->numify if $ver ge v0.800; } return $ret; } sub import { my $class = shift; my $caller = caller; $class->import_into( $caller, @_ ); } sub _import_experimental { shift; my ( $syms, @experiments ) = @_; my %enabled; my $i = 0; while( $i < @$syms ) { my $sym = $syms->[$i]; if( $sym eq ":experimental" ) { carp "Enabling all Object::Pad experiments with an unqualified :experimental"; $enabled{$_}++ for @experiments; } elsif( $sym =~ m/^:experimental\((.*)\)$/ ) { foreach my $tag ( split m/\s+/, $1 =~ s/^\s+|\s+$//gr ) { if( $tag eq ":all" ) { $enabled{$_}++ for @experiments; } else { $enabled{$tag}++; } } } else { $i++; next; } splice @$syms, $i, 1, (); } foreach ( @experiments ) { $^H{"Object::Pad/experimental($_)"}++ if delete $enabled{$_}; } croak "Unrecognised :experimental features @{[ keys %enabled ]}" if keys %enabled; } sub _import_configuration { shift; my ( $syms ) = @_; # Undocumented options, purely to support Feature::Compat::Class adjusting # the behaviour to closer match core's use feature 'class' my $i = 0; while( $i < @$syms ) { my $sym = $syms->[$i]; if( $sym =~ m/^:config\((.*)\)$/ ) { foreach my $opt ( split m/\s+/, $1 =~ s/^\s+|\s+$//gr ) { if( $opt =~ m/^(only_class_attrs|only_field_attrs)=(.*)$/ ) { # Store an entire sub-hash inside the hints hash. This won't # survive squashing into a COP for runtime but we only need it # during compile so that's OK my ( $name, $attrs ) = ( $1, $2 ); $^H{"Object::Pad/configure($name)"} = { map { $_ => 1 } split m/,/, $attrs }; } else { $^H{"Object::Pad/configure($opt)"}++ } } } else { $i++; next; } splice @$syms, $i, 1, (); } } sub import_into { my $class = shift; my $caller = shift; $class->_import_experimental( \@_, qw( init_expr mop custom_field_attr adjust_params composed_adjust inherit_field ) ); $class->_import_configuration( \@_ ); my %syms = map { $_ => 1 } @_; # Default imports unless( %syms ) { $syms{$_}++ for qw( class role inherit apply method field has requires BUILD ADJUST ); } delete $syms{$_} and $^H{"Object::Pad/$_"}++ for qw( class role inherit apply method field has requires BUILD ADJUST ); croak "Unrecognised import symbols @{[ keys %syms ]}" if keys %syms; } # The universal base-class methods sub Object::Pad::UNIVERSAL::BUILDARGS { shift; # $class return @_; } # Back-compat wrapper sub Object::Pad::MOP::SlotAttr::register { shift; # $class croak "Object::Pad::MOP::SlotAttr->register is now removed; use Object::Pad::MOP::FieldAttr->register instead"; } =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 { field $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. =head2 Devel::MAT When using L to help analyse or debug memory issues with programs that use C, you will likely want to additionally install the module L. This will provide new commands and extend existing ones to better assist with analysing details related to C classes and instances of them. pmat> fields 0x55d7c173d4b8 The field AV ARRAY(3)=NativeClass at 0x55d7c173d4b8 Ix Field Value 0 $sfield SCALAR(UV) at 0x55d7c173d938 = 123 ... pmat> identify 0x55d7c17606d8 REF() at 0x55d7c17606d8 is: └─the %hfield field of ARRAY(3)=NativeClass at 0x55d7c173d4b8, which is: ... =head1 DESIGN TODOs The following points are details about the design of pad field-based object systems in general: =over 4 =item * Is multiple inheritance 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 inheritance 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; field $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.810/lib/Object/Pad.xs000444001750001750 16110414655674547 15436 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-2023 -- 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 # define WANT_DMD_API_044 # include "DMD_helper.h" #endif #include "perl-additions.c.inc" #include "lexer-additions.c.inc" #include "exec_optree.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" #define warn_deprecated(...) Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED), __VA_ARGS__) typedef void MethodAttributeHandler(pTHX_ MethodMeta *meta, const char *value, void *data); struct MethodAttributeDefinition { char *attrname; /* TODO: int flags */ MethodAttributeHandler *apply; void *applydata; }; /********************************** * Class and Field Implementation * **********************************/ 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/fields)", 0, NULL, NULL); if(padix != PADIX_FIELDS) croak("ARGH: Expected that padix[@fields] = 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 bind_field_to_pad(sv, fieldix, private, padix) S_bind_field_to_pad(aTHX_ sv, fieldix, private, padix) static void S_bind_field_to_pad(pTHX_ SV *sv, FIELDOFFSET fieldix, U8 private, PADOFFSET padix) { SV *val; switch(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(padix)); PAD_SVl(padix) = SvREFCNT_inc(val); save_freesv(val); } 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 = MUST_ROLEEMBEDDING(SvPVX(embeddingsv)))) { if(embedding == &ObjectPad__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(!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 *fieldstore; if(is_role) { if(embedding == &ObjectPad__embedding_standalone) { fieldstore = NULL; } else { fieldstore = get_obj_fieldstore(self, embedding->classmeta->repr, create); } } else { /* op_private contains the repr type so we can extract backing */ fieldstore = get_obj_fieldstore(self, PL_op->op_private, create); } if(fieldstore) { SAVESPTR(PAD_SVl(PADIX_FIELDS)); PAD_SVl(PADIX_FIELDS) = SvREFCNT_inc(fieldstore); save_freesv(fieldstore); } #ifdef METHSTART_CONTAINS_FIELD_BINDINGS UNOP_AUX_item *aux = cUNOP_AUX->op_aux; if(aux) { U32 fieldcount = (aux++)->uv; U32 max_fieldix = (aux++)->uv; SV **fieldsvs = fieldstore_fields(fieldstore); if(max_fieldix + offset > fieldstore_maxfield(fieldstore)) croak("ARGH: instance does not have a field at index %ld", (long int)max_fieldix); while(fieldcount) { PADOFFSET padix = (aux++)->uv; UV fieldix = (aux++)->uv + offset; U8 private = fieldix >> FIELDIX_TYPE_SHIFT; fieldix &= FIELDIX_MASK; bind_field_to_pad(fieldsvs[fieldix], fieldix, private, padix); fieldcount--; } } #else PERL_UNUSED_VAR(offset); #endif return PL_op->op_next; } OP *ObjectPad_newMETHSTARTOP(pTHX_ U32 flags) { #ifdef METHSTART_CONTAINS_FIELD_BINDINGS /* We know we're on 5.22 or above, so no worries about assert failures */ OP *op = newUNOP_AUX(OP_CUSTOM, flags, NULL, NULL); op->op_ppaddr = &pp_methstart; #else OP *op = newOP_CUSTOM(&pp_methstart, flags); #endif op->op_private = (U8)(flags >> 8); return op; } static XOP xop_commonmethstart; static OP *pp_commonmethstart(pTHX) { SV *self = av_shift(GvAV(PL_defgv)); if(SvROK(self)) /* TODO: Should handle this somehow */ croak("Cannot invoke common method on an instance"); save_clearsv(&PAD_SVl(PADIX_SELF)); sv_setsv(PAD_SVl(PADIX_SELF), self); return PL_op->op_next; } OP *ObjectPad_newCOMMONMETHSTARTOP(pTHX_ U32 flags) { OP *op = newOP_CUSTOM(&pp_commonmethstart, 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 padix = PL_op->op_targ; if(PL_op->op_flags & OPf_SPECIAL) { RoleEmbedding *embedding = get_embedding_from_pad(); if(embedding && embedding != &ObjectPad__embedding_standalone) { fieldix += embedding->offset; } } SV *fieldstore = PAD_SV(PADIX_FIELDS); SV **fieldsvs = fieldstore_fields(fieldstore); if(fieldix > fieldstore_maxfield(fieldstore)) croak("ARGH: instance does not have a field at index %ld", (long int)fieldix); bind_field_to_pad(fieldsvs[fieldix], fieldix, PL_op->op_private, padix); 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 MUST_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, PTR2UV(meta)); } ClassMeta *ObjectPad_get_compclassmeta(pTHX) { if(!have_compclassmeta) croak("An Object::Pad class is not currently under compilation"); return compclassmeta; } XS_INTERNAL(xsub_mop_class_seal) { dXSARGS; ClassMeta *meta = MUST_CLASSMETA(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; } static 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_apply_method_common(pTHX_ MethodMeta *meta, const char *val, void *_data) { meta->is_common = true; } static void S_apply_method_override(pTHX_ MethodMeta *meta, const char *val, void *_data) { if(!meta->name) croak("Cannot apply :override to anonymous methods"); GV *gv = gv_fetchmeth_sv(compclassmeta->stash, meta->name, 0, 0); if(gv && GvCV(gv)) return; croak("Superclass does not have a method named '%" SVf "'", SVfARG(meta->name)); } static struct MethodAttributeDefinition method_attributes[] = { { "common", &S_apply_method_common, NULL }, { "override", &S_apply_method_override, NULL }, { 0 } }; /******************* * Custom Keywords * *******************/ static IV next_anonclass_id; static int build_classlike(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata) { int argi = 0; HV *hints = GvHV(PL_hintgv); int imported_version = 0; { SV **svp; if(hints && (svp = hv_fetchs(hints, "Object::Pad/imported-version", 0))) imported_version = SvNV(*svp) * 1000; } bool is_anon = false; SV *packagename = args[argi++]->sv; if(!packagename) { is_anon = true; packagename = newSVpvf("Object::Pad::__ANONCLASS__::%" IVdf, next_anonclass_id++); } enum MetaType type = PTR2UV(hookdata); SV *packagever = args[argi++]->sv; if(args[argi++]->i) /* isa */ croak("ARGH should not have seen any 'isa' keywords"); ClassMeta *meta = mop_create_class(type, packagename); int nimplements = args[argi++]->i; if(nimplements) croak("ARGH should not have seen any 'does' keywords"); int nattrs = args[argi++]->i; if(nattrs) { if(hv_fetchs(hints, "Object::Pad/configure(no_class_attrs)", 0)) croak("Class/role attributes are not permitted"); SV **svp = hv_fetchs(hints, "Object::Pad/configure(only_class_attrs)", 0); HV *only_class_attrs = svp && SvROK(*svp) ? HV_FROM_REF(*svp) : NULL; int i; for(i = 0; i < nattrs; i++) { SV *attrname = args[argi]->attr.name; SV *attrval = args[argi]->attr.value; if(only_class_attrs && !hv_fetch_ent(only_class_attrs, attrname, 0, 0)) croak("Class/role attribute :%" SVf " is not permitted", SVfARG(attrname)); inplace_trim_whitespace(attrval); mop_class_apply_attribute(meta, SvPVX(attrname), attrval); argi++; } } if(hv_fetchs(hints, "Object::Pad/configure(always_strict)", 0)) { mop_class_apply_attribute(meta, "strict", sv_2mortal(newSVpvs("params"))); } /* 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; if(is_anon) croak("Anonymous class requires a {BLOCK}"); } else croak("Expected a block or ';'"); if(!hv_fetchs(hints, "Object::Pad/configure(no_implicit_pragmata)", 0)) { bool was_explicit_strict = (PL_hints & HINT_STRICT_REFS) && (PL_hints & HINT_STRICT_SUBS) && (PL_hints & HINT_STRICT_VARS); bool was_explicit_warnings = PL_compiling.cop_warnings != pWARN_STD; /* TODO: might be set to something custom? */ 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 if(imported_version >= 800) { const char *kwname = (type == METATYPE_ROLE) ? "role" : "class"; if(!was_explicit_strict) warn("%s keyword enabled 'use strict' but this will be removed in a later version", kwname); if(!was_explicit_warnings) warn("%s keyword enabled 'use warnings' but this will be removed in a later version", kwname); } } /* 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; if(is_anon) { *out = newSVOP(OP_CONST, 0, SvREFCNT_inc(packagename)); return KEYWORD_PLUGIN_EXPR; } else { /* 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_OPT, XPK_VSTRING_OPT, XPK_OPTIONAL( XPK_LITERAL("isa"), XPK_FAILURE("The 'isa' modifier keyword is no longer available; use 'inherit' instead") ), XPK_REPEATED( XPK_LITERAL("does"), XPK_FAILURE("The 'does' modifier keyword is no longer available; use 'apply' instead") ), 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 int build_inherit(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata) { int argi = 0; SV *supername = args[argi++]->sv; SV *superver = args[argi++]->sv; OP *argsexpr = args[argi++]->op; ClassMeta *meta = compclassmeta; if(meta->begun) croak("Too late to 'inherit' into a class; this must be the first significant declaration within the class"); AV *argsav = NULL; if(argsexpr) { SAVEFREEOP(argsexpr); argsav = exec_optree_list(argsexpr); SAVEFREESV(argsav); } mop_class_load_and_set_superclass(meta, supername, superver); mop_class_begin(meta); if(argsav && av_count(argsav)) { HV *hints = GvHV(PL_hintgv); if(!hv_fetchs(hints, "Object::Pad/experimental(inherit_field)", 0)) Perl_ck_warner(aTHX_ packWARN(WARN_EXPERIMENTAL), "inheriting fields is experimental and may be changed or removed without notice"); mop_class_inherit_from_superclass(meta, AvARRAY(argsav), av_count(argsav)); } return KEYWORD_PLUGIN_STMT; } static const struct XSParseKeywordHooks kwhooks_inherit = { .permit_hintkey = "Object::Pad/inherit", .pieces = (const struct XSParseKeywordPieceType []){ XPK_PACKAGENAME, XPK_VSTRING_OPT, XPK_LISTEXPR_LISTCTX_OPT, {0} }, .build = &build_inherit, }; static int build_apply(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata) { int argi = 0; SV *rolename = args[argi++]->sv; SV *rolever = args[argi++]->sv; ClassMeta *meta = compclassmeta; mop_class_begin(meta); mop_class_load_and_add_role(meta, rolename, rolever); return KEYWORD_PLUGIN_STMT; } static const struct XSParseKeywordHooks kwhooks_apply = { .permit_hintkey = "Object::Pad/apply", .pieces = (const struct XSParseKeywordPieceType []){ XPK_PACKAGENAME, XPK_VSTRING_OPT, /* TODO: Allow more apply-time args later */ {0} }, .build = &build_apply, }; enum { FIELD_INIT_CLASSEXPR, FIELD_INIT_BLOCK, FIELD_INIT_EXPR, FIELD_INIT_DOREXPR, FIELD_INIT_OREXPR, }; static void check_field(pTHX_ void *hookdata) { char *kwname = hookdata; if(!have_compclassmeta) croak("Cannot '%s' outside of 'class'", kwname); 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_field(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata) { int argi = 0; SV *name = args[argi++]->sv; char sigil = SvPV_nolen(name)[0]; ClassMeta *classmeta = compclassmeta; mop_class_begin(classmeta); FieldMeta *fieldmeta = mop_class_add_field(classmeta, name); SvREFCNT_dec(name); int nattrs = args[argi++]->i; if(nattrs) { if(hv_fetchs(GvHV(PL_hintgv), "Object::Pad/configure(no_field_attrs)", 0)) croak("Field attributes are not permitted"); SV **svp = hv_fetchs(GvHV(PL_hintgv), "Object::Pad/configure(only_field_attrs)", 0); HV *only_field_attrs = svp && SvROK(*svp) ? HV_FROM_REF(*svp) : NULL; 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; if(only_field_attrs && !hv_fetch_ent(only_field_attrs, attrname, 0, 0)) croak("Field attribute :%" SVf " is not permitted", SVfARG(attrname)); inplace_trim_whitespace(attrval); mop_field_parse_and_apply_attribute(fieldmeta, SvPVX(attrname), attrval); if(attrval) SvREFCNT_dec(attrval); argi++; } } bool is_block = FALSE; /* 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... :/ */ int inittype = args[argi++]->i; switch(inittype) { case -1: /* no expr */ break; case FIELD_INIT_CLASSEXPR: { OP *op = args[argi++]->op; SV *defaultsv = newSV(0); /* 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; } mop_field_set_default_sv(fieldmeta, defaultsv); } break; case FIELD_INIT_BLOCK: is_block = TRUE; /* FALLTHROUGH */ case FIELD_INIT_EXPR: case FIELD_INIT_DOREXPR: case FIELD_INIT_OREXPR: { OP *op = args[argi++]->op; U8 want = 0; forbid_outofblock_ops(op, is_block ? "a field initialiser block" : "a field initialiser expression"); switch(sigil) { case '$': want = G_SCALAR; break; case '@': case '%': want = G_LIST; break; } fieldmeta->defaultexpr = op_contextualize(op_scope(op), want); if(inittype == FIELD_INIT_DOREXPR) fieldmeta->def_if_undef = true; if(inittype == FIELD_INIT_OREXPR) fieldmeta->def_if_false = true; } break; } mop_field_seal(fieldmeta); return KEYWORD_PLUGIN_STMT; } static void setup_parse_field(pTHX_ bool is_block) { CV *was_compcv = PL_compcv; HV *hints = GvHV(PL_hintgv); ClassMeta *classmeta = compclassmeta; resume_compcv_and_save(&classmeta->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; hv_stores(hints, "Object::Pad/__CLASS__", newSVsv(&PL_sv_yes)); hv_stores(hints, "Object::Pad/fieldcopline", newSVuv(CopLINE(PL_curcop))); if(!is_block) { /* Hide the $self lexical by scrubbing its name */ PADNAME *pn_self = PadnamelistARRAY(PadlistNAMES(CvPADLIST(PL_compcv)))[PADIX_SELF]; SAVEI8(PadnamePV(pn_self)[1]); PadnamePV(pn_self)[1] = '\0'; } U32 nfields = av_count(classmeta->fields); if(classmeta->next_field_for_initfields < nfields) { add_fields_to_pad(classmeta, classmeta->next_field_for_initfields); intro_my(); classmeta->next_field_for_initfields = nfields; } } static void setup_parse_field_initblock(pTHX_ void *hookdata) { HV *hints = GvHV(PL_hintgv); if(hv_fetchs(hints, "Object::Pad/configure(no_field_block)", 0)) croak("Field initialisation block is not permitted"); if(!hv_fetchs(hints, "Object::Pad/experimental(init_expr)", 0)) Perl_ck_warner(aTHX_ packWARN(WARN_EXPERIMENTAL), "field initialiser block is experimental and may be changed or removed without notice"); setup_parse_field(aTHX_ TRUE); } static void setup_parse_field_initexpr(pTHX_ void *hookdata) { setup_parse_field(aTHX_ FALSE); } #define XPK_DOREQUALS XPK_LITERAL("//=") #define XPK_OREQUALS XPK_LITERAL("||=") static const struct XSParseKeywordHooks kwhooks_field = { .flags = XPK_FLAG_STMT, .permit_hintkey = "Object::Pad/field", .check = &check_field, .pieces = (const struct XSParseKeywordPieceType []){ XPK_LEXVARNAME(XPK_LEXVAR_ANY), XPK_ATTRIBUTES, XPK_TAGGEDCHOICE( XPK_PREFIXED_BLOCK_ENTERLEAVE(XPK_SETUP(&setup_parse_field_initblock)), XPK_TAG(FIELD_INIT_BLOCK), XPK_SEQUENCE(XPK_EQUALS, XPK_PREFIXED_TERMEXPR_ENTERLEAVE(XPK_SETUP(&setup_parse_field_initexpr)), XPK_AUTOSEMI), XPK_TAG(FIELD_INIT_EXPR), XPK_SEQUENCE(XPK_DOREQUALS, XPK_PREFIXED_TERMEXPR_ENTERLEAVE(XPK_SETUP(&setup_parse_field_initexpr)), XPK_AUTOSEMI), XPK_TAG(FIELD_INIT_DOREXPR), XPK_SEQUENCE(XPK_OREQUALS, XPK_PREFIXED_TERMEXPR_ENTERLEAVE(XPK_SETUP(&setup_parse_field_initexpr)), XPK_AUTOSEMI), XPK_TAG(FIELD_INIT_OREXPR) ), {0} }, .build = &build_field, }; static const struct XSParseKeywordHooks kwhooks_has = { .flags = XPK_FLAG_STMT, .permit_hintkey = "Object::Pad/has", .check = &check_field, .pieces = (const struct XSParseKeywordPieceType []){ XPK_WARNING_DEPRECATED("'has' is deprecated; use 'field' instead"), XPK_LEXVARNAME(XPK_LEXVAR_ANY), XPK_ATTRIBUTES, XPK_CHOICE( XPK_SEQUENCE(XPK_EQUALS, XPK_TERMEXPR, XPK_AUTOSEMI), XPK_PREFIXED_BLOCK_ENTERLEAVE(XPK_SETUP(&setup_parse_field_initblock)) ), {0} }, .build = &build_field, }; /* 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] = "ADJUST", }; static bool parse_method_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_method_pre_subparse(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata) { enum PhaserType type = PTR2UV(hookdata); /* 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: case PHASER_BUILD: case PHASER_ADJUST: break; case PHASER_ADJUSTPARAMS: if(0) warn("ADJUSTPARAMS is now the same as ADJUST; you should use ADJUST instead"); 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; ClassMeta *meta = compclassmeta; mop_class_begin(meta); prepare_method_parse(meta); MethodMeta *compmethodmeta; Newx(compmethodmeta, 1, MethodMeta); *compmethodmeta = (MethodMeta){ LINNET_INIT(LINNET_VAL_METHODMETA) .name = SvREFCNT_inc(ctx->name), }; hv_stores(ctx->moddata, "Object::Pad/compmethodmeta", newSVuv(PTR2UV(compmethodmeta))); hv_stores(GvHV(PL_hintgv), "Object::Pad/__CLASS__", newSVsv(&PL_sv_yes)); } static bool parse_method_filter_attr(pTHX_ struct XSParseSublikeContext *ctx, SV *attr, SV *val, void *hookdata) { MethodMeta *compmethodmeta = MUST_METHODMETA(SvUV(*hv_fetchs(ctx->moddata, "Object::Pad/compmethodmeta", 0))); struct MethodAttributeDefinition *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_ compmethodmeta, SvPOK(val) ? SvPVX(val) : NULL, def->applydata); return true; } /* No error, just let it fall back to usual attribute handling */ return false; } static bool parse_phaser_filter_attr(pTHX_ struct XSParseSublikeContext *ctx, SV *attr, SV *val, void *hookdata) { enum PhaserType type = PTR2UV(hookdata); HV *hints = GvHV(PL_hintgv); if(hv_fetchs(hints, "Object::Pad/configure(no_adjust_attrs)", 0)) croak("ADJUST block attributes are not permitted"); if(strEQ(SvPVX(attr), "params")) { if(type != PHASER_ADJUST) croak("Cannot set :params for a phaser block other than ADJUST"); hv_stores(ctx->moddata, "Object::Pad/ADJUST:params", newRV_noinc((SV *)newAV())); return true; } return false; } static void parse_method_post_blockstart(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata) { enum PhaserType type = PTR2UV(hookdata); MethodMeta *compmethodmeta = MUST_METHODMETA(SvUV(*hv_fetchs(ctx->moddata, "Object::Pad/compmethodmeta", 0))); /* `method` always permits signatures */ #ifdef HAVE_PARSE_SUBSIGNATURE import_pragma("feature", "signatures"); import_pragma("-warnings", "experimental::signatures"); #endif start_method_parse(compclassmeta, compmethodmeta->is_common); SV **svp; if(type == PHASER_ADJUST && (svp = hv_fetchs(ctx->moddata, "Object::Pad/ADJUST:params", 0))) { AV *params = AV_FROM_REF(*svp); prepare_adjust_params(compclassmeta); parse_adjust_params(compclassmeta, params); } } #define walk_optree_warn_for_defargs(o) S_walk_optree_warn_for_defargs(aTHX_ o) static void S_walk_optree_warn_for_defargs(pTHX_ OP *o); static void S_walk_optree_warn_for_defargs(pTHX_ OP *o) { OP *kid; switch(o->op_type) { case OP_NEXTSTATE: case OP_DBSTATE: PL_curcop = (COP *)o; break; case OP_RV2AV: /* check for @_; also catches $_[0] as part of AELEM etc */ if(o->op_flags & OPf_KIDS && (kid = cUNOPo->op_first) && kid->op_type == OP_GV && kGVOP_gv == PL_defgv) warn_deprecated("Use of @_ is deprecated in ADJUST"); break; case OP_SHIFT: case OP_POP: if(o->op_flags & OPf_SPECIAL) warn_deprecated("Implicit use of @_ in %s is deprecated in ADJUST", PL_op_name[o->op_type]); break; } if(o->op_flags & OPf_KIDS) { for(kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) walk_optree_warn_for_defargs(kid); } } static void parse_method_pre_blockend(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata) { enum PhaserType type = PTR2UV(hookdata); MethodMeta *compmethodmeta = MUST_METHODMETA(SvUV(*hv_fetchs(ctx->moddata, "Object::Pad/compmethodmeta", 0))); SV **svp; if(type == PHASER_ADJUST) { ENTER; SAVEVPTR(PL_curcop); #if HAVE_PERL_VERSION(5, 26, 0) OP *o = ctx->body; /* Try to find the first significant op in the tree. There's a few * standard tricks we can do to attempt to find the OP_ARGCHECK if there * is one. */ while(1) { redo: if(!o) break; switch(o->op_type) { case OP_NULL: if(o->op_targ == OP_ARGCHECK) { o = cUNOPo->op_first; goto redo; } o = NULL; break; case OP_NEXTSTATE: case OP_DBSTATE: PL_curcop = (COP *)o; o = OpSIBLING(o); goto redo; case OP_LINESEQ: o = cLISTOPo->op_first; goto redo; } break; } if(o && o->op_type == OP_ARGCHECK) { warn_deprecated("Use of ADJUST (signature) {BLOCK} is now deprecated"); } #endif walk_optree_warn_for_defargs(ctx->body); LEAVE; } if(type == PHASER_ADJUST && (svp = hv_fetchs(ctx->moddata, "Object::Pad/ADJUST:params", 0))) { AV *params = AV_FROM_REF(*svp); ctx->body = finish_adjust_params(compclassmeta, params, ctx->body); } ctx->body = finish_method_parse(compclassmeta, compmethodmeta->is_common, ctx->body); 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_method_post_newcv(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata) { enum PhaserType type = PTR2UV(hookdata); MethodMeta *compmethodmeta; { SV *tmpsv = *hv_fetchs(ctx->moddata, "Object::Pad/compmethodmeta", 0); compmethodmeta = MUST_METHODMETA(SvUV(tmpsv)); sv_setuv(tmpsv, 0); } 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)) { MethodMeta *meta = mop_class_add_method(compclassmeta, ctx->name); meta->is_common = compmethodmeta->is_common; } break; case PHASER_BUILD: mop_class_add_BUILD(compclassmeta, ctx->cv); /* steal CV */ break; case PHASER_ADJUST: case PHASER_ADJUSTPARAMS: mop_class_add_ADJUST(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); SvREFCNT_dec(compmethodmeta->name); Safefree(compmethodmeta); } 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_method_permit, .pre_subparse = parse_method_pre_subparse, .filter_attr = parse_method_filter_attr, .post_blockstart = parse_method_post_blockstart, .pre_blockend = parse_method_pre_blockend, .post_newcv = parse_method_post_newcv, }; static struct XSParseSublikeHooks parse_phaser_hooks = { .flags = XS_PARSE_SUBLIKE_FLAG_FILTERATTRS | XS_PARSE_SUBLIKE_COMPAT_FLAG_DYNAMIC_ACTIONS, .skip_parts = XS_PARSE_SUBLIKE_PART_NAME, /* no permit */ .pre_subparse = parse_method_pre_subparse, .filter_attr = parse_phaser_filter_attr, .post_blockstart = parse_method_post_blockstart, .pre_blockend = parse_method_pre_blockend, .post_newcv = parse_method_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); if(PTR2UV(hookdata) == PHASER_ADJUST && compclassmeta->composed_adjust) { ClassMeta *classmeta = compclassmeta; ENTER; resume_compcv_and_save(&classmeta->adjust_compcv); bool do_params = false; if(lex_consume_unichar(':')) { lex_read_space(0); SV *name = sv_newmortal(), *val = sv_newmortal(); /* A custom copy of lex_scan_attrs() because we only care about one thing */ while(lex_scan_attrval_into(name, val)) { lex_read_space(0); if(!strEQ(SvPVX(name), "params")) // Normally core perl makes this complaint; we'll have to make do here SvPOK(val) ? croak("Invalid CODE attribute %" SVf "(%" SVf ")", SVfARG(name), SVfARG(val)) : croak("Invalid CODE attribute %" SVf, SVfARG(name)); // ignore the value - even its mere presence do_params = true; if(lex_peek_unichar(0) == ':') { lex_read_unichar(0); lex_read_space(0); } } } U32 nfields = av_count(classmeta->fields); if(classmeta->next_field_for_adjust < nfields) { ENTER; SAVESPTR(PL_comppad); SAVESPTR(PL_comppad_name); SAVESPTR(PL_curpad); CV *fieldscope = CvOUTSIDE(PL_compcv); PL_comppad = PadlistARRAY(CvPADLIST(fieldscope))[1]; PL_comppad_name = PadlistNAMES(CvPADLIST(fieldscope)); PL_curpad = AvARRAY(PL_comppad); add_fields_to_pad(classmeta, classmeta->next_field_for_adjust); intro_my(); LEAVE; classmeta->next_field_for_adjust = nfields; } CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax; if(do_params) { parse_adjust_params(classmeta, classmeta->adjust_params); } OP *body = parse_block(0); if(!body || PL_parser->error_count) { croak("syntax error"); } classmeta->adjust_lines = op_append_list(OP_LINESEQ, classmeta->adjust_lines, body); LEAVE; return KEYWORD_PLUGIN_STMT; } return xs_parse_sublike(&parse_phaser_hooks, hookdata, out); } static const struct XSParseKeywordHooks kwhooks_BUILD = { .permit_hintkey = "Object::Pad/BUILD", .parse = &parse_phaser, }; static const struct XSParseKeywordHooks kwhooks_ADJUST = { .permit_hintkey = "Object::Pad/ADJUST", .parse = &parse_phaser, }; static void check_uuCLASS(pTHX_ void *hookdata) { /* We test this other hints key purely to get a more useful error message * in cases like class X { say "My class is", __CLASS__; } */ SV **svp; if(!(svp = hv_fetchs(GvHV(PL_hintgv), "Object::Pad/__CLASS__", 0)) || !SvTRUE(*svp)) croak("Cannot use __CLASS__ outside of a method, ADJUST block or field initialiser"); } static OP *pp_curclass(pTHX) { dSP; SV *self = PAD_SVl(PADIX_SELF); assert(SvROK(self) && SvOBJECT(SvRV(self))); EXTEND(SP, 1); PUSHs(sv_newmortal()); #if HAVE_PERL_VERSION(5, 24, 0) sv_ref(*SP, SvRV(self), TRUE); #else HV *stash = SvSTASH(SvRV(self)); sv_setpv(*SP, HvNAME(stash)); if(HvNAMEUTF8(stash)) SvUTF8_on(*SP); #endif RETURN; } static int build_uuCLASS(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata) { *out = newOP_CUSTOM(&pp_curclass, 0); return KEYWORD_PLUGIN_EXPR; } static const struct XSParseKeywordHooks kwhooks_uuCLASS = { .flags = XPK_FLAG_EXPR, .permit_hintkey = "Object::Pad/class", .check = &check_uuCLASS, .pieces = (const struct XSParseKeywordPieceType []){ {0} }, .build = &build_uuCLASS, }; 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; ClassMeta *meta = compclassmeta; mop_class_begin(meta); mop_class_add_required_method(meta, 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_WARNING_DEPRECATED("'requires' is now discouraged; use an empty 'method NAME;' declaration instead"), XPK_IDENT, {0} }, .build = &build_requires, }; #ifdef HAVE_DMD_HELPER static void dump_fieldmeta(pTHX_ DMDContext *ctx, FieldMeta *fieldmeta) { DMD_DUMP_STRUCT(ctx, "Object::Pad/FieldMeta", fieldmeta, sizeof(FieldMeta), 7, ((const DMDNamedField []){ {"the name SV", DMD_FIELD_PTR, .ptr = fieldmeta->name}, {"is direct", DMD_FIELD_BOOL, .b = fieldmeta->is_direct}, {"the class", DMD_FIELD_PTR, .ptr = fieldmeta->class}, {"the default value SV", DMD_FIELD_PTR, .ptr = mop_field_get_default_sv(fieldmeta)}, /* TODO: Maybe hunt for constants in the defaultexpr optree fragment? */ {"fieldix", DMD_FIELD_UINT, .n = fieldmeta->fieldix}, {"the :param name SV", DMD_FIELD_PTR, .ptr = fieldmeta->paramname}, {"the hooks AV", DMD_FIELD_PTR, .ptr = fieldmeta->hooks}, }) ); } static void dump_methodmeta(pTHX_ DMDContext *ctx, MethodMeta *methodmeta) { DMD_DUMP_STRUCT(ctx, "Object::Pad/MethodMeta", methodmeta, sizeof(MethodMeta), 4, ((const DMDNamedField []){ {"the name SV", DMD_FIELD_PTR, .ptr = methodmeta->name}, {"the class", DMD_FIELD_PTR, .ptr = methodmeta->class}, {"the origin role", DMD_FIELD_PTR, .ptr = methodmeta->role}, {"is_common", DMD_FIELD_BOOL, .b = methodmeta->is_common}, }) ); } static void dump_parammeta(pTHX_ DMDContext *ctx, ParamMeta *parammeta) { switch(parammeta->type) { case PARAM_FIELD: DMD_DUMP_STRUCT(ctx, "Object::Pad/ParamMeta.field", parammeta, sizeof(ParamMeta), 4, ((const DMDNamedField []){ {"the name SV", DMD_FIELD_PTR, .ptr = parammeta->name}, {"the class", DMD_FIELD_PTR, .ptr = parammeta->class}, {"the field", DMD_FIELD_PTR, .ptr = parammeta->field.fieldmeta}, {"fieldix", DMD_FIELD_UINT, .n = parammeta->field.fieldix}, }) ); break; case PARAM_ADJUST: DMD_DUMP_STRUCT(ctx, "Object::Pad/ParamMeta.adjust", parammeta, sizeof(ParamMeta), 3, ((const DMDNamedField []){ {"the name SV", DMD_FIELD_PTR, .ptr = parammeta->name}, {"the class", DMD_FIELD_PTR, .ptr = parammeta->class}, {"padix", DMD_FIELD_UINT, .n = parammeta->adjust.padix}, /* No point dumping the defexpr because Devel::MAT can't peek into them */ }) ); break; } } static void dump_roleembedding(pTHX_ DMDContext *ctx, RoleEmbedding *embedding) { DMD_DUMP_STRUCT(ctx, "Object::Pad/RoleEmbedding", embedding, sizeof(RoleEmbedding), 4, ((const DMDNamedField []){ {"the embedding SV", DMD_FIELD_PTR, .ptr = embedding->embeddingsv}, {"the role", DMD_FIELD_PTR, .ptr = embedding->rolemeta}, {"the class", DMD_FIELD_PTR, .ptr = embedding->classmeta}, {"offset", DMD_FIELD_UINT, .n = embedding->offset} }) ); } static void dump_classmeta(pTHX_ DMDContext *ctx, ClassMeta *classmeta) { /* We'll handle the two types of classmeta by claiming two different struct * types */ #define N_COMMON_FIELDS 16 #define COMMON_FIELDS \ {"type", DMD_FIELD_U8, .n = classmeta->type}, \ {"repr", DMD_FIELD_U8, .n = classmeta->repr}, \ {"sealed", DMD_FIELD_BOOL, .b = classmeta->sealed}, \ {"start_fieldix", DMD_FIELD_UINT, .n = classmeta->start_fieldix}, \ {"the name SV", DMD_FIELD_PTR, .ptr = classmeta->name}, \ {"the stash SV", DMD_FIELD_PTR, .ptr = classmeta->stash}, \ {"the pending submeta AV", DMD_FIELD_PTR, .ptr = classmeta->pending_submeta}, \ {"the hooks AV", DMD_FIELD_PTR, .ptr = classmeta->hooks}, \ {"the fields AV", DMD_FIELD_PTR, .ptr = classmeta->fields}, \ {"the direct methods AV", DMD_FIELD_PTR, .ptr = classmeta->direct_methods}, \ {"the param map HV", DMD_FIELD_PTR, .ptr = classmeta->parammap}, \ {"the requiremethods AV", DMD_FIELD_PTR, .ptr = classmeta->requiremethods}, \ {"the initfields CV", DMD_FIELD_PTR, .ptr = classmeta->initfields}, \ {"the BUILD blocks AV", DMD_FIELD_PTR, .ptr = classmeta->buildcvs}, \ {"the ADJUST blocks AV", DMD_FIELD_PTR, .ptr = classmeta->adjustcvs}, \ {"the temporary method scope", DMD_FIELD_PTR, .ptr = classmeta->methodscope} switch(classmeta->type) { case METATYPE_CLASS: DMD_DUMP_STRUCT(ctx, "Object::Pad/ClassMeta.class", classmeta, sizeof(ClassMeta), N_COMMON_FIELDS+5, ((const DMDNamedField []){ COMMON_FIELDS, {"the supermeta", DMD_FIELD_PTR, .ptr = classmeta->cls.supermeta}, {"the foreign superclass constructor CV", DMD_FIELD_PTR, .ptr = classmeta->cls.foreign_new}, {"the foreign superclass DOES CV", DMD_FIELD_PTR, .ptr = classmeta->cls.foreign_does}, {"the direct roles AV", DMD_FIELD_PTR, .ptr = classmeta->cls.direct_roles}, {"the embedded roles AV", DMD_FIELD_PTR, .ptr = classmeta->cls.embedded_roles}, }) ); break; case METATYPE_ROLE: DMD_DUMP_STRUCT(ctx, "Object::Pad/ClassMeta.role", classmeta, sizeof(ClassMeta), N_COMMON_FIELDS+2, ((const DMDNamedField []){ COMMON_FIELDS, {"the superroles AV", DMD_FIELD_PTR, .ptr = classmeta->role.superroles}, {"the role applied classes HV", DMD_FIELD_PTR, .ptr = classmeta->role.applied_classes}, }) ); break; } #undef COMMON_FIELDS I32 i; for(i = 0; i < av_count(classmeta->fields); i++) { FieldMeta *fieldmeta = MUST_FIELDMETA(AvARRAY(classmeta->fields)[i]); dump_fieldmeta(aTHX_ ctx, fieldmeta); } for(i = 0; i < av_count(classmeta->direct_methods); i++) { MethodMeta *methodmeta = MUST_METHODMETA(AvARRAY(classmeta->direct_methods)[i]); dump_methodmeta(aTHX_ ctx, methodmeta); } HV *parammap; if((parammap = classmeta->parammap)) { hv_iterinit(parammap); HE *iter; while((iter = hv_iternext(parammap))) { ParamMeta *parammeta = MUST_PARAMMETA(HeVAL(iter)); dump_parammeta(aTHX_ ctx, parammeta); } } switch(classmeta->type) { case METATYPE_CLASS: for(i = 0; i < av_count(classmeta->cls.direct_roles); i++) { RoleEmbedding *embedding = MUST_ROLEEMBEDDING(AvARRAY(classmeta->cls.direct_roles)[i]); dump_roleembedding(aTHX_ ctx, embedding); } break; case METATYPE_ROLE: /* No need to dump the values of role.applied_classes because any class * they're applied to will have done that already */ break; } } static int dumppackage_class(pTHX_ DMDContext *ctx, const SV *sv) { int ret = 0; ClassMeta *meta = MUST_CLASSMETA(SvUV((SV *)sv)); dump_classmeta(aTHX_ ctx, meta); ret += DMD_ANNOTATE_SV(sv, (SV *)meta, "the Object::Pad class"); 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; } /* internal function shared by various *.c files */ void ObjectPad__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 } } /* used by XSUB deconstruct_object */ #define deconstruct_object_class(fieldstore, classmeta, offset) S_deconstruct_object_class(aTHX_ fieldstore, classmeta, offset) static U32 S_deconstruct_object_class(pTHX_ SV *fieldstore, ClassMeta *classmeta, FIELDOFFSET offset) { dSP; U32 retcount = 0; AV *fields = classmeta->fields; U32 nfields = av_count(fields); EXTEND(SP, nfields * 2); SV **fieldsvs = fieldstore_fields(fieldstore); FIELDOFFSET i; for(i = 0; i < nfields; i++) { FieldMeta *fieldmeta = MUST_FIELDMETA(AvARRAY(fields)[i]); if(!fieldmeta->is_direct) continue; mPUSHs(newSVpvf("%" SVf ".%" SVf, SVfARG(classmeta->name), SVfARG(fieldmeta->name))); SV *value = fieldsvs[fieldmeta->fieldix + offset]; switch(SvPV_nolen(fieldmeta->name)[0]) { case '$': value = newSVsv(value); break; case '@': value = newRV_noinc((SV *)newAVav(AV_FROM_REF(value))); break; case '%': value = newRV_noinc((SV *)newHVhv(HV_FROM_REF(value))); break; } mPUSHs(value); retcount += 2; } PUTBACK; return retcount; } /* used by XSUB ref_field */ #define ref_field_class(want_fieldname, fieldstore, classmeta, offset) S_ref_field_class(aTHX_ want_fieldname, fieldstore, classmeta, offset) static SV *S_ref_field_class(pTHX_ SV *want_fieldname, SV *fieldstore, ClassMeta *classmeta, FIELDOFFSET offset) { FieldMeta *fieldmeta = mop_class_find_field(classmeta, want_fieldname, 0); if(!fieldmeta) return NULL; /* found it */ SV *sv = fieldstore_fields(fieldstore)[fieldmeta->fieldix + offset]; switch(mop_field_get_sigil(fieldmeta)) { case '$': return newRV_inc(sv); case '@': case '%': return newSVsv(sv); } return NULL; } 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); { if(!cophh_exists_pvs(CopHINTHASH_get(PL_curcop), "Object::Pad/experimental(custom_field_attr)", 0)) Perl_ck_warner(aTHX_ packWARN(WARN_EXPERIMENTAL), "Object::Pad::MOP::FieldAttr is experimental and may be changed or removed without notice"); } struct FieldHookFuncs funcs = {}; struct CustomFieldHookData funcdata = {}; funcs.ver = OBJECTPAD_ABIVERSION; funcs.apply = &fieldhook_custom_apply; static const char *args[] = { "permit_hintkey", "apply", "no_value", "must_value", NULL, }; while(KWARG_NEXT(args)) { switch(kwarg) { case 0: /* permit_hintkey */ funcs.permit_hintkey = SvPV_nolen(kwval); break; case 1: /* apply */ funcdata.apply_cb = kwval; break; case 2: /* no_value */ if(SvTRUE(kwval)) funcs.flags |= OBJECTPAD_FLAG_ATTR_NO_VALUE; break; case 3: /* must_value */ if(SvTRUE(kwval)) funcs.flags |= OBJECTPAD_FLAG_ATTR_MUST_VALUE; break; } } if((funcs.flags & OBJECTPAD_FLAG_ATTR_NO_VALUE) && (funcs.flags & OBJECTPAD_FLAG_ATTR_MUST_VALUE)) croak("Cannot register a FieldAttr with both 'no_value' and 'must_value'"); struct FieldHookFuncs *_funcs; Newxz(_funcs, 1, struct FieldHookFuncs); Copy(&funcs, _funcs, 1, struct FieldHookFuncs); if(_funcs->permit_hintkey) _funcs->permit_hintkey = savepv(_funcs->permit_hintkey); struct CustomFieldHookData *_funcdata; Newxz(_funcdata, 1, struct CustomFieldHookData); Copy(&funcdata, _funcdata, 1, struct CustomFieldHookData); if(_funcdata->apply_cb) _funcdata->apply_cb = newSVsv(_funcdata->apply_cb); register_field_attribute(savepv(SvPV_nolen(name)), _funcs, _funcdata); } MODULE = Object::Pad PACKAGE = Object::Pad::MetaFunctions SV * metaclass(SV *obj) CODE: { if(!SvROK(obj) || !SvOBJECT(SvRV(obj))) croak("Expected an object reference to metaclass"); HV *stash = SvSTASH(SvRV(obj)); GV **gvp = (GV **)hv_fetchs(stash, "META", 0); if(!gvp) croak("Unable to find ClassMeta for %" HEKf, HEKfARG(HvNAME_HEK(stash))); RETVAL = newSVsv(GvSV(*gvp)); } OUTPUT: RETVAL void deconstruct_object(SV *obj) PPCODE: { if(!SvROK(obj) || !SvOBJECT(SvRV(obj))) croak("Expected an object reference to deconstruct_object"); ClassMeta *classmeta = mop_get_class_for_stash(SvSTASH(SvRV(obj))); SV *fieldstore = get_obj_fieldstore(obj, classmeta->repr, true); U32 retcount = 0; PUSHs(sv_mortalcopy(classmeta->name)); retcount++; PUTBACK; while(classmeta) { retcount += deconstruct_object_class(fieldstore, classmeta, 0); AV *roles = classmeta->cls.direct_roles; U32 nroles = av_count(roles); for(U32 i = 0; i < nroles; i++) { RoleEmbedding *embedding = MUST_ROLEEMBEDDING(AvARRAY(roles)[i]); retcount += deconstruct_object_class(fieldstore, embedding->rolemeta, embedding->offset); } classmeta = classmeta->cls.supermeta; } SPAGAIN; XSRETURN(retcount); } SV * ref_field(SV *fieldname, SV *obj) CODE: { SV *want_classname = NULL, *want_fieldname; if(!SvROK(obj) || !SvOBJECT(SvRV(obj))) croak("Expected an object reference to ref_field"); SvGETMAGIC(fieldname); char *s = SvPV_nolen(fieldname); char *dotpos; if((dotpos = strchr(s, '.'))) { U32 flags = SvUTF8(fieldname) ? SVf_UTF8 : 0; want_classname = newSVpvn_flags(s, dotpos - s, flags); want_fieldname = newSVpvn_flags(dotpos + 1, strlen(dotpos + 1), flags); } else { want_fieldname = SvREFCNT_inc(fieldname); } SAVEFREESV(want_classname); SAVEFREESV(want_fieldname); ClassMeta *classmeta = mop_get_class_for_stash(SvSTASH(SvRV(obj))); SV *fieldstore = get_obj_fieldstore(obj, classmeta->repr, true); while(classmeta) { if(!want_classname || sv_eq(want_classname, classmeta->name)) { RETVAL = ref_field_class(want_fieldname, fieldstore, classmeta, 0); if(RETVAL) goto done; } AV *roles = classmeta->cls.direct_roles; U32 nroles = av_count(roles); for(U32 i = 0; i < nroles; i++) { RoleEmbedding *embedding = MUST_ROLEEMBEDDING(AvARRAY(roles)[i]); if(!want_classname || sv_eq(want_classname, embedding->rolemeta->name)) { RETVAL = ref_field_class(want_fieldname, fieldstore, embedding->rolemeta, embedding->offset); if(RETVAL) goto done; } } classmeta = classmeta->cls.supermeta; } if(want_classname) croak("Could not find a field called %" SVf " in class %" SVf, SVfARG(want_fieldname), SVfARG(want_classname)); else croak("Could not find a field called %" SVf " in any class", SVfARG(want_fieldname)); done: ; } OUTPUT: RETVAL BOOT: XopENTRY_set(&xop_methstart, xop_name, "methstart"); XopENTRY_set(&xop_methstart, xop_desc, "enter method"); #ifdef METHSTART_CONTAINS_FIELD_BINDINGS XopENTRY_set(&xop_methstart, xop_class, OA_UNOP_AUX); #else XopENTRY_set(&xop_methstart, xop_class, OA_BASEOP); #endif Perl_custom_op_register(aTHX_ &pp_methstart, &xop_methstart); XopENTRY_set(&xop_commonmethstart, xop_name, "commonmethstart"); XopENTRY_set(&xop_commonmethstart, xop_desc, "enter method :common"); XopENTRY_set(&xop_commonmethstart, xop_class, OA_BASEOP); Perl_custom_op_register(aTHX_ &pp_commonmethstart, &xop_commonmethstart); 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.39); /* XPK_LISTEXPR_OPT */ register_xs_parse_keyword("class", &kwhooks_class, (void *)METATYPE_CLASS); register_xs_parse_keyword("role", &kwhooks_role, (void *)METATYPE_ROLE); register_xs_parse_keyword("inherit", &kwhooks_inherit, NULL); register_xs_parse_keyword("apply", &kwhooks_apply, NULL); register_xs_parse_keyword("field", &kwhooks_field, "field"); register_xs_parse_keyword("has", &kwhooks_has, "has"); register_xs_parse_keyword("BUILD", &kwhooks_BUILD, (void *)PHASER_BUILD); register_xs_parse_keyword("ADJUST", &kwhooks_ADJUST, (void *)PHASER_ADJUST); register_xs_parse_keyword("ADJUSTPARAMS", &kwhooks_ADJUST, (void *)PHASER_ADJUSTPARAMS); register_xs_parse_keyword("__CLASS__", &kwhooks_uuCLASS, NULL); register_xs_parse_keyword("requires", &kwhooks_requires, NULL); boot_xs_parse_sublike(0.15); /* dynamic actions */ register_xs_parse_sublike("method", &parse_method_hooks, (void *)PHASER_NONE); ObjectPad__boot_classes(aTHX); ObjectPad__boot_fields(aTHX); Object-Pad-0.810/lib/Object/mop-class.xsi000444001750001750 2546714655674547 16774 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; { const COP *cop; const HV *mystash = CopSTASH(PL_curcop); for(int level = 0; level < 20; level++) { const PERL_CONTEXT *cx = caller_cx(level, NULL); if(!cx) break; cop = cx->blk_oldcop; if(CopSTASH(cop) != mystash) break; cop = NULL; } if(cop && !cophh_exists_pvs(CopHINTHASH_get(cop), "Object::Pad/experimental(mop)", 0)) Perl_ck_warner(aTHX_ packWARN(WARN_EXPERIMENTAL), "The Object::Pad MOP API is experimental and may be changed or removed without notice"); } 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_begin(meta); 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_begin(meta); mop_class_add_BUILD(meta, (CV *)SvREFCNT_inc((SV *)code)); } SV * add_method(self, mname, ...) SV *self SV *mname CODE: { if(items < 3) croak_xs_usage(cv, "self, mname, ..., code"); SV *ref = ST(items-1); items--; if(!SvROK(ref) || SvTYPE(SvRV(ref)) != SVt_PVCV) croak("Expected CODE reference"); dKWARG(2); /* Take a copy now to run FETCH magic */ mname = sv_2mortal(newSVsv(mname)); ClassMeta *meta = NUM2PTR(ClassMeta *, SvUV(SvRV(self))); mop_class_begin(meta); 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_cv(meta, mname, (CV *)SvREFCNT_inc(CV_FROM_REF(ref))); static const char *args[] = { "common", NULL }; while(KWARG_NEXT(args)) { switch(kwarg) { case 0: /* common */ methodmeta->is_common = SvTRUE(kwval); break; } } 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_begin(meta); 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))); mop_class_begin(meta); 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 */ mop_field_set_default_sv(fieldmeta, 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))); FieldMeta *fieldmeta = mop_class_find_field(meta, fieldname, FIND_FIELD_ONLY_DIRECT); if(fieldmeta) { 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->fields; U32 nfields = av_count(fields); EXTEND(SP, nfields); U32 retcount = 0; FIELDOFFSET i; for(i = 0; i < nfields; i++) { FieldMeta *fieldmeta = (FieldMeta *)AvARRAY(fields)[i]; if(!fieldmeta->is_direct) continue; ST(i) = sv_newmortal(); sv_setref_iv(ST(i), "Object::Pad::MOP::Field", PTR2UV(fieldmeta)); retcount++; } XSRETURN(retcount); 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.810/lib/Object/mop-field.xsi000444001750001750 456014655674547 16721 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"); SV *value = get_obj_fieldsv(obj, classmeta, meta); /* 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->attrdata); } OUTPUT: RETVAL void get_attribute_values(self, name) SV *self SV *name PPCODE: { FieldMeta *meta = NUM2PTR(FieldMeta *, SvUV(SvRV(self))); AV *values = mop_field_get_attribute_values(meta, SvPV_nolen(name)); if(!values) croak("Field does not have an attribute called %" SVf, SVfARG(name)); Size_t count = av_count(values); EXTEND(SP, count); for(Size_t i = 0; i < count; i++) PUSHs(SvREFCNT_inc(AvARRAY(values)[i])); SvREFCNT_dec(values); XSRETURN(count); } Object-Pad-0.810/lib/Object/mop-method.xsi000444001750001750 75514655674547 17100 0ustar00leoleo000000000000 SV * name(self) SV *self ALIAS: name = 0 class = 1 is_common = 2 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; case 2: RETVAL = boolSV(meta->is_common); break; default: RETVAL = NULL; } } OUTPUT: RETVAL Object-Pad-0.810/lib/Object/Pad000755001750001750 014655674547 14662 5ustar00leoleo000000000000Object-Pad-0.810/lib/Object/Pad/ExtensionBuilder.pm000444001750001750 402414655674547 20640 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.810; 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 =head1 METHODS =cut =head2 write_object_pad_h Object::Pad::ExtensionBuilder->write_object_pad_h; This method no longer does anything I. =cut sub write_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; require File::ShareDir; require File::Spec; require Object::Pad; return "-I" . File::Spec->catdir( File::ShareDir::module_dir( "Object::Pad" ), "include" ); } =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 ) = @_; # 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.810/lib/Object/Pad/MetaFunctions.pm000444001750001750 1161714655674547 20162 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, 2022 -- leonerd@leonerd.org.uk package Object::Pad::MetaFunctions 0.810; use v5.14; use warnings; use Exporter 'import'; our @EXPORT_OK = qw( metaclass deconstruct_object ref_field get_field ); BEGIN { if( defined &builtin::reftype ) { warnings->unimport( 'experimental::builtin' ); builtin->import(qw( reftype )); } else { require Scalar::Util; Scalar::Util->import(qw( reftype )); } } =head1 NAME C - utility functions for C classes =head1 SYNOPSIS use v5.36; use Object::Pad::MetaFunctions qw( deconstruct_object ); sub debug_print_object ( $obj ) { my ( $classname, @repr ) = deconstruct_object( $obj ); say "An object of type $classname having:"; foreach my ( $fieldname, $value ) ( @repr ) { printf "%30s = %s\n", $fieldname, $value; } } =head1 DESCRIPTION This module contains a number of miscellaneous utility functions for working with L-based classes or instances thereof. These functions all involve a certain amount of encapsulation-breaking into the object instances being operated on. This sort of thing shouldn't be encouraged in most regular code, but there can be occasions when it is useful; such as debug printing of values, generic serialisation, or tightly-coupled unit tests that wish to operate on the interals of the object instances they test. Therefore, use of these functions should be considered "last-resort". Consider carefully the sorts of things you are trying to do with them, and whether this kind of reaching into the internals of an object, bypassing all of its interface encapsulation, is really the best technique to achieve your goal. =head1 FUNCTIONS =cut =head2 metaclass $metaclass = metaclass( $obj ); I Returns the L metaclass associated with the class that the object is an instance of. =head2 deconstruct_object ( $classname, @repr ) = deconstruct_object( $obj ); I Returns a list of perl values containing a representation of all the fields in the object instance. This representation form may be useful for tasks such as debug printing or serialisation of the instance. This list is prefixed by the name of the class of instance as a plain string. The exact form of this representation is still experimental and may change in a later version. Currently, it takes the form of an even-sized list of key/value pairs, associating field names with their values. Each key gives the name of a component class and the full name of the field within it, separated by a dot (C<.>). 'CLASSNAME.$FIELD1' => VALUE, 'CLASSNAME.@FIELD2' => VALUE, ... In the case of scalar fields, the value is the actual value of that field. In the case of array or hash fields, the value in the repr list is a reference to an anonymous I the value stored in the field. 'CLASSNAME.$SCALARFIELD' => $VALUE, 'CLASSNAME.@ARRAYFIELD' => [ @VALUE ], 'CLASSNAME.%HASHFIELD' => { %VALUE }, The pairs are ordered, with the actual object class type first, followed by any roles added by that class, then each parent class recursively. Within each component class, the fields are given in declared order. This reliable ordering may be useful when printing values in human-readable form, or serialising to some stable storage. =head2 ref_field $fieldref = ref_field( $fieldname, $obj ); I Returns a reference to the named field storage variable of the given instance object. The I<$fieldname> should be specified as the class name and the field name separated by a dot (C<.>) (as per L). The class name may also be omitted; at which point the first occurance of a field of the given name found in any component class it matched instead. If no matching field is found, an exception is thrown. Be careful when using this function as it has the ability to expose instance fields in a way that allows them to be modified. For a safer alternative when only read access is required, use L instead. =cut =head2 get_field $scalar = get_field( $fieldname, $obj ); @array = get_field( $fieldname, $obj ); %hash = get_field( $fieldname, $obj ); I Returns the value of the named field of the given instance object. Behaves correctly given context; namely, that when invoked on array or hash fields in scalar context it will return the number of elements or keys, or in list context will return the list of elements or key/value pairs. =cut sub get_field { my $ref = ref_field( @_ ); my $type = reftype $ref; return @$ref if $type eq "ARRAY"; return %$ref if $type eq "HASH"; return $$ref; } =head1 AUTHOR Paul Evans =cut 0x55AA; Object-Pad-0.810/lib/Object/Pad/MOP000755001750001750 014655674547 15315 5ustar00leoleo000000000000Object-Pad-0.810/lib/Object/Pad/MOP/Class.pm000444001750001750 2777214655674547 17114 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-2023 -- leonerd@leonerd.org.uk package Object::Pad::MOP::Class 0.810; 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 B, and will emit warnings to that effect. They can be silenced with use Object::Pad qw( :experimental(mop) ); or use Object::Pad::MOP::Class qw( :experimental(mop) ); =cut sub import { my $class = shift; my $caller = caller; $class->import_into( $caller, @_ ); } sub import_into { my $class = shift; my $caller = shift; Object::Pad->_import_experimental( \@_, qw( mop ) ); croak "Unrecognised import symbols @_" if @_; } =head1 CONSTRUCTOR =head2 for_class $metaclass = Object::Pad::MOP::Class->for_class( $class ); I Returns the metaclass instance associated with the given class name. Throws an exception if the requested class is not using C. =head2 try_for_class $metaclass = Object::Pad::MOP::Class->try_for_class( $class ); I If the given class name is built using C then returns the metaclass instance for it. If not, returns C. =cut sub try_for_class { shift; my ( $targetclass ) = @_; my $level = 0; $level++ while (caller $level)[0] eq __PACKAGE__; my $callerhints = (caller $level)[10]; if( !$callerhints or !$callerhints->{"Object::Pad/experimental(mop)"} ) { warnings::warnif experimental => "Object::Pad::MOP is experimental and may be changed or removed without notice"; } my $code = do { my $fqname = "${targetclass}::META"; no strict 'refs'; defined &$fqname or return undef; \&{"${targetclass}::META"}; }; return $code->( $targetclass ); } sub for_class { my $self = shift; my ( $targetclass ) = @_; return $self->try_for_class( $targetclass ) // croak "Cannot obtain Object::Pad::MOP::Class for '$targetclass' as it does not appear to be based on Object::Pad"; } =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, %args, $code ); Adds a new named method to the class under the given name, as CODE reference. Returns an instance of L to represent it. Recognises the following additional named arguments: =over 4 =item common => BOOL I If true, the method is a class-common method. =back =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.810/lib/Object/Pad/MOP/Field.pm000444001750001750 607014655674547 17036 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.810; 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 B, and will emit warnings to that effect. They can be silenced with use Object::Pad qw( :experimental(mop) ); =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. =head2 get_attribute_values @values = $metafield->get_attribute_values( $name ); I Returns all the stored values of an attached attribute, if one exists. If the attribute has not been attached then an exception is thrown. This allows inspection of stored attribute values if it makes meaningful sense for the attribute to be applied multiple times to the same field. This is unlikely to be useful for core-defined attributes, but may be meaningful for third-party attributes. =cut =head1 AUTHOR Paul Evans =cut 0x55AA; Object-Pad-0.810/lib/Object/Pad/MOP/FieldAttr.pm000444001750001750 605214655674547 17671 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.810; 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. This API should be considered B, and will emit warnings to that effect. They can be silenced with use Object::Pad qw( :experimental(custom_field_attr) ); =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 no_value => BOOL An optional flag; if set to true then no value is permitted on the attribute's declaration. A compiletime error will be generated if a value is provided =item must_value => BOOL An optional flag; if set to true then a value is required on the attribute's declaration. A compiletime error will be generated if a value is not provided. If neither of these flags are provided, then a value is optional. It is not permitted to set both flags at once. =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.810/lib/Object/Pad/MOP/Method.pm000444001750001750 241414655674547 17231 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.810; 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 B, and will emit warnings to that effect. They can be silenced with use Object::Pad qw( :experimental(mop) ); =cut =head1 METHODS =head2 name $name = $metamethod->name; Returns the name of the method, as a plain string. =head2 class $metaclass = $metamethod->class; Returns the L instance representing the class of which this method is a member. =head2 is_common $bool = $metamethod->is_common; I Returns true if the method is a class-common method, or false for a regular instance method. =cut =head1 AUTHOR Paul Evans =cut 0x55AA; Object-Pad-0.810/share000755001750001750 014655674547 13304 5ustar00leoleo000000000000Object-Pad-0.810/share/include000755001750001750 014655674547 14727 5ustar00leoleo000000000000Object-Pad-0.810/share/include/object_pad.h000444001750001750 3223714655674547 17356 0ustar00leoleo000000000000#ifndef __OBJECT_PAD__TYPES_H__ #define __OBJECT_PAD__TYPES_H__ #define OBJECTPAD_ABIVERSION_MINOR 810 #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 struct ClassMeta ClassMeta; typedef struct FieldMeta FieldMeta; 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 **attrdata_ptr, void *funcdata); /* called immediately before class seal */ void (*pre_seal)(pTHX_ ClassMeta *classmeta, SV *attrdata, void *funcdata); /* called immediately after class seal */ void (*post_seal)(pTHX_ ClassMeta *classmeta, SV *attrdata, void *funcdata); /* called by mop_class_add_field() */ void (*post_add_field)(pTHX_ ClassMeta *classmeta, SV *attrdata, void *funcdata, FieldMeta *fieldmeta); }; struct ClassHook { const struct ClassHookFuncs *funcs; void *funcdata; SV *attrdata; /* used to be called 'hookdata' */ }; struct FieldHookFuncs { U32 ver; /* caller must initialise to OBJECTPAD_VERSION */ U32 flags; const char *permit_hintkey; /* optional; called when parsing `:ATTRNAME(ATTRVALUE)` source code */ SV *(*parse)(pTHX_ FieldMeta *fieldmeta, SV *valuesrc, void *funcdata); /* 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 **attrdata_ptr, void *funcdata); /* called at the end of `has` statement compiletime */ void (*seal)(pTHX_ FieldMeta *fieldmeta, SV *attrdata, void *funcdata); /* called as part of accessor generation */ void (*gen_accessor_ops)(pTHX_ FieldMeta *fieldmeta, SV *attrdata, void *funcdata, enum AccessorType type, struct AccessorGenerationCtx *ctx); /* called by constructor */ union { void (*post_makefield)(pTHX_ FieldMeta *fieldmeta, SV *attrdata, void *funcdata, SV *field); // This used to be called post_initfield but was badly named because it // actually ran *before* initfields void (*post_initfield)(pTHX_ FieldMeta *fieldmeta, SV *attrdata, void *funcdata, SV *field); }; void (*post_construct)(pTHX_ FieldMeta *fieldmeta, SV *attrdata, void *funcdata, SV *field); /* called as part of constructor generation * TODO: Not yet used by accessors, but maybe a future version will add a * flag to do this. */ OP *(*gen_valueassert_op)(pTHX_ FieldMeta *fieldmeta, SV *attrdata, void *funcdata, OP *valueop); }; struct FieldHook { FIELDOFFSET fieldix; /* unused when in FieldMeta->hooks; used by ClassMeta->fieldhooks_* */ FieldMeta *fieldmeta; const struct FieldHookFuncs *funcs; void *funcdata; SV *attrdata; /* used to be called '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 */ REPR_KEYS, /* instances are blessed HASHes, each field lives in an individually-named key */ REPR_PVOBJ, /* instances are SVt_PVOBJ on perl 5.38+ */ }; /* Special pad indexes within `method` CVs */ enum { PADIX_SELF = 1, PADIX_FIELDS = 2, /* for role methods */ PADIX_EMBEDDING = 3, /* during initfields */ PADIX_PARAMS = 4, }; /* Function prototypes */ #define get_compclassmeta() ObjectPad_get_compclassmeta(aTHX) ClassMeta *ObjectPad_get_compclassmeta(pTHX); #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); #define newCOMMONMETHSTARTOP(flags) ObjectPad_newCOMMONMETHSTARTOP(aTHX_ flags) OP *ObjectPad_newCOMMONMETHSTARTOP(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); /* Deprecated */ #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); #define get_obj_fieldstore(self, repr, create) ObjectPad_get_obj_fieldstore(aTHX_ self, repr, create) SV *ObjectPad_get_obj_fieldstore(pTHX_ SV *self, enum ReprType repr, bool create); #define get_obj_fieldsv(self, classmeta, fieldmeta) ObjectPad_get_obj_fieldsv(aTHX_ self, classmeta, fieldmeta) SV *ObjectPad_get_obj_fieldsv(pTHX_ SV *self, ClassMeta *classmeta, FieldMeta *fieldmeta); /* 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_get_class_for_stash(stash) ObjectPad_mop_get_class_for_stash(aTHX_ stash) ClassMeta *ObjectPad_mop_get_class_for_stash(pTHX_ HV *stash); #define mop_class_get_name(class) ObjectPad_mop_class_get_name(aTHX_ class) SV *ObjectPad_mop_class_get_name(pTHX_ ClassMeta *class); #define mop_class_load_and_set_superclass(class, supername, superver) ObjectPad_mop_class_load_and_set_superclass(aTHX_ class, supername, superver) void ObjectPad_mop_class_load_and_set_superclass(pTHX_ ClassMeta *class, SV *supername, SV *superver); #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_inherit_from_superclass(class, args, nargs) ObjectPad_mop_class_inherit_from_superclass(aTHX_ class, args, nargs) void ObjectPad_mop_class_inherit_from_superclass(pTHX_ ClassMeta *class, SV **args, size_t nargs); #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_method_cv(class, methodname, cv) ObjectPad_mop_class_add_method_cv(aTHX_ class, methodname, cv) MethodMeta *ObjectPad_mop_class_add_method_cv(pTHX_ ClassMeta *meta, SV *methodname, CV *cv); #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); enum { FIND_FIELD_ONLY_DIRECT = (1<<0), FIND_FIELD_ONLY_INHERITABLE = (1<<1), }; #define mop_class_find_field(class, fieldname, flags) ObjectPad_mop_class_find_field(aTHX_ class, fieldname, flags) FieldMeta *ObjectPad_mop_class_find_field(pTHX_ ClassMeta *meta, SV *fieldname, U32 flags); #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_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 mop_class_get_attribute(classmeta, name) ObjectPad_mop_class_get_attribute(aTHX_ classmeta, name) struct ClassHook *ObjectPad_mop_class_get_attribute(pTHX_ ClassMeta *classmeta, const char *name); #define mop_class_get_attribute_values(classmeta, name) ObjectPad_mop_class_get_attribute_values(aTHX_ classmeta, name) AV *ObjectPad_mop_class_get_attribute_values(pTHX_ ClassMeta *classmeta, const char *name); #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, fieldix, classmeta) ObjectPad_mop_create_field(aTHX_ fieldname, fieldix, classmeta) FieldMeta *ObjectPad_mop_create_field(pTHX_ SV *fieldname, FIELDOFFSET fieldix, 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_parse_and_apply_attribute(fieldmeta, name, value) ObjectPad_mop_field_parse_and_apply_attribute(aTHX_ fieldmeta, name, value) void ObjectPad_mop_field_parse_and_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_attribute_values(fieldmeta, name) ObjectPad_mop_field_get_attribute_values(aTHX_ fieldmeta, name) AV *ObjectPad_mop_field_get_attribute_values(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); /* Integration with XS::Parse::Keyword v0.30 * To enable this you must #include "XSParseKeyword.h" before this file */ #ifdef XPK_STAGED_ANONSUB /* These are not really API functions but we need to see them to let these call it */ void ObjectPad__prepare_method_parse(pTHX_ ClassMeta *meta); void ObjectPad__start_method_parse(pTHX_ ClassMeta *meta, bool is_common); OP *ObjectPad__finish_method_parse(pTHX_ ClassMeta *meta, bool is_common, OP *body); static void opxpk_anonsub_prepare(pTHX_ void *hookdata) { ObjectPad__prepare_method_parse(aTHX_ get_compclassmeta()); } static void opxpk_anonsub_start(pTHX_ void *hookdata) { ObjectPad__start_method_parse(aTHX_ get_compclassmeta(), FALSE); } static OP *opxpk_anonsub_wrap(pTHX_ OP *o, void *hookdata) { return ObjectPad__finish_method_parse(aTHX_ get_compclassmeta(), FALSE, o); } /* OPXPK_ANONMETHOD is like XPK_ANONSUB but constructs an anonymous method * CV in the currently compiling class. As usual it will have $self and all * the field lexicals visible inside it */ #define OPXPK_ANONMETHOD_PREPARE XPK_ANONSUB_PREPARE(&opxpk_anonsub_prepare) #define OPXPK_ANONMETHOD_START XPK_ANONSUB_START (&opxpk_anonsub_start) #define OPXPK_ANONMETHOD_WRAP XPK_ANONSUB_WRAP (&opxpk_anonsub_wrap) #define OPXPK_ANONMETHOD \ XPK_STAGED_ANONSUB( \ OPXPK_ANONMETHOD_PREPARE, \ OPXPK_ANONMETHOD_START, \ OPXPK_ANONMETHOD_WRAP \ ) #endif #endif Object-Pad-0.810/src000755001750001750 014655674547 12771 5ustar00leoleo000000000000Object-Pad-0.810/src/class.c000444001750001750 23034614655674547 14447 0ustar00leoleo000000000000/* vi: set ft=xs : */ #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifdef HAVE_DMD_HELPER # define WANT_DMD_API_044 # include "DMD_helper.h" #endif #include "perl-backcompat.c.inc" #include "sv_setrv.c.inc" #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" #include "cv_copy_flags.c.inc" #include "OP_HELEMEXISTSOR.c.inc" #include "object_pad.h" #include "class.h" #include "field.h" #undef register_class_attribute #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 #if HAVE_PERL_VERSION(5, 22, 0) # define COP_SEQ_RANGE_LOW_set(sv,val) \ STMT_START { (sv)->xpadn_low = (val); } STMT_END #else /* Before Perl 5.22, padnames were just normal SVs with some weird fields in them */ # define COP_SEQ_RANGE_LOW_set(sv,val) \ STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END #endif #ifndef COP_SEQMAX_INC #define COP_SEQMAX_INC \ (PL_cop_seqmax++, \ (void)(PL_cop_seqmax == PERL_PADSEQ_INTRO && PL_cop_seqmax++)) #endif #define need_PLparser() ObjectPad__need_PLparser(aTHX) void ObjectPad__need_PLparser(pTHX); /* in Object/Pad.xs */ /* Empty MGVTBL simply for locating instance backing AV */ static MGVTBL vtbl_backingav = {}; RoleEmbedding ObjectPad__embedding_standalone = { LINNET_INIT(LINNET_VAL_ROLEEMBEDDING) }; 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 = (struct ClassAttributeRegistration){ .name = name, .funcs = funcs, .funcdata = funcdata, }; if(funcs->permit_hintkey) reg->permit_hintkeylen = strlen(funcs->permit_hintkey); else reg->permit_hintkeylen = 0; reg->next = classattrs; classattrs = reg; } struct ClassHookFuncs_v57 { U32 ver; U32 flags; const char *permit_hintkey; bool (*apply)(pTHX_ ClassMeta *classmeta, SV *value, SV **hookdata_ptr, void *funcdata); /* No pre- or post-seal */ void (*post_add_field)(pTHX_ ClassMeta *classmeta, SV *hookdata, void *funcdata, FieldMeta *fieldmeta); }; 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"); if(funcs->ver < OBJECTPAD_ABIVERSION) { const struct ClassHookFuncs_v57 *funcs_v57 = (const struct ClassHookFuncs_v57 *)funcs; struct ClassHookFuncs *funcs_v76; Newx(funcs_v76, 1, struct ClassHookFuncs); *funcs_v76 = (struct ClassHookFuncs){ .ver = OBJECTPAD_ABIVERSION, .flags = funcs_v57->flags, .permit_hintkey = funcs_v57->permit_hintkey, .apply = funcs_v57->apply, .post_add_field = funcs_v57->post_add_field, }; funcs = funcs_v76; } 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 *attrdata = value; if(reg->funcs->apply) { if(!(*reg->funcs->apply)(aTHX_ classmeta, value, &attrdata, reg->funcdata)) return; } if(!classmeta->hooks) classmeta->hooks = newAV(); struct ClassHook *hook; Newx(hook, 1, struct ClassHook); *hook = (struct ClassHook){ .funcs = reg->funcs, .funcdata = reg->funcdata, .attrdata = attrdata, }; av_push(classmeta->hooks, (SV *)hook); if(value && value != attrdata) SvREFCNT_dec(value); return; } croak("Unrecognised class attribute :%s", name); } static ClassAttributeRegistration *get_active_registration(pTHX_ const char *name) { COPHH *cophh = CopHINTHASH_get(PL_curcop); for(ClassAttributeRegistration *reg = classattrs; 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; return reg; } return NULL; } struct ClassHook *ObjectPad_mop_class_get_attribute(pTHX_ ClassMeta *classmeta, const char *name) { /* First, work out what hookfuncs the name maps to */ ClassAttributeRegistration *reg = get_active_registration(aTHX_ name); if(!reg) return NULL; /* Now lets see if classmeta has one */ if(!classmeta->hooks) return NULL; U32 hooki; for(hooki = 0; hooki < av_count(classmeta->hooks); hooki++) { struct ClassHook *hook = (struct ClassHook *)AvARRAY(classmeta->hooks)[hooki]; if(hook->funcs == reg->funcs) return hook; } return NULL; } AV *ObjectPad_mop_class_get_attribute_values(pTHX_ ClassMeta *classmeta, const char *name) { /* First, work out what hookfuncs the name maps to */ ClassAttributeRegistration *reg = get_active_registration(aTHX_ name); if(!reg) return NULL; /* Now lets see if classmeta has one */ if(!classmeta->hooks) return NULL; AV *ret = NULL; U32 hooki; for(hooki = 0; hooki < av_count(classmeta->hooks); hooki++) { struct ClassHook *hook = (struct ClassHook *)AvARRAY(classmeta->hooks)[hooki]; if(hook->funcs != reg->funcs) continue; if(!ret) ret = newAV(); av_push(ret, newSVsv(hook->attrdata)); } return ret; } ClassMeta *ObjectPad_mop_get_class_for_stash(pTHX_ HV *stash) { GV **gvp = (GV **)hv_fetchs(stash, "META", 0); if(!gvp) croak("Unable to find ClassMeta for %" HEKf, HEKfARG(HvNAME_HEK(stash))); return MUST_CLASSMETA(SvUV(SvRV(GvSV(*gvp)))); } SV *ObjectPad_mop_class_get_name(pTHX_ ClassMeta *class) { return class->name; } #define make_instance_fields(classmeta, fieldstore, roleoffset) S_make_instance_fields(aTHX_ classmeta, fieldstore, roleoffset) static void S_make_instance_fields(pTHX_ const ClassMeta *classmeta, SV *fieldstore, 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, fieldstore, 0); } AV *fields = classmeta->fields; I32 nfields = av_count(fields); if(SvTYPE(fieldstore) == SVt_PVAV) av_extend((AV *)fieldstore, classmeta->next_fieldix - 1 + roleoffset); I32 i; for(i = 0; i < nfields; i++) { FieldMeta *fieldmeta = MUST_FIELDMETA(AvARRAY(fields)[i]); if(!fieldmeta->is_direct) continue; char sigil = SvPV_nolen(fieldmeta->name)[0]; FIELDOFFSET fieldix = fieldmeta->fieldix + roleoffset; /* We can't av_push() because REPR_KEYS would break here */ SV **svp; #ifdef HAVE_SVt_PVOBJ if(SvTYPE(fieldstore) == SVt_PVOBJ) { svp = &ObjectFIELDS(fieldstore)[fieldix]; *svp = newSV(0); } else #endif { svp = av_fetch_simple((AV *)fieldstore, fieldix, TRUE); } assert(svp); switch(sigil) { case '$': /* simply fetching will create the SV */ break; case '@': sv_setrv_noinc(*svp, (SV *)newAV()); break; case '%': sv_setrv_noinc(*svp, (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 = MUST_ROLEEMBEDDING(embeddings[i]); ClassMeta *rolemeta = embedding->rolemeta; assert(rolemeta->sealed); make_instance_fields(rolemeta, fieldstore, embedding->offset); } } } #define alias_fieldkeys_into_av(classmeta, hv, backingav) S_alias_fieldkeys_into_av(aTHX_ classmeta, hv, backingav) static void S_alias_fieldkeys_into_av(pTHX_ ClassMeta *classmeta, HV *hv, AV *backingav) { if(classmeta->cls.supermeta) alias_fieldkeys_into_av(classmeta->cls.supermeta, hv, backingav); AV *fields = classmeta->fields; I32 nfields = av_count(fields); I32 i; for(i = 0; i < nfields; i++) { FieldMeta *fieldmeta = MUST_FIELDMETA(AvARRAY(fields)[i]); if(!fieldmeta->is_direct) continue; SV *fieldkey = newSVpvf("%" SVf "/%" SVf, classmeta->name, fieldmeta->name); HE *he = hv_fetch_ent(hv, fieldkey, 1, 0); SvREFCNT_dec(fieldkey); av_store(backingav, fieldmeta->fieldix, SvREFCNT_inc(HeVAL(he))); } } SV *ObjectPad_get_obj_fieldstore(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 = mop_get_class_for_stash(SvSTASH(rv)); SV *fieldstore = (SV *)newAV(); make_instance_fields(classmeta, fieldstore, 0); backingsvp = hv_fetchs((HV *)rv, "Object::Pad/slots", TRUE); sv_setrv_noinc(*backingsvp, fieldstore); } 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; case REPR_KEYS: { /* TODO: This representation is going to be sloooooow */ if(SvTYPE(rv) != SVt_PVHV) croak("Not a HASH reference"); HV *hv = (HV *)rv; AV *backingav = newAV(); SAVEFREESV((SV *)backingav); alias_fieldkeys_into_av(mop_get_class_for_stash(SvSTASH(rv)), hv, backingav); return (SV *)backingav; } case REPR_PVOBJ: #ifdef HAVE_SVt_PVOBJ if(SvTYPE(rv) != SVt_PVOBJ) croak("ARGH not an SVt_PVOBJ"); return rv; #else croak("ARGH cannot SVt_PVOBJ on this version of perl"); #endif } croak("ARGH unhandled repr type"); } SV *ObjectPad_get_obj_backingav(pTHX_ SV *self, enum ReprType repr, bool create) { if(repr == REPR_PVOBJ) croak("ARGH cannot get_obj_backingav for REPR_PVOBJ because it isn't an AV"); else return get_obj_fieldstore(self, repr, create); } #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)); /* Perl core's cv_clone() would break in some situation here; see * https://rt.cpan.org/Ticket/Display.html?id=141483 */ CV *embedded_cv = cv_copy_flags(cv, 0); 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__get_embedding_from_pad(pTHX) { /* 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) return MUST_ROLEEMBEDDING(SvPVX(embeddingsv)); else return NULL; } 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); } void ObjectPad__prepare_method_parse(pTHX_ ClassMeta *meta) { /* Save the methodscope for this subparse, in case of nested methods * (RT132321) */ SAVESPTR(meta->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 = meta->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); /* We can't actually add the fields yet because we don't know if it'll be * a :common method. Just save the seqnum for what they would be */ meta->methodscope_seq = PL_cop_seqmax; COP_SEQMAX_INC; LEAVE; } void ObjectPad__start_method_parse(pTHX_ ClassMeta *meta, bool is_common) { /* Splice in the field scope CV in */ CV *methodscope = meta->methodscope; if(CvANON(PL_compcv)) CvANON_on(methodscope); CvOUTSIDE (methodscope) = CvOUTSIDE (PL_compcv); CvOUTSIDE_SEQ(methodscope) = CvOUTSIDE_SEQ(PL_compcv); CvOUTSIDE(PL_compcv) = methodscope; if(!is_common) { /* instance method */ extend_pad_vars(meta); intro_my(); ENTER; SAVESPTR(PL_comppad); SAVESPTR(PL_comppad_name); SAVESPTR(PL_curpad); PL_comppad = PadlistARRAY(CvPADLIST(methodscope))[1]; PL_comppad_name = PadlistNAMES(CvPADLIST(methodscope)); PL_curpad = AvARRAY(PL_comppad); /* Pretend we saw these variables at an earlier time */ assert(meta->methodscope_seq < CvOUTSIDE_SEQ(PL_compcv)); SAVEI32(PL_cop_seqmax); PL_cop_seqmax = meta->methodscope_seq; add_fields_to_pad(meta, 0); intro_my(); LEAVE; } else { /* :common method */ PADOFFSET padix; padix = pad_add_name_pvs("$class", 0, NULL, NULL); if(padix != PADIX_SELF) croak("ARGH: Expected that padix[$class] = 1"); intro_my(); } if(meta->type == METATYPE_ROLE) { PAD *pad1 = PadlistARRAY(CvPADLIST(PL_compcv))[1]; if(meta->role_is_invokable) { SV *sv = PadARRAY(pad1)[PADIX_EMBEDDING]; SvUPGRADE(sv, SVt_PV); SvPOK_on(sv); SvLEN(sv) = 0; SvPVX(sv) = (void *)&ObjectPad__embedding_standalone; } else { SvREFCNT_dec(PadARRAY(pad1)[PADIX_EMBEDDING]); PadARRAY(pad1)[PADIX_EMBEDDING] = &PL_sv_undef; } } } void ObjectPad__add_fields_to_pad(pTHX_ ClassMeta *meta, U32 since_field) { AV *fields = meta->fields; U32 nfields = av_count(fields); U32 i; for(i = since_field; i < nfields; i++) { FieldMeta *fieldmeta = MUST_FIELDMETA(AvARRAY(fields)[i]); /* Skip the anonymous ones */ if(SvCUR(fieldmeta->name) < 2) continue; /* includes the non-direct ones */ /* 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); } } #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 } #define make_methstart_ops(meta, outerscope) S_make_methstart_ops(aTHX_ meta, outerscope) static OP *S_make_methstart_ops(pTHX_ ClassMeta *meta, CV *outerscope) { U8 opf_special_if_role = (meta->type == METATYPE_ROLE) ? OPf_SPECIAL : 0; AV *fields = meta->fields; I32 nfields = av_count(fields); PADNAMELIST *fieldnames = outerscope ? PadlistNAMES(CvPADLIST(outerscope)) : NULL; PADNAME **snames = fieldnames ? PadnamelistARRAY(fieldnames) : NULL; OP *ops = NULL, *methstartop; ops = op_append_list(OP_LINESEQ, ops, methstartop = newMETHSTARTOP(opf_special_if_role | (meta->repr << 8)) ); #ifdef METHSTART_CONTAINS_FIELD_BINDINGS AV *fieldmap = newAV(); U32 fieldcount = 0, max_fieldix = 0; SAVEFREESV((SV *)fieldmap); #endif #if HAVE_PERL_VERSION(5, 22, 0) PADNAME **padnames = PadnamelistARRAY(PadlistNAMES(CvPADLIST(PL_compcv))); U32 cop_seq_low = COP_SEQ_RANGE_LOW(padnames[PADIX_SELF]); #endif int i; for(i = 0; i < nfields; i++) { FieldMeta *fieldmeta = MUST_FIELDMETA(AvARRAY(fields)[i]); if(snames) { 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; } /* TODO: Find a better test for initfields so it doesn't think we capture * every field declared up til now. */ FIELDOFFSET fieldix = fieldmeta->fieldix; PADOFFSET padix = outerscope ? find_padix_for_field(fieldmeta) : pad_findmy_pv(SvPVX(fieldmeta->name), 0); 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; } #ifdef METHSTART_CONTAINS_FIELD_BINDINGS PERL_UNUSED_VAR(opf_special_if_role); assert((fieldix & ~FIELDIX_MASK) == 0); av_store(fieldmap, padix, newSVuv(((UV)private << FIELDIX_TYPE_SHIFT) | fieldix)); fieldcount++; if(fieldix > max_fieldix) max_fieldix = fieldix; #else ops = op_append_list(OP_LINESEQ, ops, /* alias the padix from the field */ newFIELDPADOP(private << 8 | opf_special_if_role, padix, fieldix)); #endif #if HAVE_PERL_VERSION(5, 22, 0) if(snames) { PADNAME *fieldname = snames[i + 1]; /* 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 } #ifdef METHSTART_CONTAINS_FIELD_BINDINGS if(fieldcount) { UNOP_AUX_item *aux; Newx(aux, 2 + fieldcount*2, UNOP_AUX_item); cUNOP_AUXx(methstartop)->op_aux = aux; (aux++)->uv = fieldcount; (aux++)->uv = max_fieldix; for(Size_t i = 0; i < av_count(fieldmap); i++) { if(!AvARRAY(fieldmap)[i] || !SvOK(AvARRAY(fieldmap)[i])) continue; (aux++)->uv = i; (aux++)->uv = SvUV(AvARRAY(fieldmap)[i]); } } #endif return ops; } OP *ObjectPad__finish_method_parse(pTHX_ ClassMeta *meta, bool is_common, OP *body) { assert(meta->methodscope && SvTYPE(meta->methodscope) == SVt_PVCV); /* If we have no body that means this was a bodyless method * declaration; a required method for a role */ if(body && !is_common) { { ENTER; SAVEVPTR(PL_curcop); PADNAME **padnames = PadnamelistARRAY(PadlistNAMES(CvPADLIST(PL_compcv))); /* 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, body, &padcop)) PL_curcop = padcop; warn("\"my\" variable $self masks earlier declaration in same scope"); } LEAVE; } body = op_append_list(OP_LINESEQ, make_methstart_ops(meta, meta->methodscope), body); } else if(body && is_common) { body = op_append_list(OP_LINESEQ, newCOMMONMETHSTARTOP(0 | (meta->repr << 8)), body); } meta->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); } return body; } void ObjectPad__prepare_adjust_params(pTHX_ ClassMeta *meta) { /* Skip the PADIX_EMBEDDING slot if not already done so */ if(meta->type != METATYPE_ROLE) pad_add_name_pvs("", 0, NULL, NULL); PADOFFSET params_padix = pad_add_name_pvs("%(params)", 0, NULL, NULL); assert(params_padix == PADIX_PARAMS); PERL_UNUSED_VAR(params_padix); intro_my(); } void ObjectPad__parse_adjust_params(pTHX_ ClassMeta *meta, AV *params) { /* This is a custom parser because XPK won't handle this */ if(lex_peek_unichar(0) != '(') croak("Expected ADJUST :params signature in parens"); lex_read_unichar(0); if(!meta->parammap) meta->parammap = newHV(); HV *parammap = meta->parammap; bool seen_slurpy = false; while(1) { lex_read_space(0); /* Should now follow a sequence of comma-separated elements; each element is * :$NAME or * :$NAME = EXPR * :$NAME //= EXPR * :$NAME ||= EXPR * The final one may also be * %NAME */ char c = lex_peek_unichar(0); if(c == ')') break; if(seen_slurpy) croak("Cannot have more parameters after the final slurpy one"); if(c == ':') { lex_read_unichar(0); lex_read_space(0); SV *varname = lex_scan_lexvar(); lex_read_space(0); if(SvPVX(varname)[0] != '$') croak("Expected a named scalar parameter"); SV *paramname = newSVpvn(SvPVX(varname)+1, SvCUR(varname)-1); check_colliding_param(meta, paramname); PADOFFSET padix = pad_add_name_sv(varname, 0, NULL, NULL); ParamMeta *parammeta; Newx(parammeta, 1, struct ParamMeta); *parammeta = (struct ParamMeta){ LINNET_INIT(LINNET_VAL_PARAMMETA) .name = paramname, .class = meta, .type = PARAM_ADJUST, .adjust.padix = padix, }; av_push(params, newSVuv(PTR2UV((SV *)parammeta))); hv_store_ent(parammap, paramname, (SV *)parammeta, 0); if(lex_consume("=")) { lex_read_space(0); parammeta->adjust.defexpr = parse_termexpr(0); } else if(lex_consume("//=")) { lex_read_space(0); parammeta->adjust.defexpr = parse_termexpr(0); parammeta->adjust.def_if_undef = 1; } else if(lex_consume("||=")) { lex_read_space(0); parammeta->adjust.defexpr = parse_termexpr(0); parammeta->adjust.def_if_false = 1; } intro_my(); } else if(c == '%') { SV *varname = lex_scan_lexvar(); /* Lets now be evil and simply rename %(params) to this. Due to the way * that the PADNAME structure itself contains the string, we can't * just change the name *inside* it. Instead we'll have to allocate a * new one and swap it in. */ PADNAME **pnp = &PadnamelistARRAY(PL_comppad_name)[PADIX_PARAMS]; PADNAME *new_pn = newPADNAMEpvn(SvPVX(varname), SvCUR(varname)); COP_SEQ_RANGE_LOW_set(new_pn, COP_SEQ_RANGE_LOW(*pnp)); PadnameREFCNT_dec(*pnp); *pnp = new_pn; /* Don't need to intro_my() because the padname has already been * introduced */ seen_slurpy = true; } else croak("Expected a named scalar parameter or slurpy hash"); lex_read_space(0); c = lex_peek_unichar(0); if(c == ')') break; if(c != ',') croak("Expected , or end of signature parens"); lex_read_unichar(0); } /* consume the ')' */ lex_read_unichar(0); lex_read_space(0); } static OP *pp_bind_params_hv(pTHX) { HV *params = HV_FROM_REF(*av_fetch(GvAV(PL_defgv), 0, 0)); SAVESPTR(PAD_SVl(PADIX_PARAMS)); PAD_SVl(PADIX_PARAMS) = SvREFCNT_inc(params); save_freesv((SV *)params); return NORMAL; } OP *ObjectPad__finish_adjust_params(pTHX_ ClassMeta *meta, AV *params, OP *body) { OP *paramsops = NULL; paramsops = op_append_elem(OP_LINESEQ, paramsops, newOP_CUSTOM(&pp_bind_params_hv, 0)); for(U32 i = 0; params && i < av_count(params); i++) { ParamMeta *parammeta = MUST_PARAMMETA(SvUV(AvARRAY(params)[i])); SV *paramname = parammeta->name; OP *defexpr = parammeta->adjust.defexpr; if(!defexpr) defexpr = newop_croak_from_constructor( newSVpvf("Required parameter '%" SVf "' is missing for %" SVf " constructor", SVfARG(paramname), SVfARG(meta->name))); OP *helemop = newBINOP(OP_HELEM, 0, newPADxVOP(OP_PADHV, OPf_REF, PADIX_PARAMS), newSVOP(OP_CONST, 0, SvREFCNT_inc(paramname))); OP *rhs; if(parammeta->adjust.def_if_undef) { /* delete $(params){KEY} // DEFEXPR */ rhs = newLOGOP(OP_DOR, 0, newUNOP(OP_DELETE, 0, helemop), defexpr); } else if(parammeta->adjust.def_if_false) { /* delete $(params){KEY} || DEFEXPR */ rhs = newLOGOP(OP_OR, 0, newUNOP(OP_DELETE, 0, helemop), defexpr); } else { /* Equivalent of * exists $(params){KEY} ? delete $(params){KEY} : DEFEXPR; */ rhs = newHELEMEXISTSOROP(OPpHELEMEXISTSOR_DELETE << 8, helemop, defexpr); } paramsops = op_append_elem(OP_LINESEQ, paramsops, newBINOP(OP_SASSIGN, 0, rhs, newPADxVOP(OP_PADSV, OPf_MOD|OPf_REF, parammeta->adjust.padix))); } return op_append_list(OP_LINESEQ, paramsops, body); } MethodMeta *ObjectPad_mop_class_add_method(pTHX_ ClassMeta *meta, SV *methodname) { AV *methods = meta->direct_methods; if(!meta->begun) croak("Cannot add a new method to a class that is not yet begun"); 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 = MUST_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 = (MethodMeta){ LINNET_INIT(LINNET_VAL_METHODMETA) .name = SvREFCNT_inc(methodname), .class = meta, }; av_push(methods, (SV *)methodmeta); return methodmeta; } MethodMeta *ObjectPad_mop_class_add_method_cv(pTHX_ ClassMeta *meta, SV *methodname, CV *cv) { MethodMeta *methodmeta = mop_class_add_method(meta, methodname); I32 klen = SvCUR(methodname); if(SvUTF8(methodname)) klen = -klen; GV **gvp = (GV **)hv_fetch(meta->stash, SvPVX(methodname), klen, GV_ADD); gv_init_sv(*gvp, meta->stash, methodname, 0); GvMULTI_on(*gvp); GvCV_set(*gvp, cv); CvGV_set(cv, *gvp); return methodmeta; } FieldMeta *ObjectPad_mop_class_add_field(pTHX_ ClassMeta *meta, SV *fieldname) { AV *fields = meta->fields; if(!meta->begun) 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"); } if(mop_class_find_field(meta, fieldname, 0)) croak("Cannot add another field named %" SVf, fieldname); FieldMeta *fieldmeta = mop_create_field(fieldname, meta->next_fieldix, meta); av_push(fields, (SV *)fieldmeta); meta->next_fieldix++; MOP_CLASS_RUN_HOOKS(meta, post_add_field, fieldmeta); return fieldmeta; } FieldMeta *ObjectPad_mop_class_find_field(pTHX_ ClassMeta *meta, SV *fieldname, U32 flags) { AV *fields = meta->fields; U32 i, nfields = av_count(fields); for(i = 0; i < nfields; i++) { FieldMeta *fieldmeta = MUST_FIELDMETA(AvARRAY(fields)[i]); if(SvCUR(fieldmeta->name) < 2) continue; if((flags & FIND_FIELD_ONLY_DIRECT) && !(fieldmeta->is_direct)) continue; if((flags & FIND_FIELD_ONLY_INHERITABLE) && !(fieldmeta->is_inheritable)) continue; if(sv_eq(fieldmeta->name, fieldname)) return fieldmeta; } return NULL; } void ObjectPad_mop_class_add_BUILD(pTHX_ ClassMeta *meta, CV *cv) { if(!meta->begun) croak("Cannot add a new BUILD block to a class that is not yet begun"); 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->buildcvs) meta->buildcvs = newAV(); av_push(meta->buildcvs, (SV *)cv); } void ObjectPad_mop_class_add_ADJUST(pTHX_ ClassMeta *meta, CV *cv) { if(!meta->begun) croak("Cannot add a new ADJUST block to a class that is not yet begun"); if(meta->sealed) croak("Cannot add an ADJUST(PARAMS) block to an already-sealed class"); warn_outofblock_ops(CvROOT(cv), "Using %s to leave an ADJUST block is discouraged and will be removed in a later version"); if(!meta->adjustcvs) meta->adjustcvs = newAV(); meta->has_adjust = true; av_push(meta->adjustcvs, (SV *)cv); } 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->begun) croak("Cannot add a new required method to a class that is not yet begun"); 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(MUST_ROLEEMBEDDING(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(MUST_CLASSMETA(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 = (RoleEmbedding){ LINNET_INIT(LINNET_VAL_ROLEEMBEDDING) .embeddingsv = embeddingsv, .rolemeta = rolemeta, .classmeta = classmeta, .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->buildcvs ? av_count(rolemeta->buildcvs) : 0; for(i = 0; i < nbuilds; i++) { CV *buildcv = (CV *)AvARRAY(rolemeta->buildcvs)[i]; CV *embedded_buildcv = embed_cv(buildcv, embedding); if(!classmeta->buildcvs) classmeta->buildcvs = newAV(); av_push(classmeta->buildcvs, (SV *)embedded_buildcv); } U32 nadjusts = rolemeta->adjustcvs ? av_count(rolemeta->adjustcvs) : 0; for(i = 0; i < nadjusts; i++) { CV *cv = (CV *)AvARRAY(rolemeta->adjustcvs)[i]; CV *embedded_cv = embed_cv(cv, embedding); mop_class_add_ADJUST(classmeta, embedded_cv); } if(rolemeta->has_adjust) classmeta->has_adjust = true; U32 nmethods = av_count(rolemeta->direct_methods); for(i = 0; i < nmethods; i++) { MethodMeta *methodmeta = MUST_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; dstmethodmeta->is_common = methodmeta->is_common; } 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 *cv = GvCV((GV *)HeVAL(he)); if(!methodmeta->is_common) { CV *newcv = embed_cv(cv, embedding); GvCV_set(*gvp, newcv); CvGV_set(newcv, *gvp); } else /* :common methods don't get an embedding */ GvCV_set(*gvp, (CV *)SvREFCNT_inc((SV *)cv)); } 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->begun) croak("Cannot add a new role to a class that is not yet begun"); 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, MUST_CLASSMETA(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 = MUST_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 = (struct FieldHook){ .fieldix = roleh->fieldix + offset, .fieldmeta = roleh->fieldmeta, .funcs = roleh->funcs, .attrdata = roleh->attrdata, }; 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 = MUST_PARAMMETA(HeVAL(iter)); ParamMeta *classparammeta; Newx(classparammeta, 1, struct ParamMeta); *classparammeta = (struct ParamMeta){ LINNET_INIT(LINNET_VAL_PARAMMETA) .name = SvREFCNT_inc(roleparammeta->name), .class = roleparammeta->class, .type = roleparammeta->type, }; switch(roleparammeta->type) { case PARAM_FIELD: classparammeta->field.fieldmeta = roleparammeta->field.fieldmeta; classparammeta->field.fieldix = roleparammeta->field.fieldix + embedding->offset; break; case PARAM_ADJUST: classparammeta->adjust.padix = roleparammeta->adjust.padix; classparammeta->adjust.defexpr = roleparammeta->adjust.defexpr; /* no refcnt on optrees */ break; } 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_makefield) { if(!classmeta->fieldhooks_makefield) classmeta->fieldhooks_makefield = newAV(); U32 i; for(i = 0; i < av_count(rolemeta->fieldhooks_makefield); i++) { struct FieldHook *roleh = (struct FieldHook *)AvARRAY(rolemeta->fieldhooks_makefield)[i]; av_push(classmeta->fieldhooks_makefield, (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 += rolemeta->next_fieldix; /* 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(MUST_ROLEEMBEDDING(arr[i])); } } void ObjectPad__check_colliding_param(pTHX_ ClassMeta *classmeta, SV *paramname) { HV *parammap = classmeta->parammap; assert(parammap); HE *he = hv_fetch_ent(parammap, paramname, 0, 0); if(!he) return; ParamMeta *colliding_parammeta = MUST_PARAMMETA(HeVAL(he)); ClassMeta *origclassmeta = colliding_parammeta->class; if(origclassmeta != classmeta) croak("Already have a named constructor parameter called '%" SVf "' inherited from %" SVf, SVfARG(paramname), SVfARG(origclassmeta->name)); else croak("Already have a named constructor parameter called '%" SVf "'", SVfARG(paramname)); } static OP *pp_alias_params(pTHX) { dSP; PADOFFSET padix = PADIX_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 void S_generate_initfields_method(pTHX_ ClassMeta *meta) { 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 /* TODO: This will create a method start op that appears to capture every * field except the final one. There's not a lot we can do about this * without duplicating a lot of the `methodscope` structure for initfields, * except more complex due to the multiple suspend/resume nature of parsing * it. */ OP *ops = make_methstart_ops(meta, NULL); 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 */ 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)); ops = op_append_list(OP_LINESEQ, ops, /* Build an OP_ENTERSUB for supermeta's initfields */ newLISTOPn(OP_ENTERSUB, OPf_WANT_VOID|OPf_STACKED, newPADxVOP(OP_PADSV, 0, PADIX_SELF), newPADxVOP(OP_PADHV, OPf_REF, PADIX_PARAMS), newSVOP(OP_CONST, 0, (SV *)supermeta->initfields), NULL)); } if(meta->initfields_lines) { ops = op_append_list(OP_LINESEQ, ops, meta->initfields_lines); } if(meta->type == METATYPE_CLASS) { U32 nroles; RoleEmbedding **embeddings = mop_class_get_direct_roles(meta, &nroles); for(i = 0; i < nroles; i++) { RoleEmbedding *embedding = MUST_ROLEEMBEDDING(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)); ops = op_append_list(OP_LINESEQ, ops, newLISTOPn(OP_ENTERSUB, OPf_WANT_VOID|OPf_STACKED, newPADxVOP(OP_PADSV, 0, PADIX_SELF), newPADxVOP(OP_PADHV, OPf_REF, PADIX_PARAMS), newSVOP(OP_CONST, 0, (SV *)embed_cv(rolemeta->initfields, embedding)), NULL)); } } 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->begun) mop_class_begin(meta); if(meta->sealed) /* idempotent */ return; MOP_CLASS_RUN_HOOKS_NOARGS(meta, pre_seal); 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)); } GV *gv = gv_fetchmeth_pvs(meta->stash, "BUILDARGS", -1, 0); assert(gv); assert(SvTYPE(gv) == SVt_PVGV); if(GvSTASH(gv) != gv_stashpvs("Object::Pad::UNIVERSAL", 0)) meta->has_buildargs = true; } if(meta->strict_params && meta->buildcvs) croak("Class %" SVf " cannot be :strict(params) because it has BUILD blocks", SVfARG(meta->name)); { AV *fields = meta->fields; U32 nfields = av_count(fields); U32 i; for(i = 0; i < nfields; i++) { FieldMeta *fieldmeta = MUST_FIELDMETA(AvARRAY(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_makefield) { if(!meta->fieldhooks_makefield) meta->fieldhooks_makefield = newAV(); struct FieldHook *fasth; Newx(fasth, 1, struct FieldHook); *fasth = (struct FieldHook){ .fieldix = fieldmeta->fieldix, .fieldmeta = fieldmeta, .funcs = h->funcs, .funcdata = h->funcdata, .attrdata = h->attrdata, }; av_push(meta->fieldhooks_makefield, (SV *)fasth); } if(*h->funcs->post_construct) { if(!meta->fieldhooks_construct) meta->fieldhooks_construct = newAV(); struct FieldHook *fasth; Newx(fasth, 1, struct FieldHook); *fasth = (struct FieldHook){ .fieldix = fieldmeta->fieldix, .fieldmeta = fieldmeta, .funcs = h->funcs, .funcdata = h->funcdata, .attrdata = h->attrdata, }; av_push(meta->fieldhooks_construct, (SV *)fasth); } } } } S_generate_initfields_method(aTHX_ meta); if(meta->adjust_lines) { ENTER; need_PLparser(); I32 floor_ix = PL_savestack_ix; { SAVEI32(PL_subline); save_item(PL_subname); resume_compcv(&meta->adjust_compcv); } SvREFCNT_inc(PL_compcv); OP *body = finish_adjust_params(meta, meta->adjust_params, meta->adjust_lines); meta->methodscope = meta->adjust_methodscope; body = finish_method_parse(meta, FALSE, body); CV *adjustcv = newATTRSUB(floor_ix, NULL, NULL, NULL, body); mop_class_add_ADJUST(meta, adjustcv); LEAVE; } meta->sealed = true; MOP_CLASS_RUN_HOOKS_NOARGS(meta, post_seal); if(meta->pending_submeta) { int i; SV **arr = AvARRAY(meta->pending_submeta); for(i = 0; i < av_count(meta->pending_submeta); i++) { ClassMeta *submeta = MUST_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 = MUST_CLASSMETA(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(); I32 nargs = 0; SAVEFREESV(args); if(meta->has_buildargs) { /* @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; nargs = call_method("BUILDARGS", G_ARRAY); SPAGAIN; for(svp = SP - nargs + 1; svp <= SP; svp++) av_push_simple(args, SvREFCNT_inc(*svp)); FREETMPS; LEAVE; } else { nargs = items - 1; SV **svp; for(svp = SP - nargs + 1; svp <= SP; svp++) av_push_simple(args, SvREFCNT_inc(*svp)); } 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: case REPR_KEYS: DEBUG_SET_CURCOP_LINE(__LINE__); self = sv_2mortal(newRV_noinc((SV *)newHV())); sv_bless(self, stash); break; case REPR_PVOBJ: #ifdef HAVE_SVt_PVOBJ { DEBUG_SET_CURCOP_LINE(__LINE__); /* TODO: Perl needs to export newSVobject() */ U32 fieldcount = meta->next_fieldix; SV *obj = newSV_type(SVt_PVOBJ); Newx(ObjectFIELDS(obj), fieldcount, SV *); ObjectMAXFIELD(obj) = fieldcount - 1; Zero(ObjectFIELDS(obj), fieldcount, SV *); self = sv_2mortal(newRV_noinc(obj)); sv_bless(self, stash); } #else croak("ARGH cannot SVt_PVOBJ on this version of perl"); #endif 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, nargs); SV **argstart = SP - nargs; 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_PVOBJ: croak("ARGH shouldn't ever have REPR_PVOBJ with foreign_new"); case REPR_HASH: case_REPR_HASH: case REPR_KEYS: 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); } SV *fieldstore; if(need_makefields) { fieldstore = get_obj_fieldstore(self, meta->repr, TRUE); make_instance_fields(meta, fieldstore, 0); } else { fieldstore = get_obj_fieldstore(self, meta->repr, FALSE); } SV **fieldsvs = fieldstore_fields(fieldstore); if(meta->fieldhooks_makefield || meta->fieldhooks_construct) { /* We need to set up a fake pad so these hooks can still get PADIX_SELF / PADIX_FIELDS */ /* 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_FIELDS) = fieldstore; } if(meta->fieldhooks_makefield) { DEBUG_SET_CURCOP_LINE(__LINE__); AV *fieldhooks = meta->fieldhooks_makefield; 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_makefield)(aTHX_ h->fieldmeta, h->attrdata, h->funcdata, fieldsvs[fieldix]); } } HV *paramhv = NULL; if(meta->parammap || meta->has_adjust || meta->strict_params) { paramhv = newHV(); SAVEFREESV((SV *)paramhv); if(nargs % 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 < nargs; idx += 2) { SV *name = argsv[idx]; SV *value = idx < nargs-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->buildcvs) { DEBUG_SET_CURCOP_LINE(__LINE__); AV *buildcvs = meta->buildcvs; SV **argsvs = AvARRAY(args); int i; for(i = 0; i < av_count(buildcvs); i++) { CV *buildcv = (CV *)AvARRAY(buildcvs)[i]; ENTER; SAVETMPS; SPAGAIN; EXTEND(SP, nargs); PUSHMARK(SP); PUSHs(self); int argi; for(argi = 0; argi < nargs; argi++) PUSHs(argsvs[argi]); PUTBACK; assert(buildcv); call_sv((SV *)buildcv, G_VOID); FREETMPS; LEAVE; } } if(meta->adjustcvs) { DEBUG_SET_CURCOP_LINE(__LINE__); AV *adjustcvs = meta->adjustcvs; U32 i; for(i = 0; i < av_count(adjustcvs); i++) { CV *cv = (CV *)AvARRAY(adjustcvs)[i]; ENTER; SAVETMPS; SPAGAIN; EXTEND(SP, 1 + !!paramhv); PUSHMARK(SP); PUSHs(self); if(paramhv) mPUSHs(newRV_inc((SV *)paramhv)); PUTBACK; assert(cv); call_sv((SV *)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 = newSVpvn("", 0); SAVEFREESV(params); sv_catpvf(params, "'%" SVf "'", SVfARG(HeSVKEY_force(he))); 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->attrdata, h->funcdata, fieldsvs[fieldix]); } } #ifdef DEBUG_OVERRIDE_PLCURCOP PL_curcop = prevcop; #endif ST(0) = self; XSRETURN(1); } XS_INTERNAL(injected_constructor_role); XS_INTERNAL(injected_constructor_role) { const ClassMeta *meta = MUST_CLASSMETA(XSANY.any_ptr); croak("Cannot directly construct an instance of role '%" SVf "'", SVfARG(meta->name)); } XS_INTERNAL(injected_DOES) { dXSARGS; const ClassMeta *meta = MUST_CLASSMETA(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 = MUST_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; } 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); } OP *ObjectPad__newop_croak_from_constructor(pTHX_ SV *message) { return newUNOP_CUSTOM(&pp_croak_from_constructor, 0, newSVOP(OP_CONST, 0, message)); } ClassMeta *ObjectPad_mop_create_class(pTHX_ enum MetaType type, SV *name) { assert(type == METATYPE_CLASS || type == METATYPE_ROLE); HV *stash = gv_stashsv(name, GV_ADD); ClassMeta *meta; Newx(meta, 1, ClassMeta); *meta = (ClassMeta){ LINNET_INIT(LINNET_VAL_CLASSMETA) .type = type, .repr = REPR_AUTOSELECT, .name = SvREFCNT_inc(name), .stash = stash, .next_fieldix = -1, .fields = newAV(), .direct_methods = newAV(), .requiremethods = newAV(), }; switch(type) { case METATYPE_CLASS: 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(); 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); } /* Prepare meta->initfields for containing a CV parsing operation */ { 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_PARAMS) croak("ARGH: Expected that padix[%%params] = 4"); intro_my(); suspend_compcv(&meta->initfields_compcv); LEAVE_SCOPE(floor_ix); } if(hv_fetchs(GvHV(PL_hintgv), "Object::Pad/experimental(composed_adjust)", 0)) { meta->composed_adjust = TRUE; prepare_method_parse(meta); I32 floor_ix = start_subparse(FALSE, 0); start_method_parse(meta, FALSE); prepare_adjust_params(meta); meta->adjust_params = newAV(); suspend_compcv(&meta->adjust_compcv); meta->adjust_methodscope = meta->methodscope; meta->next_field_for_adjust = 0; LEAVE_SCOPE(floor_ix); } meta->tmpcop = (COP *)newSTATEOP(0, NULL, NULL); CopFILE_set(meta->tmpcop, __FILE__); meta->methodscope = NULL; meta->initfields_lines = NULL; { /* Inject the constructor */ SV *newname = newSVpvf("%" SVf "::new", name); SAVEFREESV(newname); CV *newcv; if(type == METATYPE_CLASS) { newcv = newXS_flags(SvPV_nolen(newname), injected_constructor, __FILE__, NULL, SvFLAGS(newname) & SVf_UTF8); } else { newcv = newXS_flags(SvPV_nolen(newname), injected_constructor_role, __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 = MUST_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->buildcvs) { if(!meta->buildcvs) meta->buildcvs = newAV(); av_push_from_av_noinc(meta->buildcvs, supermeta->buildcvs); } if(supermeta->adjustcvs) { if(!meta->adjustcvs) meta->adjustcvs = newAV(); av_push_from_av_noinc(meta->adjustcvs, supermeta->adjustcvs); } if(supermeta->fieldhooks_makefield) { if(!meta->fieldhooks_makefield) meta->fieldhooks_makefield = newAV(); av_push_from_av_noinc(meta->fieldhooks_makefield, supermeta->fieldhooks_makefield); } 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_adjust) meta->has_adjust = true; U32 nroles; RoleEmbedding **embeddings = mop_class_get_all_roles(supermeta, &nroles); if(nroles) { U32 i; for(i = 0; i < nroles; i++) { RoleEmbedding *embedding = MUST_ROLEEMBEDDING(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); } meta->has_superclass = true; meta->cls.supermeta = supermeta; } void ObjectPad_mop_class_load_and_set_superclass(pTHX_ ClassMeta *class, SV *supername, SV *superver) { if(class->type != METATYPE_CLASS) croak("Only a class may extend another"); HV *superstash = gv_stashsv(supername, 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(supername), NULL, NULL); superstash = gv_stashsv(supername, 0); } if(!superstash) croak("Superclass %" SVf " does not exist", supername); if(superver && SvOK(superver)) ensure_module_version(supername, superver); mop_class_set_superclass(class, supername); } void ObjectPad_mop_class_inherit_from_superclass(pTHX_ ClassMeta *meta, SV **args, size_t nargs) { if(!meta->begun) croak("Cannot inherit into a class that is not yet begun"); if(meta->sealed) croak("Cannot inherit into an already-sealed class"); ClassMeta *supermeta = meta->cls.supermeta; if(meta->type != METATYPE_CLASS || !supermeta) croak("Cannot inherit into a non-class or from a non-Object::Pad-based superclass"); for(int i = 0; i < nargs; i++) { SV *arg = args[i]; if(SvPVX(arg)[0] == '$') { /* A field name */ FieldMeta *superfield = mop_class_find_field(supermeta, arg, FIND_FIELD_ONLY_INHERITABLE); if(!superfield) croak("Superclass does not have a field named %" SVf " (or it is not :inheritable", SVfARG(arg)); assert(superfield->fieldix < meta->next_fieldix); if(mop_class_find_field(meta, arg, 0)) croak("Cannot add another field named %" SVf, arg); FieldMeta *fieldmeta = mop_create_field(superfield->name, superfield->fieldix, meta); fieldmeta->is_direct = false; av_push(meta->fields, (SV *)fieldmeta); /* TODO: Think about running some field hooks?? */ } else croak("Unrecognised inherit argument '%" SVf "'", SVfARG(arg)); } } void ObjectPad_mop_class_begin(pTHX_ ClassMeta *meta) { if(meta->begun) /* idempotent */ return; SV *isaname = newSVpvf("%" SVf "::ISA", meta->name); SAVEFREESV(isaname); if(meta->type == METATYPE_CLASS && !meta->cls.supermeta) { AV *isa = get_av(SvPV_nolen(isaname), GV_ADD | (SvFLAGS(isaname) & SVf_UTF8)); 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->begun = true; 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 **attrdata, 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); mop_class_load_and_set_superclass(classmeta, superclassname, superclassver); 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 **attrdata, 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_begin(classmeta); 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 **attrdata, 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, "keys")) classmeta->repr = REPR_KEYS; else if(strEQ(val, "pvobj")) { if(classmeta->type == METATYPE_CLASS && classmeta->cls.foreign_new) croak("Cannot switch a subclass of a foreign superclass type to :repr(pvobj)"); #ifdef HAVE_SVt_PVOBJ classmeta->repr = REPR_PVOBJ; #else croak("Cannot switch to :repr(pvobj) on Perl " PERL_VERSION_STRING); #endif } 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 **attrdata, 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 **attrdata_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(pTHX) { 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); #ifdef HAVE_DMD_HELPER DMD_ADD_ROOT((SV *)&vtbl_backingav, "the Object::Pad backing AV VTBL"); #endif } Object-Pad-0.810/src/field.c000444001750001750 6223014655674547 14400 0ustar00leoleo000000000000/* vi: set ft=xs : */ #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #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" #include "OP_HELEMEXISTSOR.c.inc" #include "object_pad.h" #include "class.h" #include "field.h" #undef register_field_attribute #if HAVE_PERL_VERSION(5,36,0) # define HAVE_OP_WEAKEN #endif #define need_PLparser() ObjectPad__need_PLparser(aTHX) void ObjectPad__need_PLparser(pTHX); /* in Object/Pad.xs */ FieldMeta *ObjectPad_mop_create_field(pTHX_ SV *fieldname, FIELDOFFSET fieldix, ClassMeta *classmeta) { FieldMeta *fieldmeta; Newx(fieldmeta, 1, FieldMeta); assert(fieldix > -1); *fieldmeta = (FieldMeta){ LINNET_INIT(LINNET_VAL_FIELDMETA) .name = SvREFCNT_inc(fieldname), .is_direct = true, .class = classmeta, .fieldix = fieldix, }; 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(); check_colliding_param(classmeta, paramname); ParamMeta *parammeta; Newx(parammeta, 1, struct ParamMeta); *parammeta = (struct ParamMeta){ LINNET_INIT(LINNET_VAL_PARAMMETA) .name = SvREFCNT_inc(paramname), .class = classmeta, .type = PARAM_FIELD, .field.fieldmeta = fieldmeta, .field.fieldix = fieldmeta->fieldix, }; fieldmeta->paramname = SvREFCNT_inc(paramname); hv_store_ent(classmeta->parammap, paramname, (SV *)parammeta, 0); } SV *ObjectPad_mop_field_get_default_sv(pTHX_ FieldMeta *fieldmeta) { if(!fieldmeta->defaultexpr) return NULL; OP *o = fieldmeta->defaultexpr; switch(mop_field_get_sigil(fieldmeta)) { case '$': break; case '@': if(o->op_type != OP_RV2AV) return NULL; o = cUNOPo->op_first; break; case '%': if(o->op_type != OP_RV2HV) return NULL; o = cUNOPo->op_first; break; } if(o->op_type != OP_CUSTOM || o->op_ppaddr != PL_ppaddr[OP_CONST]) return NULL; return cSVOPo_sv; } void ObjectPad_mop_field_set_default_sv(pTHX_ FieldMeta *fieldmeta, SV *sv) { if(fieldmeta->defaultexpr) op_free(fieldmeta->defaultexpr); /* 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 *valueop = newSVOP_CUSTOM(PL_ppaddr[OP_CONST], 0, sv); switch(mop_field_get_sigil(fieldmeta)) { case '$': fieldmeta->defaultexpr = valueop; break; case '@': assert(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV); fieldmeta->defaultexpr = newUNOP(OP_RV2AV, 0, valueop); break; case '%': assert(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV); fieldmeta->defaultexpr = newUNOP(OP_RV2HV, 0, valueop); break; } } 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 = (struct FieldAttributeRegistration){ .name = name, .funcs = funcs, .funcdata = funcdata, }; if(funcs->permit_hintkey) reg->permit_hintkeylen = strlen(funcs->permit_hintkey); else reg->permit_hintkeylen = 0; reg->next = fieldattrs; fieldattrs = reg; } static void apply_attribute(pTHX_ FieldMeta *fieldmeta, const char *name, bool parse_value, 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; break; } if(!reg) croak("Unrecognised field attribute :%s", name); 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); if(parse_value && reg->funcs->parse) value = (*reg->funcs->parse)(aTHX_ fieldmeta, value, reg->funcdata); SV *attrdata = value; if(reg->funcs->apply) { if(!(*reg->funcs->apply)(aTHX_ fieldmeta, value, &attrdata, reg->funcdata)) return; } if(attrdata && attrdata == value) SvREFCNT_inc(attrdata); if(!fieldmeta->hooks) fieldmeta->hooks = newAV(); struct FieldHook *hook; Newx(hook, 1, struct FieldHook); *hook = (struct FieldHook){ .funcs = reg->funcs, .attrdata = attrdata, .funcdata = reg->funcdata, }; av_push(fieldmeta->hooks, (SV *)hook); } void ObjectPad_mop_field_apply_attribute(pTHX_ FieldMeta *fieldmeta, const char *name, SV *value) { apply_attribute(aTHX_ fieldmeta, name, false, value); } void ObjectPad_mop_field_parse_and_apply_attribute(pTHX_ FieldMeta *fieldmeta, const char *name, SV *value) { apply_attribute(aTHX_ fieldmeta, name, true, value); } static FieldAttributeRegistration *get_active_registration(pTHX_ const char *name) { COPHH *cophh = CopHINTHASH_get(PL_curcop); for(FieldAttributeRegistration *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; return reg; } return NULL; } struct FieldHook *ObjectPad_mop_field_get_attribute(pTHX_ FieldMeta *fieldmeta, const char *name) { /* First, work out what hookfuncs the name maps to */ FieldAttributeRegistration *reg = get_active_registration(aTHX_ name); 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; } AV *ObjectPad_mop_field_get_attribute_values(pTHX_ FieldMeta *fieldmeta, const char *name) { /* First, work out what hookfuncs the name maps to */ FieldAttributeRegistration *reg = get_active_registration(aTHX_ name); if(!reg) return NULL; /* Now lets see if fieldmeta has one */ if(!fieldmeta->hooks) return NULL; AV *ret = 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) continue; if(!ret) ret = newAV(); av_push(ret, newSVsv(hook->attrdata)); } return ret; } SV *ObjectPad_get_obj_fieldsv(pTHX_ SV *self, ClassMeta *classmeta, FieldMeta *fieldmeta) { SV *fieldstore; FIELDOFFSET fieldix; assert(SvROK(self)); assert(SvOBJECT(SvRV(self))); if(classmeta->type == METATYPE_ROLE) { HV *objstash = SvSTASH(SvRV(self)); 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 = MUST_ROLEEMBEDDING(*svp); fieldstore = get_obj_fieldstore(self, embedding->classmeta->repr, true); fieldix = fieldmeta->fieldix + embedding->offset; } else { const char *stashname = HvNAME(classmeta->stash); if(!stashname || !sv_derived_from(self, stashname)) croak("Cannot fetch field value from a non-derived instance"); fieldstore = get_obj_fieldstore(self, classmeta->repr, true); fieldix = fieldmeta->fieldix; } if(fieldix > fieldstore_maxfield(fieldstore)) croak("ARGH: instance does not have a field at index %ld", (long int)fieldix); SV *sv = fieldstore_fields(fieldstore)[fieldix]; return sv; } static OP *pp_fieldsv(pTHX) { dSP; FIELDOFFSET fieldix = PL_op->op_targ; if(PL_op->op_flags & OPf_SPECIAL) { RoleEmbedding *embedding = get_embedding_from_pad(); if(embedding && embedding != &ObjectPad__embedding_standalone) { fieldix += embedding->offset; } } SV *fieldstore = PAD_SVl(PADIX_FIELDS); SV *fieldsv = fieldstore_fields(fieldstore)[fieldix]; EXTEND(SP, 1); PUSHs(fieldsv); RETURN; } #define newFIELDSVOP(flags, fieldix) S_newFIELDSVOP(aTHX_ flags, fieldix) static OP *S_newFIELDSVOP(pTHX_ U32 flags, FIELDOFFSET fieldix) { OP *o = newOP_CUSTOM(&pp_fieldsv, flags); o->op_targ = fieldix; return o; } #define gen_field_init_op(fieldmeta) S_gen_field_init_op(aTHX_ fieldmeta) static OP *S_gen_field_init_op(pTHX_ FieldMeta *fieldmeta) { ClassMeta *classmeta = fieldmeta->class; U8 opf_special_if_role = (classmeta->type == METATYPE_ROLE) ? OPf_SPECIAL : 0; char sigil = SvPV_nolen(fieldmeta->name)[0]; OP *op = NULL; switch(sigil) { case '$': { OP *valueop = NULL; if(fieldmeta->defaultexpr) { valueop = fieldmeta->defaultexpr; } if(fieldmeta->paramname) { SV *paramname = fieldmeta->paramname; if(!valueop) valueop = newop_croak_from_constructor( newSVpvf("Required parameter '%" SVf "' is missing for %" SVf " constructor", SVfARG(paramname), SVfARG(classmeta->name))); OP *helemop = newBINOP(OP_HELEM, 0, newPADxVOP(OP_PADHV, OPf_REF, PADIX_PARAMS), newSVOP(OP_CONST, 0, SvREFCNT_inc(paramname))); if(fieldmeta->def_if_undef) /* delete $params{$paramname} // valueop */ valueop = newLOGOP(OP_DOR, 0, newUNOP(OP_DELETE, 0, helemop), valueop); else if(fieldmeta->def_if_false) /* delete $params{$paramname} || valueop */ valueop = newLOGOP(OP_OR, 0, newUNOP(OP_DELETE, 0, helemop), valueop); else /* Equivalent of * exists $params{$paramname} ? delete $params{$paramname} : valueop; */ valueop = newHELEMEXISTSOROP(OPpHELEMEXISTSOR_DELETE << 8, helemop, valueop); } if(valueop) { op = newBINOP(OP_SASSIGN, 0, valueop, /* $fields[$idx] */ newFIELDSVOP(OPf_MOD | opf_special_if_role, fieldmeta->fieldix)); /* Can't just * MOP_FIELD_RUN_HOOKS(fieldmeta, gen_valueassert_op, ...) * because of collecting up the return values */ 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->gen_valueassert_op) continue; OP *assertop = (*h->funcs->gen_valueassert_op)(aTHX_ fieldmeta, h->attrdata, h->funcdata, newFIELDSVOP(opf_special_if_role, fieldmeta->fieldix)); if(!assertop) continue; op = op_append_elem(OP_LINESEQ, op, assertop); } } break; } case '@': case '%': { OP *valueop = NULL; U16 coerceop = (sigil == '%') ? OP_RV2HV : OP_RV2AV; if(fieldmeta->defaultexpr) { valueop = fieldmeta->defaultexpr; } if(valueop) { /* $fields[$idx]->@* or ->%* */ OP *lhs = force_list_keeping_pushmark(newUNOP(coerceop, OPf_MOD|OPf_REF, newFIELDSVOP(opf_special_if_role, 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); } return op; } void ObjectPad_mop_field_seal(pTHX_ FieldMeta *fieldmeta) { MOP_FIELD_RUN_HOOKS_NOARGS(fieldmeta, seal); need_PLparser(); ClassMeta *classmeta = fieldmeta->class; OP *lines = classmeta->initfields_lines; /* TODO: grab a COP at the initexpr time */ lines = op_append_elem(OP_LINESEQ, lines, newSTATEOP(0, NULL, NULL)); lines = op_append_elem(OP_LINESEQ, lines, gen_field_init_op(fieldmeta)); classmeta->initfields_lines = lines; } /******************* * Attribute hooks * *******************/ /* :weak */ static void fieldhook_weak_post_construct(pTHX_ FieldMeta *fieldmeta, SV *_attrdata, void *_funcdata, SV *field) { sv_rvweaken(field); } #ifndef HAVE_OP_WEAKEN static XOP xop_weaken; static OP *pp_weaken(pTHX) { dSP; sv_rvweaken(POPs); return NORMAL; } #endif static void fieldhook_weak_gen_accessor(pTHX_ FieldMeta *fieldmeta, SV *attrdata, void *_funcdata, enum AccessorType type, struct AccessorGenerationCtx *ctx) { if(type != ACCESSOR_WRITER) return; ctx->post_bodyops = op_append_list(OP_LINESEQ, ctx->post_bodyops, #ifdef HAVE_OP_WEAKEN newUNOP(OP_WEAKEN, 0, #else newUNOP_CUSTOM(&pp_weaken, 0, #endif 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 **attrdata_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); *attrdata_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; U8 opf_special_if_role = (classmeta->type == METATYPE_ROLE ? OPf_SPECIAL : 0); char sigil = SvPVX(fieldmeta->name)[0]; SV *mname_fq = newSVpvf("%" SVf "::%" SVf, classmeta->name, mname); if(PL_curstash != classmeta->stash) { /* RT141599 */ SAVESPTR(PL_curstash); PL_curstash = classmeta->stash; } need_PLparser(); I32 floor_ix = start_subparse(FALSE, 0); SAVEFREESV(PL_compcv); I32 save_ix = block_start(TRUE); extend_pad_vars(classmeta); PADOFFSET padix = pad_add_name_sv(fieldmeta->name, 0, NULL, NULL); intro_my(); OP *ops = op_append_list(OP_LINESEQ, NULL, newSTATEOP(0, NULL, NULL)); OP *methstartop; ops = op_append_list(OP_LINESEQ, ops, methstartop = newMETHSTARTOP(0 | opf_special_if_role | (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)); FIELDOFFSET fieldix = fieldmeta->fieldix; U8 private = 0; switch(sigil) { case '$': private = OPpFIELDPAD_SV; break; case '@': private = OPpFIELDPAD_AV; break; case '%': private = OPpFIELDPAD_HV; break; } #ifdef METHSTART_CONTAINS_FIELD_BINDINGS { UNOP_AUX_item *aux; Newx(aux, 2 + 1*2, UNOP_AUX_item); cUNOP_AUXx(methstartop)->op_aux = aux; (aux++)->uv = 1; /* fieldcount */ (aux++)->uv = fieldix; /* max_fieldix */ (aux++)->uv = padix; (aux++)->uv = ((UV)private << FIELDIX_TYPE_SHIFT) | fieldix; } #else { ops = op_append_list(OP_LINESEQ, ops, newFIELDPADOP(private << 8 | opf_special_if_role, padix, fieldix)); } #endif /* Generate the basic ops here so the ordering doesn't matter if other * attributes want to modify these */ struct AccessorGenerationCtx ctx = { .padix = padix, }; switch(type) { case ACCESSOR_READER: { OPCODE optype = 0; switch(sigil) { 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, padix)); break; } case ACCESSOR_WRITER: { switch(sigil) { case '$': ctx.bodyop = newBINOP(OP_SASSIGN, 0, newOP(OP_SHIFT, 0), newPADxVOP(OP_PADSV, 0, 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, 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, padix))); break; } ctx.retop = newLISTOP(OP_RETURN, 0, newOP(OP_PUSHMARK, 0), newPADxVOP(OP_PADSV, 0, PADIX_SELF)); break; } case ACCESSOR_LVALUE_MUTATOR: { assert(sigil == '$'); CvLVALUE_on(PL_compcv); ctx.retop = newLISTOP(OP_RETURN, 0, newOP(OP_PUSHMARK, 0), newPADxVOP(OP_PADSV, 0, padix)); break; } case ACCESSOR_COMBINED: { assert(sigil == '$'); /* $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, padix))); ctx.retop = newLISTOP(OP_RETURN, 0, newOP(OP_PUSHMARK, 0), newPADxVOP(OP_PADSV, 0, padix)); break; } } 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); ops = op_append_list(OP_LINESEQ, ops, ctx.retop); SvREFCNT_inc(PL_compcv); ops = block_end(save_ix, ops); CV *cv = newATTRSUB(floor_ix, NULL, NULL, NULL, ops); CvMETHOD_on(cv); mop_class_add_method_cv(classmeta, mname, cv); LEAVE; } static bool fieldhook_reader_apply(pTHX_ FieldMeta *fieldmeta, SV *value, SV **attrdata_ptr, void *_funcdata) { *attrdata_ptr = make_accessor_mnamesv(aTHX_ fieldmeta, value, "%s"); return TRUE; } static void fieldhook_reader_seal(pTHX_ FieldMeta *fieldmeta, SV *attrdata, void *_funcdata) { S_generate_field_accessor_method(aTHX_ fieldmeta, attrdata, ACCESSOR_READER); } static struct FieldHookFuncs fieldhooks_reader = { .ver = OBJECTPAD_ABIVERSION, .apply = &fieldhook_reader_apply, .seal = &fieldhook_reader_seal, }; /* :writer */ static bool fieldhook_writer_apply(pTHX_ FieldMeta *fieldmeta, SV *value, SV **attrdata_ptr, void *_funcdata) { *attrdata_ptr = make_accessor_mnamesv(aTHX_ fieldmeta, value, "set_%s"); return TRUE; } static void fieldhook_writer_seal(pTHX_ FieldMeta *fieldmeta, SV *attrdata, void *_funcdata) { S_generate_field_accessor_method(aTHX_ fieldmeta, attrdata, ACCESSOR_WRITER); } static struct FieldHookFuncs fieldhooks_writer = { .ver = OBJECTPAD_ABIVERSION, .apply = &fieldhook_writer_apply, .seal = &fieldhook_writer_seal, }; /* :mutator */ static bool fieldhook_mutator_apply(pTHX_ FieldMeta *fieldmeta, SV *value, SV **attrdata_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"); *attrdata_ptr = make_accessor_mnamesv(aTHX_ fieldmeta, value, "%s"); return TRUE; } static void fieldhook_mutator_seal(pTHX_ FieldMeta *fieldmeta, SV *attrdata, void *_funcdata) { S_generate_field_accessor_method(aTHX_ fieldmeta, attrdata, ACCESSOR_LVALUE_MUTATOR); } static struct FieldHookFuncs fieldhooks_mutator = { .ver = OBJECTPAD_ABIVERSION, .apply = &fieldhook_mutator_apply, .seal = &fieldhook_mutator_seal, }; /* :accessor */ static void fieldhook_accessor_seal(pTHX_ FieldMeta *fieldmeta, SV *attrdata, void *_funcdata) { S_generate_field_accessor_method(aTHX_ fieldmeta, attrdata, ACCESSOR_COMBINED); } static struct FieldHookFuncs fieldhooks_accessor = { .ver = OBJECTPAD_ABIVERSION, .apply = &fieldhook_mutator_apply, /* generate method name the same as :mutator */ .seal = &fieldhook_accessor_seal, }; /* :inheritable */ static bool fieldhook_inheritble_apply(pTHX_ FieldMeta *fieldmeta, SV *value, SV **attrdata_ptr, void *_funcdata) { HV *hints = GvHV(PL_hintgv); if(!hv_fetchs(hints, "Object::Pad/experimental(inherit_field)", 0)) Perl_ck_warner(aTHX_ packWARN(WARN_EXPERIMENTAL), "inheriting fields is experimental and may be changed or removed without notice"); fieldmeta->is_inheritable = true; return false; } static struct FieldHookFuncs fieldhooks_inheritable = { .ver = OBJECTPAD_ABIVERSION, .flags = OBJECTPAD_FLAG_ATTR_NO_VALUE, .apply = &fieldhook_inheritble_apply, }; struct FieldHookFuncs_v76 { U32 ver; U32 flags; const char *permit_hintkey; bool (*apply)(pTHX_ FieldMeta *fieldmeta, SV *value, SV **attrdata_ptr, void *funcdata); void (*seal)(pTHX_ FieldMeta *fieldmeta, SV *attrdata, void *funcdata); void (*gen_accessor_ops)(pTHX_ FieldMeta *fieldmeta, SV *attrdata, void *funcdata, enum AccessorType type, struct AccessorGenerationCtx *ctx); void (*post_makefield)(pTHX_ FieldMeta *fieldmeta, SV *attrdata, void *funcdata, SV *field); void (*post_construct)(pTHX_ FieldMeta *fieldmeta, SV *attrdata, void *funcdata, SV *field); }; 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"); if(funcs->ver < OBJECTPAD_ABIVERSION) { const struct FieldHookFuncs_v76 *funcs_v76 = (const struct FieldHookFuncs_v76 *)funcs; struct FieldHookFuncs *funcs_v810; Newx(funcs_v810, 1, struct FieldHookFuncs); *funcs_v810 = (struct FieldHookFuncs){ .ver = OBJECTPAD_ABIVERSION, .flags = funcs_v76->flags, .permit_hintkey = funcs_v76->permit_hintkey, .apply = funcs_v76->apply, .seal = funcs_v76->seal, .gen_accessor_ops = funcs_v76->gen_accessor_ops, .post_makefield = funcs_v76->post_makefield, .post_construct = funcs_v76->post_construct, }; funcs = funcs_v810; } register_field_attribute(name, funcs, funcdata); } void ObjectPad__boot_fields(pTHX) { #ifndef HAVE_OP_WEAKEN 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); #endif 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); // TODO: temporary name register_field_attribute("inheritable", &fieldhooks_inheritable, NULL); } Object-Pad-0.810/src/suspended_compcv.c000444001750001750 361314655674547 16636 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.810/t000755001750001750 014655674547 12445 5ustar00leoleo000000000000Object-Pad-0.810/t/00use.t000444001750001750 23514655674547 13703 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; require Object::Pad; require Object::Pad::ExtensionBuilder; pass "Modules loaded"; done_testing; Object-Pad-0.810/t/01method.t000444001750001750 324714655674547 14416 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0 0.000148; # is_refcount use Object::Pad 0.800; class Point { BUILD { @$self = @_; } method where { sprintf "(%d,%d)", @$self } method classname { return __CLASS__ } } { 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' ); is( $p->classname, "Point", '__CLASS__ inside 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( [ @$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 { field $_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.810/t/02fields.t000444001750001750 657514655674547 14414 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0 0.000148; # is_refcount use Object::Pad 0.800; use constant HAVE_DATA_DUMP => defined eval { require Data::Dump; }; class Counter { field $count = 0; method inc { $count++ } method count { return $count; } } { my $counter = Counter->new; is( $counter->count, 0, 'Count initially 0' ); $counter->inc; $counter->inc; $counter->inc; is( $counter->count, 3, 'Count is now 3 after ->inc x 3' ); } { use Data::Dumper; class AllTheTypes { field $scalar = 123; field @array = ( 45, 67 ); field %hash = ( 89 => 10 ); method test { ::is( $scalar, 123, '$scalar field' ); ::is( \@array, [ 45, 67 ], '@array field' ); ::is( \%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' ); } { use Object::Pad ':experimental(init_expr)'; my $class_in_fieldblock; class AllTheTypesByBlock { field $scalar { "one" } field @array { "two", "three" } field %hash { four => "five" } field $__dummy { $class_in_fieldblock = __CLASS__ } method test { ::is( $scalar, "one", '$scalar field' ); ::is( \@array, [qw( two three )], '@array field' ); ::is( \%hash, { four => "five" }, '%hash field' ); } } AllTheTypesByBlock->new->test; is( $class_in_fieldblock, "AllTheTypesByBlock" ); } # Variant of RT132228 about individual field lexicals class Holder { field $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' ); } # Fields are visible to string-eval() { class Evil { field $field; method test { $field = "the value"; ::is( eval '$field', "the value", 'fields are visible to string eval()' ); } } Evil->new->test; } ok( !eval <<'EOPERL', class SelfInField { field $x = $self + 1; } EOPERL 'field init expression cannot see $self' ); # TODO: Annoyingly, real parse error message has disappeared entirely from $@ # and all we get is "parse failed--compilation aborted at ..." so there's no # point like()-testing $@ here # RT154639 - fields should not be visible to :common methods my $e = eval <<'EOPERL' ? undef : $@; class FieldInCommonMethod { field $x; method m :common { $x } } EOPERL like( $e, qr/^Global symbol "\$x" requires explicit package name /, 'fields are not visible to :common methods' ); done_testing; Object-Pad-0.810/t/03create.t000444001750001750 733214655674547 14402 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Scalar::Util qw( reftype ); use Object::Pad 0.800; class Point { field $x = 0; field $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( \@buildargs, [qw( WithBuildargs 1 2 3 )], '@_ to BUILDARGS' ); is( \@build, [qw( 4 5 6 )], '@_ to BUILD' ); } { my @called; my $class_in_ADJUST; class WithAdjust { BUILD { push @called, "BUILD"; } ADJUST { push @called, "ADJUST"; $class_in_ADJUST = __CLASS__; } } WithAdjust->new; is( \@called, [qw( BUILD ADJUST )], 'ADJUST invoked after BUILD' ); is( $class_in_ADJUST, "WithAdjust", '__CLASS__ during ADJUST block' ) } { my $paramvalue; class StrictParams :strict(params) { ADJUSTPARAMS { my ($href) = @_; $paramvalue = delete $href->{param}; } } StrictParams->new( param => "thevalue" ); is( $paramvalue, "thevalue", 'ADJUSTPARAMS captured the value' ); ok( !defined eval { StrictParams->new( unknown => "name" ) }, ':strict(params) complains about unrecognised param' ); like( $@, qr/^Unrecognised parameters for StrictParams 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 ADJUST 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) { field $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' ); } # Create a base class with keys representation { class NativelyHashWithKeys :repr(keys) { field $s = "value"; field @a = ( 12, 34 ); field %h; method fields { $s, \@a, \%h } } my $o = NativelyHashWithKeys->new; is( reftype $o, "HASH", 'NativelyHashWithKeys is natively a HASH reference' ); is( [ $o->fields ], [ "value", [ 12, 34 ], {} ], ':repr(keys) objects still support fields' ); is( $o->{'NativelyHashWithKeys/$s'}, "value", ':repr(keys) object fields directly accessible' ); is( $o, { 'NativelyHashWithKeys/$s' => "value", 'NativelyHashWithKeys/@a' => [ 12, 34 ], 'NativelyHashWithKeys/%h' => {}, }, ':repr(keys) object entirely' ); } # Subclasses without BUILD shouldn't double-invoke superclass { my $BUILD_invoked; class One { BUILD { $BUILD_invoked++ } } class Two { inherit One; } Two->new; is( $BUILD_invoked, 1, 'One::BUILD invoked only once for Two->new' ); } done_testing; Object-Pad-0.810/t/04adjust.t000444001750001750 1077514655674547 14457 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800 ':experimental(adjust_params)'; { my %captured; class WithAdjustParams { ADJUST :params ( :$req, :$opt = "default opt" ) { $captured{req} = $req; $captured{opt} = $opt; } } undef %captured; WithAdjustParams->new( req => "the req", opt => "the opt" ); is( \%captured, { req => "the req", opt => "the opt" }, 'ADJUST :params saw req and opt' ); undef %captured; WithAdjustParams->new( req => "the req" ); is( \%captured, { req => "the req", opt => "default opt" }, 'ADJUST :params saw req and default opt' ); my $LINE = __LINE__+1; ok( !defined eval { WithAdjustParams->new(); 1 }, 'Missing required parameter throws exception' ); like( $@, qr/^Required parameter 'req' is missing for WithAdjustParams constructor at \S+ line $LINE\./, 'Exception thrown from constructor with missing parameter' ); } { my %captured; class WithAdjustParamsDefaults { ADJUST :params ( :$x = "default X", :$y //= "default Y", :$z ||= "default Z" ) { $captured{x} = $x; $captured{y} = $y; $captured{z} = $z; } } undef %captured; WithAdjustParamsDefaults->new( x => "the X", y => "the Y", z => "the Z" ); is( \%captured, { x => "the X", y => "the Y", z => "the Z" }, 'ADJUST :params saw passed values' ); undef %captured; WithAdjustParamsDefaults->new(); is( \%captured, { x => "default X", y => "default Y", z => "default Z" }, 'ADJUST :params saw defaults when absent' ); undef %captured; WithAdjustParamsDefaults->new( x => undef, y => undef, z => undef ); is( \%captured, { x => undef, y => "default Y", z => "default Z" }, 'ADJUST :params saw x undef but y z defaults when undef' ); undef %captured; WithAdjustParamsDefaults->new( x => "", y => "", z => "" ); is( \%captured, { x => "", y => "", z => "default Z" }, 'ADJUST :params saw x y "" but z defaults when ""' ); } { class StrictlyWithParams :strict(params) { # Check that a trailing comma is permitted ADJUST :params ( :$param = undef, ) { } } ok( defined eval { StrictlyWithParams->new( param => 123 ) }, ':strict(params) is OK' ) or diag( "Exception was: $@" ); ok( !defined eval { StrictlyWithParams->new( more => 2 ) }, ':strict(params) complains about others' ); } { my %captured; class WithRestParams { ADJUST :params ( :$one = 1, :$two = 2, %params ) { %captured = %params; } } undef %captured; WithRestParams->new( one => 111, three => 3 ); is( \%captured, { three => 3 }, 'ADJUST :params rest views remaining params' ); } { my %captured; class StrictlyWithRestParams :strict(params) { ADJUST :params ( %params ) { %captured = %params; %params = (); } } StrictlyWithRestParams->new( unknown => "OK" ); is( \%captured, { unknown => "OK" }, 'ADJUST :params rest can consume params' ); } { class ExpressionOrder { field $val; ADJUST :params ( :$first = undef, :$second = uc $first, ) { $val = $second; } method val { return $val; } } is( ExpressionOrder->new( first => "value" )->val, "VALUE", 'Named param expressions are evaluated in order' ); } # out-of-block control flow emits warnings { my $warnings; BEGIN { $SIG{__WARN__} = sub { $warnings .= $_[0] }; } my $WARNLINE; class ReturnFromAdjust { $WARNLINE = __LINE__+1; ADJUST { return; } } BEGIN { undef $SIG{__WARN__} } like( $warnings, qr/^Using return to leave an ADJUST block is discouraged and will be removed in a later version at \S+ line $WARNLINE\./, 'return from ADJUST emits warning' ); } use Object::Pad ':experimental(composed_adjust)'; # class with composed ADJUST blocks { class ComposedAdjust { field $adjusted; field $a = "a"; ADJUST { $adjusted .= $a; } ADJUST { $adjusted .= "b"; } field $c = "c"; ADJUST { $adjusted .= $c; } method result { $adjusted } } is( ComposedAdjust->new->result, "abc", 'Composed ADJUST blocks still work' ); } # ADJUST :params can also be composed { class ComposedAdjustParams { field $adjusted; ADJUST { $adjusted .= "a"; } ADJUST :params ( :$x ) { $adjusted .= $x; } ADJUST { $adjusted .= "c"; } method result { $adjusted } } is( ComposedAdjustParams->new( x => "X" )->result, "aXc", 'Composed ADJUST blocks permit :params' ); } done_testing; Object-Pad-0.810/t/04extend-classical.t000444001750001750 56714655674547 16346 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800; class BaseClass { field $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.810/t/05subclass.t000444001750001750 317714655674547 14763 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800; class Animal 1.23 { field $legs; method legs { $legs }; BUILD { ( $legs ) = @_; } } is( $Animal::VERSION, 1.23, 'Versioned class has $VERSION' ); class Spider 4.56 { inherit 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 { inherit 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 { field $_afield; class SubClass { inherit 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 ADJUST still works via trivial subclasses { my $param; class WithAdjustParams { ADJUSTPARAMS { my ( $href ) = @_; $param = delete $href->{param}; } } # Test whitespace trimming on attribute class TrivialSubclass :isa( WithAdjustParams ) {} TrivialSubclass->new( param => "value" ); is( $param, "value", 'ADJUST still invoked on superclass' ); } done_testing; Object-Pad-0.810/t/06subclass-foreign-HASH.t000444001750001750 1047714655674547 17155 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800; package Base::Class { sub new { my $class = shift; my ( $ok ) = @_; ::is( $ok, "ok", '@_ to Base::Class::new' ); ::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 { inherit Base::Class; field $derived_field = 456; BUILD { my @args = @_; ::is( \@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( \@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 { inherit 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( \@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 { inherit RT132263::Parent; method example_method { 1 } } my $e; ok( !defined( $e = dies { RT132263::Child1->new } ), 'RT132263 case 1 constructs OK' ) or diag( "Exception was $e" ); } # Test case two - read from an initialised field { class RT132263::Child2 { inherit RT132263::Parent; field $value = 456; method example_method { $value } } my $obj; my $e; ok( !defined( $e = dies { $obj = RT132263::Child2->new } ), 'RT132263 case 2 constructs OK' ) or diag( "Exception was $e" ); # 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( dies { 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 { inherit 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' ); } # Ensure next::method works with subclassing (RT#150794) { package RT150794::Base { sub new { return bless {}, shift } sub configure {} } class RT150794::Derived { inherit RT150794::Base; method configure { $self->next::method } } is( scalar( grep { $_ eq "Object::Pad::UNIVERSAL" } @RT150794::Derived::ISA ), 1, 'RT150794::Derived @ISA contains Object::Pad::UNIVERSAL only once' ); RT150794::Derived->new->configure; } done_testing; Object-Pad-0.810/t/07subclass-foreign-ARRAY.t000444001750001750 216314655674547 17262 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800; package Base::Class { sub new { my $class = shift; my ( $ok ) = @_; ::is( $ok, "ok", '@_ to Base::Class::new' ); ::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 { inherit Base::Class; field $derived_field = 456; BUILD { my @args = @_; ::is( \@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.810/t/08subclass-Moo.t000444001750001750 163214655674547 15510 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; BEGIN { plan skip_all => "Moo is not available" unless eval { require Moo }; } use Object::Pad 0.800; my $moocount; package Base::Class { use Moo; sub BUILD { my ( $self, $args ) = @_; ::is( $args, { arg => "value" }, '@_ to Base::Class::BUILD' ); $moocount++; } } my $opcount; class Derived::Class { inherit Base::Class; field $field; BUILD { my ( $args ) = @_; ::is( $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.810/t/10method-attrs.t000444001750001750 214214655674547 15542 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800; use attributes (); class Counter { field $count = 0; method count :lvalue { $count } method inc { $count++ }; } # Counter::count has both :lvalue :method attrs { is( [ 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 { inherit Counter; method inc :override { $self->SUPER::inc; $self->SUPER::inc; } } { my $counter2 = TwiceCounter->new; is( $counter2->count, 0, 'count is initially 0' ); $counter2->inc; is( $counter2->count, 2, 'count is 2 after double-inc' ); } class CountFromTen { inherit Counter; method from_ten :common { my $self = $class->new; $self->count = 10; return $self; } } { my $counter10 = CountFromTen->from_ten; is( $counter10->count, 10, 'count is initially 10' ); } done_testing; Object-Pad-0.810/t/11method-signatures.t000444001750001750 256514655674547 16603 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; BEGIN { $] >= 5.026000 or plan skip_all => "No parse_subsignature()"; } use Object::Pad 0.800; class List { field @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( [ $l->nshift( 2 ) ], [qw( a b )], '$l->nshift yields values' ); } class Greeter { field $_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' ); } { my @keys; class WithAdjustParams { ADJUSTPARAMS ( $params ) { @keys = sort keys %$params; %$params = () } } WithAdjustParams->new( x => 1, y => 2, z => 3 ); is( \@keys, [qw( x y z )], 'Keys captured from $params' ); } { my $warnings; my $LINE; BEGIN { $SIG{__WARN__} = sub { $warnings .= $_[0] }; } class WithAdjustSignature { $LINE = __LINE__+1; ADJUST ( $params ) { } } BEGIN { undef $SIG{__WARN__}; } like( $warnings, qr/^Use of ADJUST \(signature\) \{BLOCK\} is now deprecated at \S+ line $LINE\./, 'ADJUST (signature) { BLOCK } raises a warning' ); } done_testing; Object-Pad-0.810/t/12method-private.t000444001750001750 114314655674547 16061 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800; class AClass { field $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 { field $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.810/t/20fields-private.t000444001750001750 133114655674547 16045 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800 ':experimental(inherit_field)'; class Class1 { field $data :inheritable; method data { $data } ADJUST { $data = "base data" } } class Class2 { inherit Class1; field $data; method data { $data } ADJUST { $data = "derived data"; } } { my $c = Class2->new; is( $c->data, "derived data", 'subclass wins methods' ); is( $c->Class1::data, "base data", 'base class still accessible' ); } class Class3 { inherit Class1 qw( $data ); method data3 { return $data } } { my $c = Class3->new; is( $c->data3, "base data", 'subclass can inherit base field' ); } done_testing; Object-Pad-0.810/t/21fields-capture.t000444001750001750 127014655674547 16041 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800; class Counter { field $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 { field $_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.810/t/22fields-accesssors.t000444001750001750 552714655674547 16560 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800; 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 { field $red :reader :writer; field $green :reader(get_green) :writer; field $blue :mutator; field $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 { field @av :reader; field %hv :reader; ADJUST { @av = qw( one two three ); %hv = (one => 1, two => 2); } } my $allthetypes = AllTheTypesReader->new; is( [ $allthetypes->av ], [qw( one two three )], ':reader on array field' ); is( { $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( [ $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 { field @av :writer; field %hv :writer; method test { ::is( \@av, [qw( four five six )], ':writer on array field' ); ::is( \%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.810/t/23fields-signatures.t000444001750001750 66414655674547 16552 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; BEGIN { $] >= 5.026000 or plan skip_all => "No parse_subsignature()"; } use Object::Pad 0.800; # See also # https://rt.cpan.org/Ticket/Display.html?id=134456 class C { field $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.810/t/24fields-constructor.t000444001750001750 436014655674547 16771 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800; class Point { field $x :param; field $y :param = 0; method pos { return ( $x, $y ); } } { my $point = Point->new( x => 10 ); is( [ $point->pos ], [ 10, 0 ], 'Point with default y' ); } { my $point = Point->new( x => 30, y => 40 ); is( [ $point->pos ], [ 30, 40 ], 'Point fully specified' ); } class Point3D { inherit Point; field $z :param = 0; method pos { return ( $self->next::method, $z ) } } { my $point = Point3D->new( x => 50, y => 60, z => 70 ); is( [ $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) { field $red :param = 0; field $green :param = 0; field $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' ); } # Param assignment modes { class AllTheOps { field $exists :param = "default"; field $defined :param //= "default"; field $true :param ||= "default"; method values { return ( $exists, $defined, $true ); } } is( [ AllTheOps->new(exists => "value", defined => "value", true => "value")->values ], [ "value", "value", "value" ], 'AllTheOps for true values' ); is( [ AllTheOps->new(exists => 0, defined => 0, true => 0)->values ], [ 0, 0, "default" ], 'AllTheOps for false values' ); is( [ AllTheOps->new(exists => undef, defined => undef, true => undef)->values ], [ undef, "default", "default" ], 'AllTheOps for undef values' ); is( [ AllTheOps->new()->values ], [ "default", "default", "default" ], 'AllTheOps for missing values' ); } done_testing; Object-Pad-0.810/t/25fields-weak.t000444001750001750 214014655674547 15326 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0 0.000148; # is_refcount use Object::Pad 0.800; my $arr = []; class WithWeak { field $one = 1; field $field :writer :param :weak; field $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 { inherit WithWeak; field $three = 3; } my $obj = subWithWeak->new( field => $arr ); is_oneref( $arr, '$arr has one reference after subWithWeak construction' ); } { class WithInnerHelper { field $field :writer :param :weak; class InnerHelperClass { inherit 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.810/t/26fields-initexpr.t000444001750001750 330414655674547 16245 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800 ':experimental(init_expr)'; # initexprs can capture regular class-level lexicals { class SerialNumbered { my $next_seq = 1; field $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 { field $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 { field $x { push @inited, "x" } field $y { push @inited, "y" } field $z { push @inited, "z" } } WithThreeFields->new; is( \@inited, [qw( x y z )], 'initexprs run in declared order' ); } # :param overrides initexpr { my %init_called; class WithParams { field $one :param :reader { $init_called{one} = 1 } field $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' ); } # field initexprs can see earlier fields { class FieldsSeeFields { field $one :param; field $two = 2; field $three :reader = $one + $two; } is( FieldsSeeFields->new( one => 1 )->three, 3, 'field initialised from fields' ); } done_testing; Object-Pad-0.810/t/30unit-class.t000444001750001750 45714655674547 15202 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800; class Counter; field $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.810/t/31pad-outside.t000444001750001750 157514655674547 15361 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800; { class Counter { field $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.810/t/32threads.t000444001750001750 224414655674547 14570 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Test2::IPC; use Object::Pad 0.800; eval { require Config && $Config::Config{useithreads} } or plan skip_all => "This perl does not support threads"; require threads; class Cnative :repr(native) { field $x :param; method x { return $x } } class CHASH :repr(HASH) { field $x :param; method x { return $x } } package CmagicBase { sub new { return bless {}, shift } } class Cmagic :isa(CmagicBase) :repr(magic) { field $x :param; method x { return $x } } { my $ret = threads->create(sub { pass( "Created dummy thread" ); return 1; })->join; is( $ret, 1, "Returned from dummy thread" ); } foreach my $repr (qw( native HASH magic )) { my $class = "C$repr"; subtest "Class using :repr($repr)" => sub { { my $obj = $class->new( x => 10 ); threads->create(sub { is( $obj->x, 10, '$obj->x inside thread created before' ); })->join; } threads->create(sub { my $obj = $class->new( x => 20 ); is( $obj->x, 20, '$obj->x created inside thread' ); })->join; } } done_testing; Object-Pad-0.810/t/33class-anon.t000444001750001750 46714655674547 15162 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800; # anon class { my $class = class { method message { "hello, world" } }; my $obj = $class->new; ok( ref $obj, 'obj exists' ); is( $obj->message, "hello, world", 'obj has message method' ); } done_testing; Object-Pad-0.810/t/40role.t000444001750001750 471414655674547 14102 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use utf8; use Test2::V0; use Object::Pad 0.800; role ARole { method one { return 1 } method own_cvname { return +(caller(0))[3]; } } class AClass { apply 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' ); } is( (class { apply ARole })->new->one, 1, 'anonymous classes can apply roles' ); # Older :does attribute notation class AClassAttr :does(ARole) { } { my $obj = AClassAttr->new; isa_ok( $obj, [ "AClassAttr" ], '$obj' ); is( $obj->one, 1, 'AClassAttr has a ->one method' ); is( $obj->own_cvname, "AClassAttr::own_cvname", '->own_cvname sees correct subname' ); } role BRole { method two { return 2 } } class BClass { apply ARole; apply 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 { apply 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 { apply RecurseRole } is( RecurseClass->new->recurse( 5 ), 5, 'role methods can be reëntrant' ); } role DRole { apply BRole; method four { return 4 } } class DClass { apply DRole; } { my $obj = DClass->new; is( $obj->four, 4, 'DClass has DRole method' ); is( $obj->two, 2, 'DClass inherited BRole method' ); } role ERole { apply ARole; apply BRole; } class EClass { apply ERole; } { my $obj = EClass->new; is( $obj->one, 1, 'EClass has a ->one method' ); is( $obj->two, 2, 'EClass has a ->two method' ); } role FRole { method onetwothree :common { 123 } } class FClass { apply FRole; } { is( FClass->onetwothree, 123, 'FClass has a :common ->onetwothree method' ); } # Perl #19676 # https://github.com/Perl/perl5/issues/19676 role GRole { method a { pack "C", 65 } } class GClass { apply GRole; } { is( GClass->new->a, "A", 'GClass ->a method has constant' ); } done_testing; Object-Pad-0.810/t/41role-repr.t000444001750001750 110314655674547 15036 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800; role ARole { method one { return 1 } } package Base::HASH { sub new { bless {}, shift } } class Derived::HASH { inherit Base::HASH; apply 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 { inherit Base::ARRAY; apply ARole; } { my $obj = Derived::ARRAY->new; is( $obj->one, 1, 'Derived::ARRAY has a ->one method' ); } done_testing; Object-Pad-0.810/t/42role-BUILD.t000444001750001750 173714655674547 14743 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800; my @BUILD; my @ADJUST; role ARole { BUILD { push @BUILD, "ARole" } ADJUST { push @ADJUST, "ARole" } } class AClass { apply ARole; BUILD { push @BUILD, "AClass" } ADJUST { push @ADJUST, "AClass" } } { undef @BUILD; undef @ADJUST; AClass->new; is( \@BUILD, [qw( ARole AClass )], 'Roles are built before their implementing classes' ); is( \@ADJUST, [qw( ARole AClass )], 'Roles are adjusted before their implementing classes' ); } class BClass { inherit AClass; apply ARole; BUILD { push @BUILD, "BClass" } } { undef @BUILD; BClass->new; is( \@BUILD, [qw( ARole AClass BClass )], 'Roles are built once only even if implemented multiple times' ); } # RT154494 { use Object::Pad ':experimental(composed_adjust)'; role RT154494Role { } pass( 'Managed to compile a role under :experimental(composed_adjust)' ); } done_testing; Object-Pad-0.810/t/43role-fields.t000444001750001750 401314655674547 15341 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0 0.000148; # is_refcount use Object::Pad 0.800; role ARole { field $one = 1; method one { $one } } class AClass { apply ARole; field $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 AClassLate { field $two = 2; method two { $two } apply ARole; } { my $obj = AClassLate->new; isa_ok( $obj, [ "AClassLate" ], '$obj' ); is( $obj->one, 1, 'AClassLate has a ->one method' ); is( $obj->two, 2, 'AClassLate has a ->two method' ); } class BClass { inherit AClass; field $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 { apply ARole; field $three = 3; method three { $three } } class CClass { apply 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 { field $field = 1; ADJUST { $field++ } method field { $field } } role D1Role { apply DRole; } role D2Role { apply DRole; } role DxRole { apply D1Role; apply D2Role; } class DClass { apply D1Role; apply D2Role; } my $obj1 = DClass->new; is( $obj1->field, 2, 'DClass->field is 2 via diamond' ); class DxClass { apply DxRole; } my $obj2 = DxClass->new; is( $obj2->field, 2, 'DxClass->field is 2 via diamond' ); } # RT139665 { my $arr = []; role WithWeakRole { field $field :param :weak; } class implWithWeak { apply WithWeakRole; } my $obj = implWithWeak->new( field => $arr ); is_oneref( $arr, '$arr has one reference after implWithWeak constructor' ); } done_testing; Object-Pad-0.810/t/44role-accessors.t000444001750001750 71014655674547 16041 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800; role ARole { field $one :reader = 1; } class AClass { apply ARole; } # RT136507 { my $obj = AClass->new; is( $obj->one, 1, '$obj->one is visible' ); } role BRole { field $data :reader :param; } class BClass { apply BRole; } { my $obj = BClass->new( data => 123 ); is( $obj->data, 123, 'BClass constructor takes role params' ); } done_testing; Object-Pad-0.810/t/45role-does.t000444001750001750 374614655674547 15043 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800; role ARole { } class AClass { apply 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 { apply ARole; apply BRole; } { my $obj = BClass->new; ok( $obj->DOES( "ARole" ), 'BClass::DOES ARole' ); ok( $obj->DOES( "BRole" ), 'BClass::DOES BRole' ); } role CRole { } class CClass { apply 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 { apply ARole; } class ADerived { inherit 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 { inherit FBaseOne; apply 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 { inherit FBaseTwo; apply ARole; } { ok( FClassTwo->DOES( "ARole" ), 'Our role on a class with foreign base' ); ok( FClassTwo->DOES( "FakeRole42" ), 'Foreign base class DOES method' ); } role DRole { apply ARole; } class DClass { apply DRole; } { ok( DClass->DOES( "DRole" ), 'Sanity?' ); ok( DClass->DOES( "ARole" ), 'Class does role inherited by role' ); } done_testing; Object-Pad-0.810/t/49role-compat.t000444001750001750 126514655674547 15372 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800; 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' ); } # RT152793 { role RT152793 :compat(invokable) { method f { return 42; } } undef &RT152793::f; pass( 'Did not crash when deleting method of invokable role (RT152793)' ); } done_testing; Object-Pad-0.810/t/50croak-method.t000444001750001750 110214655674547 15503 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800; class Point { field $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.810/t/51pragmata.t000444001750001750 355214655674547 14736 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad; # no version { 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 (?:\(Do you need to predeclare "foo"\?\) )?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.810/t/52croak-scope.t000444001750001750 162514655674547 15350 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800; { ok( !eval <<'EOPERL', field $field; EOPERL 'field outside class fails' ); like( $@, qr/^Cannot 'field' outside of 'class' at /, 'message from failure of field' ); } # RT132337 { ok( !eval <<'EOPERL', class AClass { } field $field; EOPERL 'field after closed class block fails' ); like( $@, qr/^Cannot 'field' 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' ); } { ok( !eval <<'EOPERL', class BClass { my $c = __CLASS__; } EOPERL '__CLASS__ outside method fails' ); like( $@, qr/^Cannot use __CLASS__ outside of a /, 'message from failure of __CLASS__' ); } done_testing; Object-Pad-0.810/t/53croak-override.t000444001750001750 56414655674547 16040 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800; { 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.810/t/54croak-role.t000444001750001750 253614655674547 15204 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800; { role ARole { method m {} } my $warnings; $SIG{__WARN__} = sub { $warnings .= join "", @_ }; like( dies { ARole->new }, qr/^Cannot directly construct an instance of role 'ARole' /, 'failure from directly create a role instance' ); ok( !eval <<'EOPERL', class AClass { apply 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 { method bmeth; } ok( !eval <<'EOPERL', class BClass { apply 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) { field $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.810/t/55croak-params.t000444001750001750 202614655674547 15521 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800 ':experimental(adjust_params)'; { ok( !eval <<'EOPERL', class AClass { field $x :param(foo); field $y :param(foo); } EOPERL 'Clashing :param names fails' ); like( $@, qr/^Already have a named constructor parameter called 'foo' at /, 'message from clashing :param names' ); } { ok( !eval <<'EOPERL', class BClass { field $x :param(foo); ADJUST :params ( :$foo ) { } } EOPERL 'Clashing :param/ADJUST names fails' ); like( $@, qr/^Already have a named constructor parameter called 'foo' at /, 'message from clashing :param/ADJUST names' ); } { ok( !eval <<'EOPERL', class CClass { ADJUST :params ( :$foo ) { } field $x :param(foo); } EOPERL 'Clashing ADJUST/:param names fails' ); like( $@, qr/^Already have a named constructor parameter called 'foo' at /, 'message from clashing ADJUST/:param names' ); } done_testing; Object-Pad-0.810/t/60mop-class.t000444001750001750 167614655674547 15045 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800 ':experimental(mop)'; 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( [ $meta->superclasses ], [], '$meta->superclasses' ); is( [ $meta->direct_roles ], [], '$meta->direct_roles' ); is( [ $meta->all_roles ], [], '$meta->all_roles' ); class Example2 { inherit Example; } is( [ Object::Pad::MOP::Class->for_class( "Example2" )->superclasses ], [ $meta ], '$meta->superclasses on subclass' ); is( Object::Pad::MOP::Class->try_for_class( "main" ), undef, '->try_for_class does not throw' ); package NotObjectPad { use base qw( Example ); } is( Object::Pad::MOP::Class->try_for_class( "NotObjectPad" ), undef, '->try_for_class not confused by non-OP subclasses' ); done_testing; Object-Pad-0.810/t/61mop-create-class.t000444001750001750 165614655674547 16305 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800 ':experimental(mop)'; { 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 { field $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' ); } field $other = "child"; method other { return $other } } is( Child->new->other, "child", '->begin_class can extend superclasses' ); } done_testing; Object-Pad-0.810/t/62mop-field.t000444001750001750 650014655674547 15014 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800 ':experimental(mop inherit_field)'; class Example { field $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( [ $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 { field $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 { apply ARole; field $data = 21; } my $obja = AClass->new; is( $fieldmeta->value( $obja ), 42, '$fieldmeta->value as accessor on role instance fetches correct field' ); class BClass { inherit AClass; field $data = 63; } my $objb = BClass->new; is( $fieldmeta->value( $objb ), 42, '$fieldmeta->value as accessor on role instance subclass fetches correct field' ); } # Inherited fields aren't directly visible { class CClass { field $x :inheritable; } class DClass { inherit CClass qw( $x ); } my $classmeta = Object::Pad::MOP::Class->for_class( 'DClass' ); like( dies { $classmeta->get_field( '$x' ) }, qr/^Class DClass does not have a field called '\$x' at /, 'Attempt to get fieldmeta for inherited field fails' ); is( [ $classmeta->fields ], [], '->fields returns an empty list' ); } # RT136869 { class A { field @arr; ADJUST { @arr = (1,2,3) } method m { @arr } } role R { field $data :param; } class B { inherit A; apply R; } is( [ B->new( data => 456 )->m ], [ 1, 2, 3 ], 'Role params are embedded correctly' ); } # Forbid writing to non-scalar fields via ->value { class List { field @values :reader; } my $list = List->new; my $arrayfieldmeta = Object::Pad::MOP::Class->for_class( "List" ) ->get_field( '@values' ); like( dies { no warnings; $arrayfieldmeta->value( $list ) = [] }, qr/^Modification of a read-only value attempted at /, 'Attempt to set value of list field fails' ); my $e; ok( !defined( $e = dies { @{ $arrayfieldmeta->value( $list ) } = (1,2,3) } ), '->value accessor still works fine' ) or diag( "Exception was $e" ); is( [ $list->values ], [ 1,2,3 ], '$list->values after modification via fieldmeta' ); } done_testing; Object-Pad-0.810/t/63mop-create-field.t000444001750001750 446114655674547 16262 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800 ':experimental(mop)'; class AClass { use Test2::V0 qw( :DEFAULT !field ); # don't import the field() check as its name will clash 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( dies { $classmeta->add_field( undef ) }, qr/^fieldname must not be undefined or empty /, 'Failure from ->add_field undef' ); like( dies { $classmeta->add_field( "" ) }, qr/^fieldname must not be undefined or empty /, 'Failure from ->add_field on empty string' ); like( dies { $classmeta->add_field( "foo" ) }, qr/^fieldname must begin with a sigil /, 'Failure from ->add_field without sigil' ); like( dies { $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( !dies { $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.810/t/64mop-method.t000444001750001750 305114655674547 15211 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800 ':experimental(mop)'; 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' ); ok( !$methodmeta->is_common, '$methodmeta->is_common' ); is( $classmeta->get_method( 'm' )->name, "m", '$classmeta->get_method' ); is( [ $classmeta->direct_methods ], [ $methodmeta ], '$classmeta->direct_methods' ); is( [ $classmeta->all_methods ], [ $methodmeta ], '$classmeta->all_methods' ); class SubClass { inherit Example; } ok( defined Object::Pad::MOP::Class->for_class( "SubClass" )->get_method( 'm' ), 'Subclass can ->get_method' ); # subclass with overridden method { class WithOverride { inherit Example; method m { "different" } } my @methodmetas = Object::Pad::MOP::Class->for_class( "WithOverride" )->all_methods; is( scalar @methodmetas, 1, 'overridden method is not duplicated' ); } # :common methods { class BClass { method cm :common { } } my $classmeta = Object::Pad::MOP::Class->for_class( "BClass" ); my $methodmeta = $classmeta->get_direct_method( 'cm' ); is( $methodmeta->name, "cm", '$methodmeta->name for :common' ); is( $methodmeta->class->name, "BClass", '$methodmeta->class gives class for :common' ); ok( $methodmeta->is_common, '$methodmeta->is_common for :common' ); } done_testing; Object-Pad-0.810/t/65mop-create-method.t000444001750001750 314614655674547 16460 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800 ':experimental(mop)'; class AClass { use Test2::V0; 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( dies { $classmeta->add_method( undef, sub {} ) }, qr/^methodname must not be undefined or empty /, 'Failure from ->add_method undef' ); like( dies { $classmeta->add_method( "", sub {} ) }, qr/^methodname must not be undefined or empty /, 'Failure from ->add_method on empty string' ); like( dies { $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' ); } $classmeta->add_method( 'cmethod', common => 1, sub { return "Classy result"; } ); } } { my $obj = AClass->new; is( $obj->method, "result", '->method works' ); my $can = $obj->can('method'); is( ref($can), 'CODE', '->can("method") returns coderef' ); is( $obj->$can, 'result', '... which works' ); } # common method { is( AClass->cmethod, "Classy result", '->cmethod works' ); } done_testing; Object-Pad-0.810/t/66mop-role.t000444001750001750 230114655674547 14671 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800 ':experimental(mop)'; role Example { no warnings 'deprecated'; 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( [ $meta->required_method_names ], [qw( a_method b_method )], '$meta->required_method_names' ); class Implementor { apply Example; method a_method {} method b_method {} } is( [ Object::Pad::MOP::Class->for_class( "Implementor" )->direct_roles ], [ $meta ], '$meta->direct_roles on implementing class' ); is( [ Object::Pad::MOP::Class->for_class( "Implementor" )->all_roles ], [ $meta ], '$meta->all_roles on implementing class' ); class Inheritor { inherit Implementor; } # Roles via subclass { is( [ Object::Pad::MOP::Class->for_class( "Inheritor" )->direct_roles ], [], '$meta->direct_roles on inheriting class' ); is( [ Object::Pad::MOP::Class->for_class( "Inheritor" )->all_roles ], [ $meta ], '$meta->all_roles on inheriting class' ); } done_testing; Object-Pad-0.810/t/67mop-create-role.t000444001750001750 163214655674547 16141 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800 ':experimental(mop)'; { 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 { apply 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 { apply 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.810/t/68mop-compose-role.t000444001750001750 154214655674547 16344 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800 ':experimental(mop)'; 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( [ 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( [ map { $_->name } $bmeta->direct_roles ], [qw( TheRole )], 'BClass meta ->direct_roles' ); can_ok( BClass->new, qw( m ) ); } done_testing; Object-Pad-0.810/t/69mop-generated.t000444001750001750 160514655674547 15677 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad::MOP::Class ':experimental(mop)'; # An attempt to programmatically generate everything { my $classmeta = Object::Pad::MOP::Class->create_class( "Point" ); my $xfieldmeta = $classmeta->add_field( '$x', reader => 'x' ); my $yfieldmeta = $classmeta->add_field( '$y', reader => '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' ); is( $point->x, 10, '$point->x' ); } done_testing; Object-Pad-0.810/t/70mop-custom-fieldattr.t000444001750001750 267714655674547 17231 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800 ':experimental( mop custom_field_attr )'; my $n; Object::Pad::MOP::FieldAttr->register( SomeAttr => permit_hintkey => "t/SomeAttr", must_value => 1, apply => sub { my ( $fieldmeta, $value ) = @_; ::is( $value, "the value", '$value passed to apply callback' ); return "result-" . ++$n; }, ); ok( defined eval <<'EOPERL', BEGIN { $^H{"t/SomeAttr"}++ } class MyClass { field $x; field $y :SomeAttr(the value) :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" ), "result-1", 'stored value for :SomeAttr' ); is( [ $fieldmeta->get_attribute_values( "SomeAttr" ) ], [ "result-1", "result-2" ], 'can get multiple values' ); } like( defined eval <<'EOPERL' ? undef : $@, BEGIN { $^H{"t/SomeAttr"}++ } class Test2 { field $x :SomeAttr; } EOPERL qr/^Attribute :SomeAttr requires a value at /, 'field attribute that requires a value complains when missing one' ); done_testing; Object-Pad-0.810/t/75metafunctions.t000444001750001750 517114655674547 16026 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800 ':experimental(mop inherit_field)'; use Object::Pad::MetaFunctions qw( metaclass deconstruct_object ref_field get_field ); class Point { field $x :param = 0; field $y :param = 0; } is( metaclass( Point->new ), Object::Pad::MOP::Class->for_class( "Point" ), 'metaclass() returns Point metaclass' ); class AllFieldTypes { field $s = "scalar"; field @a = ( "array", "values" ); field %h = ( key => "value" ); } is( [ deconstruct_object( AllFieldTypes->new ) ], [ 'AllFieldTypes', 'AllFieldTypes.$s' => "scalar", 'AllFieldTypes.@a' => [ "array", "values" ], 'AllFieldTypes.%h' => { key => "value" } ], 'deconstruct_object on AllFieldTypes' ); class AClass { field $a = "a"; } role BRole { field $b = "b"; } class CClass { inherit AClass; apply BRole; field $c = "c"; } is( [ deconstruct_object( CClass->new ) ], [ 'CClass', 'CClass.$c' => "c", 'BRole.$b' => "b", 'AClass.$a' => "a", ], 'deconstruct_object on CClass' ); # Inherited fields don't deconstruct { class DClass { field $x :inheritable; } class EClass { inherit DClass qw( $x ); ADJUST { $x = 123; } } is( [ deconstruct_object( EClass->new ) ], [ 'EClass', 'DClass.$x' => 123, ], 'deconstruct_object does not dump inherited fields' ); } # ref_field { my $obj = AllFieldTypes->new; is( ref_field( 'AllFieldTypes.$s', $obj ), \"scalar", 'ref_field on scalar field' ); is( ref_field( 'AllFieldTypes.@a', $obj ), [ "array", "values" ], 'ref_field on array field' ); is( ref_field( 'AllFieldTypes.%h', $obj ), { key => "value" }, 'ref_field on hash field' ); is( ref_field( '$s', $obj ), \"scalar", 'ref_field short name' ); is( ref_field( 'BRole.$b', CClass->new ), \"b", 'ref_field can search roles' ); } # get_field { my $obj = AllFieldTypes->new; is( get_field( '$s', $obj ), "scalar", 'get_field on scalar field' ); is( [ get_field( '@a', $obj ) ], [ "array", "values" ], 'get_field on array field' ); is( scalar get_field( '@a', $obj ), 2, 'scalar get_field on array field' ); # Before perl 5.26 hashes in scalar context would yield a string like # 'KEYCOUNT/BUCKETCOUNT'. We can't be sure what the bucket count will be # here my $scalar_hash_re = ( $] < 5.026 ) ? qr(^1/\d+$) : qr(^1$); is( { get_field( '%h', $obj ) }, { key => "value" }, 'get_field on hash field' ); like( scalar get_field( '%h', $obj ), $scalar_hash_re, 'scalar get_field on hash field' ); } done_testing; Object-Pad-0.810/t/77repr-pvobj.t000444001750001750 366514655674547 15245 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; BEGIN { $^V ge v5.38 or plan skip_all => "Not supported on Perl $^V"; } use Object::Pad 0.800; class Test1 :repr(pvobj) { field $x :reader = 10; field $y :reader = 20; method where { sprintf "(%d,%d)", $x, $y } } { my $obj = Test1->new; is( $obj->where, "(10,20)", 'Basic instances can be created on :repr(pvobj)' ); } class Test2 { inherit Test1; field $z :reader = 30; method where { sprintf "(%d,%d,%d)", $self->x, $self->y, $z } } { my $obj = Test2->new; is( $obj->where, "(10,20,30)", 'Subclasses work' ); } role Test3R { field $w :reader = 40; } class Test3 :isa(Test2) :does(Test3R) {} { my $obj = Test3->new; is( $obj->w, 40, 'Roles can have fields' ); } { use Object::Pad ':experimental(mop)'; my $obj = Test3->new; my $class1meta = Object::Pad::MOP::Class->for_class( "Test1" ); is( $class1meta->get_field( '$x' )->value( $obj ), 10, 'Fieldmeta for base class field usable as accessor' ); my $class2meta = Object::Pad::MOP::Class->for_class( "Test2" ); is( $class2meta->get_field( '$z' )->value( $obj ), 30, 'Fieldmeta for derived class field usable as accessor' ); my $role3meta = Object::Pad::MOP::Class->for_class( "Test3R" ); is( $role3meta->get_field( '$w' )->value( $obj ), 40, 'Fieldmeta for role field usable as accessor' ); } use Object::Pad::MetaFunctions qw( deconstruct_object get_field ); { my $obj = Test3->new; is( [ deconstruct_object $obj ], [ 'Test3', 'Test3R.$w' => 40, 'Test2.$z' => 30, 'Test1.$x' => 10, 'Test1.$y' => 20, ], 'deconstruct_object on Test3' ); is( get_field( 'Test1.$x', $obj ), 10, 'get_field on base class field' ); is( get_field( 'Test2.$z', $obj ), 30, 'get_field on derived class field' ); is( get_field( 'Test3R.$w', $obj ), 40, 'get_field on role field' ); } done_testing; Object-Pad-0.810/t/80async-method.t000444001750001750 461414655674547 15537 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0 0.000148; # is_refcount BEGIN { plan skip_all => "Future >= 0.49 is not available" unless eval { require Future; Future->VERSION( '0.49' ) }; 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.800 is not available" unless eval { require Object::Pad; Object::Pad->VERSION( '0.800' ) }; # If Future::XS is installed, then check it's at least 0.08; earlier # versions will crash if( eval { require Future::XS } ) { plan skip_all => "Future::XS is installed but it is older than 0.08" unless eval { Future::AsyncAwait->VERSION( '0.08' ); }; } Future::AsyncAwait->import; Object::Pad->import; diag( "Future::AsyncAwait $Future::AsyncAwait::VERSION, " . "Object::Pad $Object::Pad::VERSION" ); } # async method { class Thunker { field $_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 { apply 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.810/t/80dynamically+Object-Pad.t000444001750001750 162214655674547 17352 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; BEGIN { plan skip_all => "Syntax::Keyword::Dynamically is not available" unless eval { require Syntax::Keyword::Dynamically }; plan skip_all => "Object::Pad >= 0.800 is not available" unless eval { require Object::Pad; Object::Pad->VERSION( '0.800' ) }; Syntax::Keyword::Dynamically->import; Object::Pad->import; diag( "Syntax::Keyword::Dynamically $Syntax::Keyword::Dynamically::VERSION, " . "Object::Pad $Object::Pad::VERSION" ); } class Datum { field $value = 1; method value { $value } method test { ::is( $self->value, 1, 'value is 1 initially' ); { dynamically $value = 2; ::is( $self->value, 2, 'value is 2 inside dynamically-assigned block' ); } ::is( $self->value, 1, 'value is 1 finally' ); } } Datum->new->test; done_testing; Object-Pad-0.810/t/80extended+Object-Pad.t000444001750001750 117414655674547 16646 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; BEGIN { $] >= 5.026000 or plan skip_all => "No parse_subsignature()"; eval { require Object::Pad; Object::Pad->VERSION( '0.800' ); 1; } or plan skip_all => "No Object::Pad"; eval { require Sublike::Extended; 1; } or plan skip_all => "No Sublike::Extended"; Object::Pad->import; Sublike::Extended->import; } # extended method { class C1 { extended method f (:$x, :$y) { return "x=$x y=$y" } } is( C1->new->f( x => "first", y => "second" ), "x=first y=second", 'async method' ); } done_testing; Object-Pad-0.810/t/81async-method+dynamically.t000444001750001750 336414655674547 20043 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; 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.800 is not available" unless eval { require Object::Pad; Object::Pad->VERSION( '0.800' ) }; 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 { field $_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.810/t/82devel-mat-dumper-helper.t000444001750001750 376214655674547 17576 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; BEGIN { eval { require Devel::MAT; Devel::MAT->VERSION( '0.49' ) } or plan skip_all => "No Devel::MAT version 0.49"; require Devel::MAT::Dumper; } use Object::Pad 0.800; class AClass { field $afield :param :reader; } my $obj = AClass->new( afield => 123 ); ( my $file = __FILE__ ) =~ s/\.t$/.pmat/; Devel::MAT::Dumper::dump( $file ); END { unlink $file if -f $file } my $pmat = Devel::MAT->load( $file ); my $df = $pmat->dumpfile; # class/field/method representation { my $classmeta = $pmat->find_symbol( "&AClass::META" )->constval->rv ->outref_named( "the Object::Pad class" ) ->sv; ok( $classmeta, 'AClass has a classmeta' ); isa_ok( $classmeta, [ "Devel::MAT::SV::C_STRUCT" ], '$classmeta' ); is( $classmeta->desc, "C_STRUCT(Object::Pad/ClassMeta.class)", '$classmeta->desc' ); is( $classmeta->field_named( "the name SV" )->pv, 'AClass', '$classmeta name SV' ); # Field my @fieldmetas = $classmeta->field_named( "the fields AV" )->elems; is( scalar @fieldmetas, 1, '$classmeta has 1 fieldmeta' ); my $fieldmeta = $fieldmetas[0]; isa_ok( $fieldmeta, [ "Devel::MAT::SV::C_STRUCT" ], '$fieldmeta' ); is( $fieldmeta->desc, "C_STRUCT(Object::Pad/FieldMeta)", '$fieldmeta->desc' ); is( $fieldmeta->field_named( "the name SV" )->pv, '$afield', '$fieldmeta name SV' ); is( $fieldmeta->field_named( "the class" ), $classmeta, '$fieldmeta class' ); # Method my @methodmetas = $classmeta->field_named( "the direct methods AV" )->elems; is( scalar @methodmetas, 1, '$classmeta has 1 methodmeta' ); my $methodmeta = $methodmetas[0]; isa_ok( $methodmeta, [ "Devel::MAT::SV::C_STRUCT" ], '$methodmeta' ); is( $methodmeta->desc, "C_STRUCT(Object::Pad/MethodMeta)", '$methodmeta->desc' ); is( $methodmeta->field_named( "the name SV" )->pv, 'afield', '$methodmeta name SV' ); is( $methodmeta->field_named( "the class" ), $classmeta, '$methodmeta class' ); } done_testing; Object-Pad-0.810/t/90leak.t000444001750001750 214014655674547 14051 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; BEGIN { plan skip_all => "Test::MemoryGrowth is not available" unless defined eval { require Test::MemoryGrowth }; Test::MemoryGrowth->import; } use Object::Pad 0.800; # RT132332 { class Example { # Needs at least one field member to trigger failures field $thing; # ... and we need to refer to it in a method as well ADJUST { $thing } } no_growth { Example->new }; } { class WithContainerFields { field @array; field %hash; ADJUST { @array = (); %hash = (); } } no_growth { WithContainerFields->new }; } { use Object::Pad ':experimental(adjust_params)'; class WithAdjustParams { field $_x; ADJUST :params ( :$x ) { $_x = $x; } } no_growth { WithAdjustParams->new( x => "the X value" ) } 'named constructor param does not leak'; } { class WithHashKeys :repr(keys) { field $f = "value"; method x { $f = $f; } } no_growth { WithHashKeys->new->x } ':repr(keys) does not leak'; } done_testing; Object-Pad-0.810/t/91rt141483.t000444001750001750 37614655674547 14241 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800; use lib "t/lib"; BEGIN { require "91rt141483Role.pm" } class C { apply R; } is( C->new->name, "Gantenbein", 'Value preserved from role-scoped lexical' ); done_testing; Object-Pad-0.810/t/92legacy.t000444001750001750 355314655674547 14414 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800; class AClass { method classm { "AClass" } } my $warnings = ""; BEGIN { $SIG{__WARN__} = sub { $warnings .= $_[0] }; } role DRole { requires mmethod; } BEGIN { like( $warnings, qr/^'requires' is now discouraged; use an empty 'method NAME;' declaration instead at /m, 'requires keyword provokes discouraged warning' ); undef $warnings; } { my @called; my $paramsref; class EClass { ADJUST { push @called, "ADJUST"; } ADJUSTPARAMS { my ( $href ) = @_; push @called, "ADJUSTPARAMS"; $paramsref = $href; } ADJUST { push @called, "ADJUST"; } } EClass->new( key => "val" ); is( \@called, [qw( ADJUST ADJUSTPARAMS ADJUST )], 'ADJUST and ADJUSTPARAMS invoked together' ); is( $paramsref, { key => "val" }, 'ADJUSTPARAMS received HASHref' ); } my $ADJUST_LINE; class FClass { ADJUST { BEGIN { $ADJUST_LINE = __LINE__+1 } my @d0 = @_; my $d1 = shift; my $d2 = shift @_; my $d3 = $_[0]; } } BEGIN { my $line0 = $ADJUST_LINE; like( $warnings, qr/^Use of \@_ is deprecated in ADJUST at \S+ line $line0\./m, '@_ in ADJUST prints deprecation warning' ); my $line1 = $ADJUST_LINE+1; like( $warnings, qr/^Implicit use of \@_ in shift is deprecated in ADJUST at \S+ line $line1\./m, 'shift in ADJUST prints deprecation warning' ); my $line2 = $ADJUST_LINE+2; like( $warnings, qr/^Use of \@_ is deprecated in ADJUST at \S+ line $line2\./m, 'shift @_ in ADJUST prints deprecation warning' ); my $line3 = $ADJUST_LINE+3; like( $warnings, qr/^Use of \@_ is deprecated in ADJUST at \S+ line $line3\./m, '$_[0] in ADJUST prints deprecation warning' ); undef $warnings; } BEGIN { undef $SIG{__WARN__}; } done_testing; Object-Pad-0.810/t/93legacy-has.t000444001750001750 361214655674547 15162 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800; my @warnings; BEGIN { $SIG{__WARN__} = sub { push @warnings, $_[0] }; } class Counter { has $count = 0; method inc { $count++ } method describe { "Count is now $count" } } like( $warnings[0], qr/^'has' is deprecated; use 'field' instead at /, 'legacy has keyword emits deprecation warning' ); # can't (yet) do # no warnings 'deprecated'; # because 'class' will turn them all back on again { 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' ); } { class AllTheTypes { has $scalar = 123; has @array = ( 45, 67 ); has %hash = ( 89 => 10 ); method test { ::is( $scalar, 123, '$scalar field' ); ::is( \@array, [ 45, 67 ], '@array field' ); ::is( \%hash, { 89 => 10 }, '%hash field' ); } } my $instance = AllTheTypes->new; $instance->test; } # Sequencing order of `has` 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( \@order, [qw( start class new construct )], 'seq() calls happened in the correct order' ); } Sequencing->new->test; done_testing; Object-Pad-0.810/t/93legacy-pragmata.t000444001750001750 110114655674547 16172 0ustar00leoleo000000000000#!/usr/bin/perl # specifically *don't* # use v5.14; # use warnings; use Test2::V0 -no_strict => 1, -no_warnings => 1; use Object::Pad 0.800; my @warnings; BEGIN { $SIG{__WARN__} = sub { push @warnings, $_[0] }; } class X {} like( $warnings[0], qr/^class keyword enabled 'use strict' but this will be removed in a later version at /, 'class keyword emits warning about use strict' ); like( $warnings[1], qr/^class keyword enabled 'use warnings' but this will be removed in a later version at /, 'class keyword emits warning about use warnings' ); done_testing; Object-Pad-0.810/t/94experimental.t000444001750001750 154714655674547 15650 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Object::Pad 0.800; my $warnings = ""; BEGIN { $SIG{__WARN__} = sub { $warnings .= $_[0] }; } my $LINE; class C1 { BEGIN { $LINE = __LINE__+1 } field $x { "init-block" } } BEGIN { like( $warnings, qr/^field initialiser block is experimental .* at \S+ line $LINE\./, 'field {BLOCK} raises warning' ); $warnings = ""; } class C2 { BEGIN { $LINE = __LINE__+1 } field $x :inheritable; } BEGIN { like( $warnings, qr/^inheriting fields is experimental .* at \S+ line $LINE\./, 'field :inheritable raises warning' ); $warnings = ""; } class C3 { BEGIN { $LINE = __LINE__+1 } inherit C2 '$x'; } BEGIN { like( $warnings, qr/^inheriting fields is experimental .* at \S+ line $LINE\./, 'inherit Class ARGS raises warning' ); $warnings = ""; } done_testing; Object-Pad-0.810/t/95utf8.t000444001750001750 254414655674547 14040 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use utf8; BEGIN { binmode STDOUT, ":encoding(UTF-8)" } use Test2::V0; use Object::Pad 0.800 ':experimental(mop)'; # 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++ } field $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.810/t/99pod.t000444001750001750 25514655674547 13715 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); Object-Pad-0.810/t/lib000755001750001750 014655674547 13213 5ustar00leoleo000000000000Object-Pad-0.810/t/lib/91rt141483Role.pm000444001750001750 17614655674547 16000 0ustar00leoleo000000000000use v5.14; use warnings; use Object::Pad 0.800; role R { my $name = "Gantenbein"; method name { $name }; } 0x55AA;