meta-0.013000755001750001750 015002211532 11153 5ustar00leoleo000000000000meta-0.013/.editorconfig000444001750001750 5315002211532 13723 0ustar00leoleo000000000000root = true [*.{pm,pl,t}] indent_size = 3 meta-0.013/Build.PL000444001750001750 105115002211532 12601 0ustar00leoleo000000000000use v5; use strict; use warnings; use Module::Build; my @extra_compiler_flags; push @extra_compiler_flags, qw( -DDEBUGGING=-g ) if $^X =~ m|/debugperl|; my $build = Module::Build->new( module_name => 'meta', configure_requires => { 'Module::Build' => "0.4004", # test_requires }, requires => { 'perl' => '5.014', }, test_requires => { 'Test2::V0' => 0, }, license => 'perl', create_license => 1, create_readme => 1, extra_compiler_flags => \@extra_compiler_flags, ); $build->create_build_script; meta-0.013/Changes000444001750001750 575615002211532 12620 0ustar00leoleo000000000000Revision history for meta 0.013 2025-04-23 [BUGFIXES] * Skip t/80subname+Sub-Util.t on perls that don't have Sub::Util 0.012 2024-10-14 [BUGFIXES] * Make `$metasub->signature` work correctly on `method` subs of Perl 5.38 0.011 2024-10-08 [BUGFIXES] * Various small fixes to avoid upsetting `gcc -Wall` 0.010 2024-10-01 [CHANGES] * Added `$metasub->signature` and the meta-signature object representation [BUGFIXES] * Don't leak extra `SVt_NULL` SVs from the internal `wrap_*()` helper functions 0.009 2024-09-14 [CHANGES] * Added `$metapkg->is_class` and `$metasub->is_method` for querying about elements created with Perl 5.38's `use feature 'class'` [BUGFIXES] * Use `GvCVu()` when looking at the CV slot of a GV so as not to get confused about method caches 0.008 2024-09-11 [CHANGES] * Added `$metapkg->add_named_sub` for efficiently adding subroutines and setting the subname of them at the same time * Complain if the `->get` method is called on a metapackage instance, and remind users they probably wanted a `->get_*` method instead 0.007 2024-09-10 [CHANGES] * Added `meta::for_reference()` * Added `$metasub->set_subname` and `->set_prototype`, which can be used to replace `Sub::Util`. * Account for refcount retention of referred items when creating meta wrappers, now that the `for_reference()` constructor can wrap anonymous things too 0.006 2024-09-06 [CHANGES] * Added `$metapkg->list_symbols` and `$metapkg->list_subpackages` methods 0.005 2024-09-06 [CHANGES] * Added `meta::package->list_globs` and variations * Declare the `->can_...` prefixed methods as deprecated, print a deprecation warning when calling them 0.004 2024-01-06 [CHANGES] * Emit warnings in the `meta::experimental` category from all entrypoint functions. * Added `meta::package->get` and `meta::glob->get` constructors * Added `->try_get_...` name variant of all the `can` methods * Added `meta::glob->try_get` * Added `meta::glob->get_or_add` and `$metapkg->get_or_add_symbol` [BUGFIXES] * Avoid C99-style variable declaration in for loop * Make sure to define _MUST_SVTYPE_FROM_REFSV also for compilers that lack PERL_USE_GCC_BRACE_GROUPS 0.003 2023-12-31 [CHANGES] * Add documentation pointing out it's experimental * Add a SEE ALSO link to the PPC 0022 document (no actual code change) 0.002 2023-12-29 [CHANGES] * Provide a real non-placeholder implementation 0.001 2023-09-20 First version, released on an unsuspecting world. Purely placeholder for the name while developing in devel versions meta-0.013/LICENSE000444001750001750 4653415002211532 12351 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 meta-0.013/MANIFEST000444001750001750 51015002211532 12415 0ustar00leoleo000000000000.editorconfig Build.PL Changes lib/meta.pm lib/meta.xs LICENSE MANIFEST This list of files META.json META.yml README t/00use.t t/01package.t t/02glob.t t/03symbols.t t/10variables.t t/11subroutines.t t/12sub-signature.t t/20add.t t/21remove.t t/60class.t t/61method-signature.t t/80subname+Sub-Util.t t/94warnings.t t/99pod.t meta-0.013/META.json000444001750001750 207315002211532 12733 0ustar00leoleo000000000000{ "abstract" : "meta-programming API", "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" : "meta", "prereqs" : { "build" : { "requires" : { "ExtUtils::CBuilder" : "0" } }, "configure" : { "requires" : { "Module::Build" : "0.4004" } }, "runtime" : { "requires" : { "perl" : "5.014" } }, "test" : { "requires" : { "Test2::V0" : "0" } } }, "provides" : { "meta" : { "file" : "lib/meta.pm", "version" : "0.013" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.013", "x_serialization_backend" : "JSON::PP version 4.16" } meta-0.013/META.yml000444001750001750 116115002211532 12560 0ustar00leoleo000000000000--- abstract: 'meta-programming API' author: - 'Paul Evans ' build_requires: ExtUtils::CBuilder: '0' Test2::V0: '0' configure_requires: Module::Build: '0.4004' 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: meta provides: meta: file: lib/meta.pm version: '0.013' requires: perl: '5.014' resources: license: http://dev.perl.org/licenses/ version: '0.013' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' meta-0.013/README000444001750001750 3421315002211532 12213 0ustar00leoleo000000000000NAME meta - meta-programming API SYNOPSIS use v5.14; use meta; my $metapkg = meta::get_package( "MyApp::Some::Package" ); $metapkg->add_symbol( '&a_function' => sub { say "New function was created" } ); MyApp::Some::Package::a_function(); DESCRIPTION This package provides an API for metaprogramming; that is, allowing code to inspect or manipulate parts of its own program structure. Parts of the perl interpreter itself can be accessed by means of "meta"-objects provided by this package. Methods on these objects allow inspection of details, as well as creating new items or removing existing ones. The intention of this API is to provide a nicer replacement for existing tricks such as no strict 'refs' and using globrefs, and also to be a more consistent place to add new abilities, such as more APIs for inspection and alteration of internal structures, metaprogramming around the new 'class' feature, and other such uses. This module should be considered experimental; no API stability guarantees are made at this time. Behaviour may be added, altered, or removed in later versions. Once a workable API shape has been found, it is hoped that this module will eventually become dual-life and shipped as part of Perl core, as the implementation for PPC 0022. See the link in the "SEE ALSO" section. This module attempts to find a balance between accurately representing low-level concepts within the current implementation of the Perl interpreter, while also providing higher-level abstractions that provide useful behaviour for code that uses it. One place this can be seen is the lower-level "list_globs" method, which directly maps to the way that GVs are stored in symbol table stashes but requires the user to be aware of the GV-less optimisised storage of CVs, as compared to the higher-level "list_symbols" method which provides an abstraction over this complication and presents the more useful but less accurate impression of separately named symbols that neatly map to their values. Since version 0.003_002 all the entry-point functions and constructors in this module will provoke warnings in the meta::experimental category. They can be silenced by use meta; no warnings 'meta::experimental'; Since version 0.005 the various can_...-prefixed variant accessor methods print deprecation warnings. They are likely to be removed soon. FUNCTIONS get_package $metapkg = meta::get_package( $pkgname ); Returns a metapackage reference representing the given package name, creating it if it did not previously exist. An alternative to meta::package->get in a plain function style. get_this_package $metapkg = meta::get_this_package; Since version 0.002. Returns a metapackage reference representing the package of the code that called the function. Useful for performing meta-programming on the contents of a module during its BEGIN or loading time. Equivalent to but more efficient than the following: meta::get_package(__PACKAGE__) for_reference $metasym = meta::for_reference( $ref ); Since version 0.007. Returns a metasymbol reference representing the glob, variable or subroutine that is pointed to by the given reference. Note that passing in a reference to a symbol table hash ("stash") does not result in a metapackage. For that you will have to call "get_package" or similar. METHODS ON meta::package get $metapkg = meta::package->get( $pkgname ); Since version 0.003_001. Returns a metapackage reference representing the given package name, creating it if it did not previously exist. An alternative to meta::get_package in an object constructor style. is_class $bool = $metapkg->is_class; Since version 0.009. Returns true if on a version of Perl that supports use feature 'class', and the package being represented is a real class created by that feature. False for regular packages, and always false on earlier versions of Perl before that feature was introduced. name $name = $metapkg->name; Returns the name of the package being represented. get_glob $metaglob = $metapkg->get_glob( $name ); Returns a metaglob reference representing the given symbol name within the package, if it exists. Throws an exception if not. try_get_glob, can_glob $metaglob = $metapkg->try_get_glob( $name ); $metaglob = $metapkg->can_glob( $name ); Similar to "get_glob" but returns undef if the glob does not exist. list_globs @metaglobs = $metapkg->list_globs; Since version 0.005. Returns a list of all the globs in the package that may refer to symbols (i.e. not subpackages). They are returned in no particular order. For a more convenient return value form, see also "list_symbols". list_subpackage_globs list_all_globs @metaglobs = $metapkg->list_subpackage_globs; @metaglobs = $metapkg->list_all_globs; Since version 0.005. Returns a list of all the globs in the package that refer to subpackages, or all globs, including subpackages. They are returned in no particular order. For a more convenient return value form, see also "list_subpackages". get_symbol $metasym = $metapkg->get_symbol( $name ); Returns a metasymbol reference representing the given symbol name within the package. The symbol name should include the leading sigil; one of the characters *, $, @, % or &. Throws an exception if the symbol does not exist. try_get_symbol, can_symbol $metasym = $metapkg->try_get_symbol( $name ); $metasym = $metapkg->can_symbol( $name ); Similar to "get_symbol" but returns undef if the symbol does not exist. add_symbol $metasym = $metapkg->add_symbol( $name, $valueref ); Creates a new symbol of the given name in the given package. The new symbol will refer to the item given by reference, whose type must match the sigil of the symbol name. Returns a metasymbol reference as per "get_symbol". If a symbol already existed of the given name then an exception is thrown. Note that this does not create a copy of a variable, but stores an alias to the referred item itself within the symbol table. $metapkg->add_symbol( '@things', \my @array ); push @array, "more", "values"; # these values are now visible in the @things array If adding a scalar, array or hash variable, the $valueref argument is optional. If not provided then a new, blank variable of the correct type will be created. get_or_add_symbol $metasym = $metapkg->get_or_add_symbol( $name, $valueref ); Since version 0.003_003. Similar to "get_symbol" but creates a new symbol if it didn't already exist as per "add_symbol". Note that if the symbol did already exist it is returned and $valueref will be ignored. The symbol will not be modified in that case to point to the value referred to instead. remove_symbol $metapkg->remove_symbol( $name ); Removes a symbol of the given name from the given package. If the symbol was the last item in the glob then the glob too is removed from the package. If the named symbol did not previously exist then an exception is thrown. To only conditionally remove a symbol if it already exists, test for it first by using "try_get_symbol": $metapkg->try_get_symbol( '$variable' ) and $metapkg->remove_symbol( '$variable' ); list_symbols %sub_metasyms = $metapkg->list_symbols; %sub_metasyms = $metapkg->list_symbols( sigils => $filter ); Since version 0.006. Returns an even-sized key/value list containing the symbols within the given package instance. Each symbol is returned as a pair, with its sigil-prefixed basename first, followed by a metasymbol instance representing it. Since the sigil-prefixed names must be unique, it is convenient to assign this list into a hash. The symbols are returned in no particular order. If the optional sigils named parameter is given, it should be a string of possible symbol sigils (the characters $, @, % or &). In this case, only symbols whose sigil is present in this string will be returned. list_subpackages %sub_metapkgs = $metapkg->list_subpackages; Since version 0.006. Returns an even-sized key/value list containing the immediate sub-packages of the given package instance. Each sub-package is returned as a pair, with its basename first (minus the "::" suffix), followed by a metapackage instance representing it. Since the names of each sub-package must be unique, it is convenient to assign this list into a hash. The sub-packages are returned in no particular order. add_named_sub $metasub = $metapkg->add_named_sub( $name, $code ); Since version 0.008. A convenient shortcut for adding a subroutine symbol and setting the subname of the newly-added sub. Equivalent to calling "add_symbol" and then "set_subname" on its result, but more efficient as it does not have to create a separate fake GV to store the subname in. Note that $name should be given as a barename, without the leading & sigil. METHODS ON METASYMBOLS is_glob, is_scalar, ... $bool = $metasym->is_glob; $bool = $metasym->is_scalar; $bool = $metasym->is_array; $bool = $metasym->is_hash; $bool = $metasym->is_subroutine; Returns true if the symbol being referred to is of the given type, or false if not. reference $ref = $metasym->reference; Returns a regular Perl reference to the symbol being represented. METHODS ON meta::glob get $metaglob = meta::glob->get( $globname ); Since version 0.003_001. Returns a metaglob reference representing the given symbol from the symbol table from a fully-qualified name, if it exists. Throws an exception if not. try_get $metaglob = meta::glob->try_get( $globname ); Since version 0.003_003. Similar to "get" but returns undef if the given symbol does not exist. get_or_add $metaglob = meta::glob->get_or_add( $globname ); Since version 0.003_003. Similar to "get" but creates the symbol if it didn't already exist. basename $name = $metaglob->basename; Returns the name of the glob within its package. get_scalar, get_array, ... $metasym = $metaglob->get_scalar; $metasym = $metaglob->get_array; $metasym = $metaglob->get_hash; $metasym = $metaglob->get_code; Returns a metasymbol reference representing the symbol in the given slot of the glob, if it exists. Throws an exception if not. try_get_scalar, try_get_array, ... Similar to "get_scalar", "get_array", etc... but returns undef if the given slot does not exist. METHODS ON METAVARIABLES value $scalar = $metavar->value; @array = $metavar->value; %hash = $metavar->value; $count = scalar $metavar->value; Returns the current value of the variable, as if it appeared in regular Perl code. METHODS ON METASUBROUTINES is_method $bool = $metasub->is_method; Since version 0.009. Returns true if on a version of Perl that supports use feature 'class', and the subroutine being represented is a real method created by that feature. False for regular sub-based subroutines, and always false on earlier versions of Perl before that feature was introduced. subname $name = $metasub->subname; Returns the (fully-qualified) name of the subroutine. set_subname $metasub = $metasub->set_subname( $name ); Since version 0.007. Sets a new name for the subroutine. If $name is not fully-qualified (i.e. does not contain a :: sequence), then the package name of the caller is used to create the fully-qualified name to be stored. prototype $proto = $metasub->prototype; Returns the prototype of the subroutine. set_prototype $metasub = $metasub->set_prototype( $proto ); Since version 0.007. Sets a new prototype for the subroutine. Returns the $metasub instance itself to allow for easy chaining. signature $metasig = $metasub->signature; Since version 0.010. If on Perl version 5.26 or above and the subroutine has a signature, returns an object reference representing details about the signature. This can be queried using the methods below. If the subroutine does not use a signature (or on Perl versions before 5.26) returns undef. METHODS ON SUBROUTINE METASIGNATURES mandatory_params $n = $metasig->mandatory_params; Returns the number of parameters that are mandatory (i.e. do not have a defaulting expression). This is the minimum number of argument values that must be passed to any call of this function and does not count a final slurpy parameter. Note that the implicit $self parameter to a method subroutine is included in this count. This count will always be at least 1 on such a method. optional_params $n = $metasig->optional_params; Returns the number of parameters that are optional (i.e. have a defaulting expression). slurpy $slurpy = $metasig->slurpy; Returns the sigil character associated with the final slurpy parameter if it exists (i.e. % or @), or undef if no slurpy parameter is defined. min_args max_args $n = $metasig->min_args; $n = $metasig->max_args; Returns the minimum or maximum number of argument values that can be passed to a call to this function. min_args is the same as mandatory_params but is offered as an alias in case the data model ever changes. max_args will be undef if the function uses a slurpy final parameter. TODO * Access to the new parts of API introduced by Perl 5.38 to deal with classes, methods, fields. SEE ALSO PPC 0022 "metaprogramming" AUTHOR Paul Evans meta-0.013/lib000755001750001750 015002211532 11721 5ustar00leoleo000000000000meta-0.013/lib/meta.pm000444001750001750 3543715002211532 13376 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, 2023-2024 -- leonerd@leonerd.org.uk package meta 0.013; use v5.14; use warnings; require XSLoader; XSLoader::load( __PACKAGE__, our $VERSION ); use Carp; # Hackery to make warnings::warnif callable from XS, on perls too old to have # warnif_at_level $^V ge v5.28 or *warnif_trampoline = sub { warnings::warnif(@_); }; =head1 NAME C - meta-programming API =head1 SYNOPSIS =for highlighter language=perl use v5.14; use meta; my $metapkg = meta::get_package( "MyApp::Some::Package" ); $metapkg->add_symbol( '&a_function' => sub { say "New function was created" } ); MyApp::Some::Package::a_function(); =head1 DESCRIPTION This package provides an API for metaprogramming; that is, allowing code to inspect or manipulate parts of its own program structure. Parts of the perl interpreter itself can be accessed by means of "meta"-objects provided by this package. Methods on these objects allow inspection of details, as well as creating new items or removing existing ones. The intention of this API is to provide a nicer replacement for existing tricks such as C and using globrefs, and also to be a more consistent place to add new abilities, such as more APIs for inspection and alteration of internal structures, metaprogramming around the new C<'class'> feature, and other such uses. This module should be considered B; no API stability guarantees are made at this time. Behaviour may be added, altered, or removed in later versions. Once a workable API shape has been found, it is hoped that this module will eventually become dual-life and shipped as part of Perl core, as the implementation for PPC 0022. See the link in the L section. This module attempts to find a balance between accurately representing low-level concepts within the current implementation of the Perl interpreter, while also providing higher-level abstractions that provide useful behaviour for code that uses it. One place this can be seen is the lower-level L method, which directly maps to the way that GVs are stored in symbol table stashes but requires the user to be aware of the GV-less optimisised storage of CVs, as compared to the higher-level L method which provides an abstraction over this complication and presents the more useful but less accurate impression of separately named symbols that neatly map to their values. I all the entry-point functions and constructors in this module will provoke warnings in the C category. They can be silenced by use meta; no warnings 'meta::experimental'; I the various C-prefixed variant accessor methods print deprecation warnings. They are likely to be removed soon. =cut =head1 FUNCTIONS =head2 get_package $metapkg = meta::get_package( $pkgname ); Returns a metapackage reference representing the given package name, creating it if it did not previously exist. An alternative to C<< meta::package->get >> in a plain function style. =head2 get_this_package $metapkg = meta::get_this_package; I Returns a metapackage reference representing the package of the code that called the function. Useful for performing meta-programming on the contents of a module during its C or loading time. Equivalent to but more efficient than the following: meta::get_package(__PACKAGE__) =head2 for_reference $metasym = meta::for_reference( $ref ); I Returns a metasymbol reference representing the glob, variable or subroutine that is pointed to by the given reference. Note that passing in a reference to a symbol table hash ("stash") does not result in a metapackage. For that you will have to call L or similar. =cut =head1 METHODS ON C =head2 get $metapkg = meta::package->get( $pkgname ); I Returns a metapackage reference representing the given package name, creating it if it did not previously exist. An alternative to C in an object constructor style. =head2 is_class $bool = $metapkg->is_class; I Returns true if on a version of Perl that supports C, and the package being represented is a real C created by that feature. False for regular packages, and always false on earlier versions of Perl before that feature was introduced. =head2 name $name = $metapkg->name; Returns the name of the package being represented. =head2 get_glob $metaglob = $metapkg->get_glob( $name ); Returns a metaglob reference representing the given symbol name within the package, if it exists. Throws an exception if not. =head2 try_get_glob, can_glob $metaglob = $metapkg->try_get_glob( $name ); $metaglob = $metapkg->can_glob( $name ); Similar to L but returns undef if the glob does not exist. =head2 list_globs @metaglobs = $metapkg->list_globs; I Returns a list of all the globs in the package that may refer to symbols (i.e. not subpackages). They are returned in no particular order. For a more convenient return value form, see also L. =head2 list_subpackage_globs =head2 list_all_globs @metaglobs = $metapkg->list_subpackage_globs; @metaglobs = $metapkg->list_all_globs; I Returns a list of all the globs in the package that refer to subpackages, or all globs, including subpackages. They are returned in no particular order. For a more convenient return value form, see also L. =head2 get_symbol $metasym = $metapkg->get_symbol( $name ); Returns a metasymbol reference representing the given symbol name within the package. The symbol name should include the leading sigil; one of the characters C<*>, C<$>, C<@>, C<%> or C<&>. Throws an exception if the symbol does not exist. =head2 try_get_symbol, can_symbol $metasym = $metapkg->try_get_symbol( $name ); $metasym = $metapkg->can_symbol( $name ); Similar to L but returns undef if the symbol does not exist. =head2 add_symbol $metasym = $metapkg->add_symbol( $name, $valueref ); Creates a new symbol of the given name in the given package. The new symbol will refer to the item given by reference, whose type must match the sigil of the symbol name. Returns a metasymbol reference as per L. If a symbol already existed of the given name then an exception is thrown. I that this does not create a copy of a variable, but stores an alias to the referred item itself within the symbol table. $metapkg->add_symbol( '@things', \my @array ); push @array, "more", "values"; # these values are now visible in the @things array If adding a scalar, array or hash variable, the C<$valueref> argument is optional. If not provided then a new, blank variable of the correct type will be created. =head2 get_or_add_symbol $metasym = $metapkg->get_or_add_symbol( $name, $valueref ); I Similar to L but creates a new symbol if it didn't already exist as per L. Note that if the symbol did already exist it is returned and C<$valueref> will be ignored. The symbol will not be modified in that case to point to the value referred to instead. =head2 remove_symbol $metapkg->remove_symbol( $name ); Removes a symbol of the given name from the given package. If the symbol was the last item in the glob then the glob too is removed from the package. If the named symbol did not previously exist then an exception is thrown. To only conditionally remove a symbol if it already exists, test for it first by using L: $metapkg->try_get_symbol( '$variable' ) and $metapkg->remove_symbol( '$variable' ); =head2 list_symbols %sub_metasyms = $metapkg->list_symbols; %sub_metasyms = $metapkg->list_symbols( sigils => $filter ); I Returns an even-sized key/value list containing the symbols within the given package instance. Each symbol is returned as a pair, with its sigil-prefixed basename first, followed by a metasymbol instance representing it. Since the sigil-prefixed names must be unique, it is convenient to assign this list into a hash. The symbols are returned in no particular order. If the optional C named parameter is given, it should be a string of possible symbol sigils (the characters C<$>, C<@>, C<%> or C<&>). In this case, only symbols whose sigil is present in this string will be returned. =head2 list_subpackages %sub_metapkgs = $metapkg->list_subpackages; I Returns an even-sized key/value list containing the immediate sub-packages of the given package instance. Each sub-package is returned as a pair, with its basename first (minus the "::" suffix), followed by a metapackage instance representing it. Since the names of each sub-package must be unique, it is convenient to assign this list into a hash. The sub-packages are returned in no particular order. =cut # Named param handling is a lot easier in pureperl sub meta::package::list_symbols { my ( $self, %params ) = @_; my $sigils = delete $params{sigils}; keys %params and croak "Unrecognised named parameters to meta::package::list_symbols: " . join( ", ", sort keys %params ); return meta::package::_list_symbols( $self, $sigils ); } =head2 add_named_sub $metasub = $metapkg->add_named_sub( $name, $code ); I A convenient shortcut for adding a subroutine symbol and setting the subname of the newly-added sub. Equivalent to calling L and then L on its result, but more efficient as it does not have to create a separate fake GV to store the subname in. Note that C<$name> should be given as a barename, without the leading C<&> sigil. =cut =head1 METHODS ON METASYMBOLS =head2 is_glob, is_scalar, ... $bool = $metasym->is_glob; $bool = $metasym->is_scalar; $bool = $metasym->is_array; $bool = $metasym->is_hash; $bool = $metasym->is_subroutine; Returns true if the symbol being referred to is of the given type, or false if not. =head2 reference $ref = $metasym->reference; Returns a regular Perl reference to the symbol being represented. =cut =head1 METHODS ON C =cut @meta::glob::ISA = qw( meta::symbol ); =head2 get $metaglob = meta::glob->get( $globname ); I Returns a metaglob reference representing the given symbol from the symbol table from a fully-qualified name, if it exists. Throws an exception if not. =head2 try_get $metaglob = meta::glob->try_get( $globname ); I Similar to L but returns undef if the given symbol does not exist. =head2 get_or_add $metaglob = meta::glob->get_or_add( $globname ); I Similar to L but creates the symbol if it didn't already exist. =head2 basename $name = $metaglob->basename; Returns the name of the glob I. =head2 get_scalar, get_array, ... $metasym = $metaglob->get_scalar; $metasym = $metaglob->get_array; $metasym = $metaglob->get_hash; $metasym = $metaglob->get_code; Returns a metasymbol reference representing the symbol in the given slot of the glob, if it exists. Throws an exception if not. =head2 try_get_scalar, try_get_array, ... Similar to L, L, etc... but returns undef if the given slot does not exist. =cut =head1 METHODS ON METAVARIABLES =cut @meta::variable::ISA = qw( meta::symbol ); =head2 value $scalar = $metavar->value; @array = $metavar->value; %hash = $metavar->value; $count = scalar $metavar->value; Returns the current value of the variable, as if it appeared in regular Perl code. =cut =head1 METHODS ON METASUBROUTINES =cut @meta::subroutine::ISA = qw( meta::symbol ); =head2 is_method $bool = $metasub->is_method; I Returns true if on a version of Perl that supports C, and the subroutine being represented is a real C created by that feature. False for regular C-based subroutines, and always false on earlier versions of Perl before that feature was introduced. =head2 subname $name = $metasub->subname; Returns the (fully-qualified) name of the subroutine. =head2 set_subname $metasub = $metasub->set_subname( $name ); I Sets a new name for the subroutine. If C<$name> is not fully-qualified (i.e. does not contain a C<::> sequence), then the package name of the caller is used to create the fully-qualified name to be stored. =head2 prototype $proto = $metasub->prototype; Returns the prototype of the subroutine. =head2 set_prototype $metasub = $metasub->set_prototype( $proto ); I Sets a new prototype for the subroutine. Returns the C<$metasub> instance itself to allow for easy chaining. =head2 signature $metasig = $metasub->signature; I If on Perl version 5.26 or above and the subroutine has a signature, returns an object reference representing details about the signature. This can be queried using the methods below. If the subroutine does not use a signature (or on Perl versions before 5.26) returns C. =cut =head1 METHODS ON SUBROUTINE METASIGNATURES =head2 mandatory_params $n = $metasig->mandatory_params; Returns the number of parameters that are mandatory (i.e. do not have a defaulting expression). This is the minimum number of argument values that must be passed to any call of this function and does not count a final slurpy parameter. Note that the implicit C<$self> parameter to a C subroutine is included in this count. This count will always be at least 1 on such a method. =head2 optional_params $n = $metasig->optional_params; Returns the number of parameters that are optional (i.e. have a defaulting expression). =head2 slurpy $slurpy = $metasig->slurpy; Returns the sigil character associated with the final slurpy parameter if it exists (i.e. C<%> or C<@>), or C if no slurpy parameter is defined. =head2 min_args =head2 max_args $n = $metasig->min_args; $n = $metasig->max_args; Returns the minimum or maximum number of argument values that can be passed to a call to this function. C is the same as C but is offered as an alias in case the data model ever changes. C will be C if the function uses a slurpy final parameter. =cut =head1 TODO =over 4 =item Access to the new parts of API introduced by Perl 5.38 to deal with classes, methods, fields. =back =cut =head1 SEE ALSO L =cut =head1 AUTHOR Paul Evans =cut 0x55AA; meta-0.013/lib/meta.xs000444001750001750 7235515002211532 13414 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 */ #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #define HAVE_PERL_VERSION(R, V, S) \ (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) #if !HAVE_PERL_VERSION(5,16,0) # define true TRUE # define false FALSE /* CvPROTO was just stored in SvPV */ # define CvPROTO(cv) SvPVX(cv) # define CvPROTOLEN(cv) SvCUR(cv) /* HvNAMELEN did not exist; stash names cannot contain \0 */ # define HvNAMELEN(stash) strlen(HvNAME(stash)) /* HvNAME and GvNAME could never be UTF-8 */ # define HvNAMEUTF8(hv) 0 # define GvNAMEUTF8(gv) 0 # define gv_init_sv(gv, stash, sv, flags) \ gv_init(gv, stash, SvPV_nolen(sv), SvCUR(sv), SvUTF8(sv) | flags) # define gv_init_pvn(gv, stash, pv, len, flags) \ gv_init(gv, stash, pv, len, flags) #endif #if !HAVE_PERL_VERSION(5, 22, 0) /* copypaste from perl-v5.22.0/perl.h */ # ifndef DEBUGGING # if __has_builtin(__builtin_unreachable) \ || (__GNUC__ == 4 && __GNUC_MINOR__ >= 5 || __GNUC__ > 4) /* 4.5 -> */ # define ASSUME(x) ((x) ? (void) 0 : __builtin_unreachable()) # elif defined(_MSC_VER) # define ASSUME(x) __assume(x) # elif defined(__ARMCC_VERSION) /* untested */ # define ASSUME(x) __promise(x) # else /* a random compiler might define assert to its own special optimization token so pass it through to C lib as a last resort */ # define ASSUME(x) assert(x) # endif # else # define ASSUME(x) assert(x) # endif # define NOT_REACHED ASSUME(0) #endif #if HAVE_PERL_VERSION(5, 26, 0) # define HAVE_SUB_SIGNATURES #endif #ifndef av_count # define av_count(av) (AvFILL(av)+1) #endif #ifndef G_LIST # define G_LIST G_ARRAY #endif #ifndef CvREFCNT_inc # define CvREFCNT_inc(cv) ((CV *)SvREFCNT_inc((SV *)(cv))) #endif #if defined (DEBUGGING) && defined(PERL_USE_GCC_BRACE_GROUPS) # define _MUST_SVTYPE_FROM_REFSV(rsv, type, svt) \ ({ type sv = (type)(SvUV(SvRV(rsv))); assert(sv && SvTYPE(sv) == svt); sv; }) #else # define _MUST_SVTYPE_FROM_REFSV(rsv, type, svt) \ ((type)(SvUV(SvRV(rsv)))) #endif #define MUST_STASH_FROM_REFSV(sv) _MUST_SVTYPE_FROM_REFSV(sv, HV *, SVt_PVHV) #define MUST_GV_FROM_REFSV(sv) _MUST_SVTYPE_FROM_REFSV(sv, GV *, SVt_PVGV) #define MUST_CV_FROM_REFSV(sv) _MUST_SVTYPE_FROM_REFSV(sv, CV *, SVt_PVCV) #define SV_FROM_REFSV(sv) \ ((SV *)(SvUV(SvRV(sv)))) #define wrap_sv_refsv(sv) S_wrap_sv_refsv(aTHX_ sv) SV *S_wrap_sv_refsv(pTHX_ SV *sv) { const char *metaclass; switch(SvTYPE(sv)) { case SVt_PVGV: metaclass = "meta::glob"; break; case SVt_PVCV: metaclass = "meta::subroutine"; break; default: metaclass = "meta::variable"; break; } return sv_setref_uv(newSV(0), metaclass, PTR2UV(SvREFCNT_inc(sv))); } #define wrap_stash(stash) S_wrap_stash(aTHX_ stash) static SV *S_wrap_stash(pTHX_ HV *stash) { // TODO: Do we need to refcnt_inc stash? return sv_setref_uv(newSV(0), "meta::package", PTR2UV(stash)); } struct CVwithOP { CV *cv; OP *op; U32 flags; }; enum { CVSIGNATURE_IS_METHOD = (1<<0), }; #define wrap_cv_signature(cv, op, flags) S_wrap_cv_signature(aTHX_ cv, op, flags) static SV *S_wrap_cv_signature(pTHX_ CV *cv, OP *op, U32 flags) { struct CVwithOP ret = { .cv = CvREFCNT_inc(cv), .op = op, .flags = flags }; return sv_setref_pvn(newSV(0), "meta::subsignature", (const char *)&ret, sizeof(ret)); } #ifdef SVf_QUOTEDPREFIX # define CROAK_QUOTED_PREFIX(msg, arg) \ croak(msg "%" SVf_QUOTEDPREFIX, arg) #else # define CROAK_QUOTED_PREFIX(msg, arg) \ croak(msg "\"%" SVf "\"", arg) #endif #define gv_is_empty(gv) S_gv_is_empty(aTHX_ gv) static bool S_gv_is_empty(pTHX_ GV *gv) { if(SvFAKE(gv) || GvSV(gv) || GvAV(gv) || GvHV(gv) || GvCV(gv) || GvIO(gv) || GvFORM(gv)) return false; /* TODO: any other safety checks? */ return true; } /* Some helpers for warnings.pm * * The custom warning categories defined by warnings.pm are implemented * entirely in the Perl code, so interacting with it means a lot of call_pv() * wrapper functions. * * The warnings::warnif function is intended to be called from Perl, and * presumes the caller stack will have a corresponding caller frame that it * should skip. Since we're calling it here from XSUBs that does not happen, * so we have to take extra measures to ensure it sees the correct caller * context. */ #if HAVE_PERL_VERSION(5, 28, 0) # define HAVE_WARNINGS_WARNIF_AT_LEVEL #endif #define warnings_register_category(category) S_warnings_register_category(aTHX_ category) static void S_warnings_register_category(pTHX_ const char *category) { dSP; ENTER; EXTEND(SP, 1); PUSHMARK(SP); mPUSHp(category, strlen(category)); PUTBACK; call_pv("warnings::register_categories", G_VOID); LEAVE; } #define warnings_warnsvif(category, msv) S_warnings_warnsvif(aTHX_ category, msv) static void S_warnings_warnsvif(pTHX_ const char *category, SV *msv) { dSP; ENTER; #ifdef HAVE_WARNINGS_WARNIF_AT_LEVEL EXTEND(SP, 3); PUSHMARK(SP); mPUSHp(category, strlen(category)); mPUSHi(-1); // level = -1 because our XSUB does not have a caller frame PUSHs(msv); PUTBACK; call_pv("warnings::warnif_at_level", G_VOID); #else // warnings::warnif needs to see an extra call frame here. There's no way // to hack this up using cx_pushblock etc... as that only works for pureperl // CVs. We'll just have to use a trampoline EXTEND(SP, 2); PUSHMARK(SP); mPUSHp(category, strlen(category)); PUSHs(msv); PUTBACK; call_pv("meta::warnif_trampoline", G_VOID); #endif LEAVE; } #define META_WARNING_CATEGORY "meta::experimental" #define warn_experimental(fname) S_warn_experimental(aTHX_ fname) static void S_warn_experimental(pTHX_ const char *fname) { warnings_warnsvif(META_WARNING_CATEGORY, sv_2mortal(newSVpvf("%s is experimental and may be changed or removed without notice", fname))); } #define warn_sub_deprecated(cv) S_warn_sub_deprecated(aTHX_ cv) static void S_warn_sub_deprecated(pTHX_ CV *cv) { GV *gv = CvGV(cv); Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED), "%s::%s() is deprecated and may be removed without notice", GvNAME(GvSTASH(gv)), GvNAME(gv)); } #if HAVE_PERL_VERSION(5, 38, 0) # define HAVE_FEATURE_CLASS #endif // Flags for get-alike methods enum { GET_OR_UNDEF, GET_OR_THROW, GET_OR_ADD, ADD_OR_THROW, GET_OR_UNDEF_WITH_WARNING, }; static SV *S_get_metaglob_slot(pTHX_ SV *metaglob, U8 svt, const char *slotname, U8 ix) { GV *gv = MUST_GV_FROM_REFSV(metaglob); SV *ret; switch(svt) { case SVt_PVMG: ret = GvSV (gv); break; case SVt_PVAV: ret = (SV *)GvAV (gv); break; case SVt_PVHV: ret = (SV *)GvHV (gv); break; case SVt_PVCV: ret = (SV *)GvCVu(gv); break; } if(ret) return wrap_sv_refsv(ret); switch(ix) { case GET_OR_THROW: croak("Glob does not have a %s slot", slotname); case GET_OR_UNDEF_WITH_WARNING: case GET_OR_UNDEF: return &PL_sv_undef; default: NOT_REACHED; } } static void split_fqname(const char *namepv, STRLEN namelen, const char **pkgnamepvp, STRLEN *pkgnamelenp, const char **basenamepvp, STRLEN *basenamelenp) { STRLEN pkgnamelen = 0; const char *pkgnamepv = NULL; STRLEN basenamelen = namelen; const char *basenamepv = namepv; const char *s = namepv + namelen - 2; for(/**/; s > namepv; s--) { if(s[0] != ':' || s[1] != ':') continue; /* s now points at the final occurence of '::' in the name * pkgname is namepv up to s, basename is s+2 up to its original end */ pkgnamepv = namepv; pkgnamelen = s - namepv; basenamepv = s + 2; basenamelen = namelen - (basenamepv - namepv); break; } if(pkgnamepvp) *pkgnamepvp = pkgnamepv; if(pkgnamelenp) *pkgnamelenp = pkgnamelen; if(basenamepvp) *basenamepvp = basenamepv; if(basenamelenp) *basenamelenp = basenamelen; } MODULE = meta PACKAGE = meta SV * get_package(SV *pkgname) CODE: warn_experimental("meta::get_package"); RETVAL = wrap_stash(gv_stashsv(pkgname, GV_ADD)); OUTPUT: RETVAL SV * get_this_package() CODE: warn_experimental("meta::get_this_package"); RETVAL = wrap_stash(CopSTASH(PL_curcop)); OUTPUT: RETVAL SV * for_reference(SV *ref) CODE: warn_experimental("meta::for_reference"); if(!SvROK(ref)) croak("meta::for_reference requires a reference value"); /* TODO: maybe there's some kinds of SV we'll forbid here? */ RETVAL = wrap_sv_refsv(SvRV(ref)); OUTPUT: RETVAL MODULE = meta PACKAGE = meta::package SV * get(SV *cls, SV *pkgname) CODE: if(SvROK(cls)) croak("meta::package->get(name) should not be invoked on an instance " "(did you mean to call one of the ->get_... methods?)"); warn_experimental("meta::package->get"); RETVAL = wrap_stash(gv_stashsv(pkgname, GV_ADD)); OUTPUT: RETVAL bool is_class(SV *metapkg) CODE: { #ifdef HAVE_FEATURE_CLASS HV *stash = MUST_STASH_FROM_REFSV(metapkg); RETVAL = HvSTASH_IS_CLASS(stash); #else PERL_UNUSED_VAR(metapkg); RETVAL = false; #endif } OUTPUT: RETVAL SV * name(SV *metapkg) CODE: { HV *stash = MUST_STASH_FROM_REFSV(metapkg); RETVAL = newSVpvn_flags(HvNAME(stash), HvNAMELEN(stash), HvNAMEUTF8(stash) ? SVf_UTF8 : 0); } OUTPUT: RETVAL SV * get_glob(SV *metapkg, SV *name) ALIAS: can_glob = GET_OR_UNDEF_WITH_WARNING get_glob = GET_OR_THROW try_get_glob = GET_OR_UNDEF CODE: { if(ix == GET_OR_UNDEF_WITH_WARNING) warn_sub_deprecated(cv); HV *stash = MUST_STASH_FROM_REFSV(metapkg); HE *he = hv_fetch_ent(stash, name, 0, 0); if(he) { GV *gv = (GV *)HeVAL(he); assert(SvTYPE(gv) == SVt_PVGV); RETVAL = wrap_sv_refsv((SV *)gv); } else switch(ix) { case GET_OR_THROW: CROAK_QUOTED_PREFIX("Package does not contain a glob called ", SVfARG(name)); case GET_OR_UNDEF_WITH_WARNING: case GET_OR_UNDEF: RETVAL = &PL_sv_undef; break; default: NOT_REACHED; } } OUTPUT: RETVAL SV * get_symbol(SV *metapkg, SV *name, SV *value = NULL) ALIAS: can_symbol = GET_OR_UNDEF_WITH_WARNING get_symbol = GET_OR_THROW try_get_symbol = GET_OR_UNDEF get_or_add_symbol = GET_OR_ADD add_symbol = ADD_OR_THROW CODE: { if(ix == GET_OR_UNDEF_WITH_WARNING) warn_sub_deprecated(cv); bool create = ix >= GET_OR_ADD; if(create) { if(value && !SvROK(value)) croak("Expected a reference for the new value to add_symbol"); } else { if(value) croak("meta::glob->get_symbol args"); } HV *stash = MUST_STASH_FROM_REFSV(metapkg); char sigil = SvPV_nolen(name)[0]; SV *valuesv = NULL; if(value) { valuesv = SvRV(value); switch(sigil) { case '*': croak("TODO: Cannot currently cope with adding GLOBs via ->add_symbol"); break; case '$': if(SvTYPE(valuesv) > SVt_PVMG) croak("Expected a SCALAR reference for the new value to add_symbol('$...')"); break; case '@': if(SvTYPE(valuesv) != SVt_PVAV) croak("Expected a ARRAY reference for the new value to add_symbol('@...')"); break; case '%': if(SvTYPE(valuesv) != SVt_PVHV) croak("Expected a HASH reference for the new value to add_symbol('%%...')"); break; case '&': if(SvTYPE(valuesv) != SVt_PVCV) croak("Expected a CODE reference for the new value to add_symbol('&...')"); break; default: croak("Unrecognised name sigil for add_symbol"); } } SV *basename = newSVpvn_flags(SvPV_nolen(name) + 1, SvCUR(name) - 1, (SvUTF8(name) ? SVf_UTF8 : 0) | SVs_TEMP); SV *ret = NULL; HE *he = hv_fetch_ent(stash, basename, create ? GV_ADD : 0, 0); if(!he) goto gv_missing; SV *sv = HeVAL(he); if(create && SvTYPE(sv) != SVt_PVGV) { gv_init_sv((GV *)sv, stash, basename, 0); GvMULTI_on(sv); } if(SvTYPE(sv) == SVt_PVGV) { GV *gv = (GV *)sv; switch(sigil) { case '*': ret = (SV *) gv; break; case '$': ret = GvSV (gv); break; case '@': ret = (SV *)GvAV (gv); break; case '%': ret = (SV *)GvHV (gv); break; case '&': ret = (SV *)GvCVu(gv); break; } } else if(SvROK(sv)) { // GV-less optimisation; this is an RV to one kind of element SV *rv = SvRV(sv); switch(sigil) { case '*': /* We know it isn't an SVt_PVGV */ ret = NULL; break; case '$': ret = (SvTYPE(rv) <= SVt_PVMG) ? rv : NULL; break; case '@': ret = (SvTYPE(rv) == SVt_PVAV) ? rv : NULL; break; case '%': ret = (SvTYPE(rv) == SVt_PVHV) ? rv : NULL; break; case '&': ret = (SvTYPE(rv) == SVt_PVCV) ? rv : NULL; break; } } else croak("TODO: Not sure what to do with SvTYPE(sv)=%d\n", SvTYPE(sv)); if(ix == ADD_OR_THROW && ret) CROAK_QUOTED_PREFIX("Already have a symbol named ", SVfARG(name)); if(!ret && create) { GV *gv = (GV *)sv; ret = valuesv; switch(sigil) { case '*': croak("Cannot create the glob slot itself"); case '$': if(!ret) ret = newSV(0); GvSV(gv) = SvREFCNT_inc(ret); break; case '@': if(!ret) ret = (SV *)newAV(); GvAV(gv) = (AV *)SvREFCNT_inc(ret); break; case '%': if(!ret) ret = (SV *)newHV(); GvHV(gv) = (HV *)SvREFCNT_inc(ret); break; case '&': if(!ret) croak("Cannot create a subroutine by ->get_or_add_symbol"); GvCV_set(gv, (CV *)SvREFCNT_inc(ret)); GvCVGEN(gv) = 0; break; } } gv_missing: if(ret) RETVAL = (GIMME_V != G_VOID) ? wrap_sv_refsv(ret) : &PL_sv_undef; else switch(ix) { case GET_OR_THROW: CROAK_QUOTED_PREFIX("Package has no symbol named ", SVfARG(name)); case GET_OR_UNDEF_WITH_WARNING: case GET_OR_UNDEF: RETVAL = &PL_sv_undef; break; default: NOT_REACHED; } } OUTPUT: RETVAL SV * add_named_sub(SV *metapkg, SV *name, SV *value) CODE: { HV *stash = MUST_STASH_FROM_REFSV(metapkg); if(!SvROK(value) || SvTYPE(SvRV(value)) != SVt_PVCV) croak("Expected a CODE reference for the new value to add_named_sub"); CV *cv = (CV *)SvRV(value); HE *he = hv_fetch_ent(stash, name, GV_ADD, 0); GV *gv; { assert(he); SV *sv = HeVAL(he); if(SvTYPE(sv) != SVt_PVGV) { gv_init_sv((GV *)sv, stash, name, 0); GvMULTI_on(sv); } gv = (GV *)sv; } if(GvCVu(gv)) CROAK_QUOTED_PREFIX("Already have a symbol named &", SVfARG(name)); /* Set these in the right order so the name GV works properly */ GvCV_set(gv, CvREFCNT_inc(cv)); GvCVGEN(gv) = 0; CvGV_set(cv, gv); RETVAL = wrap_sv_refsv((SV *)cv); } OUTPUT: RETVAL void remove_symbol(SV *metapkg, SV *name) CODE: { HV *stash = MUST_STASH_FROM_REFSV(metapkg); char sigil = SvPV_nolen(name)[0]; SV *basename = newSVpvn_flags(SvPV_nolen(name) + 1, SvCUR(name) - 1, (SvUTF8(name) ? SVf_UTF8 : 0) | SVs_TEMP); HE *he = hv_fetch_ent(stash, basename, 0, 0); if(!he) goto missing; SV *sv = HeVAL(he); if(SvTYPE(sv) == SVt_PVGV) { GV *gv = (GV *)sv; SV *sv = NULL; switch(sigil) { case '*': croak("TODO: Cannot ->remove_symbol on a glob"); break; case '$': sv = GvSV(gv); GvSV(gv) = NULL; break; case '@': sv = (SV *)GvAV(gv); GvAV(gv) = NULL; break; case '%': sv = (SV *)GvHV(gv); GvHV(gv) = NULL; break; case '&': sv = (SV *)GvCVu(gv); GvCV_set(gv, NULL); GvCVGEN(gv) = 0; break; } if(!sv) missing: CROAK_QUOTED_PREFIX("Cannot remove non-existing symbol from package: ", SVfARG(name)); SvREFCNT_dec(sv); /* TODO: Perl core has a gv_try_downgrade() we could call here, but XS * modules can't see it */ if(gv_is_empty(gv)) hv_delete_ent(stash, basename, G_DISCARD, 0); } else if(SvROK(sv)) { // GV-less optimisation; this is an RV to one kind of element SV *rv = SvRV(sv); switch(sigil) { case '*': /* We know it isn't a SVt_PVGV */ goto missing; break; case '$': if(SvTYPE(rv) > SVt_PVMG) goto missing; break; case '@': if(SvTYPE(rv) != SVt_PVAV) goto missing; break; case '%': if(SvTYPE(rv) != SVt_PVHV) goto missing; break; case '&': if(SvTYPE(rv) != SVt_PVCV) goto missing; break; } hv_delete_ent(stash, basename, G_DISCARD, 0); } else croak("TODO: Not sure what to do with SvTYPE(sv)=%d\n", SvTYPE(sv)); } void list_globs(SV *metapkg) ALIAS: list_all_globs = 0 list_globs = 1 list_subpackage_globs = 2 PPCODE: { HV *stash = MUST_STASH_FROM_REFSV(metapkg); UV retcount = 0; hv_iterinit(stash); HE *he; while((he = hv_iternext(stash))) { GV *gv = (GV *)HeVAL(he); assert(SvTYPE(gv) == SVt_PVGV); if(ix) { STRLEN keylen; const char *keypv = HePV(he, keylen); bool is_subpackage = keylen > 2 && keypv[keylen-2] == ':' && keypv[keylen-1] == ':'; if(ix == 1 && is_subpackage) continue; if(ix == 2 && !is_subpackage) continue; } EXTEND(SP, 1); mPUSHs(wrap_sv_refsv((SV *)gv)); retcount++; } XSRETURN(retcount); } void _list_symbols(SV *metapkg, SV *sigils) PPCODE: { HV *stash = MUST_STASH_FROM_REFSV(metapkg); const char *sigilfilter = sigils && SvOK(sigils) ? SvPV_nolen(sigils) : NULL; UV retcount = 0; hv_iterinit(stash); HE *he; while((he = hv_iternext(stash))) { STRLEN keylen; const char *keypv = HePV(he, keylen); bool is_subpackage = keylen > 2 && keypv[keylen-2] == ':' && keypv[keylen-1] == ':'; if(is_subpackage) continue; #define PUSH_SVREF_IF(sv, sigil) \ if((sv) && \ (!sigilfilter || strchr(sigilfilter, sigil))) { \ SV *_sv = (SV *)(sv); \ SV *namesv = newSVpvf("%c%.*s", sigil, (int)keylen, keypv); \ if(HeUTF8(he)) SvUTF8_on(namesv); \ EXTEND(SP, 2); \ mPUSHs(namesv); \ mPUSHs(wrap_sv_refsv(_sv)); \ retcount += 2; \ } SV *sv = HeVAL(he); if(SvTYPE(sv) == SVt_PVGV) { GV *gv = (GV *)sv; PUSH_SVREF_IF(GvSV (gv), '$'); PUSH_SVREF_IF(GvAV (gv), '@'); PUSH_SVREF_IF(GvHV (gv), '%'); PUSH_SVREF_IF(GvCVu(gv), '&'); } else if(SvROK(sv)) { // GV-less optimisation; this is an RV to one kind of element SV *rv = SvRV(sv); U8 type = SvTYPE(rv); PUSH_SVREF_IF(type <= SVt_PVMG ? rv : NULL, '$'); PUSH_SVREF_IF(type == SVt_PVAV ? rv : NULL, '@'); PUSH_SVREF_IF(type == SVt_PVHV ? rv : NULL, '%'); PUSH_SVREF_IF(type == SVt_PVCV ? rv : NULL, '&'); } else croak("TODO: Not sure what to do with SvTYPE(sv)=%d\n", SvTYPE(sv)); } #undef PUSH_SVREF_IF XSRETURN(retcount); } void list_subpackages(SV *metapkg) PPCODE: { HV *stash = MUST_STASH_FROM_REFSV(metapkg); UV retcount = 0; hv_iterinit(stash); HE *he; while((he = hv_iternext(stash))) { STRLEN keylen; const char *keypv = HePV(he, keylen); bool is_subpackage = keylen > 2 && keypv[keylen-2] == ':' && keypv[keylen-1] == ':'; if(!is_subpackage) continue; GV *gv = (GV *)HeVAL(he); assert(SvTYPE(gv) == SVt_PVGV); HV *substash = GvHV(gv); EXTEND(SP, 2); mPUSHp(keypv, keylen - 2); if(HeUTF8(he)) SvUTF8_on(*SP); mPUSHs(wrap_stash(substash)); retcount += 2; } XSRETURN(retcount); } MODULE = meta PACKAGE = meta::symbol void DESTROY(SV *metasym) CODE: { SV *sv = SV_FROM_REFSV(metasym); SvREFCNT_dec(sv); } bool is_scalar(SV *metasym) CODE: { SV *sv = SV_FROM_REFSV(metasym); RETVAL = SvTYPE(sv) <= SVt_PVMG; } OUTPUT: RETVAL bool _is_type(SV *metasym) ALIAS: is_glob = SVt_PVGV is_array = SVt_PVAV is_hash = SVt_PVHV is_subroutine = SVt_PVCV CODE: { SV *sv = SV_FROM_REFSV(metasym); RETVAL = SvTYPE(sv) == ix; } OUTPUT: RETVAL SV * reference(SV *metasym) CODE: { SV *sv = SV_FROM_REFSV(metasym); RETVAL = newRV_inc(sv); } OUTPUT: RETVAL MODULE = meta PACKAGE = meta::glob SV * get(SV *cls, SV *globname) ALIAS: get = GET_OR_THROW try_get = GET_OR_UNDEF get_or_add = GET_OR_ADD CODE: { if(SvROK(cls)) croak("meta::glob->get(name) should not be invoked on an instance " "(did you mean to call one of the ->get_... methods?)"); bool create = (ix == GET_OR_ADD); warn_experimental("meta::glob->get"); GV *gv = gv_fetchsv(globname, create ? GV_ADDMULTI : 0, SVt_PVGV); if(gv) { assert(SvTYPE(gv) == SVt_PVGV); RETVAL = wrap_sv_refsv((SV *)gv); } else switch(ix) { case GET_OR_THROW: CROAK_QUOTED_PREFIX("Symbol table does not contain a glob called ", SVfARG(globname)); case GET_OR_UNDEF: RETVAL = &PL_sv_undef; break; default: NOT_REACHED; } } OUTPUT: RETVAL SV * basename(SV *metaglob) CODE: { GV *gv = MUST_GV_FROM_REFSV(metaglob); RETVAL = newSVpvn_flags(GvNAME(gv), GvNAMELEN(gv), GvNAMEUTF8(gv) ? SVf_UTF8 : 0); } OUTPUT: RETVAL SV *get_scalar(SV *metaglob) ALIAS: can_scalar = GET_OR_UNDEF_WITH_WARNING get_scalar = GET_OR_THROW try_get_scalar = GET_OR_UNDEF CODE: if(ix == GET_OR_UNDEF_WITH_WARNING) warn_sub_deprecated(cv); RETVAL = S_get_metaglob_slot(aTHX_ metaglob, SVt_PVMG, "scalar", ix); OUTPUT: RETVAL SV *get_array(SV *metaglob) ALIAS: can_array = GET_OR_UNDEF_WITH_WARNING get_array = GET_OR_THROW try_get_array = GET_OR_UNDEF CODE: if(ix == GET_OR_UNDEF_WITH_WARNING) warn_sub_deprecated(cv); RETVAL = S_get_metaglob_slot(aTHX_ metaglob, SVt_PVAV, "array", ix); OUTPUT: RETVAL SV *get_hash(SV *metaglob) ALIAS: can_hash = GET_OR_UNDEF_WITH_WARNING get_hash = GET_OR_THROW try_get_hash = GET_OR_UNDEF CODE: if(ix == GET_OR_UNDEF_WITH_WARNING) warn_sub_deprecated(cv); RETVAL = S_get_metaglob_slot(aTHX_ metaglob, SVt_PVHV, "hash", ix); OUTPUT: RETVAL SV *get_code(SV *metaglob) ALIAS: can_code = GET_OR_UNDEF_WITH_WARNING get_code = GET_OR_THROW try_get_code = GET_OR_UNDEF CODE: if(ix == GET_OR_UNDEF_WITH_WARNING) warn_sub_deprecated(cv); RETVAL = S_get_metaglob_slot(aTHX_ metaglob, SVt_PVCV, "code", ix); OUTPUT: RETVAL MODULE = meta PACKAGE = meta::variable void value(SV *metavar) PPCODE: { if(GIMME_V == G_VOID) // TODO: warn? XSRETURN(0); /* TODO: all of the-below is super-fragile and probably doesn't work * properly with tied scalars/arrays/hashes. Eugh. */ SV *sv = SV_FROM_REFSV(metavar); if(SvTYPE(sv) <= SVt_PVMG) { SV *ret = sv_mortalcopy(sv); XPUSHs(ret); XSRETURN(1); } else if(SvTYPE(sv) == SVt_PVAV) { /* Array */ AV *av = (AV *)sv; UV count = av_count(av); if(GIMME_V == G_SCALAR) { mXPUSHu(count); XSRETURN(1); } EXTEND(SP, count); UV i; for(i = 0; i < count; i++) PUSHs(sv_mortalcopy(*av_fetch(av, i, 0))); XSRETURN(count); } else if(SvTYPE(sv) == SVt_PVHV) { /* Hash */ HV *hv = (HV *)sv; UV count = 0; U8 gimme = GIMME_V; HE *he; hv_iterinit(hv); while((he = hv_iternext(hv))) { SV *key = HeSVKEY(he); if(!key) key = newSVpvn_flags(HeKEY(he), HeKLEN(he), HeKFLAGS(he) | SVs_TEMP); if(gimme == G_LIST) { EXTEND(SP, 2); PUSHs(key); PUSHs(HeVAL(he)); } count++; } if(gimme == G_LIST) XSRETURN(count * 2); mPUSHu(count); XSRETURN(1); } else croak("Argh unrecognised SvTYPE(sv)=%d", SvTYPE(sv)); } MODULE = meta PACKAGE = meta::subroutine bool is_method(SV *metasub) CODE: { #ifdef HAVE_FEATURE_CLASS CV *cv = MUST_CV_FROM_REFSV(metasub); RETVAL = CvIsMETHOD(cv); #else PERL_UNUSED_VAR(metasub); RETVAL = false; #endif } OUTPUT: RETVAL SV * subname(SV *metasub) CODE: { CV *cv = MUST_CV_FROM_REFSV(metasub); GV *gv = CvGV(cv); if(!gv) RETVAL = &PL_sv_undef; else RETVAL = newSVpvf("%s::%s", HvNAME(GvSTASH(gv)), GvNAME(gv)); } OUTPUT: RETVAL SV * set_subname(SV *metasub, SV *name) CODE: { CV *cv = MUST_CV_FROM_REFSV(metasub); STRLEN namelen; const char *namepv = SvPV(name, namelen); const char *pkgnamepv, *basenamepv; STRLEN pkgnamelen, basenamelen; split_fqname(namepv, namelen, &pkgnamepv, &pkgnamelen, &basenamepv, &basenamelen); HV *stash; if(pkgnamelen) stash = gv_stashpvn(pkgnamepv, pkgnamelen, GV_ADD | SvUTF8(name)); else stash = CopSTASH(PL_curcop); /* We can't just change the name in the sub's GV because that might be * shared and break all kinds of things. We'll have to make a new GV. */ GV *newgv = (GV *)newSV(0); gv_init_pvn(newgv, stash, basenamepv, basenamelen, SvUTF8(name)); CvANON_off(cv); CvGV_set(cv, newgv); /* CvGV_set claimed a reference to newgv; we can drop it now */ SvREFCNT_dec(newgv); RETVAL = SvREFCNT_inc(metasub); } OUTPUT: RETVAL SV * prototype(SV *metasub) CODE: { CV *cv = MUST_CV_FROM_REFSV(metasub); if(!SvPOK(cv)) RETVAL = &PL_sv_undef; else RETVAL = newSVpvn_flags(CvPROTO(cv), CvPROTOLEN(cv), SvUTF8(cv)); } OUTPUT: RETVAL SV * set_prototype(SV *metasub, SV *proto) CODE: { CV *cv = MUST_CV_FROM_REFSV(metasub); if(SvOK(proto)) sv_copypv((SV *)cv, proto); else SvPOK_off((SV *)cv); RETVAL = SvREFCNT_inc(metasub); } OUTPUT: RETVAL SV * signature(SV *metasub) CODE: { CV *cv = MUST_CV_FROM_REFSV(metasub); RETVAL = &PL_sv_undef; #ifdef HAVE_SUB_SIGNATURES if(CvISXSUB(cv)) goto nosig; OP *oproot = CvROOT(cv); if(!oproot) goto nosig; /* The optree of a signatured sub should be an OP_LEAVESUB at toplevel. * Nested inside will be maybe one or two OP_NULL[OP_LINESEQ[...]] * subtrees, inside of which will be a COP, OP_ARGCHECK, ... * It is the OP_ARGCHECK we are looking for */ assert(oproot->op_type == OP_LEAVESUB); OP *o = cUNOPx(oproot)->op_first; U32 flags = 0; /* Descend into OP_NULL / OP_LINESEQ trees while skipping past COPs */ while(o) { if(o->op_type == OP_NULL) o = cUNOPo->op_first; else if(o->op_type == OP_LINESEQ) o = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL; else if(o->op_type == OP_NEXTSTATE || o->op_type == OP_DBSTATE) o = OpSIBLING(o); # ifdef HAVE_FEATURE_CLASS else if(o->op_type == OP_METHSTART) o = OpSIBLING(o), flags |= CVSIGNATURE_IS_METHOD; # endif else break; } if(!o || o->op_type != OP_ARGCHECK) goto nosig; RETVAL = wrap_cv_signature(cv, o, flags); nosig: ; #endif } OUTPUT: RETVAL MODULE = meta PACKAGE = meta::subsignature void DESTROY(SV *metasig) CODE: { struct CVwithOP *cvop = (struct CVwithOP *)SvPVX(SvRV(metasig)); SvREFCNT_dec(cvop->cv); // ->op is not refcounted } SV * mandatory_params(SV *metasig) ALIAS: mandatory_params = 0 optional_params = 1 slurpy = 2 min_args = 0 max_args = 3 CODE: { #ifdef HAVE_SUB_SIGNATURES struct CVwithOP *cvop = (struct CVwithOP *)SvPVX(SvRV(metasig)); # if HAVE_PERL_VERSION(5, 31, 5) struct op_argcheck_aux *aux = (struct op_argcheck_aux *)cUNOP_AUXx(cvop->op)->op_aux; int params = aux->params + ((cvop->flags & CVSIGNATURE_IS_METHOD) ? 1 : 0); int opt_params = aux->opt_params; char slurpy = aux->slurpy; # else UNOP_AUX_item *aux = cUNOP_AUXx(cvop->op)->op_aux; int params = aux[0].iv; int opt_params = aux[1].iv; char slurpy = aux[2].iv; # endif switch(ix) { case 0: RETVAL = newSViv(params - opt_params); break; case 1: RETVAL = newSViv(opt_params); break; case 2: RETVAL = slurpy ? newSVpvf("%c", slurpy) : &PL_sv_undef; break; case 3: RETVAL = slurpy ? &PL_sv_undef : newSViv(params); break; default: NOT_REACHED; } #endif } OUTPUT: RETVAL BOOT: warnings_register_category(META_WARNING_CATEGORY); meta-0.013/t000755001750001750 015002211532 11416 5ustar00leoleo000000000000meta-0.013/t/00use.t000444001750001750 16215002211532 12653 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; require meta; pass( 'Modules loaded' ); done_testing; meta-0.013/t/01package.t000444001750001750 300215002211532 13467 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use meta; no warnings qw( meta::experimental ); # meta::package->get { my $metapkg = meta::package->get( "meta" ); ok( $metapkg, 'meta::package->get for "meta"' ); is( $metapkg->name, "meta", 'Name of package' ); } # Test2::V0's metapackage { is( meta::package->get( "Test2::V0" )->name, "Test2::V0", 'Name of the Test2::V0 package' ); } # missing gets created { my $metapkg; ok( lives { $metapkg = meta::package->get( "this-is-not-a-package" ) }, 'get_package creates a new package' ); is( $metapkg->name, "this-is-not-a-package" ); } # Older meta::get_package function interface { my $metapkg = meta::get_package( "meta" ); ok( $metapkg, 'meta::get_package for "meta"' ); is( $metapkg->name, "meta", 'Name of package' ); } # this file's main package { my $metapkg = meta::get_this_package(); is( $metapkg->name, "main", 'Name of the main package from get_this_package' ); # This method should always exist even on perls before feature 'class', and # always return false on main. ok( !$metapkg->is_class, 'The main package is not a class' ); } # subpackages { my %sub_metapkgs = meta::get_package( "meta" )->list_subpackages; ok( keys %sub_metapkgs, '->list_subpackages returned some entries' ); ok( my $package_metapkg = $sub_metapkgs{"package"}, 'subpackage for "package" exists' ); is( $package_metapkg->name, "meta::package", 'name of "package" subpackage' ); } done_testing; meta-0.013/t/02glob.t000444001750001750 514615002211532 13033 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use meta; no warnings qw( meta::experimental ); { my $metapkg = meta::package->get( "meta" ); my $metaglob = $metapkg->get_glob( "get_package" ); ok( $metaglob, '$metapkg->get_glob on get_package' ); is( $metaglob->basename, "get_package", '$metaglob->basename' ); $metaglob = meta::for_reference( \*meta ); ok( $metaglob->is_glob, '$metaglob for reference ->is_glob' ); is( $metaglob->basename, "meta", '$metaglob from for_reference' ); } # missing { my $metapkg = meta::package->get( "meta" ); ok( !defined $metapkg->try_get_glob( "not-a-glob" ), 'try_get_glob yields undef on missing glob' ); like( dies { $metapkg->get_glob( "not-a-glob" ) }, qr/^Package does not contain a glob called "not-a-glob" /, 'get_glob throws on missing glob' ); } # meta::glob->get method { my $metaglob = meta::glob->get( "meta::get_package" ); ok( $metaglob, 'meta:;glob->get on meta::get_package' ); is( $metaglob->basename, "get_package", '$metaglob->basename' ); } # missing on methods { ok( !defined meta::glob->try_get( "not-a-glob" ), 'meta::glob->try_get yields undef on missing glob' ); like( dies { meta::glob->get( "not-a-glob" ) }, qr/^Symbol table does not contain a glob called "not-a-glob" /, 'meta::glob->get throws on missing glob' ); } # ->get_or_add { ok( !defined meta::glob->try_get( "created-symbol" ), 'created-symbol did not exist' ); my $metaglob = meta::glob->get_or_add( "created-symbol" ); ok( $metaglob, '->get_or_add returned metaglob' ); is( $metaglob->basename, "created-symbol", 'Name of newly-created symbol' ); ok( defined meta::glob->try_get( "created-symbol" ), 'created-symbol now exists' ); } # ->list_*_globs { my $metapkg = meta::package->get( "meta" ); my @metaglobs = $metapkg->list_globs; # Don't be too sensitive to what globs we found ok( scalar @metaglobs, 'list_globs returned a list of globs' ); ok( scalar( grep { $_->basename eq "get_package" } @metaglobs ), 'list_globs result included a glob for "get_package"' ); ok( !scalar( grep { $_->basename eq "package::" } @metaglobs ), 'list_globs does not return subpackages' ); my @metaglobs_pkgs = $metapkg->list_subpackage_globs; ok( scalar( grep { $_->basename eq "package::" } @metaglobs_pkgs ), 'list_subpackage_globs returns subpackages' ); my @metaglobs_all = $metapkg->list_all_globs; ok( @metaglobs + @metaglobs_pkgs == @metaglobs_all, 'list_all_globs returns a list totalling the prior two' ); } done_testing; meta-0.013/t/03symbols.t000444001750001750 516215002211532 13577 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use meta; no warnings qw( meta::experimental ); our $VAR; our @VAR; # via glob { my $metapkg = meta::package->get( "main" ); my $metaglob = $metapkg->get_glob( "VAR" ); my $metasym = $metaglob->get_scalar; ok( $metasym, '$metaglob->get_scalar' ); is( $metasym->reference, \$VAR, '$metasym->reference' ); is( $metaglob->get_array->reference, \@VAR, '$metaglob->get_array->reference' ); } # missing { my $metapkg = meta::package->get( "main" ); my $metaglob = $metapkg->get_glob( "VAR" ); ok( !defined $metaglob->try_get_hash, 'try_get_hash yields undef on missing HV' ); like( dies { $metaglob->get_hash }, qr/^Glob does not have a hash slot /, 'get_hash throws on missing HV' ); } # direct shortcut { my $metapkg = meta::package->get( "main" ); is( $metapkg->get_symbol( '$VAR' )->reference, \$VAR, '$metapkg->get_symbol for scalar' ); is( $metapkg->try_get_symbol( '$VAR' )->reference, \$VAR, '$metapkg->try_get_symbol for scalar' ); is( $metapkg->get_or_add_symbol( '$VAR' )->reference, \$VAR, '$metapkg->get_or_add_symbol for scalar' ); is( $metapkg->get_symbol( '@VAR' )->reference, \@VAR, '$metapkg->get_symbol for array' ); ok( !defined $metapkg->try_get_symbol( '%VAR' ), 'try_get_symbol yields undef on missing HV' ); like( dies { $metapkg->get_symbol( '%VAR' ) }, qr/^Package has no symbol named "%VAR" /, 'get_symbol throws on missing HV' ); like( dies { $metapkg->get_symbol( '%missing-name' ) }, qr/^Package has no symbol named "%missing-name" /, 'get_symbol throws on missing GV' ); } sub func {} { my $metapkg = meta::package->get( "main" ); is( $metapkg->get_symbol( '&func' )->reference, \&func, '$metapkg->get_symbol for code not confused by GV-less optimisation' ); } # ->list_symbols { my $metapkg = meta::package->get( "main" ); my %metasyms = $metapkg->list_symbols; ok( $metasyms{'$VAR'}, '->list_symbols found $VAR' ); ref_is( $metasyms{'$VAR'}->reference, \$VAR, '->list_symbols returned the correct $VAR' ); ok( $metasyms{'@VAR'}, '->list_symbols found @VAR' ); ref_is( $metasyms{'@VAR'}->reference, \@VAR, '->list_symbols returned the correct @VAR' ); ok( $metasyms{'&func'}, '->list_symbols found &func via GV-less optimisation' ); ref_is( $metasyms{'&func'}->reference, \&func, '->list_symbols returned the correct &func' ); %metasyms = $metapkg->list_symbols( sigils => '$' ); ok( !$metasyms{'@VAR'}, '->list_symbols sigil filtering omits array' ); } done_testing; meta-0.013/t/10variables.t000444001750001750 430215002211532 14050 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use meta; no warnings qw( meta::experimental ); our $SCALAR = "the scalar"; { my $metavar = meta::package->get( "main" )->get_symbol( '$SCALAR' ); ok( !$metavar->is_glob, '$metavar->is_glob false' ); ok( $metavar->is_scalar, '$metavar->is_scalar' ); ok( !$metavar->is_array, '$metavar->is_array false' ); ok( !$metavar->is_hash, '$metavar->is_hash false' ); ok( !$metavar->is_subroutine, '$metavar->is_subroutine false' ); is( $metavar->value, "the scalar", '$metavar->value of $SCALAR' ); $metavar = meta::for_reference( \$SCALAR ); ok( $metavar->is_scalar, '$metavar for reference ->is_scalar' ); ref_is( $metavar->reference, \$SCALAR, 'meta::for_reference SCALAR yields metavar' ); } our @ARRAY = qw( ab cd ef ); { my $metavar = meta::package->get( "main" )->get_symbol( '@ARRAY' ); ok( $metavar->is_array, '$metavar->is_array' ); is( scalar $metavar->value, 3, '$metavar->value of @ARRAY in scalar context' ); is( [ $metavar->value ], [qw( ab cd ef )], '$metavar->value of @ARRAY in list context' ); $metavar = meta::for_reference( \@ARRAY ); ok( $metavar->is_array, '$metavar for reference ->is_array' ); ref_is( $metavar->reference, \@ARRAY, 'meta::for_reference ARRAY yields metavar' ); } our %HASH = ( one => 1, two => 2 ); { my $metavar = meta::package->get( "main" )->get_symbol( '%HASH' ); ok( $metavar->is_hash, '$metavar->is_hash' ); is( scalar $metavar->value, 2, '$metavar->value of %HASH in scalar context' ); is( { $metavar->value }, { one => 1, two => 2 }, '$metavar->value of %HASH in list context' ); $metavar = meta::for_reference( \%HASH ); ok( $metavar->is_hash, '$metavar for reference ->is_hash' ); ref_is( $metavar->reference, \%HASH, 'meta::for_reference HASH yields metavar' ); } { my $destroyed; sub DestroyWatcher::DESTROY { $destroyed++ } my $metavar = meta::for_reference( [ bless [], "DestroyWatcher" ] ); ok( !$destroyed, 'metavar keeps referred array alive' ); undef $metavar; ok( $destroyed, 'destruction of metavar destroys referred array' ); } done_testing; meta-0.013/t/11subroutines.t000444001750001750 511415002211532 14465 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use meta; no warnings qw( meta::experimental ); sub testfunc ($$@) { } { my $metasub = meta::package->get( "main" )->get_symbol( '&testfunc' ); isa_ok( $metasub, [ "meta::subroutine" ], '$metasub isa meta subroutine' ); ok( $metasub->is_subroutine, '$metasub->is_subroutine' ); # This method should always exist even on perls before feature 'class', and # return false on plain sub. ok( !$metasub->is_method, '$metasub->is_method is false' ); is( $metasub->subname, "main::testfunc", '$metasub->subname' ); is( $metasub->prototype, '$$@', '$metasub->prototype' ); $metasub = meta::for_reference( \&testfunc ); ok( $metasub->is_subroutine, '$metasub for reference ->is_subroutine' ); ref_is( $metasub->reference, \&testfunc, 'meta::for_reference ARRAY yields metasub' ); } sub to_be_modified { } { my $metasub = meta::package->get( "main" )->get_symbol( '&to_be_modified' ); $metasub->set_subname( "a-new-name-here" ); # does not have to be valid is( $metasub->subname, "main::a-new-name-here", '$metasub->subname after ->set_subname' ); $metasub->set_subname( "different::package::name" ); is( $metasub->subname, "different::package::name", '$metasub->subname after ->set_subname on different package' ); $metasub->set_prototype( '$$' ); is( $metasub->prototype, '$$', '$metasub->prototype after ->set_prototype' ); } { my $metapkg = meta::package->get( "main" ); my $metasub = $metapkg->add_named_sub( newly_added_sub => sub { "the result" } ); ok( $metasub->is_subroutine, '->add_named_sub returned a metasub' ); is( main->newly_added_sub(), "the result", 'Result of calling sub added by ->add_named_sub' ); is( $metapkg->get_symbol( '&newly_added_sub' )->subname, "main::newly_added_sub", 'Newly added sub has correct subname' ); } # ->get_symbol and friends should not get confused by subclass method resolution { package Class1 { sub a_method {} } package Class2 { use base 'Class1'; } my $metapkg1 = meta::package->get( "Class1" ); ok( $metapkg1->try_get_symbol( '&a_method' ), 'metapkg for Class1 sees a_method' ); # Force the method cache to exist Class2->a_method(); my $metapkg2 = meta::package->get( "Class2" ); ok( !$metapkg2->try_get_symbol( '&a_method' ), 'metapkg for Class2 does not see a_method' ); $metapkg2->add_symbol( '&a_method' => sub {} ); ok( $metapkg2->try_get_symbol( '&a_method' ), 'metapkg for Class2 now sees overridden a_method' ); } done_testing; meta-0.013/t/12sub-signature.t000444001750001750 343315002211532 14676 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; BEGIN { $^V ge v5.26 or plan skip_all => "Not supported on Perl $^V"; } use meta; no warnings qw( meta::experimental ); use experimental 'signatures'; sub testfunc ( $x, $y, $z = undef ) { ... } sub testfunc_with_array ( $first, @rest ) { ... } sub testfunc_with_hash ( $first, %rest ) { ... } my $mainpkg = meta::package->get( "main" ); { my $metasub = $mainpkg->get_symbol( '&testfunc' ); my $metasig = $metasub->signature; ok( $metasig, '$metasub->signature yields something' ); is( $metasig->mandatory_params, 2, 'signature has 2 mandatory params' ); is( $metasig->optional_params, 1, 'signature has 1 optional param' ); is( $metasig->slurpy, undef, 'signature has no slurpy param' ); is( $metasig->min_args, 2, 'signature requires at least 2 argument values' ); is( $metasig->max_args, 3, 'signature supports at most 3 argument values' ); $metasig = meta::for_reference( sub ( $x ) { } )->signature; ok( $metasig, '$metasig for anonymous CODE reference' ); is( $metasig->mandatory_params, 1, 'anon code signature has 1 mandatory param' ); } # subs with slurpy { my $metasig = $mainpkg->get_symbol( '&testfunc_with_array' )->signature; is( $metasig->slurpy, '@', 'signature slurpy array' ); is( $metasig->min_args, 1, 'signature with slurpy array requires at least 1 argument value' ); is( $metasig->max_args, undef, 'signature with slurpy array supports unbounded argument values' ); is( $mainpkg->get_symbol( '&testfunc_with_hash' )->signature->slurpy, '%', 'signature slurpy hash' ); } sub func_no_sig { } { my $metasub = $mainpkg->get_symbol( '&func_no_sig' ); ok( !$metasub->signature, '$metasub for non-signatured sub has no signature' ); } done_testing; meta-0.013/t/20add.t000444001750001750 677515002211532 12651 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use meta; no warnings qw( meta::experimental ); my $metapkg = meta::package->get( "main" ); # add scalar { my $var = 1234; my $metasym = $metapkg->add_symbol( '$NEW_SCALAR', \$var ); ok( $metasym, '->add_symbol returned metasym' ); is( eval('$main::NEW_SCALAR'), 1234, 'New scalar appears in package' ); ref_is( $metasym->reference, \$var, '$metasym->reference for scalar' ); like( dies { $metapkg->add_symbol( '$NEW_SCALAR', \my $tmp ) }, qr/^Already have a symbol named "\$NEW_SCALAR" /, '->add_symbol on same name throws exception' ); is( $metapkg->add_symbol( '$BLANK_SCALAR' )->reference, \undef, 'New blank scalar' ); } # get_or_add scalar { my $metasym = $metapkg->get_or_add_symbol( '$SCALAR1' ); ok( $metasym, '->get_or_add_symbol returned metasym' ); ${ $metasym->reference } = 1235; is( eval('$main::SCALAR1'), 1235, 'New scalar appears in package' ); } # add array { my @var = ( 56, 78 ); my $metasym = $metapkg->add_symbol( '@NEW_ARRAY', \@var ); ok( $metasym, '->add_symbol returned metasym' ); is( [ eval('@main::NEW_ARRAY') ], [ 56, 78 ], 'New array appears in package' ); ref_is( $metasym->reference, \@var, '$metasym->reference for array' ); is( $metapkg->add_symbol( '@BLANK_ARRAY' )->reference, [], 'New blank array' ); } # get_or_add array { my $metasym = $metapkg->get_or_add_symbol( '@ARRAY1' ); ok( $metasym, '->get_or_add_symbol returned metasym' ); push @{ $metasym->reference }, 57; is( [ eval('@main::ARRAY1') ], [ 57 ], 'New array appears in package' ); } # add hash { my %var = ( nine => 10 ); my $metasym = $metapkg->add_symbol( '%NEW_HASH', \%var ); ok( $metasym, '->add_symbol returned metasym' ); is( { eval('%main::NEW_HASH') }, { nine => 10 }, 'New hash appears in package' ); is( $metasym->reference, \%var, '$metasym->reference for hash' ); is( $metapkg->add_symbol( '%BLANK_HASH' )->reference, {}, 'New blank hash' ); } # get_or_add hash { my $metasym = $metapkg->get_or_add_symbol( '%HASH1' ); ok( $metasym, '->get_or_add_symbol returned metasym' ); ${ $metasym->reference }{ten} = 11; is( { eval('%main::HASH1') }, { ten => 11 }, 'New hash appears in package' ); } # add code { my $sub = sub { return "the function" }; my $metasym = $metapkg->add_symbol( '&NEW_SUB', $sub ); ok( $metasym, '->add_symbol returned metasym' ); is( eval('main::NEW_SUB()'), "the function", 'New function appears in package' ); is( $metasym->reference, $sub, '$metasym->reference for function' ); } # multiple slots can be added at once without clashing { my $metascalar = $metapkg->add_symbol( '$SHARED', \my $tmp ); my $metaarray = $metapkg->add_symbol( '@SHARED', \my @tmp ); my $metahash = $metapkg->add_symbol( '%SHARED', \my %tmp ); ok( eval( ' $::SHARED = "scalar"; @::SHARED = ( "array" ); %::SHARED = ( hash => undef ); ' ), 'new variables can be written' ) or diag $@; is( \$tmp, \"scalar", 'Scalar written to' ); is( \@tmp, ["array"], 'Array written to' ); is( \%tmp, {hash => undef}, 'Hash written to' ); } sub func { "toplevel func" } # Can add a slot around a GV-less optimised symbol table entry { $metapkg->add_symbol( '$func', \my $var ); $var = 123; is( main->can( "func" )->(), "toplevel func", 'Toplevel func still works after adding var called $func' ); } done_testing; meta-0.013/t/21remove.t000444001750001750 415515002211532 13405 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use meta; no warnings qw( meta::experimental ); my $metapkg = meta::package->get( "main" ); # scalar { our $SCALAR_VAR; $metapkg->remove_symbol( '$SCALAR_VAR' ); ok( !$metapkg->try_get_symbol( '$SCALAR_VAR' ), '$metapkg no longer has scalar symbol after remove' ); ok( !$metapkg->try_get_glob( 'SCALAR_VAR' ), '$metapkg no longer has old glob after remove' ); like( dies { $metapkg->remove_symbol( '$SCALAR_VAR' ) }, qr/^Cannot remove non-existing symbol from package: "\$SCALAR_VAR" /, '->remove_symbol on same name throws exception' ); } # array { our @ARRAY_VAR; $metapkg->remove_symbol( '@ARRAY_VAR' ); ok( !$metapkg->try_get_symbol( '@ARRAY_VAR' ), '$metapkg no longer has array symbol after remove' ); ok( !$metapkg->try_get_glob( 'ARRAY_VAR' ), '$metapkg no longer has old glob after remove' ); } # hash { our %HASH_VAR; $metapkg->remove_symbol( '%HASH_VAR' ); ok( !$metapkg->try_get_symbol( '%HASH_VAR' ), '$metapkg no longer has hash symbol after remove' ); ok( !$metapkg->try_get_glob( 'HASH_VAR' ), '$metapkg no longer has old glob after remove' ); } # hash { sub FUNCTION { } $metapkg->remove_symbol( '&FUNCTION' ); ok( !$metapkg->try_get_symbol( '&FUNCTION' ), '$metapkg no longer has code symbol after remove' ); ok( !$metapkg->try_get_glob( 'FUNCTION' ), '$metapkg no longer has old glob after remove' ); } # can delete one slot without losing them all { our $SHARED; our @SHARED; our %SHARED; $metapkg->remove_symbol( '@SHARED' ); ok( !$metapkg->try_get_symbol( '@SHARED' ), '$metapkg no longer has @SHARED after remove' ); ok( $metapkg->try_get_symbol( '$SHARED' ), '$metapkg still has $SHARED after remove array' ); ok( $metapkg->try_get_symbol( '%SHARED' ), '$metapkg still has %SHARED after remove array' ); like( dies { $metapkg->remove_symbol( '@SHARED' ) }, qr/^Cannot remove non-existing symbol from package: "\@SHARED" /, '->remove_symbol on same name throws exception' ); } done_testing; meta-0.013/t/60class.t000444001750001750 155715002211532 13223 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; BEGIN { $^V ge v5.38 or plan skip_all => "Not supported on Perl $^V"; } use meta; no warnings qw( meta::experimental ); use feature 'class'; no warnings qw( experimental::class ); package NotAClass { sub not_a_method {} } class IsAClass { sub not_a_method {} method is_a_method {} } # ->is_class { ok( !meta::package->get( "NotAClass" )->is_class, 'metapkg for non-class is not a class' ); ok( meta::package->get( "IsAClass" )->is_class, 'metapkg for class is a class' ); } # ->is_method { my $metapkg = meta::package->get( "IsAClass" ); ok( !$metapkg->get_symbol( '¬_a_method' )->is_method, 'metasub for not_a_method is not a method' ); ok( $metapkg->get_symbol( '&is_a_method' )->is_method, 'metasub for is_a_method is a method' ); } done_testing; meta-0.013/t/61method-signature.t000444001750001750 176715002211532 15401 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; BEGIN { $^V ge v5.38 or plan skip_all => "Not supported on Perl $^V"; } use meta; no warnings qw( meta::experimental ); use feature 'class'; no warnings qw( experimental::class ); class TestClass { method testmethod ( $x, $y, $z = undef ) { ... } } my $metaclass = meta::package->get( "TestClass" ); { my $metamethod = $metaclass->get_symbol( '&testmethod' ); my $metasig = $metamethod->signature; ok( $metasig, '$metamethod->signature yields something' ); # Implicit $self should count as an additional mandatory argument is( $metasig->mandatory_params, 3, 'signature has 3 mandatory params' ); is( $metasig->optional_params, 1, 'signature has 1 optional param' ); is( $metasig->slurpy, undef, 'signature has no slurpy param' ); is( $metasig->min_args, 3, 'signature requires at least 3 argument values' ); is( $metasig->max_args, 4, 'signature supports at most 4 argument values' ); } done_testing; meta-0.013/t/80subname+Sub-Util.t000444001750001750 216415002211532 15205 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use meta; no warnings qw( meta::experimental ); # This is a core module since 5.22 use Test2::Require::Module 'Sub::Util'; use Sub::Util; # Values set by Sub::Util are readable by meta { my $testsub = Sub::Util::set_subname name_of_the_sub => Sub::Util::set_prototype '&$$@' => sub { ... }; my $metasub = meta::for_reference( $testsub ); is( $metasub->subname, "main::name_of_the_sub", '$metasub->subname from Sub::Util::set_subname' ); is( $metasub->prototype, '&$$@', '$metasub->prototype from Sub::Util::set_prototype' ); } # Values set by meta are readable by Sub::Util { # ensure this is a real closure so it's unique my $testsub = meta::for_reference( do { my $x; sub { $x } } ) ->set_subname( 'name_of_the_sub' ) ->set_prototype( '&$$@' ) ->reference; is( Sub::Util::subname( $testsub ), 'main::name_of_the_sub', 'Sub::Util::subname from $metasub->set_subname' ); is( Sub::Util::prototype( $testsub ), '&$$@', 'Sub::Util::prototype from $metasub->set_prototype' ); } done_testing; meta-0.013/t/94warnings.t000444001750001750 101215002211532 13737 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use meta; my $FILE = quotemeta __FILE__; { my $LINE = __LINE__+1; like( warning { meta::get_package( "meta" ) }, qr/^meta::get_package is experimental and may be changed or removed without notice at $FILE line $LINE\./, 'meta::get_package provokes experimental warning' ); } { no warnings 'meta::experimental'; is( warning { meta::get_package( "meta" ) }, undef, 'experimental warnings can be disabled' ); } done_testing; meta-0.013/t/99pod.t000444001750001750 25515002211532 12666 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok();