Object-Pad-0.820000755001750001750 014757670420 12170 5ustar00leoleo000000000000Object-Pad-0.820/.editorconfig000444001750001750 5314757670420 14740 0ustar00leoleo000000000000root = true [*.{pm,pl,t}] indent_size = 3 Object-Pad-0.820/Build.PL000444001750001750 416114757670420 13623 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.47', 'XS::Parse::Sublike' => '0.35', }, test_requires => { 'Test2::V0' => '0.000148', }, configure_requires => { 'Module::Build' => '0.4004', # test_requires 'XS::Parse::Keyword::Builder' => '0.48', 'XS::Parse::Sublike::Builder' => '0.35', }, 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.820/Changes000444001750001750 10752314757670420 13670 0ustar00leoleo000000000000Revision history for Object-Pad 0.820 2025-02-26 [BUGFIXES] * Account for perl 5.41.9's GV-less stash optimisation (RT159823) 0.819 2025-01-10 [CHANGES] * Initial experimental attempt to support lexical `my class` syntax * Neater, smaller `hax/` files by squashing out code guarded on versions of Perl before 5.18 0.818 2024-12-23 [BUGFIXES] * Ensure that `method :common` works with the new `OP_ARGELEM` code in the signature handling code (RT158048) 0.817 2024-12-20 [CHANGES] * Initial attempt at supporting an `:abstract` attribute on classes. Similar to roles but much simpler and easier to implement * Much internal reärrangement of the way OP_METHSTART is set up, to hopefully allow more seamless integration with upcoming core perl `faster-signatures` branch work 0.816 2024-11-25 [CHANGES] * Rewrote module introduction documentation, emphasising the relating to core perl 'class' feature and `Feature::Compat::Class` * Added a documentation file, giving a guide to migrating from classical Perl to `Object::Pad` [BUGFIXES] * Fix for t/82devel-mat-dumper-helper.t should require `Devel::MAT` v0.53 or later, in case DMD writes a file in format version 0.6 (RT157189) 0.815 2024-11-13 [CHANGES] * Initial experiment at adding `APPLY` phaser blocks to roles 0.814 2024-09-20 [CHANGES] * Depend on `XS::Parse::Sublike` v0.25 because of RT155630 bugfix * Document and test the operation of `my method` [BUGFIXES] * Don't segfault when `->get_direct_method` fails to find the requested method 0.813 2024-09-03 [CHANGES] * Removed the `has` keyword; it now immediately throws a compiletime error [BUGFIXES] * Ensure that the RHS of a field init expression permits any kind of listexpr, including `( VAL ) x COUNT` * Fix some docs typoes (thanks Nick Morrott) (RT155106) 0.812 2024-08-29 [BUGFIXES] * Fix for perl 5.41.3, when `SAVEt_LONG` was removed 0.811 2024-08-21 [CHANGES] * Accept requesting additional attributes to the `$classmeta->add_field` MOP method * XS API changes: + `get_obj_fieldsv()` does not need to take a ClassMeta argument + Added `mop_field_get_class()` + Added `get_field_for_padix()` 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.820/LICENSE000444001750001750 4653414757670420 13366 0ustar00leoleo000000000000This software is copyright (c) 2025 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) 2025 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) 2025 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.820/MANIFEST000444001750001750 436714757670420 13470 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/newMYCONSTSUB.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/Guide/MigratingFromClassicalPerl.pod 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/13my-method.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/34class-abstract.t t/35my-class.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/71role-APPLY.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-pragmata.t t/94experimental.t t/95utf8.t t/99pod.t t/lib/91rt141483Role.pm typemap Object-Pad-0.820/META.json000444001750001750 412514757670420 13750 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.48", "XS::Parse::Sublike::Builder" : "0.35" } }, "runtime" : { "requires" : { "File::ShareDir" : "1.00", "XS::Parse::Keyword" : "0.47", "XS::Parse::Sublike" : "0.35", "perl" : "5.018" } }, "test" : { "requires" : { "Test2::V0" : "0.000148" } } }, "provides" : { "Object::Pad" : { "file" : "lib/Object/Pad.pm", "version" : "0.820" }, "Object::Pad::ExtensionBuilder" : { "file" : "lib/Object/Pad/ExtensionBuilder.pm", "version" : "0.820" }, "Object::Pad::MOP::Class" : { "file" : "lib/Object/Pad/MOP/Class.pm", "version" : "0.820" }, "Object::Pad::MOP::Field" : { "file" : "lib/Object/Pad/MOP/Field.pm", "version" : "0.820" }, "Object::Pad::MOP::FieldAttr" : { "file" : "lib/Object/Pad/MOP/FieldAttr.pm", "version" : "0.820" }, "Object::Pad::MOP::Method" : { "file" : "lib/Object/Pad/MOP/Method.pm", "version" : "0.820" }, "Object::Pad::MetaFunctions" : { "file" : "lib/Object/Pad/MetaFunctions.pm", "version" : "0.820" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.820", "x_serialization_backend" : "JSON::PP version 4.16" } Object-Pad-0.820/META.yml000444001750001750 254714757670420 13606 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.48' XS::Parse::Sublike::Builder: '0.35' 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.820' Object::Pad::ExtensionBuilder: file: lib/Object/Pad/ExtensionBuilder.pm version: '0.820' Object::Pad::MOP::Class: file: lib/Object/Pad/MOP/Class.pm version: '0.820' Object::Pad::MOP::Field: file: lib/Object/Pad/MOP/Field.pm version: '0.820' Object::Pad::MOP::FieldAttr: file: lib/Object/Pad/MOP/FieldAttr.pm version: '0.820' Object::Pad::MOP::Method: file: lib/Object/Pad/MOP/Method.pm version: '0.820' Object::Pad::MetaFunctions: file: lib/Object/Pad/MetaFunctions.pm version: '0.820' requires: File::ShareDir: '1.00' XS::Parse::Keyword: '0.47' XS::Parse::Sublike: '0.35' perl: '5.018' resources: license: http://dev.perl.org/licenses/ version: '0.820' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Object-Pad-0.820/README000444001750001750 16306714757670420 13262 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. Relation to use feature 'class' Since its original creation, this module has evolved to become the test-bed for refining the design of what a good class-based object system would look like for Perl. While useful in its own right, it also acts as a preview of what Perl's use feature 'class' syntax will likely become. Being a CPAN module, this can be iterated much faster than core Perl, which only gets one major release per year. Getting the design right in this module first therefore helps to reduce the amount of development time needed in core Perl. Where features overlap, both this module and the class feature added to recent Perl versions should largely agree on syntax and semantics. This module will likely always be ahead of core Perl in terms of exact abilties because it is acting as a test-bed for these new ideas. However, where both implementations support the same idea, they should in general use the same syntax and semantics to provide it. If you are interested in using this object system in new code in a way that will be forward-compatible with the feature added directly in newer Perl versions, while also supporting versions of Perl before this feature was added, you may wish to use instead the module Feature::Compat::Class. That module enables the core Perl feature on the latest version of Perl, or uses Object::Pad to fill in the missing syntax and features on older Perl versions. Experimental Features Since version 0.63. While most of this module has evolved into a stable state, recently-added parts remain experimental because the design is still evolving, and many features and ideas have yet to implemented. Of these experimental features, feel free to try them out in newly-developed code, but don't complain if a later version is incompatible with your current code and you'll have to change it. Once individual features are stable and no longer declared experimental, they should have the same stability guarantees as any other long-term supported CPAN module, or core Perl itself. 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 - both within this CPAN module and as the wider experiment to provide it as a core Perl feature. See the "FEEDBACK" section. Features of this module that are currently marked as experimental 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(apply_phaser)'; use Object::Pad ':experimental(lexical_class)'; 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. :abstract :abstract Since version 0.817. Declares that this class is abstract. An abstract class is permitted to define required methods (i.e. named methods without a body definition). Instances may not be created of this class type directly. Instead, a subclass of this class must be derived that provides method bodies for any of the named required methods. Any subclass of an abstract class must either provide bodies for all remaining required methods, or themselves be declared :abstract as well. This provides a way in which a generic type of class can be created, that is intended for multiple different specialisations to further define different kinds of behaviour by providing bodies for those named methods. Being abstract means that instances cannot be created of this as-yet-incomplete class type. :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. my class my class Name :ATTRS... { ... } Since version 0.819; experimental If a class keyword is preceded by my it creates a class that has lexical visiblity, rather than being available globally via a fully-qualified name in the symbol table. This is useful for creating internal helper classes within modules, such as for returning complex structures, or simply to use internally without being visible to the caller. As the class itself is only visible lexically, callers in other scopes are unable to see it to create new instances of it. class My::Module; my class HelperStructure { field $name :param :reader; field $value :param :reader; } method get_thing () { return HelperStructure->new( name => "the name", value => "the value", ); } Note: the above is technically a lie. Current versions of perl do not support truely anonymous packages to be used as classes, so even these "lexical" classes are in fact named on the symbol table. However, they are given a name that is syntactically-impossible for regular code to create or use, and a const-returning lexical function is created with the correct lexical name, which returns the true name of the class, so that the ->new method can still be called on it. As a result of this limitation, there are a number of operations that lexical classes do not currently support - such as subclassing. It is hoped that later versions of either this module, or perl itself, will be able to expand on these abilities. For now, this feature remains an experimental best-effort basis. Due to the way this lexical function works, it can stand in for the class name when used with the ->isa method. Note carefully here, that the lexical class is used directly as a bareword and not quoted. if( $obj->isa( HelperStructure ) ) { ... } Additionally, as the right-hand side operand of the isa operator (in Perl version 5.32 or later) does not need quoting, it can be used there directly: if( $obj isa HelperStructure ) { ... } inherit inherit Classname; inherit Classname VER; inherit Classname LIST...; inherit Classname VER LIST...; Since version 0.807. 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 Since version 0.813 this keyword is no longer recognised. It used to be an earlier version of what is now the "field" keyword. has $var; has @var; has %var; has $var = EXPR; has $var { BLOCK } Because of the one-shot immediate nature of these initialisation expressions (and a bunch of other reasons), the keyword was removed. 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 or abstract class. Such a method must be provided by any class that wishes to be non-abstract. It will be a compiletime error to apply the role to a class, or derive from an abstract 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 or abstract base classes, 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. my method my method NAME { ... } Since version 0.814 lexical method declarations are supported using the my keyword prefix. These become available as lexical functions, rather than being stored in the class package. As a result, they are not available by named method resolution, package ->can lookup, or via the MOP. These are a convenient alternative to the syntax given above, where the method is stored anonymously via a lexical variable. Since lexical methods are not visible to named method resolution, they must be invoked by function-call syntax, remembering to pass in the invocant as the first argument: my method inner { ... } method outer { inner($self, @args); } 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; non-experimental since version 0.805. 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 preceded 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. APPLY Experimental. Since version 0.815. APPLY ( $class_mop ) { # on perl 5.26 onwards ... } APPLY { my $class_mop = shift; ... } Only valid within a role definition. Declares a block of code that will be run at compile-time whenever the role is applied to a class. Each time it is applied to a new class, the code will be invoked. It receives as an argument a Object::Pad::MOP::Class instance representing the class to which the role is currently being applied. The eventual intent is that the presence of any of these phaser blocks will replace the current implicit behaviour of applying a role, though currently they run in addition to it. This is part of an ongoing experiment whose details will change over time. __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.820/typemap000444001750001750 34714757670420 13713 0ustar00leoleo000000000000ClassMeta * CLASSMETA FieldMeta * FIELDMETA MethodMeta * METHODMETA INPUT CLASSMETA $var = MUST_CLASSMETA_FROM_RV($arg); FIELDMETA $var = MUST_FIELDMETA_FROM_RV($arg); METHODMETA $var = MUST_METHODMETA_FROM_RV($arg); Object-Pad-0.820/hax000755001750001750 014757670420 12750 5ustar00leoleo000000000000Object-Pad-0.820/hax/OP_HELEMEXISTSOR.c.inc000444001750001750 357414757670420 16463 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.820/hax/cv_copy_flags.c.inc000444001750001750 772014757670420 16645 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(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 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]); 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(origpad[padix]) newval = SvREFCNT_inc_NN(origpad[padix]); } PL_curpad[padix] = newval; } LEAVE_with_name("cv_copy_flags"); } return new; } Object-Pad-0.820/hax/dumpers.c.inc000444001750001750 3344714757670420 15533 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.820/hax/exec_optree.c.inc000444001750001750 104614757670420 16324 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.820/hax/forbid_outofblock_ops.c.inc000444001750001750 1026614757670420 20423 0ustar00leoleo000000000000/* vi: set ft=c : */ 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(cPVOPo->op_private & OPpPV_IS_UTF8) SvUTF8_on(target); 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(cPVOPo->op_private & OPpPV_IS_UTF8) SvUTF8_on(target); SAVEFREESV(target); if(hv_fetch_ent(permittedloops, target, FALSE, 0)) break; goto forbid; } case OP_LEAVELOOP: { STRLEN label_len; U32 label_flags; const char *label_pv = CopLABEL_len_flags(PL_curcop, &label_len, &label_flags); if(label_pv) { labelsv = newSVpvn_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.820/hax/force_list_keeping_pushmark.c.inc000444001750001750 133114757670420 21564 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.820/hax/lexer-additions.c.inc000444001750001750 1564614757670420 17150 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; /* Don't get confused by things that look like attrs */ if((flags & LEX_IDENT_PACKAGENAME) && (ident[0] == ':' && ident[1] != ':')) return FALSE; 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 == ':') && (PL_parser->bufptr[1] == ':')) { lex_read_unichar(0); if(lex_read_unichar(0) != ':') /* Probably unreachable now due to condition above? */ 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.820/hax/make_argcheck_aux.c.inc000444001750001750 132314757670420 17441 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.820/hax/make_argcheck_ops.c.inc000444001750001750 553714757670420 17460 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.820/hax/newMYCONSTSUB.c.inc000444001750001750 210314757670420 16235 0ustar00leoleo000000000000/* vi: set ft=c : */ #define newMYCONSTSUB(nameop, sv) S_newMYCONSTSUB(aTHX_ nameop, sv) static CV *S_newMYCONSTSUB(pTHX_ OP *nameop, SV *sv) { I32 floor_ix = start_subparse(FALSE, 0); SvREFCNT_inc(PL_compcv); OP *protoop = newSVOP(OP_CONST, 0, newSVpvs("")); OP *body = newSVOP(OP_CONST, 0, SvREFCNT_inc(sv)); CV *cv = newMYSUB(floor_ix, nameop, protoop, NULL, body); CvCONST_on(cv); return cv; } /* TODO: define a _named_pvn() variant that takes char*,STRLEN,U32 */ #define newMYCONSTSUB_named_sv(lexname, sv) S_newMYCONSTSUB_named_sv(aTHX_ lexname, sv) static CV *S_newMYCONSTSUB_named_sv(pTHX_ SV *lexname, SV *sv) { /* Need to allocate pad name in the calling sub, before we start_subparse() */ SV *ampname = newSVpvf("&%" SVf, SVfARG(lexname)); SAVEFREESV(ampname); /* Strictly, nameop should be an OP_PADANY, but since newMYSUB() only cares * about o->op_targ and newPADxVOP() doesn't like OP_PADANY, we'll use an * OP_PADCV instead */ return newMYCONSTSUB( newPADxVOP(OP_PADCV, 0, pad_add_name_sv(ampname, 0, NULL, NULL)), sv); } Object-Pad-0.820/hax/newOP_CUSTOM.c.inc000444001750001750 1047114757670420 16166 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) #if HAVE_PERL_VERSION(5, 22, 0) # define newUNOP_AUX_CUSTOM(func, flags, first, aux) S_newUNOP_AUX_CUSTOM(aTHX_ func, flags, first, aux) #endif #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 newLISTOP_CUSTOM(func, flags, first, last) S_newLISTOP_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; } #if HAVE_PERL_VERSION(5, 22, 0) static OP *S_newUNOP_AUX_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags, OP *first, UNOP_AUX_item *aux) { UNOP_AUX *unop; #if HAVE_PERL_VERSION(5,22,0) unop = (UNOP_AUX *)newUNOP_AUX(OP_CUSTOM, flags, first, aux); #else croak("TODO: create newUNOP_AUX_CUSTOM"); #endif unop->op_ppaddr = func; return (OP *)unop; } #endif 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_newLISTOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags, OP *first, OP *last) { LISTOP *listop; #if HAVE_PERL_VERSION(5,22,0) listop = (LISTOP *)newLISTOP(OP_CUSTOM, flags, first, last); #else NewOp(1101, listop, 1, LISTOP); listop->op_type = (OPCODE)OP_CUSTOM; listop->op_first = first; if(first) first->op_sibling = last; listop->op_last = last; listop->op_flags = (U8)(flags | OPf_KIDS); if(last) listop->op_private = (U8)(2 | (flags >> 8)); else if(first) listop->op_private = (U8)(1 | (flags >> 8)); else listop->op_private = (U8)(flags >> 8); #endif listop->op_ppaddr = func; return (OP *)listop; } 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.820/hax/op_sibling_splice.c.inc000444001750001750 167714757670420 17520 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.820/hax/optree-additions.c.inc000444001750001750 511614757670420 17276 0ustar00leoleo000000000000/* vi: set ft=c : */ #define newAELEMOP(flags, first, key) S_newAELEMOP(aTHX_ flags, first, key) static OP *S_newAELEMOP(pTHX_ U32 flags, OP *first, I32 key) { if(key >= -128 && key < 128 && first->op_type == OP_PADAV) { OP *o = newOP(OP_AELEMFAST_LEX, flags); o->op_private = (I8)key; o->op_targ = first->op_targ; op_free(first); return o; } return newBINOP(OP_AELEM, flags, first, newSVOP(OP_CONST, 0, newSViv(key))); } #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.820/hax/perl-additions.c.inc000444001750001750 1033214757670420 16756 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; } #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; } /* 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) { GV *gv = gv_fetchmeth_pvn(stash, pv, len, level, GV_SUPER); if(!gv) return NULL; return GvCV(gv); } #define get_class_isa(stash) S_get_class_isa(aTHX_ stash) static AV *S_get_class_isa(pTHX_ HV *stash) { GV **gvp = (GV **)hv_fetchs(stash, "ISA", 0); if(!gvp || !GvAV(*gvp)) croak("Expected %s to have a @ISA list", HvNAME(stash)); return GvAV(*gvp); } #define find_cop_for_lvintro(padix, o, copp) S_find_cop_for_lvintro(aTHX_ padix, o, copp) static COP *S_find_cop_for_lvintro(pTHX_ PADOFFSET padix, OP *o, COP **copp) { for( ; o; o = OpSIBLING(o)) { if(OP_CLASS(o) == OA_COP) { *copp = (COP *)o; } else if(o->op_type == OP_PADSV && o->op_targ == padix && o->op_private & OPpLVAL_INTRO) { return *copp; } else if(o->op_flags & OPf_KIDS) { COP *ret = find_cop_for_lvintro(padix, cUNOPx(o)->op_first, copp); if(ret) return ret; } } return NULL; } #define lex_consume_unichar(c) MY_lex_consume_unichar(aTHX_ c) static bool MY_lex_consume_unichar(pTHX_ U32 c) { if(lex_peek_unichar(0) != c) return FALSE; lex_read_unichar(0); return TRUE; } #define 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.820/hax/perl-backcompat.c.inc000444001750001750 1352014757670420 17106 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, 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) ((op)->op_sibling = NULL) #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) /* PERL_UNUSED_ARG() isn't usable to fix this on early perl versions */ # define isIDFIRST_utf8_safe(s, e) ((void)sizeof(e), isIDFIRST_utf8(s)) # define isIDCONT_utf8_safe(s, e) ((void)sizeof(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.820/hax/sv_setrv.c.inc000444001750001750 46114757670420 15655 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.820/include000755001750001750 014757670420 13613 5ustar00leoleo000000000000Object-Pad-0.820/include/class.h000444001750001750 2410214757670420 15245 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 abstract : 1; 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 *isa; /* cached pointer to the @ISA array for the 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 */ AV *applycvs; /* the APPLY {} phaser blocks; each elem is a CV* directly */ } 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 /* this was only added in Perl 5.22.0 */ # 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.820/include/linnet.h000444001750001750 164314757670420 15416 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.820/include/suspended_compcv.h000444001750001750 147614757670420 17472 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.820/lib000755001750001750 014757670420 12736 5ustar00leoleo000000000000Object-Pad-0.820/lib/Object000755001750001750 014757670420 14144 5ustar00leoleo000000000000Object-Pad-0.820/lib/Object/Pad.pm000444001750001750 16466514757670420 15425 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-2025 -- leonerd@leonerd.org.uk package Object::Pad 0.820; use v5.18; 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 =for highlighter language=perl =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. =head2 Relation to C Since its original creation, this module has evolved to become the test-bed for refining the design of what a good class-based object system would look like for Perl. While useful in its own right, it also acts as a preview of what Perl's C syntax will likely become. Being a CPAN module, this can be iterated much faster than core Perl, which only gets one major release per year. Getting the design right in this module first therefore helps to reduce the amount of development time needed in core Perl. Where features overlap, both this module and the C feature added to recent Perl versions should largely agree on syntax and semantics. This module will likely always be ahead of core Perl in terms of exact abilties because it is acting as a test-bed for these new ideas. However, where both implementations support the same idea, they should in general use the same syntax and semantics to provide it. If you are interested in using this object system in new code in a way that will be forward-compatible with the feature added directly in newer Perl versions, while also supporting versions of Perl before this feature was added, you may wish to use instead the module L. That module enables the core Perl feature on the latest version of Perl, or uses C to fill in the missing syntax and features on older Perl versions. =head2 Experimental Features I While most of this module has evolved into a stable state, recently-added parts remain B because the design is still evolving, and many features and ideas have yet to implemented. Of these experimental features, feel free to try them out in newly-developed code, but don't complain if a later version is incompatible with your current code and you'll have to change it. Once individual features are stable and no longer declared experimental, they should have the same stability guarantees as any other long-term supported CPAN module, or core Perl itself. 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 - both within this CPAN module and as the wider experiment to provide it as a core Perl feature. See the L section. Features of this module that are currently marked as experimental 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(apply_phaser)'; use Object::Pad ':experimental(lexical_class)'; 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 :abstract :abstract I Declares that this class is I. An abstract class is permitted to define required methods (i.e. named methods without a body definition). Instances may not be created of this class type directly. Instead, a subclass of this class must be derived that provides method bodies for any of the named required methods. Any subclass of an abstract class must either provide bodies for all remaining required methods, or themselves be declared C<:abstract> as well. This provides a way in which a generic type of class can be created, that is intended for multiple different specialisations to further define different kinds of behaviour by providing bodies for those named methods. Being abstract means that instances cannot be created of this as-yet-incomplete class type. =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 my class my class Name :ATTRS... { ... } I If a C keyword is preceded by C it creates a class that has lexical visiblity, rather than being available globally via a fully-qualified name in the symbol table. This is useful for creating internal helper classes within modules, such as for returning complex structures, or simply to use internally without being visible to the caller. As the class itself is only visible lexically, callers in other scopes are unable to see it to create new instances of it. class My::Module; my class HelperStructure { field $name :param :reader; field $value :param :reader; } method get_thing () { return HelperStructure->new( name => "the name", value => "the value", ); } B the above is technically a lie. Current versions of perl do not support truely anonymous packages to be used as classes, so even these "lexical" classes are in fact named on the symbol table. However, they are given a name that is syntactically-impossible for regular code to create or use, and a const-returning lexical function is created with the correct lexical name, which returns the true name of the class, so that the C<< ->new >> method can still be called on it. As a result of this limitation, there are a number of operations that lexical classes do not currently support - such as subclassing. It is hoped that later versions of either this module, or perl itself, will be able to expand on these abilities. For now, this feature remains an experimental best-effort basis. Due to the way this lexical function works, it can stand in for the class name when used with the C<< ->isa >> method. Note carefully here, that the lexical class is used directly as a bareword and not quoted. if( $obj->isa( HelperStructure ) ) { ... } Additionally, as the right-hand side operand of the C operator (in Perl version 5.32 or later) does not need quoting, it can be used there directly: if( $obj isa HelperStructure ) { ... } =head2 inherit inherit Classname; inherit Classname VER; inherit Classname LIST...; inherit Classname VER LIST...; I 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 I this keyword is no longer recognised. It used to be an earlier version of what is now the L keyword. has $var; has @var; has %var; has $var = EXPR; has $var { BLOCK } Because of the one-shot immediate nature of these initialisation expressions (and a bunch of other reasons), the keyword was removed. 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 or abstract class. Such a method must be provided by any class that wishes to be non-abstract. It will be a compiletime error to apply the role to a class, or derive from an abstract 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 or abstract base classes, 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 my method my method NAME { ... } I lexical method declarations are supported using the C keyword prefix. These become available as lexical functions, rather than being stored in the class package. As a result, they are not available by named method resolution, package C<< ->can >> lookup, or via the MOP. These are a convenient alternative to the syntax given above, where the method is stored anonymously via a lexical variable. Since lexical methods are not visible to named method resolution, they must be invoked by function-call syntax, remembering to pass in the invocant as the first argument: my method inner { ... } method outer { inner($self, @args); } =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 preceded 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 APPLY I APPLY ( $class_mop ) { # on perl 5.26 onwards ... } APPLY { my $class_mop = shift; ... } Only valid within a C definition. Declares a block of code that will be run at compile-time whenever the role is applied to a class. Each time it is applied to a new class, the code will be invoked. It receives as an argument a L instance representing the class to which the role is currently being applied. The eventual intent is that the presence of any of these phaser blocks will I the current implicit behaviour of applying a role, though currently they run in addition to it. This is part of an ongoing experiment whose details will change over time. =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<> =for highlighter 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. =for highlighter language=perl =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: =for highlighter Value seen by superconstructor is B Value seen by user is C =for highlighter language=perl =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 apply_phaser lexical_class ) ); $class->_import_configuration( \@_ ); my %syms = map { $_ => 1 } @_; # Default imports unless( %syms ) { $syms{$_}++ for qw( class role inherit apply method field has requires BUILD ADJUST APPLY ); } delete $syms{$_} and $^H{"Object::Pad/$_"}++ for qw( class role inherit apply method field has requires BUILD ADJUST APPLY ); 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. =for highlighter 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: ... =for highlighter language=perl =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.820/lib/Object/Pad.xs000444001750001750 17227414757670420 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-2024 -- 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" #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 "optree-additions.c.inc" #include "newMYCONSTSUB.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); } #define methstart_common(is_role) S_methstart_common(aTHX_ is_role) static void S_methstart_common(pTHX_ bool is_role) { bool create = PL_op->op_flags & OPf_MOD; bool do_shift = PL_op->op_flags & OPf_STACKED; SV *self; if(do_shift) self = av_shift(GvAV(PL_defgv)); else self = PAD_SVl(PADIX_SELF); 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"); } if(do_shift) { 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 } static XOP xop_methstart; static OP *pp_methstart(pTHX) { methstart_common(false); return PL_op->op_next; } static XOP xop_rolemethstart; static OP *pp_rolemethstart(pTHX) { methstart_common(true); return PL_op->op_next; } OP *ObjectPad_newMETHSTARTOP(pTHX_ U32 flags) { OP *(*ppaddr)(pTHX) = (flags & OPfMETHSTART_ROLE) ? &pp_rolemethstart : &pp_methstart; #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 = ppaddr; #else OP *op = newOP_CUSTOM(ppaddr, flags); #endif op->op_private = (U8)(flags >> 8); if(flags & OPfMETHSTART_ROLE) op->op_flags |= OPf_SPECIAL; return op; } static XOP xop_commonmethstart; static OP *pp_commonmethstart(pTHX) { bool do_shift = PL_op->op_flags & OPf_STACKED; SV *self; if(do_shift) self = av_shift(GvAV(PL_defgv)); else self = PAD_SVl(PADIX_SELF); if(SvROK(self)) /* TODO: Should handle this somehow */ croak("Cannot invoke common method on an instance"); if(do_shift) { 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); if(flags & OPfMETHSTART_ROLE) op->op_flags |= OPf_SPECIAL; 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); } 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; bool is_lexical = (PL_parser->in_my != 0); SV *packagename = args[argi++]->sv; if(!packagename) { if(is_lexical) croak("Lexical class requires a name"); is_anon = true; packagename = newSVpvf("Object::Pad::__ANONCLASS__::%" IVdf, next_anonclass_id++); } if(is_lexical) { /* Lexical class is implemented by overriding the package name to * something anonymous then setting up a const sub named after the * requested name which just returns it */ if(!hv_fetchs(hints, "Object::Pad/experimental(lexical_class)", 0)) Perl_ck_warner(aTHX_ packWARN(WARN_EXPERIMENTAL), "'my class' is experimental and may be changed or removed without notice"); SV *lexname = packagename; if(strstr(SvPV_nolen(lexname), "::")) croak("Lexical class name must not be fully-qualified"); packagename = newSVpvf("%" SVf "::__LEXCLASS__/%" SVf, SVfARG(PL_curstname), lexname); int unique_suffix = 0; while(gv_stashsv(packagename, 0)) { /* Append a uniqueness number on the end of there's more than one */ sv_setpvf(packagename, "%" SVf "::__LEXCLASS__/%" SVf ".%d", SVfARG(PL_curstname), lexname, ++unique_suffix); } newMYCONSTSUB_named_sv(lexname, packagename); } enum MetaType type = PTR2UV(hookdata); SV *packagever = args[argi++]->sv; ClassMeta *meta = mop_create_class(type, packagename); 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}"); if(is_lexical) croak("Lexical class requires a {BLOCK}"); } else croak("Expected a block or ';', found > %s", PL_parser->bufptr); 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_ATTRIBUTES, {0} }; static const struct XSParseKeywordHooks kwhooks_class = { .flags = XPK_FLAG_PERMIT_LEXICAL, .permit_hintkey = "Object::Pad/class", .pieces = pieces_classlike, .build = &build_classlike, }; static const struct XSParseKeywordHooks kwhooks_role = { .flags = XPK_FLAG_PERMIT_LEXICAL, .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: croak("Unreachable"); 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_LISTEXPR_ENTERLEAVE(XPK_SETUP(&setup_parse_field_initexpr)), XPK_AUTOSEMI), XPK_TAG(FIELD_INIT_EXPR), XPK_SEQUENCE(XPK_DOREQUALS, XPK_PREFIXED_LISTEXPR_ENTERLEAVE(XPK_SETUP(&setup_parse_field_initexpr)), XPK_AUTOSEMI), XPK_TAG(FIELD_INIT_DOREXPR), XPK_SEQUENCE(XPK_OREQUALS, XPK_PREFIXED_LISTEXPR_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_FAILURE("'has' is no longer supported; use 'field' instead"), {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, PHASER_APPLY, }; static const char *phasertypename[] = { [PHASER_BUILD] = "BUILD", [PHASER_ADJUST] = "ADJUST", [PHASER_ADJUSTPARAMS] = "ADJUST", [PHASER_APPLY] = "APPLY", }; 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); HV *hints = GvHV(PL_hintgv); /* 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: case PHASER_APPLY: 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(hints, "Object::Pad/__CLASS__", newSVsv(&PL_sv_yes)); } static void parse_method_start_signature(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata) { /* reserve argidx=0 for $self */ xps_signature_add_param(ctx, (&(struct XPSSignatureParamDetails){ .ver = XSPARSESUBLIKE_ABI_VERSION, .sigil = '$', .padix = PADIX_SELF, })); } /* TODO: It'd be nice to do the rest of the signature op manipulation in a * finish_signature hook function, but currently XPS does not expose enough of * the signature ops in a visible way for us to do that. */ static void parse_classphaser_pre_subparse(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata) { ClassMeta *meta = compclassmeta; mop_class_begin(meta); ctx->actions &= ~XS_PARSE_SUBLIKE_ACTION_CVf_ANON; } 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); } } static void parse_classphaser_post_blockstart(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata) { /* phasers always permit signatures */ #ifdef HAVE_PARSE_SUBSIGNATURE import_pragma("feature", "signatures"); import_pragma("-warnings", "experimental::signatures"); #endif } #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_classphaser_pre_blockend(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata) { /* 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; case PHASER_APPLY: croak("ARHG unreachable wrong post_newcv for type=%d", type); } 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 void parse_classphaser_post_newcv(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata) { enum PhaserType type = PTR2UV(hookdata); switch(type) { case PHASER_APPLY: mop_class_add_APPLY(compclassmeta, ctx->cv); /* steal CV */ break; case PHASER_NONE: case PHASER_BUILD: case PHASER_ADJUST: case PHASER_ADJUSTPARAMS: croak("ARHG unreachable wrong post_newcv for type=%d", type); } ctx->actions &= ~(XS_PARSE_SUBLIKE_ACTION_REFGEN_ANONCODE|XS_PARSE_SUBLIKE_ACTION_RET_EXPR); } static struct XSParseSublikeHooks parse_method_hooks = { .ver = 7, .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, .start_signature = parse_method_start_signature, }; static struct XSParseSublikeHooks parse_phaser_hooks = { .ver = 7, .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, .start_signature = parse_method_start_signature, }; static struct XSParseSublikeHooks parse_classphaser_hooks = { /* hooks for phasers that apply to entire classes but not instances */ .flags = XS_PARSE_SUBLIKE_COMPAT_FLAG_DYNAMIC_ACTIONS, .skip_parts = XS_PARSE_SUBLIKE_PART_NAME, /* no permit */ .pre_subparse = parse_classphaser_pre_subparse, .post_blockstart = parse_classphaser_post_blockstart, .pre_blockend = parse_classphaser_pre_blockend, .post_newcv = parse_classphaser_post_newcv, }; static int parse_phaser(pTHX_ OP **out, void *hookdata) { enum PhaserType type = PTR2UV(hookdata); HV *hints = GvHV(PL_hintgv); if(!have_compclassmeta) croak("Cannot '%s' outside of 'class'", phasertypename[PTR2UV(hookdata)]); lex_read_space(0); if(type == 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; } switch(type) { case PHASER_NONE: case PHASER_BUILD: case PHASER_ADJUST: case PHASER_ADJUSTPARAMS: return xs_parse_sublike(&parse_phaser_hooks, hookdata, out); case PHASER_APPLY: if(!hv_fetchs(hints, "Object::Pad/experimental(apply_phaser)", 0)) Perl_ck_warner(aTHX_ packWARN(WARN_EXPERIMENTAL), "APPLY phaser blocks are experimental and may be changed or removed without notice"); return xs_parse_sublike(&parse_classphaser_hooks, hookdata, out); } croak("ARGH unreachable: unhandled phaser type %d", type); } 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 const struct XSParseKeywordHooks kwhooks_APPLY = { .permit_hintkey = "Object::Pad/APPLY", .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+3, ((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}, {"the role APPLY blocks AV", DMD_FIELD_PTR, .ptr = classmeta->role.applycvs}, }) ); 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; } /* Handy functions for MOP wrapper methods */ #define MUST_CLASSMETA_FROM_RV(self) S_must_classmeta_from_rv(aTHX_ self) static ClassMeta *S_must_classmeta_from_rv(pTHX_ SV *self) { if(!(SvROK(self) && sv_derived_from(self, "Object::Pad::MOP::Class"))) croak("Expected an Object::Pad::MOP::Class instance"); return MUST_CLASSMETA(NUM2PTR(ClassMeta *, SvUV(SvRV(self)))); } #define MUST_FIELDMETA_FROM_RV(self) S_must_fieldmeta_from_rv(aTHX_ self) static FieldMeta *S_must_fieldmeta_from_rv(pTHX_ SV *self) { if(!(SvROK(self) && sv_derived_from(self, "Object::Pad::MOP::Field"))) croak("Expected an Object::Pad::MOP::Field instance"); return MUST_FIELDMETA(NUM2PTR(FieldMeta *, SvUV(SvRV(self)))); } #define MUST_METHODMETA_FROM_RV(self) S_must_methodmeta_from_rv(aTHX_ self) static MethodMeta *S_must_methodmeta_from_rv(pTHX_ SV *self) { if(!(SvROK(self) && sv_derived_from(self, "Object::Pad::MOP::Method"))) croak("Expected an Object::Pad::MOP::Method instance"); return MUST_METHODMETA(NUM2PTR(MethodMeta *, SvUV(SvRV(self)))); } 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_rolemethstart, xop_name, "rolemethstart"); XopENTRY_set(&xop_rolemethstart, xop_desc, "enter role method"); #ifdef METHSTART_CONTAINS_FIELD_BINDINGS XopENTRY_set(&xop_rolemethstart, xop_class, OA_UNOP_AUX); #else XopENTRY_set(&xop_rolemethstart, xop_class, OA_BASEOP); #endif Perl_custom_op_register(aTHX_ &pp_rolemethstart, &xop_rolemethstart); 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.48); /* XPK_FLAG_PERMIT_LEXICAL */ 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("APPLY", &kwhooks_APPLY, (void *)PHASER_APPLY); register_xs_parse_keyword("__CLASS__", &kwhooks_uuCLASS, NULL); register_xs_parse_keyword("requires", &kwhooks_requires, NULL); boot_xs_parse_sublike(0.35); /* 'my' prefix scanning bugfix */ register_xs_parse_sublike("method", &parse_method_hooks, (void *)PHASER_NONE); ObjectPad__boot_classes(aTHX); ObjectPad__boot_fields(aTHX); Object-Pad-0.820/lib/Object/mop-class.xsi000444001750001750 2532014757670420 16746 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; bool set_abstract = 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", "abstract", 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; case 3: /* abstract */ set_abstract = SvTRUE(kwval); break; } } ClassMeta *meta = mop_create_class(ix, name); if(superclassname && SvOK(superclassname)) mop_class_set_superclass(meta, superclassname); if(set_abstract) meta->abstract = true; 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(ClassMeta *self) ALIAS: is_class = METATYPE_CLASS is_role = METATYPE_ROLE CODE: RETVAL = (self->type == ix); OUTPUT: RETVAL bool is_abstract(ClassMeta *self) CODE: RETVAL = self->abstract; OUTPUT: RETVAL SV * name(ClassMeta *self) CODE: RETVAL = SvREFCNT_inc(self->name); OUTPUT: RETVAL void superclasses(ClassMeta *self) PPCODE: if(self->type == METATYPE_CLASS && self->cls.supermeta) { PUSHs(sv_newmortal()); sv_setref_uv(ST(0), "Object::Pad::MOP::Class", PTR2UV(self->cls.supermeta)); XSRETURN(1); } XSRETURN(0); void direct_roles(ClassMeta *self) ALIAS: direct_roles = 0 all_roles = 1 PPCODE: { U32 count = 0; /* TODO Consider recursion */ U32 i; switch(self->type) { case METATYPE_CLASS: { U32 nroles; RoleEmbedding **embeddings = NULL; switch(ix) { case 0: embeddings = mop_class_get_direct_roles(self, &nroles); break; case 1: embeddings = mop_class_get_all_roles(self, &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(ClassMeta *self, role) SV *role ALIAS: compose_role = 0 CODE: { 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 = MUST_CLASSMETA_FROM_RV(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(self); mop_class_add_role(self, rolemeta); } void add_BUILD(ClassMeta *self, code) CV *code CODE: mop_class_begin(self); mop_class_add_BUILD(self, (CV *)SvREFCNT_inc((SV *)code)); SV * add_method(ClassMeta *self, mname, ...) 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)); mop_class_begin(self); if(SvOK(mname) && SvPOK(mname) && strEQ(SvPVX(mname), "BUILD")) { croak("Adding a method called BUILD is not supported; use ->add_BUILD directly"); } MethodMeta *methodmeta = mop_class_add_method_cv(self, 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(ClassMeta *self, methodname) SV *methodname ALIAS: get_method = 1 PPCODE: { bool recurse = !!ix; ClassMeta *class = self; do { AV *methods = class->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(class->type == METATYPE_CLASS) class = class->cls.supermeta; else class = NULL; } while(recurse && class); croak("Class %" SVf " does not have a method called '%" SVf "'", SVfARG(self->name), SVfARG(methodname)); } void direct_methods(ClassMeta *self) ALIAS: all_methods = 1 PPCODE: bool recurse = !!ix; /* A hash to remove overrides */ HV *mnames = NULL; if(recurse) { mnames = newHV(); SAVEFREESV(mnames); } U32 retcount = 0; do { AV *methods = self->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(self->type == METATYPE_CLASS) self = self->cls.supermeta; else self = NULL; } while(recurse && self); XSRETURN(retcount); void add_required_method(ClassMeta *self, mname) SV *mname CODE: mop_class_begin(self); mop_class_add_required_method(self, mname); SV * add_field(ClassMeta *self, fieldname, ...) SV *fieldname CODE: { dKWARG(2); mop_class_begin(self); FieldMeta *fieldmeta = mop_class_add_field(self, sv_mortalcopy(fieldname)); static const char *args[] = { "default", "param", "reader", "writer", "mutator", "accessor", "weak", "attributes", 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; case 7: /* attributes */ { if(!SvROK(kwval) || SvTYPE(SvRV(kwval)) != SVt_PVAV) croak("Expected 'attributes' to be given an ARRAY reference"); AV *attributes = AV_FROM_REF(kwval); for(IV ix = 0; ix < av_count(attributes); ix += 2) { SV *attrname = *av_fetch(attributes, ix, 0); SV *attrval = ix+1 < av_count(attributes) ? *av_fetch(attributes, ix + 1, 0) : &PL_sv_undef; mop_field_apply_attribute(fieldmeta, SvPV_nolen(attrname), attrval); } } } } mop_field_seal(fieldmeta); RETVAL = newSV(0); sv_setref_uv(RETVAL, "Object::Pad::MOP::Field", PTR2UV(fieldmeta)); } OUTPUT: RETVAL void get_field(ClassMeta *self, fieldname) SV *fieldname PPCODE: { FieldMeta *fieldmeta = mop_class_find_field(self, 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 "'", self->name, fieldname); } void fields(ClassMeta *self) PPCODE: AV *fields = self->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(ClassMeta *self) PPCODE: if(self->type != METATYPE_ROLE) croak("Can only call ->required_method_names on a metaclass for a role"); AV *required_methods = self->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(ClassMeta *self) CODE: mop_class_seal(self); Object-Pad-0.820/lib/Object/mop-field.xsi000444001750001750 376214757670420 16712 0ustar00leoleo000000000000 SV * name(FieldMeta *self) ALIAS: name = 0 sigil = 1 class = 2 CODE: switch(ix) { case 0: RETVAL = SvREFCNT_inc(self->name); break; case 1: RETVAL = newSVpvn(SvPVX(self->name), 1); break; case 2: RETVAL = newSV(0); sv_setref_uv(RETVAL, "Object::Pad::MOP::Class", PTR2UV(self->class)); break; default: RETVAL = NULL; } OUTPUT: RETVAL void value(FieldMeta *self, obj) SV *obj PPCODE: { SV *objrv; if(!SvROK(obj) || !SvOBJECT(objrv = SvRV(obj))) croak("Cannot fetch field value of a non-instance"); SV *value = get_obj_fieldsv(obj, self); /* 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(self->name)[0] != '$') { value = sv_mortalcopy(value); SvREADONLY_on(value); } /* stack does not contribute SvREFCNT */ ST(0) = value; XSRETURN(1); } bool has_attribute(FieldMeta *self, name) SV *name CODE: { const struct FieldHook *hook = mop_field_get_attribute(self, SvPV_nolen(name)); RETVAL = !!hook; } OUTPUT: RETVAL SV * get_attribute_value(FieldMeta *self, name) SV *name CODE: { const struct FieldHook *hook = mop_field_get_attribute(self, 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(FieldMeta *self, name) SV *name PPCODE: { AV *values = mop_field_get_attribute_values(self, 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.820/lib/Object/mop-method.xsi000444001750001750 64414757670420 17063 0ustar00leoleo000000000000 SV * name(MethodMeta *self) ALIAS: name = 0 class = 1 is_common = 2 CODE: switch(ix) { case 0: RETVAL = SvREFCNT_inc(self->name); break; case 1: RETVAL = newSV(0); sv_setref_uv(RETVAL, "Object::Pad::MOP::Class", PTR2UV(self->class)); break; case 2: RETVAL = boolSV(self->is_common); break; default: RETVAL = NULL; } OUTPUT: RETVAL Object-Pad-0.820/lib/Object/Pad000755001750001750 014757670420 14650 5ustar00leoleo000000000000Object-Pad-0.820/lib/Object/Pad/ExtensionBuilder.pm000444001750001750 406414757670420 20632 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.820; use v5.18; use warnings; =head1 NAME C - build-time support for extensions to C =head1 SYNOPSIS =for highlighter language=perl 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.820/lib/Object/Pad/MetaFunctions.pm000444001750001750 1166114757670420 20147 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.820; use v5.18; 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 =for highlighter language=perl 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 internals 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 occurrence 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.820/lib/Object/Pad/Guide000755001750001750 014757670420 15705 5ustar00leoleo000000000000Object-Pad-0.820/lib/Object/Pad/Guide/MigratingFromClassicalPerl.pod000444001750001750 3701214757670420 24000 0ustar00leoleo000000000000=head1 TITLE Migrating from Classical Perl to L =head1 INTRODUCTION L provides a convenient and modern syntax for writing code in a class-based object oriented style. It is likely you already have much code already written using Perl's original style, of manual calls to C, storing instance data directly in hash keys, and so on. This guide aims to provide a sequence of steps to help rewrite this kind of code into using C instead. As well as being useful on its own, this can often serve as the first step towards a further onwards migration to L, and eventually the native class syntax provided by recent version of Perl itself as L. See also L. =head1 SCENARIO 1 - A SIMPLE CLASS =for highlighter language=perl Lets suppose we have a simple module that provides some sort of object class based on a blessed hash reference. Before we start, the module file begins use v5.36; package My::Example::Class v1.23; sub new { my $class = shift; my %params = @_; return bless { x => $params{x} // 0, y => $params{y} // 0, }, $class; } ... Over the following steps we will look at a sequence of small changes that can be made to this file, to turn it into using C in a good style. These steps are self-contained, in that each can be made one at a time, while the code remains fully operational with its intended behaviour, in-between. Each of these changes is also entirely internal within the source file that implements this class. The externally-visible API to this class that other code will see remains entirely unmodified. As a result of this, you do not have to migrate everything all at once. You can start by altering just a few files, or making just the first few changes to some files, and the system or application as a whole will remain running just as it did before. This allows you to gradually rewrite in stages, without needing to perform one big distruptive change. =head2 Step 1 - Basics The first thing to do is to add the C line at the start. This gives us several new keywords - most notably the C keyword which we'll use for declaring the class itself. Don't worry about imports polluting the C namespace - the C module only has lexical effects, so the scope of its additions is limited to this file alone. We'll give a module version number to this C statement. This is important, because we want to ensure we have a sufficiently recent version of the module for our current set of features. Now our file can begin use v5.36; use Object::Pad v0.800; package My::Example::Class v1.23; sub new { ... } Next up, we need to declare our class by using the C keyword. This can be used in place of the C keyword. As we are in the process of migrating some existing code, we need to temporarily tell C to do something odd with the object instances. Normally for a newly-written class, it will pick its own internal representation type for instances, that is largely opaque to outside interaction. This internal type may be some kind of array reference on older Perl versions, but on versions of Perl new enough to support the C feature it actually uses the same opaque representation type that core Perl classes will use. Until we have finished our migration process for this class, we need to ensure it uses a blessed hash reference so that existing code we've yet to rewrite continues to work correctly. Much of this code will presume that object instances are hash references and will attempt to use individually named keys within these references to store their data. For this to keep working, we need to supply the C<:repr> attribute, and ask to specifically use blessed hash references. use v5.36; use Object::Pad v0.800; class My::Example::Class v1.23 :repr(HASH); sub new { ... } =head2 Step 2 - Constructor We could at this point try running the code already, although in practice we haven't really changed anything yet. If we did we'd get one warning already: =for highlighter Subroutine new redefined at ... =for highlighter language=perl This warning comes because C has already provided a constructor method, named C, so our code doesn't have to. The next thing we need to do, then, is to get rid of our current C method and move the code elsewhere. Looking in more detail at our original code, we can take a look at the C method. This takes a hash of incoming parameters, and extracts a couple of values to use as instance fields, along with defaulting values in case they are missing. This includes the C expression itself. sub new { my $class = shift; my %params = @_; return bless { x => $params{x} // 0, y => $params{y} // 0, }, $class; } We can replace this constructor with a C phaser. This is a named block, much like C or similar in core Perl, which provides some code that runs at a particular time. The code in this block runs as part of the constructor that C provided for us. Much like with the C<:repr> attribute we added earlier, this block is more of a temporary tool to aid the process of migrating existing code. It wouldn't be used in a newly-written native class - there are better things to use there. But for now, it is required because it gives us a way to handle the incoming arguments to the constructor and set up the initial values of those fields. Within the scope of the C phaser, a lexical variable called C<$self> is implicitly visible; its value will be a reference to the object being constructed. This will be a common theme later on - you don't need to specifically handle this as an argument; it is done automatically. When the C phaser runs, it receives as any extra arguments into its C<@_> array all of the additional values that the caller passed to the constructor. So we can inspect them there in the same way. We can now replace the entire C with the following C phaser BUILD { my %params = @_; $self->{x} = $params{x} // 0; $self->{y} = $params{y} // 0; } Since we're on a version of Perl that is newer than C, we can use subroutine signature syntax to further tidy this block up. Like subroutines (and as we'll see later on, methods), these C phasers can be annotated with a signature, to automatically unpack the arguments passed in. We can write this even shorter. BUILD ( %params ) { $self->{x} = $params{x} // 0; $self->{y} = $params{y} // 0; } =head2 Step 3 - Method Now lets turn our focus to the other methods in the file. Most likely there were some existing methods designed as field accessors, and perhaps other behaviour that actually performs some real work. For the sake of providing some interesting variety of styles to migrate from, lets look at a few different ways the existing code might have been written. sub x { return shift->{x}; } sub set_x { $_[0]->{x} = $_[1]; } sub y ( $self ) { return $self->{y}; } sub set_y ( $self, $new_y ) { $self->{y} = $new_y; } sub reset { my $self = shift; $self->{x} = $self->{y} = 0; } In each of these cases, we can use another of C's new keywords, C. A C declaration is similar to a C, except that it automatically handles the implicit C<$self> argument at the beginning of the argument list. In each method body, we already have such a variable in scope without needing to have explicitly created it ourselves. method x { return $self->{x}; } method set_x { $self->{x} = $_[0]; } method y { return $self->{y}; } method set_y ( $new_y ) { $self->{y} = $new_y; } method reset { $self->{x} = $self->{y} = 0; } In particular with the C method, note that since the implicit C<$self> has been shifted out of the arguments array, the new value for the field now appears at C<$_[0]>, not C<$_[1]> as it had done prior. Like we did earlier with the C phaser, we can additionally make consistent use of subroutine signatures while we're here, to have some neater handling of the other arguments passed in to these method. While we're at it it's always good practice to mark an empty signature C<()> on any methods we're not expecting to pass additional arguments into, so that at runtime it will complain if someone accidentally does. method x () { return $self->{x}; } method set_x ( $new_x ) { $self->{x} = $new_x; } method y () { return $self->{y}; } method set_y ( $new_y ) { $self->{y} = $new_y; } method reset () { $self->{x} = $self->{y} = 0; } =head2 Step 4 - Fields One of the key benefits of using C over plain classical Perl style is that all of the fields that store data within each instance are accessible using syntax that makes them look like lexical variables, rather than hash-key access via C<$self>. All of our changes so far have been leading up to the ability to do exactly this. So lets do that now. So far in all of our code, we have only used fields C<< $self->{x} >> and C<< $self->{y} >>. We can now declare those two using the C keyword, and replace all of the occurances in existing code with those names. field $x; field $y; BUILD ( %params ) { $x = $params{x} // 0; $y = $params{y} // 0; } method x () { return $x; } method set_x ( $new_x ) { $x = $new_x; } method y () { return $y; } method set_y ( $new_y ) { $y = $new_y; } method reset () { $x = $y = 0; } At this point it may be that there is now no longer any code left which tries to access C<$self> as if it was a hash reference. All of the basic field access in these methods has been updated to use the real C variables. If we're sure we have no other code left in this file, and no other code elsewhere that, for example, tries to make any subclasses of this class, then it will be safe to remove the C<:repr(HASH)> attribute on the C line. use v5.36; use Object::Pad v0.800; class My::Example::Class v1.23; If not, there is no great trouble in it remaining there for a while longer, until a wider and more complete migration of the entire codebase has been completed. They can be tidied up at the end. =head2 Step 5 - Convenience Accessors At this point, you may notice a common pattern with the accessor methods we defined. We have two reader methods that simply return the current value of the fields, and two writer methods that simply set a new value. As this is such a common pattern, C provides some attributes you can annotate onto a C declaration to have it build these methods for you. These attributes are called C<:reader> and C<:writer>. field $x :reader :writer; field $y :reader :writer; The C<:reader> attribute will create a reader method identical to the ones we manually created in the previous example. By default each method will be named as per the field it is attached to. Likewise, the C<:writer> attribute will create a writer method identical to the ones we created as well. Its naming convention is that it will prepend C to the name of the field, so once again its default behaviour already matches the names of the accessors we wish to be created. With these in place we can entirely delete our manually-written C, C, C and C methods. =head2 Step 6 - Parameters and Field Defaults Recall earlier that we created the C block as a temporary migration tool to help handle constructor parameters. Now that we have real C declarations it is time to fix that up into a more appropriate way of working. As was the case with the C<:reader> and C<:writer> attributes on a field, there is another attribute called C<:param> that can be applied which requests some implicit behaviour by C itself, to assign the value of a field from a named parameter passed to the constructor. field $x :reader :writer :param; field $y :reader :writer :param; As it stands, these create named parameters to the class constructor that act much like signature parameters without defaulting expressions - in that, they are mandatory. An error is raised at runtime if a caller does not provide a corresponding value for one. My::Example::Class->new( x => 100 ) Z<> =for highlighter Required parameter 'y' is missing for My::Example::Class constructor at ... =for highlighter language=perl In order to match the behaviour of the original C and later the C phaser we temporarily added, we should provide a default value for these fields that will be applied if the caller did not pass in a more specific one. Since the original behaviour applied the value C<0> using the C operator, we can preserve this same behaviour by using the C assignment operator. This applies the default if the named parameter was absent, or given as the value C. field $x :reader :writer :param //= 0; field $y :reader :writer :param //= 0; As these defaulting operators entirely provide the behaviour we wrote manually in the C phaser, we can delete that too. =head2 The End Result Now we have finished these steps, we have fully converted our original class that was written using classical Perl with manual C expressions into using all of the conveniences and features of the object system provided by C. Many of the behaviours that had been explicitly provided in manually-written code are now implied by standard features of the object system. This makes them easier to comprehend at a quick glance. There is no custom code to have to read and understand, instead the mere presence of the standard keywords and attributes. Having started with the customly-written code at the beginning, we are now left with far fewer lines. The entire behaviour is now captured by this: use v5.36; use Object::Pad v0.800; class My::Example::Class v1.23; field $x :reader :writer :param //= 0; field $y :reader :writer :param //= 0; method reset () { $x = $y = 0; } =head2 Addendum - Conventions on Field Names Since these field variables are lexically scoped at the entire file level, in larger code examples it can sometimes be hard to remember that they even are field variables, confusing them with signature parameters or lexicals within individual methods and smaller bodies of code. With the previous style of using blessed hash references, the C<< $self->{...} >> pattern gives an obvious visual clue, but that kind of clue is lacking here. It is a common style choice in larger classes to give field variables names all beginning with a single underscore character, to distinguish them. This naming style makes it a little easier to see at a glance when looking at code that may be far away from the field declarations, that these variables even are fields. field $_x; field $_y; BUILD ( %params ) { $_x = $params{x} // 0; $_y = $params{y} // 0; } method reset () { $_x = $_y = 0; } ... Since C knows about the naming convention of beginning each field variable with a leading underscore it will ignore that for the purposes of things like handling constructor arguments for C<:param>, or generating accessor methods for C<:reader> and C<:writer>. Thus the methods are still named C and C as we would like. =head1 AUTHOR Paul Evans =cut Object-Pad-0.820/lib/Object/Pad/MOP000755001750001750 014757670420 15303 5ustar00leoleo000000000000Object-Pad-0.820/lib/Object/Pad/MOP/Class.pm000444001750001750 3174714757670420 17077 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.820; use v5.18; 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 =for highlighter language=perl 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. =item abstract => BOOL Optionally; if given a true value the newly-created class will be declared as abstract, as if the L|Object::Pad/:abstract> attribute had been applied. =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 is_abstract $bool = $metaclass->is_abstract; True on a C, or a C that was declared with the C<:abstract> attribute. =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. =item attributes => ARRAY I Provides additional attributes to apply to the field, as if declared by attribute syntax. This is largely useful for applying third-party field attributes. The referenced array should contain an even-sized list of pairs. The first of each pair will be the name of an attribute, and the second will be a value to pass (or C if not applicable). Note that if the third-party attribute provides separate parse and apply phases in its hook functions, the parse part will I be invoked by this parameter. Whatever value is passed must be something accepted by the apply phase alone. =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.820/lib/Object/Pad/MOP/Field.pm000444001750001750 613014757670420 17021 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.820; use v5.18; 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 =for highlighter language=perl 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.820/lib/Object/Pad/MOP/FieldAttr.pm000444001750001750 611214757670420 17654 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.820; use v5.18; 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 =for highlighter language=perl 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.820/lib/Object/Pad/MOP/Method.pm000444001750001750 245414757670420 17223 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.820; use v5.18; 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 =for highlighter language=perl 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.820/share000755001750001750 014757670420 13272 5ustar00leoleo000000000000Object-Pad-0.820/share/include000755001750001750 014757670420 14715 5ustar00leoleo000000000000Object-Pad-0.820/share/include/object_pad.h000444001750001750 3326114757670420 17342 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 get_field_for_padix(padix) ObjectPad_get_field_for_padix(aTHX_ padix) FieldMeta *ObjectPad_get_field_for_padix(pTHX_ PADOFFSET padix); enum { /* Common flags for newMETHSTARTOP, newFIELDPADOP and newFIELDSVOP */ OPfMETHSTART_ROLE = (1 << 16), }; #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, fieldmeta) ObjectPad_get_obj_fieldsv(aTHX_ self, fieldmeta) SV *ObjectPad_get_obj_fieldsv(pTHX_ SV *self, 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_APPLY(class, cv) ObjectPad_mop_class_add_APPLY(aTHX_ class, cv) void ObjectPad_mop_class_add_APPLY(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_class(fieldmeta) ObjectPad_mop_field_get_class(aTHX_ fieldmeta) ClassMeta *ObjectPad_mop_field_get_class(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.820/src000755001750001750 014757670420 12757 5ustar00leoleo000000000000Object-Pad-0.820/src/class.c000444001750001750 24253114757670420 14434 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 } FieldMeta *ObjectPad_get_field_for_padix(pTHX_ PADOFFSET padix) { CV *scope = PL_compcv; ClassMeta *classmeta = get_compclassmeta(); while(scope && scope != classmeta->methodscope) { PADNAMELIST *pnl = PadlistNAMES(CvPADLIST(scope)); PADNAME *name = PadnamelistARRAY(pnl)[padix]; /* field names are all OUTER vars */ if(!PadnameOUTER(name)) return NULL; padix = PARENT_PAD_INDEX(name); scope = CvOUTSIDE(scope); } if(!scope) return NULL; /* padix refers to the pad offset within the methodscope, and we know that * the method scope contains all the fields in the right order */ AV *fields = classmeta->fields; if(av_count(fields) <= (padix - 1)) return NULL; FieldMeta *fieldmeta = MUST_FIELDMETA(AvARRAY(fields)[padix - 1]); /* TODO: assert on the field name being equal to the padname */ return fieldmeta; } #define prepend_methstart_ops(meta, outerscope, body, is_common) S_prepend_methstart_ops(aTHX_ meta, outerscope, body, is_common) static OP *S_prepend_methstart_ops(pTHX_ ClassMeta *meta, CV *outerscope, OP *body, bool is_common) { U32 opflags_if_role = (meta->type == METATYPE_ROLE) ? OPfMETHSTART_ROLE : 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; #if HAVE_PERL_VERSION(5, 26, 0) /* If we're on a perl with signatures, we will already have inserted an * OP_ARGELEM to perform the `$self = shift` behaviour rather than letting * OP_METHSTART do it. We need to put OP_METHSTART immediately after this, * so that its field bindings are visible to subsequent param defaulting * expressions that use field vars. */ OP *argcheck = NULL; { OP *o = body; while(o) { if(o->op_type == OP_ARGCHECK) { argcheck = o; break; } else if(o->op_type == OP_NEXTSTATE || o->op_type == OP_DBSTATE) o = OpSIBLING(o); else if(o->op_flags & OPf_KIDS) o = cUNOPo->op_first; else break; } } if(argcheck) { OP *next; next = OpSIBLING(argcheck); if(next->op_type == OP_NEXTSTATE || next->op_type == OP_DBSTATE) next = OpSIBLING(next); /* next ought to be the $self OP_ARGELEM we inserted */ assert(next); assert(next->op_type == OP_ARGELEM); assert(next->op_targ == PADIX_SELF); assert(PTR2UV(cUNOP_AUXx(next)->op_aux) == 0); OP *selfargelem = next; next = OpSIBLING(selfargelem); if(!is_common) methstartop = newMETHSTARTOP(0 | opflags_if_role | (meta->repr << 8)); else methstartop = newCOMMONMETHSTARTOP(0 | (meta->repr << 8)); OpMORESIB_set(selfargelem, methstartop); OpMORESIB_set(methstartop, next); } else #endif { if(!is_common) ops = op_append_list(OP_LINESEQ, ops, methstartop = newMETHSTARTOP(OPf_STACKED | opflags_if_role | (meta->repr << 8)) ); else ops = op_append_list(OP_LINESEQ, ops, methstartop = newCOMMONMETHSTARTOP(OPf_STACKED | (meta->repr << 8))); } if(!is_common) { #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(opflags_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 | opflags_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 op_append_list(OP_LINESEQ, ops, body); } 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 = prepend_methstart_ops(meta, meta->methodscope, body, false); } else if(body && is_common) { body = prepend_methstart_ops(meta, meta->methodscope, body, true); } 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_APPLY(pTHX_ ClassMeta *meta, CV *cv) { if(meta->type != METATYPE_ROLE) croak("Can only add a new APPLY block to a role"); if(!meta->begun) croak("Cannot add a new APPLY block to a role that is not yet begun"); if(meta->sealed) croak("Cannot add an APPLY block to an already-sealed role"); if(!meta->role.applycvs) meta->role.applycvs = newAV(); av_push(meta->role.applycvs, (SV *)cv); } void ObjectPad_mop_class_add_required_method(pTHX_ ClassMeta *meta, SV *methodname) { if(!meta->abstract) croak("Can only add a required method to a role or abstract class"); 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 copy_requiremethods_from(dst, src) S_copy_requiremethods_from(aTHX_ dst, src) static void S_copy_requiremethods_from(pTHX_ ClassMeta *dst, ClassMeta *src) { U32 nmethods = av_count(src->requiremethods); for(U32 i = 0; i < nmethods; i++) { av_push(dst->requiremethods, SvREFCNT_inc(AvARRAY(src->requiremethods)[i])); } } #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); SV *heval = he ? HeVAL(he) : NULL; CV *cv = !heval ? NULL : /* perl since 5.41.9 might store RV to CV directly in the stash */ SvROK(heval) && SvTYPE(SvRV(heval)) == SVt_PVCV ? (CV *)SvRV(heval) : SvTYPE(heval) == SVt_PVGV ? GvCV(heval) : NULL; if(!cv) 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)); 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)); } copy_requiremethods_from(classmeta, rolemeta); 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; if(rolemeta->role.applycvs) { /* TODO: if APPLY blocks exist they should *replace* the built-in behaviour */ dSP; AV *applycvs = rolemeta->role.applycvs; SV *classmop = sv_newmortal(); sv_setref_uv(classmop, "Object::Pad::MOP::Class", PTR2UV(classmeta)); int i; for(i = 0; i < av_count(applycvs); i++) { CV *applycv = (CV *)AvARRAY(applycvs)[i]; ENTER; SAVETMPS; SPAGAIN; EXTEND(SP, 1); PUSHMARK(SP); PUSHs(sv_mortalcopy(classmop)); PUTBACK; assert(applycv); call_sv((SV *)applycv, G_VOID); FREETMPS; LEAVE; } } } 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 OP *ops = 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)); } } /* 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. */ ops = prepend_methstart_ops(meta, NULL, ops, false); 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->abstract) { U32 nmethods = av_count(meta->requiremethods); U32 i; for(i = 0; i < nmethods; i++) { SV *mname = AvARRAY(meta->requiremethods)[i]; GV *gv = gv_fetchmeth_sv(meta->stash, mname, 0, 0); if(gv && GvCV(gv)) continue; croak("Class %" SVf " does not provide a required method named '%" SVf "'", SVfARG(meta->name), SVfARG(mname)); } } if(meta->type == METATYPE_CLASS) { 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->abstract) croak("Cannot directly construct an instance of abstract class '%" SVf "'", SVfARG(meta->name)); 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), /* all roles are abstract */ .abstract = (type == METATYPE_ROLE), .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); } ENTER; SAVEGENERICSV(PL_curstash); PL_curstash = (HV *)SvREFCNT_inc(meta->stash); if(!IN_PERL_COMPILETIME) { // We need to trick this too SAVESPTR(PL_curcop); PL_curcop = &PL_compiling; } /* 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 */ CV *newcv; if(type == METATYPE_CLASS) { newcv = newXS_flags("new", injected_constructor, __FILE__, NULL, 0); } else { newcv = newXS_flags("new", injected_constructor_role, __FILE__, NULL, 0); } CvXSUBANY(newcv).any_ptr = meta; } { CV *doescv = newXS_flags("DOES", injected_DOES, __FILE__, NULL, 0); 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); } #if HAVE_PERL_VERSION(5, 26, 0) /* On Perl 5.26 and above we can create and grab the @ISA array now while * we have the PL_curstash set right * On earlier perls it doesn't work this way so we have to go the long way * around */ meta->isa = get_av("ISA", GV_ADDMG); #else { SV *isaname = newSVpvf("%" SVf "::ISA", name); SAVEFREESV(isaname); meta->isa = get_av(SvPV_nolen(isaname), GV_ADD | (SvFLAGS(isaname) & SVf_UTF8)); } #endif LEAVE; 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_push(meta->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->abstract) copy_requiremethods_from(meta, supermeta); 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; if(meta->type == METATYPE_CLASS && !meta->cls.supermeta) { av_push(meta->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, }; /* :abstract */ static bool classhook_abstract_apply(pTHX_ ClassMeta *classmeta, SV *value, SV **attrdata_ptr, void *_funcdata) { if(classmeta->type == METATYPE_ROLE) warn("All roles are already abstract; there is no need to declare them as such"); classmeta->abstract = TRUE; return FALSE; } static const struct ClassHookFuncs classhooks_abstract = { .ver = OBJECTPAD_ABIVERSION, .flags = OBJECTPAD_FLAG_ATTR_NO_VALUE, .apply = &classhook_abstract_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("abstract", &classhooks_abstract, 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.820/src/field.c000444001750001750 6352014757670420 14371 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; } ClassMeta *ObjectPad_mop_field_get_class(pTHX_ FieldMeta *fieldmeta) { return fieldmeta->class; } 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; } enum { APPLY_ATTRIBUTE_PARSE = (1<<0), APPLY_ATTRIBUTE_USE_RUNTIME_HINTS = (1<<1), }; static void apply_attribute(pTHX_ FieldMeta *fieldmeta, const char *name, SV *value, U8 flags) { bool use_runtime_hints = flags & APPLY_ATTRIBUTE_USE_RUNTIME_HINTS; HV *hints = GvHV(PL_hintgv); COPHH *cophh = CopHINTHASH_get(PL_curcop); 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) { if(use_runtime_hints) { if(!cophh_fetch_pvn(cophh, reg->funcs->permit_hintkey, reg->permit_hintkeylen, 0, 0)) continue; } else { if(!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((flags & APPLY_ATTRIBUTE_PARSE) && 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) { bool runtime = !IN_PERL_COMPILETIME; apply_attribute(aTHX_ fieldmeta, name, value, runtime ? APPLY_ATTRIBUTE_USE_RUNTIME_HINTS : 0); } void ObjectPad_mop_field_parse_and_apply_attribute(pTHX_ FieldMeta *fieldmeta, const char *name, SV *value) { apply_attribute(aTHX_ fieldmeta, name, value, APPLY_ATTRIBUTE_PARSE); } 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, FieldMeta *fieldmeta) { SV *fieldstore; FIELDOFFSET fieldix; ClassMeta *classmeta = fieldmeta->class; 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; if(flags & OPfMETHSTART_ROLE) o->op_flags |= OPf_SPECIAL; 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; U32 opflags_if_role = (classmeta->type == METATYPE_ROLE) ? OPfMETHSTART_ROLE : 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 | opflags_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(opflags_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(opflags_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; U32 opflags_if_role = (classmeta->type == METATYPE_ROLE) ? OPfMETHSTART_ROLE : 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(OPf_STACKED | opflags_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 | opflags_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.820/src/suspended_compcv.c000444001750001750 361314757670420 16624 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.820/t000755001750001750 014757670420 12433 5ustar00leoleo000000000000Object-Pad-0.820/t/00use.t000444001750001750 23514757670420 13671 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; use warnings; use Test2::V0; require Object::Pad; require Object::Pad::ExtensionBuilder; pass "Modules loaded"; done_testing; Object-Pad-0.820/t/01method.t000444001750001750 324714757670420 14404 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/02fields.t000444001750001750 700314757670420 14365 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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; } { class FieldWithListExpr { field @array = ( 0 ) x 5; } pass( 'Code compiles with listexpr as field initialiser' ); } 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.820/t/03create.t000444001750001750 733214757670420 14370 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/04adjust.t000444001750001750 1077514757670420 14445 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/04extend-classical.t000444001750001750 56714757670420 16334 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/05subclass.t000444001750001750 317714757670420 14751 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/06subclass-foreign-HASH.t000444001750001750 1047714757670420 17143 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/07subclass-foreign-ARRAY.t000444001750001750 216314757670420 17250 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/08subclass-Moo.t000444001750001750 163214757670420 15476 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/10method-attrs.t000444001750001750 214214757670420 15530 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/11method-signatures.t000444001750001750 343614757670420 16567 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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 } method empty () { @values = (); } } { 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' ); } # RT158048 { my @args; my $class_during_method; class WithCommonMethods { method cmeth :common ( @rest ) { $class_during_method = $class; @args = @rest; } } WithCommonMethods->cmeth( 1, 2, 3 ); is( \@args, [ 1 .. 3 ], 'args to :common method' ); is( $class_during_method, "WithCommonMethods", '$class during :common method' ); } done_testing; Object-Pad-0.820/t/12method-private.t000444001750001750 114314757670420 16047 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/13my-method.t000444001750001750 53614757670420 15010 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; use warnings; use Test2::V0; use Object::Pad 0.800; class AClass { field $data :param; my method priv { "data<$data>"; } method m { return priv($self); } } { my $obj = AClass->new( data => "value" ); is( $obj->m, "data", 'method can invoke lexical method from pad' ); } done_testing; Object-Pad-0.820/t/20fields-private.t000444001750001750 133114757670420 16033 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/21fields-capture.t000444001750001750 127014757670420 16027 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/22fields-accesssors.t000444001750001750 552714757670420 16546 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/23fields-signatures.t000444001750001750 66414757670420 16540 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/24fields-constructor.t000444001750001750 436014757670420 16757 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/25fields-weak.t000444001750001750 214014757670420 15314 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/26fields-initexpr.t000444001750001750 330414757670420 16233 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/30unit-class.t000444001750001750 45714757670420 15170 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/31pad-outside.t000444001750001750 157514757670420 15347 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/32threads.t000444001750001750 224414757670420 14556 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/33class-anon.t000444001750001750 46714757670420 15150 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/34class-abstract.t000444001750001750 251514757670420 16035 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; use warnings; use Test2::V0; use Object::Pad 0.800; class Base :abstract { field $f :param; method m1; method m2 { return $f; } } like( dies { Base->new }, qr/^Cannot directly construct an instance of abstract class 'Base' at /, 'failure from trying to ->new an abstract class' ); class Derived { inherit Base; method m1 { return "concrete"; } } pass( 'Able to derive from abstract class Base by providing m1' ); { my $obj = Derived->new( f => "field-value" ); ok( $obj, 'Able to construct an instance of Derived class' ); is( $obj->m1, "concrete", 'Derived->m1' ); is( $obj->m2, "field-value", 'Derived->m2' ); } ok( !eval <<'EOPERL', class Base2 { inherit Base; } EOPERL 'derived concrete class without required method fails' ); like( $@, qr/^Class Base2 does not provide a required method named 'm1' at /, 'message from failure to derive concrete class' ); class Base3 :abstract { inherit Base; } pass( 'Able to derive an abstract class from another without implementing missing methods' ); class Derived3 { inherit Base3; method m1 { return "non-abstract"; } } { my $obj = Derived3->new( f => "field-value" ); ok( $obj, 'Able to construct an instance of Derived3 class' ); is( $obj->m1, "non-abstract", 'Derived3->m1' ); } done_testing; Object-Pad-0.820/t/35my-class.t000444001750001750 205514757670420 14657 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; use warnings; use Test2::V0; use Object::Pad 0.800 ':experimental(lexical_class)'; { my class Point { field $x :param :reader; field $y :param :reader; } my $p = Point->new( x => 20, y => 40 ); ok( defined $p, 'Lexical class Point can ->new' ); is( $p->x, 20, 'Lexical class instances have methods' ); ok( !defined &Point::new, 'Point:: is not a package in the symbol table' ); ok( $p->isa( Point ), '->isa method works with lexical name as bareword' ); if( $^V ge v5.32 ) { eval <<'EOPERL' or die $@; use feature 'isa'; ok( $p isa Point, 'isa operator works with lexical class' ); 1; EOPERL } } { # A second lexical class of the same lexical name in its own scope should # be distinct my class Point { field $z :param :reader; } my $p = Point->new( z => 60 ); is( $p->z, 60, 'Second lexical class of the same name in its own scope works' ); ok( !$p->can( "x" ), 'Second lexical class is distinct from the first' ); } done_testing; Object-Pad-0.820/t/40role.t000444001750001750 471414757670420 14070 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/41role-repr.t000444001750001750 110314757670420 15024 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/42role-BUILD.t000444001750001750 173714757670420 14731 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/43role-fields.t000444001750001750 401314757670420 15327 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/44role-accessors.t000444001750001750 71014757670420 16027 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/45role-does.t000444001750001750 374614757670420 15031 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/49role-compat.t000444001750001750 126514757670420 15360 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/50croak-method.t000444001750001750 110214757670420 15471 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/51pragmata.t000444001750001750 355214757670420 14724 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/52croak-scope.t000444001750001750 162514757670420 15336 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/53croak-override.t000444001750001750 56414757670420 16026 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/54croak-role.t000444001750001750 253614757670420 15172 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/55croak-params.t000444001750001750 202614757670420 15507 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/60mop-class.t000444001750001750 220514757670420 15020 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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' ); ok( !$meta->is_abstract, '$meta->is_abstract 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' ); class Example3 :abstract { } ok( Object::Pad::MOP::Class->for_class( "Example3" )->is_abstract, '$meta->is_abstract on abstract class' ); 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.820/t/61mop-create-class.t000444001750001750 230514757670420 16263 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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' ); } { package BClass { BEGIN { Object::Pad->import_into( "BClass" ); my $classmeta = Object::Pad::MOP::Class->begin_class( "BClass", abstract => 1 ); ::ok( $classmeta->is_abstract, '$classmeta->is_abstract for abstract 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.820/t/62mop-field.t000444001750001750 650014757670420 15002 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/63mop-create-field.t000444001750001750 461514757670420 16251 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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' ); my $mref = eval( 'method :lvalue { $field }' ); my $e = $@; ok( defined $mref, 'Can compile method with lexical $field' ) or diag( "eval failed: $e" ); *field = $mref; 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.820/t/64mop-method.t000444001750001750 403514757670420 15202 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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' ); # should croak and not segfault like( dies { $classmeta->get_direct_method( 'ZZZ' ) }, qr/^Class Example does not have a method called 'ZZZ' at /, 'Failure message for ->get_direct_method missing' ); 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' ); } # lexical methods should not appear in the MOP { class CClass { my method lexmeth { return "OK" } } my $classmeta = Object::Pad::MOP::Class->for_class( "CClass" ); ok( dies { $classmeta->get_direct_method( 'lexmeth' ) }, 'lexical method is not visible via MOP' ); } done_testing; Object-Pad-0.820/t/65mop-create-method.t000444001750001750 314614757670420 16446 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/66mop-role.t000444001750001750 236714757670420 14673 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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' ); ok( $meta->is_abstract, '$meta->is_abstract true' ); 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.820/t/67mop-create-role.t000444001750001750 163214757670420 16127 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/68mop-compose-role.t000444001750001750 154214757670420 16332 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/69mop-generated.t000444001750001750 160514757670420 15665 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/70mop-custom-fieldattr.t000444001750001750 362014757670420 17204 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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' ); # custom attributes can be applied via MOP { my $classmeta = Object::Pad::MOP::Class->create_class( "WithAttrMOP" ); BEGIN { $^H{"t/SomeAttr"}++ } my $fieldmeta = $classmeta->add_field( '$field', attributes => [ "SomeAttr" => "the value", ], ); ok( $fieldmeta->has_attribute( "SomeAttr" ), 'MOP-added $field has :SomeAttr' ); is( $fieldmeta->get_attribute_value( "SomeAttr" ), "result-3", 'stored value for :SomeAttr' ); } done_testing; Object-Pad-0.820/t/71role-APPLY.t000444001750001750 171014757670420 14750 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; use warnings; use utf8; use Test2::V0; use Object::Pad 0.800 ':experimental(apply_phaser)'; my $cmop_during_APPLY; role ARole { APPLY { my ( $cmop ) = @_; $cmop_during_APPLY = $cmop; } } { class AClass { apply ARole; } my $got_cmop; BEGIN { $got_cmop = $cmop_during_APPLY; undef $cmop_during_APPLY; } ok( $got_cmop, 'saw class MOP during compiletime of class' ); is( $got_cmop->name, "AClass", 'class MOP ->name' ); } role BRole { apply ARole; } { my $got_cmop; BEGIN { $got_cmop = $cmop_during_APPLY; undef $cmop_during_APPLY; } ok( !defined $got_cmop, 'APPLY block does not run for role-in-role' ); } { class BClass { apply BRole; } my $got_cmop; BEGIN { $got_cmop = $cmop_during_APPLY; undef $cmop_during_APPLY; } ok( $got_cmop, 'saw class MOP during compiletime of class' ); is( $got_cmop->name, "BClass", 'class MOP ->name' ); } done_testing; Object-Pad-0.820/t/75metafunctions.t000444001750001750 517114757670420 16014 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/77repr-pvobj.t000444001750001750 366514757670420 15233 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/80async-method.t000444001750001750 420114757670420 15515 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; use warnings; use Test2::V0 0.000148; # is_refcount use Test2::Require::Module 'Future' => '0.49'; use Test2::Require::Module 'Future::AsyncAwait' => '0.45'; use Test2::Require::Module 'Object::Pad' => '0.800'; BEGIN { # 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::XS->VERSION( '0.08' ); }; } } use Future::AsyncAwait; use Object::Pad; # 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' ); } # RT151046 if( $^V ge v5.26 ) { eval <<'EOPERL' or die $@; role RT151046 { async method foo(); } EOPERL pass( 'Required method declarations may be declared as async' ); } done_testing; Object-Pad-0.820/t/80dynamically+Object-Pad.t000444001750001750 111214757670420 17332 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; use warnings; use Test2::V0; use Test2::Require::Module 'Object::Pad' => '0.800'; use Test2::Require::Module 'Syntax::Keyword::Dynamically'; use Object::Pad; use Syntax::Keyword::Dynamically; 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.820/t/80extended+Object-Pad.t000444001750001750 134014757670420 16627 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; use warnings; use Test2::V0; BEGIN { $] >= 5.026000 or plan skip_all => "No parse_subsignature()"; } use Test2::Require::Module 'Object::Pad' => '0.800'; use Test2::Require::Module 'Sublike::Extended' => '0.29'; use Object::Pad; use Sublike::Extended; # 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", 'extended method' ); } # method + S:E 0.29 { use Sublike::Extended 'method'; class C2 { method f (:$x, :$y) { return "x=$x y=$y" } } is( C2->new->f( x => "third", y => "fourth" ), "x=third y=fourth", 'method with extended keyword' ); } done_testing; Object-Pad-0.820/t/81async-method+dynamically.t000444001750001750 221214757670420 20020 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; use warnings; use Test2::V0; use Test2::Require::Module 'Future' => '0.49'; use Test2::Require::Module 'Future::AsyncAwait' => '0.40'; use Test2::Require::Module 'Object::Pad' => '0.800'; use Test2::Require::Module 'Syntax::Keyword::Dynamically' => '0.04'; use Future::AsyncAwait; use Object::Pad; use Syntax::Keyword::Dynamically; # 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.820/t/82devel-mat-dumper-helper.t000444001750001750 400214757670420 17550 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; use warnings; use Test2::V0; # requires Devel::MAT >= 0.53 in case Devel::MAT::Dumper writes a file in # format version 0.6 use Test2::Require::Module 'Devel::MAT' => '0.53'; use Object::Pad 0.800; class AClass { field $afield :param :reader; } my $obj = AClass->new( afield => 123 ); require Devel::MAT::Dumper; ( 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.820/t/90leak.t000444001750001750 214014757670420 14037 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/91rt141483.t000444001750001750 37614757670420 14227 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/92legacy.t000444001750001750 355314757670420 14402 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/93legacy-pragmata.t000444001750001750 110114757670420 16160 0ustar00leoleo000000000000#!/usr/bin/perl # specifically *don't* # use v5.18; # 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.820/t/94experimental.t000444001750001750 154714757670420 15636 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/95utf8.t000444001750001750 254414757670420 14026 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/99pod.t000444001750001750 25514757670420 13703 0ustar00leoleo000000000000#!/usr/bin/perl use v5.18; 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.820/t/lib000755001750001750 014757670420 13201 5ustar00leoleo000000000000Object-Pad-0.820/t/lib/91rt141483Role.pm000444001750001750 17614757670420 15766 0ustar00leoleo000000000000use v5.18; use warnings; use Object::Pad 0.800; role R { my $name = "Gantenbein"; method name { $name }; } 0x55AA;