Build.PL100644001750001750 360613071222366 14600 0ustar00syoheisyohei000000000000Data-Util-0.66# ========================================================================= # THIS FILE IS AUTOMATICALLY GENERATED BY MINILLA. # DO NOT EDIT DIRECTLY. # ========================================================================= use 5.008_001; use strict; use warnings; use utf8; use Module::Build::XSUtil; use File::Basename; use File::Spec; my %args = ( license => 'perl_5', dynamic_config => 0, configure_requires => { 'Module::Build' => '0.4005', }, requires => { 'XSLoader' => '0.02', 'perl' => '5.010', }, recommends => { }, suggests => { }, build_requires => { 'Devel::PPPort' => '3.19', 'ExtUtils::MakeMaker' => '6.59', 'ExtUtils::ParseXS' => '3.18', 'Hash::Util::FieldHash::Compat' => '0', 'Scope::Guard' => '0', 'Test::Exception' => '0.27', 'Test::More' => '0.62', }, test_requires => { }, name => 'Data-Util', module_name => 'Data::Util', allow_pureperl => 1, script_files => [glob('script/*'), glob('bin/*')], c_source => [qw(xs-src)], PL_files => {}, test_files => ((-d '.git' || $ENV{RELEASE_TESTING}) && -d 'xt') ? 't/ xt/' : 't/', recursive_test_files => 1, needs_compiler_c99 => 1, needs_compiler_cpp => 0, generate_ppport_h => 'xs-src/ppport.h', generate_xshelper_h => 'xs-src/xshelper.h', cc_warnings => 0, ); if (-d 'share') { $args{share_dir} = 'share'; } my $builder = Module::Build::XSUtil->subclass( class => 'MyBuilder', code => q{ sub ACTION_distmeta { die "Do not run distmeta. Install Minilla and `minil install` instead.\n"; } sub ACTION_installdeps { die "Do not run installdeps. Run `cpanm --installdeps .` instead.\n"; } } )->new(%args); $builder->create_build_script(); Changes100644001750001750 1360413071222366 14616 0ustar00syoheisyohei000000000000Data-Util-0.66Revision history for Data-Util 0.66 2017-04-05T17:09:54Z - Fix tests of @INC issue on newer Perl 0.65 2016-08-01T13:12:55Z - Drop Perl 5.8 for maintenance - Fix pure perl installation 0.64 2016-07-23T15:13:01Z - Fix on perl 5.22.x or higher versions - Minilla migrate 0.63 2014-03-06 07:42:05+0900 - Fix a crash on perl 5.19.x (tokuhirom) 0.62 2013-04-03 16:06:46 - Fix a crash on perl 5.17.x (tokuhirom) 0.61 2013-01-28 10:52:13 - Fix usage of get_code_ref() in SYNOPSIS (thanks to @toku_bass) 0.60 2012-10-20 20:54:58 - No feature changes. Just upgraded Module::Install. 0.59 2011-10-19 20:08:49 - Re-packaging with better dependencies and latest M::I 0.58 Mon Sep 13 19:40:34 2010 - Use GvCV_set() for newer perls 0.57 Sun Aug 1 17:33:44 2010 - Fix tests for newer perls 0.56 Fri Jan 1 12:24:20 2010 - Fix RT #53167 (thanks to Andreas Koenig) - Fix a configuration issue 0.55 Thu Dec 24 16:31:07 2009 - Shipped with Module::Install::XSUtil 0.19 0.54 Wed Oct 21 14:24:29 2009 - re-fix the method-modifiers issue (thanks @nekoya) - this issue seems related to RT #69939 0.53 Mon Oct 19 19:08:19 2009 - fix an issue which broke method modifiers in some cases (thanks @nekoya) 0.52 Mon Jul 13 12:20:03 2009 - fix t/06_subroutine.t for bleadperl - add repository information 0.51 Thu Jul 9 09:42:11 2009 - add rx() and is_rx() (alias regex_ref() and is_regex_ref()) - fix possible segv in modifiers (t/23_largeargs.t) - fix typos in pods 0.50 Tue Jan 20 12:32:14 2009 - fix negative subscriptive placeholders for curry() (t/23_curry_neg_ph.t) - remove wrap_subroutine() which was deprecated from 0.31 0.44 Sun Dec 21 13:06:36 2008 - add get_code_ref() for do{ no strict 'refs'; *{$pkg.'::'.$name}{CODE} } - change install/uninstall_subroutine() to accept single hash parameter (e.g. install_subroutine($pkg, { name => \&subr }) - optimize mkopt() when a HASH ref is supplied as the option list - fix possible memory leaks in mkopt() - fix documentation - fix "Insecure dependency while -T" with DATA_UTIL_PUREPERL=1 0.43 Sun Dec 14 13:37:43 2008 - fix modifer's order of modify_subroutine()/subroutine_modifier() to be compatible with Moose - fix some bugs on neat()/is_number()/install_subroutine() - remove "original" property from subroutine_modifier(), which seems a waste of memory - internal cleanup 0.42 Wed Dec 10 13:42:50 2008 - fix is_number()/is_integer() to refuse Infinity and NaN correctly - fix a possible segfault on install_subrouitne() - internal cleanup 0.41 Man Dec 8 11:36:38 2008 - change get_stash() to be able to take an object reference - change is_number()/is_integer() to refuse "0 but true" - fix some bugs 0.40 Sun Dec 7 13:42:17 2008 - add is_value()/is_string()/is_number()/is_integer() functions - change get_stash/invocant/is_invocant to refuse "" as a class name - change uninstall_subroutine() to be able to take the same arguments as install_subroutine() 0.32 Thu Dec 4 13:25:29 2008 - fix uninstall_subroutine() to work correctly (t/17_nsclean.t) 0.31 Wed Dec 3 11:56:29 2008 - rewrite mro_compat.[hc] using MRO::Compat - rename wrap_subroutine to modify_subroutine, (wrap_subroutine has been deprecated) - add benchmark/install_subr_bench.pl - internal cleanup 0.30 Sun Nov 30 17:18:46 2008 - fix wrapped subroutines to get correct arguments 0.29_02 Sun Nov 30 14:22:47 2008 - improve portability on VC++/ICC (RT#41204) - move MethodModifiers.pm from lib/ to example/lib/ - fix uninstall_subroutine() to delete subroutine stubs correctly - fix modifier calling order 0.29_01 Mon Nov 24 12:43:03 2008 - add curry() function for currying (argument binding) - add wrap_subroutine() and subroutine_modifier() - add Data::Util::MethodModifiers module - add DISCUSSIONS section in JA.pod - update ppport.h to 3.14_05 0.21 Mon Nov 17 13:15:52 2008 - allow install_subroutine() to accept multiple pairs of name and code - add uninstall_subroutine() - change get_code_info() to return the full qualified name in scalar context 0.20 Sun Nov 16 13:04:56 2008 - add more tests - fix some bugs - remove Data::OptList dependency - internal cleanup 0.19_01 Wed Nov 12 22:33:23 2008 - some imcompatible changes - remove -fast_isa subdirective, which is no longer useful - remove -fail_handler subdirective, use Data::Util::Error instead. - add Data::Util::Error module for error handling - add invocant() and is_invocant() - add mkopt() and mkopt_hash() which are compatible with Data::OptList - improve error handlers to be inheritable - fix install_subroutine() not to locate subroutines named by Sub::Name 0.11 Mon Nov 3 10:09:57 2008 - fix possible segfault in get_code_info() 0.10 Sat Nov 1 11:02:06 2008 - add get_code_info() - add lib/Data/Util/JA.pod - add pure-perl implementation - internal cleanup 0.05 Tue Oct 28 22:39:58 2008 - add install_subroutine() - internal cleanup 0.041 Mon Oct 27 08:27:11 2008 - fix C99 portability - fix is_instance() to return a bool - fix get_stash() to accept undef silently 0.04 Sun Oct 26 10:19:11 2008 - change messsages - improve neat() when HASH or ARRAY is supplied - add "-fail_handler" subdirective - add c99portability.h for C99 portability 0.03 Fri Oct 24 12:17:13 2008 - remove unused code - a bit of optimization (using 'inline' effectively) 0.02 Fri Oct 24 09:10:31 2008 - derived from Scalar::Util::Ref - add "-fast_isa" subdirective which makes UNIVERSAL::isa() faster - remove "instanceof" operator - many optimizations - fix some bugs 0.01 Sat Oct 4 11:32:36 2008 - original version; created by Module::Starter started as Scalar::Util::Ref LICENSE100644001750001750 4375713071222366 14344 0ustar00syoheisyohei000000000000Data-Util-0.66This software is copyright (c) 2016 by Goro Fuji(gfx) .. 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) 2016 by Goro Fuji(gfx) .. 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, Suite 500, Boston, MA 02110-1335 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2016 by Goro Fuji(gfx) .. This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End META.json100644001750001750 472213071222366 14725 0ustar00syoheisyohei000000000000Data-Util-0.66{ "abstract" : "A selection of utilities for data and data types", "author" : [ "Goro Fuji(gfx) ." ], "dynamic_config" : 0, "generated_by" : "Minilla/v3.0.10", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Data-Util", "no_index" : { "directory" : [ "t", "xt", "inc", "share", "eg", "examples", "author", "builder" ] }, "prereqs" : { "build" : { "requires" : { "Devel::PPPort" : "3.19", "ExtUtils::MakeMaker" : "6.59", "ExtUtils::ParseXS" : "3.18", "Hash::Util::FieldHash::Compat" : "0", "Scope::Guard" : "0", "Test::Exception" : "0.27", "Test::More" : "0.62" } }, "configure" : { "requires" : { "Module::Build" : "0.4005", "Module::Build::XSUtil" : "0.03" } }, "develop" : { "requires" : { "Test::CPAN::Meta" : "0", "Test::MinimumVersion::Fast" : "0.04", "Test::PAUSE::Permissions" : "0.04", "Test::Pod" : "1.41", "Test::Spellunker" : "v0.2.7" } }, "runtime" : { "requires" : { "XSLoader" : "0.02", "perl" : "5.010" } } }, "provides" : { "Data::Util" : { "file" : "lib/Data/Util.pm", "version" : "0.66" }, "Data::Util::Error" : { "file" : "lib/Data/Util/Error.pm" }, "Data::Util::PurePerl" : { "file" : "lib/Data/Util/PurePerl.pm" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/gfx/Perl-Data-Util/issues" }, "homepage" : "https://github.com/gfx/Perl-Data-Util", "repository" : { "url" : "git://github.com/gfx/Perl-Data-Util.git", "web" : "https://github.com/gfx/Perl-Data-Util" } }, "version" : "0.66", "x_contributors" : [ "Fuji Goro ", "Fuji, Goro ", "Tokuhiro Matsuno ", "Fuji, Goro (gfx) ", "Patrice Clement ", "Syohei YOSHIDA " ], "x_serialization_backend" : "JSON::PP version 2.27400" } README.md100644001750001750 2726313071222366 14610 0ustar00syoheisyohei000000000000Data-Util-0.66[![Build Status](https://circleci.com/gh/gfx/Perl-Data-Util.svg)](https://circleci.com/gh/gfx/Perl-Data-Util) # NAME Data::Util - A selection of utilities for data and data types # VERSION This document describes Data::Util version 0.66 # SYNOPSIS use Data::Util qw(:validate); sub foo{ # they will die if invalid values are supplied my $sref = scalar_ref(shift); my $aref = array_ref(shift); my $href = hash_ref(shift); my $cref = code_ref(shift); my $gref = glob_ref(shift); my $rx = rx(shift); # regular expression my $obj = instance(shift, 'Foo'); # ... } use Data::Util qw(:check); sub bar{ my $x = shift; if(is_scalar_ref $x){ # $x is an array reference } # ... elsif(is_instance $x, 'Foo'){ # $x is an instance of Foo } # ... } # miscelaneous use Data::Util qw(:all); my $x = anon_scalar(); $x = anon_scalar($x); # OK my $stash = get_stash('Foo'); install_subroutine('Foo', hello => sub{ "Hello!\n" }, goodby => sub{ "Goodby!\n" }, ); print Foo::hello(); # Hello! my($pkg, $name) = get_code_info(\&Foo::hello); # => ('Foo', 'hello') my $fqn = get_code_info(\&Foo::hello); # => 'Foo::hello' my $code = get_code_ref('Foo', 'hello'); # => \&Foo::hello uninstall_subroutine('Foo', qw(hello goodby)); # simple format for errro messages (not the same as Data::Dumper) print neat("Hello!\n"); # => "Hello!\n" print neat(3.14); # => 3.14 print neat(undef); # => undef # DESCRIPTION This module provides utility functions for data and data types, including functions for subroutines and symbol table hashes (stashes). This module makes for a pure Perl and XS implementation. However, if you want to use the full capacity of it, we recommend you to opt for the XS backend. There are many benchmarks in the `DIST-DIR/benchmark/` directory. # INTERFACE ## Check functions Check functions are introduced by the `:check` import tag, which check the argument type and return a bool. These functions also check for overloading magic, e.g. `${}` corresponds to a SCALAR reference. - is\_scalar\_ref(value) Checks for a SCALAR reference. - is\_array\_ref(value) Checks for an ARRAY reference. - is\_hash\_ref(value) Checks for a HASH reference. - is\_code\_ref(value) Checks for a CODE reference. - is\_glob\_ref(value) Checks for a GLOB reference. - is\_rx(value) Checks for a regular expression reference generated by the `qr//` operator. - is\_instance(value, class) Checks for an instance of _class_. It is equivalent to the following statement: `Scalar::Util::blessed($value) && $value->isa($class)`. - is\_invocant(value) Checks for an invocant, i.e. a blessed reference or existent package name. If _value_ is a valid class name but does not exist, it will return false. - is\_value(value) Checks whether _value_ is a primitive value, i.e. a defined, non-ref, and non-type-glob value. This function has no counterpart for validation. - is\_string(value) Checks whether _value_ is a string with non-zero-length contents, equivalent to `is_value($value) && length($value) > 0`. This function has no counterpart for validation. - is\_number(value) Checks whether _value_ is a number. Here, a **number** means that the perl parser can understand it and that the perl numeric converter (e.g. invoked by `sprintf '%g', $value`) doesn't complain about it. It is similar to `Scalar::Util::looks_like_number()` but refuses `infinity`, `not a number` and `"0 but true"`. Note that `9**9**9` makes `infinity` and `9**9**9 - 9**9**9` makes `not a number`. This function has no counterpart for validation. - is\_integer(value) Checks whether _value_ is an integer. An **integer** is also a **number**, so this function refuses `infinity` and `not a number`. See also `is_number()`. This function has no counterpart for validation. ## Validating functions Validating functions are introduced by the `:validate` tag which checks for the argument and returns the first argument. These are like the `:check` functions but dies if the argument type is invalid. These functions also checks overloading magic, e.g. `${}` for a SCALAR reference. - scalar\_ref(value) Validates a SCALAR reference. - array\_ref(value) Validates an ARRAY reference. - hash\_ref(value) Validates a HASH reference. - code\_ref(value) Validates a CODE reference. - glob\_ref(value) Validates a GLOB reference. - rx(value) Validates a regular expression reference. - instance(value, class) Validates an instance of _class_. - invocant(value) Validates an invocant, i.e. a blessed reference or existent package name. If _value_ is a valid class name and the class exists, then it returns the canonical class name, which is logically cleaned up. That is, it runs `$value =~ s/^::(?:main::)*//;` before returning it. NOTE: Canonization is done so due to an inconsistency between Perl versions. For instance: package ::Foo; # OK my $x = bless {}, '::Foo'; # OK ref($x)->isa('Foo'); # Fatal The last code snippet causes a fatal error: `Can't call method "isa" without package or object reference`. However, `invocant(ref $x)->isa('Foo')` is always OK. ## Miscellaneous utilities There are some other utility functions you can import from this module. - anon\_scalar() Generates an anonymous scalar reference to `undef`. - anon\_scalar(value) Generates an anonymous scalar reference to the copy of _value_. It is equivalent to `do{ my $tmp = $value; \$tmp; }`. - neat(value) Returns a neat string that is suitable to display. This is a smart version of `. - get\_stash(invocant) Returns the symbol table hash (also known as **stash**) of _invocant_ if the stash exists. - install\_subroutine(package, name => subr \[, ...\]) Installs _subr_ into _package_ as _name_. It is similar to `do{ no strict 'refs'; *{$package.'::'.$name} = \&subr; }`. In addition, if _subr_ is an anonymous subroutine, it is located into _package_ as a named subroutine _&package::name_. For example: install_subroutine($pkg, say => sub{ print @_, "\n" }); install_subroutine($pkg, one => \&_one, two => \&_two, ); # accepts a HASH reference install_subroutine($pkg, { say => sub{ print @_, "\n" }); # To re-install _subr_, use `no warnings 'redefine'` directive: no warnings 'redefine'; install_subroutine($package, $name => $subr); - uninstall\_subroutine(package, names...) Uninstalls _names_ from _package_. It is similar to `Sub::Delete::delete_sub()`, but uninstall multiple subroutines at a time. If you want to specify deleted subroutines, you can supply `name => \&subr` pairs. For example: uninstall_subroutine('Foo', 'hello'); uninstall_subroutine('Foo', hello => \&Bar::hello); uninstall_subroutine($pkg, one => \&_one, two => \&_two, ); # accepts a HASH reference uninstall_subroutine(\$pkg, { hello => \&Bar::hello }); - get\_code\_info(subr) Returns a pair of elements, the package name and the subroutine name of _subr_. It is similar to `Sub::Identify::get_code_info()`, but it returns the fully qualified name in scalar context. - get\_code\_ref(package, name, flag?) Returns _&package::name_ if it exists, not touching the symbol in the stash. if _flag_ is a string `-create`, it returns _&package::name_ regardless of its existence. That is, it is equivalent to `do{ no strict 'refs'; \&{package . '::' . $name} }`. For example: $code = get_code_ref($pkg, $name); # like *{$pkg.'::'.$name}{CODE} $code = get_code_ref($pkg, $name, -create); # like \&{$pkg.'::'.$name} - curry(subr, args and/or placeholders) Makes _subr_ curried and returns the curried subroutine. This is also considered as lightweight closures. See also [Data::Util::Curry](https://metacpan.org/pod/Data::Util::Curry). - modify\_subroutine(subr, ...) Modifies _subr_ with subroutine modifiers and returns the modified subroutine. This is also considered as lightweight closures. _subr_ must be a code reference or callable object. Optional arguments: `before => [subroutine(s)]` called before _subr_. `around => [subroutine(s)]` called around _subr_. `after => [subroutine(s)]` called after _subr_. This seems a constructor of modified subroutines and `subroutine_modifier()` is property accessors, but it does not bless the modified subroutines. - subroutine\_modifier(subr) Returns whether _subr_ is a modified subroutine. - subroutine\_modifier(modified\_subr, property) Gets _property_ from _modified_. Valid properties are: `before`, `around`, `after`. - subroutine\_modifier(modified\_subr, modifier => \[subroutine(s)\]) Adds subroutine _modifier_ to _modified\_subr_. Valid modifiers are: `before`, `around`, `after`. - mkopt(input, moniker, require\_unique, must\_be) Produces an array of an array reference from _input_. It is compatible with `Data::OptList::mkopt()`. In addition to it, _must\_be_ can be a HASH reference with `name => type` pairs. For example: my $optlist = mkopt(['foo', bar => [42]], $moniker, $uniq, { bar => 'ARRAY' }); # $optlist == [[foo => undef], [bar => [42]] - mkopt\_hash(input, moniker, must\_be) Produces a hash reference from _input_. It is compatible with `Data::OptList::mkopt_hash()`. In addition to it, _must\_be_ can be a HASH reference with `name => type` pairs. For example: my $optlist = mkopt(['foo', bar => [42]], $moniker, { bar => 'ARRAY' }); # $optlist == {foo => undef, bar => [42]} # ENVIRONMENT VARIABLES ## DATA\_UTIL\_PUREPERL If true, `Data::Util` uses the pure Perl implementation. # DEPENDENCIES Perl 5.10 or later. If you have a C compiler, you can use the XS backend. A pure Perl backend/implementation is also made available in case you have no C compiler handy (unlikely!). # BUGS AND LIMITATIONS No bugs have been reported. Please report any bugs or feature requests to the author. # SEE ALSO [Scalar::Util](https://metacpan.org/pod/Scalar::Util). [overload](https://metacpan.org/pod/overload). [Params::Util](https://metacpan.org/pod/Params::Util). [Sub::Install](https://metacpan.org/pod/Sub::Install). [Sub::Identify](https://metacpan.org/pod/Sub::Identify). [Sub::Delete](https://metacpan.org/pod/Sub::Delete). [Sub::Curry](https://metacpan.org/pod/Sub::Curry). [Class::MOP](https://metacpan.org/pod/Class::MOP). [Class::Method::Modifiers](https://metacpan.org/pod/Class::Method::Modifiers). [Data::OptList](https://metacpan.org/pod/Data::OptList). [Mouse](https://metacpan.org/pod/Mouse) # AUTHOR Goro Fuji(gfx) <gfuji(at)cpan.org>. # LICENSE AND COPYRIGHT Copyright (c) 2008-2010, Goro Fuji <gfuji(at)cpan.org>. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Common.pm100644001750001750 130613071222366 17017 0ustar00syoheisyohei000000000000Data-Util-0.66/benchmark# benchmark/common.pl use 5.008_001; use strict; use B qw(svref_2object); use Config qw(%Config); use XSLoader(); use DynaLoader(); use Carp qw(longmess); $SIG{__WARN__} = \&longmess; sub perl_signeture{ printf "Perl %vd on %s\n", $^V, $Config{archname}; } sub module_signeture{ my($name, $subr) = @_; my $cv = svref_2object($subr); printf "%s(%s)/%s\n", $name, $cv->XSUB ? 'XS' : 'PurePerl', $name->VERSION; } sub signeture{ my %mods = @_; perl_signeture(); while(my($name, $subr) = each %mods){ module_signeture($name => $subr); } print "\n"; } if(grep { /^--pureperl$/ } @ARGV){ no warnings 'redefine'; *DynaLoader::bootstrap = sub{ die }; *XSLoader::load = sub{ die }; } 1; curry_bench.pl100644001750001750 161613071222366 20075 0ustar00syoheisyohei000000000000Data-Util-0.66/benchmark#!perl -w use strict; use Data::Util qw(curry); use FindBin qw($Bin); use lib $Bin; use Common; use Benchmark qw(:all); signeture 'Data::Util' => \&curry, ; sub f{ @_ } print "Creation:\n"; cmpthese -1 => { curry => sub{ my($a, $b) = (1, 3); my $c = curry(\&f, $a, \0, $b, \1); }, closure => sub{ my($a, $b) = (1, 3); my $c = sub{ f($a, $_[0], $b, $_[1]) }; }, }; my($a, $b) = (1, 3); my $c = curry(\&f, $a, \0, $b, \1); my $d = sub{ f($a, $_[0], $b, $_[1]) }; print "Calling with subscriptive placeholders:\n"; cmpthese -1 => { curry => sub{ $c->(2, 4) == 4 or die; }, closure => sub{ $d->(2, 4) == 4 or die; }, }; $c = curry(\&f, $a, *_, $b); $d = sub{ f($a, @_[0 .. $#_], $b) }; print "Calling with the symbolic placeholder:\n"; cmpthese -1 => { curry => sub{ $c->(1 .. 5) == 7 or die $c->(1 .. 5); }, closure => sub{ $d->(1 .. 5) == 7 or die $d->(1 .. 5); }, }; export_bench.pl100644001750001750 154113071222366 20247 0ustar00syoheisyohei000000000000Data-Util-0.66/benchmark#!perl -w use strict; use Benchmark qw(:all); use FindBin qw($Bin); use lib $Bin, "$Bin/../example/lib"; use Common; use Data::Util qw(:all); signeture 'Data::Util' => \&install_subroutine, 'Sub::Exporter' => \&Sub::Exporter::import, 'Exporter' => \&Exporter::import, ; BEGIN{ package SE; use Sub::Exporter -setup => { exports => [qw(foo bar baz hoge fuga piyo)], }; $INC{'SE.pm'} = __FILE__; package SEL; use Sub::Exporter::Lexical exports => [qw(foo bar baz hoge fuga piyo)], ; $INC{'SEL.pm'} = __FILE__; package E; use Exporter qw(import); our @EXPORT = qw(foo bar baz hoge fuga piyo); $INC{'E.pm'} = __FILE__; } cmpthese timethese -1 => { 'S::Exporter' => sub{ package A; eval q{ use SE; }; }, 'S::E::Lexical' => sub{ package B; eval q{ use SEL; }; }, 'Exporter' => sub{ package C; eval q{ use E; }; }, } gen_bench.pl100644001750001750 107113071222366 17475 0ustar00syoheisyohei000000000000Data-Util-0.66/benchmark#!perl -w use strict; use Benchmark qw(:all); use Data::Util qw(anon_scalar); use FindBin qw($Bin); use lib $Bin; use Common; signeture 'Data::Util' => \&anon_scalar; cmpthese timethese -1 => { anon_scalar => sub{ for(1 .. 10){ my $ref = anon_scalar(); } }, '\do{my $tmp}' => sub{ for(1 .. 10){ my $ref = \do{ my $tmp }; } }, }; print "\nwith an argument\n"; cmpthese timethese -1 => { anon_scalar => sub{ for(1 .. 10){ my $ref = anon_scalar(10); } }, '\do{my $tmp}' => sub{ for(1 .. 10){ my $ref = \do{ my $tmp = 10 }; } }, }; get_code_ref_bench.pl100644001750001750 62413071222366 21314 0ustar00syoheisyohei000000000000Data-Util-0.66/benchmark#!perl -w use strict; use Benchmark qw(:all); use FindBin qw($Bin); use lib $Bin; use Common; use Data::Util qw(:all); signeture 'Data::Util' => \&get_code_ref; my $pkg = 'Data::Util'; my $name = 'get_code_ref'; cmpthese timethese -1 => { get_code_ref => sub{ my $code = get_code_ref($pkg, $name); }, direct => sub{ my $code = do{ no strict 'refs'; *{$pkg . '::' . $name}{CODE}; }; }, }; get_stash_bench.pl100644001750001750 53513071222366 20671 0ustar00syoheisyohei000000000000Data-Util-0.66/benchmark#!perl -w use strict; use Benchmark qw(:all); use FindBin qw($Bin); use lib $Bin; use Common; use Data::Util qw(:all); signeture 'Data::Util' => \&get_stash; my $pkg = 'Data::Util'; cmpthese timethese -1 => { get_stash => sub{ my $stash = get_stash($pkg); }, direct => sub{ my $stash = do{ no strict 'refs'; \%{$pkg . '::'}; }; }, }; install_subr_bench.pl100644001750001750 224213071222366 21426 0ustar00syoheisyohei000000000000Data-Util-0.66/benchmark#!perl -w use strict; use Benchmark qw(:all); use FindBin qw($Bin); use lib $Bin; use Common; use Data::Util qw(:all); signeture 'Data::Util' => \&install_subroutine; my $pkg = do{ package Foo; __PACKAGE__ }; sub foo{ 42 } print "Installing a subroutine:\n"; cmpthese timethese -1 => { installer => sub{ no warnings 'redefine'; install_subroutine($pkg, foo => \&foo); }, direct => sub{ no warnings 'redefine'; no strict 'refs'; *{$pkg . '::foo'} = \&foo; }, }; print "\nInstalling 2 subroutines:\n"; cmpthese timethese -1 => { installer => sub{ no warnings 'redefine'; install_subroutine($pkg, foo => \&foo, bar => \&foo); }, direct => sub{ no warnings 'redefine'; no strict 'refs'; *{$pkg . '::foo'} = \&foo; *{$pkg . '::bar'} = \&foo; }, }; print "\nInstalling 4 subroutines:\n"; cmpthese timethese -1 => { installer => sub{ no warnings 'redefine'; install_subroutine($pkg, foo => \&foo, bar => \&foo, baz => \&foo, baz => \&foo, ); }, direct => sub{ no warnings 'redefine'; no strict 'refs'; *{$pkg . '::foo'} = \&foo; *{$pkg . '::bar'} = \&foo; *{$pkg . '::baz'} = \&foo; *{$pkg . '::bax'} = \&foo; }, }; instance_bench.pl100644001750001750 210513071222366 20527 0ustar00syoheisyohei000000000000Data-Util-0.66/benchmark#!perl -w use strict; use Benchmark qw(:all); use FindBin qw($Bin); use lib $Bin; use Common; use Data::Util qw(:all); use Params::Util qw(_INSTANCE); # 0.35 provides a XS implementation use Scalar::Util qw(blessed); signeture 'Data::Util' => \&is_instance, 'Params::Util' => \&_INSTANCE, 'Scalar::Util' => \&blessed, ; BEGIN{ package Base; sub new{ bless {} => shift; } package Foo; our @ISA = qw(Base); package Foo::X; our @ISA = qw(Foo); package Foo::X::X; our @ISA = qw(Foo::X); package Foo::X::X::X; our @ISA = qw(Foo::X::X); package Unrelated; our @ISA = qw(Base); package SpecificIsa; our @ISA = qw(Base); sub isa{ $_[1] eq 'Foo'; } } foreach my $x (Foo->new, Foo::X::X::X->new, Unrelated->new, undef, {}){ print 'For ', neat($x), "\n"; my $i = 0; cmpthese -1 => { 'blessed' => sub{ for(1 .. 10){ $i++ if blessed($x) && $x->isa('Foo'); } }, '_INSTANCE' => sub{ for(1 .. 10){ $i++ if _INSTANCE($x, 'Foo'); } }, 'is_instance' => sub{ for(1 .. 10){ $i++ if is_instance($x, 'Foo'); } }, }; print "\n"; } invocant_bench.pl100644001750001750 167413071222366 20556 0ustar00syoheisyohei000000000000Data-Util-0.66/benchmark#!perl -w use strict; use Benchmark qw(:all); use FindBin qw($Bin); use lib $Bin; use Common; use Data::Util qw(:all), @ARGV; use Params::Util qw(_INVOCANT); signeture 'Data::Util' => \&is_invocant, 'Params::Util' => \&_INVOCANT; BEGIN{ package Base; sub new{ bless {} => shift; } package Foo; our @ISA = qw(Base); package Foo::X; our @ISA = qw(Foo); package Foo::X::X; our @ISA = qw(Foo::X); package Foo::X::X::X; our @ISA = qw(Foo::X::X); } print "Benchmark: Data::Util::is_invocant() vs. Params::Util::_INVOCANT() vs. eval{}\n"; foreach my $x (Foo->new, Foo::X::X::X->new(), 'Foo', 'Foo::X::X::X', undef, {}){ print 'For ', neat($x), "\n"; my $i = 0; cmpthese -1 => { 'eval{}' => sub{ for(1 .. 10){ $i++ if eval{ $x->VERSION; 1 }; } }, '_INVOCANT' => sub{ for(1 .. 10){ $i++ if _INVOCANT($x); } }, 'is_invocant' => sub{ for(1 .. 10){ $i++ if is_invocant($x); } }, }; print "\n"; } methext_bench.pl100644001750001750 227313071222366 20407 0ustar00syoheisyohei000000000000Data-Util-0.66/benchmark#!perl -w use strict; use Benchmark qw(:all); use FindBin qw($Bin); use lib $Bin, "$Bin/../example/lib"; use Common; { package Base; sub e{ $_[1] } sub f{ $_[1] } sub g{ $_[1] } sub h{ $_[1] } sub i{ $_[1] } sub j{ $_[1] } } sub around{ my $next = shift; goto &{$next}; } { package X; use parent -norequire => qw(Base); use Method::Modifiers; before f => sub{ }; around g => \&main::around; after h => sub{ }; sub i{ my $self = shift; $self->SUPER::i(@_); } Data::Util::install_subroutine( __PACKAGE__, j => Data::Util::modify_subroutine(__PACKAGE__->can('j')), ); } signeture 'Data::Util' => \&Data::Util::modify_subroutine, ; print <<'END'; Calling extended methods: inher - no extended, only inherited before - extended with :before modifier around - extended with :around modifier after - extended with :after modifier super - extended with SUPER:: pseudo class END cmpthese -1 => { inher => sub{ X->e(42) == 42 or die; }, before => sub{ X->f(42) == 42 or die; }, around => sub{ X->g(42) == 42 or die; }, after => sub{ X->h(42) == 42 or die; }, super => sub{ X->i(42) == 42 or die; }, # simple => sub{ # X->j(42) == 42 or die; # }, }; mkopt_bench.pl100644001750001750 523513071222366 20064 0ustar00syoheisyohei000000000000Data-Util-0.66/benchmark#!perl -w use strict; use Benchmark qw(:all); use FindBin qw($Bin); use lib $Bin; use Common; use Data::Util qw(:all); use Data::OptList(); signeture 'Data::Util' => \&mkopt, 'Data::OptList' => \&Data::OptList::mkopt; my @args = ([qw(foo bar), baz => []], "moniker", 0); #use Test::More 'no_plan'; #is_deeply Data::Util::mkopt(@args), Data::OptList::mkopt(@args); print "mkopt()\n"; print "no-unique, no-validation\n"; cmpthese -1 => { 'OptList' => sub{ for(1 .. 10){ my $opt_ref = Data::OptList::mkopt(@args); } }, 'Util' => sub{ for(1 .. 10){ my $opt_ref = Data::Util::mkopt(@args); } }, 'inline' => sub{ for(1 .. 10){ my $opt_ref = [ (map{ [$_ => undef] } qw(foo bar) ), [baz => []] ]; } }, }; @args = ([qw(foo bar), baz => []], "moniker", 1); print "unique, no-validation\n"; cmpthese -1 => { 'OptList' => sub{ for(1 .. 10){ my $opt_ref = Data::OptList::mkopt(@args); } }, 'Util' => sub{ for(1 .. 10){ my $opt_ref = Data::Util::mkopt(@args); } }, }; @args = ([qw(foo bar), baz => []], "moniker", 0, 'ARRAY'); print "no-unique, validation\n"; cmpthese -1 => { 'OptList' => sub{ for(1 .. 10){ my $opt_ref = Data::OptList::mkopt(@args); } }, 'Util' => sub{ for(1 .. 10){ my $opt_ref = Data::Util::mkopt(@args); } }, }; @args = ([qw(foo bar), baz => []], "moniker", 1, 'ARRAY'); print "unique, validation\n"; cmpthese -1 => { 'OptList' => sub{ for(1 .. 10){ my $opt_ref = Data::OptList::mkopt(@args); } }, 'Util' => sub{ for(1 .. 10){ my $opt_ref = Data::Util::mkopt(@args); } }, }; @args = ({foo => [], bar => [], baz => []}, "moniker", 0); print "\nmkopt() from HASH ref\n"; cmpthese -1 => { 'OptList' => sub{ for(1 .. 10){ my $opt_ref = Data::OptList::mkopt(@args); } }, 'Util' => sub{ for(1 .. 10){ my $opt_ref = Data::Util::mkopt(@args); } }, }; @args = ([qw(foo bar), baz => []]); print "\nmkopt_hash()\n"; cmpthese -1 => { 'OptList' => sub{ for(1 .. 10){ my $opt_ref = Data::OptList::mkopt_hash(@args); } }, 'Util' => sub{ for(1 .. 10){ my $opt_ref = Data::Util::mkopt_hash(@args); } }, 'inline' => sub{ for(1 .. 10){ my $opt_ref = { (map{ $_ => undef} qw(foo bar) ), baz => [] }; } } }; @args = ([qw(foo bar), baz => []], 'test', 'ARRAY'); print "mkopt_hash() with validation\n"; cmpthese -1 => { 'OptList' => sub{ for(1 .. 10){ my $opt_ref = Data::OptList::mkopt_hash(@args); } }, 'Util' => sub{ for(1 .. 10){ my $opt_ref = Data::Util::mkopt_hash(@args); } }, 'inline' => sub{ for(1 .. 10){ my $opt_ref = { (map{ $_ => undef} qw(foo bar) ), baz => [] }; while(my($k, $v) = each %{$opt_ref}){ defined $v and array_ref($v); } } } }; modifier_bench.pl100644001750001750 334313071222366 20526 0ustar00syoheisyohei000000000000Data-Util-0.66/benchmark#!perl -w use strict; use Benchmark qw(:all); use FindBin qw($Bin); use lib $Bin, "$Bin/../example/lib"; use Common; { package Base; sub f{ 42 } sub g{ 42 } sub h{ 42 } } my $i = 0; sub around{ my $next = shift; $i++; goto &{$next}; } { package DUMM; use parent -norequire => qw(Base); use Method::Modifiers; before f => sub{ $i++ }; around g => \&main::around; after h => sub{ $i++ }; } { package CMM; use parent -norequire => qw(Base); use Class::Method::Modifiers; before f => sub{ $i++ }; around g => \&main::around; after h => sub{ $i++ }; } { package MOP; use parent -norequire => qw(Base); use Moose; before f => sub{ $i++ }; around g => \&main::around; after h => sub{ $i++ }; } signeture 'Data::Util' => \&Data::Util::modify_subroutine, 'Moose' => \&Moose::around, 'Class::Method::Modifiers' => \&Class::Method::Modifiers::around, ; print "Calling methods with before modifiers:\n"; cmpthese -1 => { du => sub{ my $old = $i; DUMM->f(); $i == ($old+1) or die $i; }, cmm => sub{ my $old = $i; CMM->f(); $i == ($old+1) or die $i; }, moose => sub{ my $old = $i; MOP->f(); $i == ($old+1) or die $i; } }; print "\n", "Calling methods with around modifiers:\n"; cmpthese -1 => { du => sub{ my $old = $i; DUMM->g(); $i == ($old+1) or die $i; }, cmm => sub{ my $old = $i; CMM->g(); $i == ($old+1) or die $i; }, moose => sub{ my $old = $i; MOP->g(); $i == ($old+1) or die $i; } }; print "\n", "Calling methods with after modifiers:\n"; cmpthese -1 => { du => sub{ my $old = $i; DUMM->h(); $i == ($old+1) or die $i; }, cmm => sub{ my $old = $i; CMM->h(); $i == ($old+1) or die $i; }, moose => sub{ my $old = $i; MOP->h(); $i == ($old+1) or die $i; } }; modify_bench.pl100644001750001750 266013071222366 20220 0ustar00syoheisyohei000000000000Data-Util-0.66/benchmark#!perl -w use strict; use Data::Util qw(:all); use Benchmark qw(:all); use FindBin qw($Bin); use lib $Bin; use Common; signeture 'Data::Util' => \&modify_subroutine; sub f { 42 } sub before { 1 } sub around { my $f = shift; $f->(@_) + 1; } sub after { 1 } my @before = (\&before, \&before); my @around = (\&around); my @after = (\&after, \&after); my $modified = modify_subroutine(\&f, before => \@before, around => \@around, after => \@after); sub modify{ my $subr = shift; my @before = @{(shift)}; my @around = @{(shift)}; my @after = @{(shift)}; $subr = curry($_, (my $tmp = $subr), *_) for @around; return sub{ $_->(@_) for @before; my @ret = wantarray ? $subr->(@_) : scalar $subr->(@_); $_->(@_) for @after; return wantarray ? @ret : $ret[0]; }; } my $closure = modify(\&f, \@before, \@around, \@after); $modified->(-1) == 43 or die $modified->(-10); $closure->(-2) == 43 or die $closure->(-20); print "Creation of modified subs:\n"; cmpthese timethese -1 => { modify => sub{ my $w = modify_subroutine(\&f, before => \@before, around => \@around, after => \@after); }, closure => sub{ my $w = modify(\&f, \@before, \@around, \@after); }, }; sub combined{ $_->(@_) for @before; around(\&f, @_); $_->(@_) for @after; } print "Calling modified subs:\n"; cmpthese timethese -1 => { modify => sub{ $modified->(42); }, closure => sub{ $closure->(42); }, combined => sub{ combined(42); }, }; number_bench.pl100644001750001750 125413071222366 20217 0ustar00syoheisyohei000000000000Data-Util-0.66/benchmark#!perl -w use strict; use Benchmark qw(:all); use Scalar::Util qw(looks_like_number); use Data::Util qw(:all); use FindBin qw($Bin); use lib $Bin; use Common; signeture 'Data::Util' => \&is_number, 'Scalar::Util' => \&looks_like_number; print "Benchmark: is_number(), is_integer(), looks_like_number()\n"; for my $x(42, exp(1), '42', sprintf('%g', exp(1)), undef){ print "For ", neat($x), "\n"; cmpthese -1 => { is_number => sub{ for(1 .. 100){ my $ok = is_number $x; } }, is_integer => sub{ for(1 .. 100){ my $ok = is_integer $x; } }, looks_like_number => sub{ for(1 .. 100){ my $ok = looks_like_number $x; } }, }; print "\n"; } ref_bench.pl100644001750001750 131013071222366 17474 0ustar00syoheisyohei000000000000Data-Util-0.66/benchmark#!perl -w use strict; use warnings FATAL => 'all'; use Benchmark qw(:all); use FindBin qw($Bin); use lib $Bin; use Common; use Params::Util qw(_ARRAY0); use Data::Util qw(:all); signeture 'Data::Util' => \&is_array_ref, 'Params::Util' => \&_ARRAY0; print "Benchmark: Params::Util::_ARRAY0() vs. Data::Util::is_array() vs. ref()\n"; foreach my $o([], {}, bless({}, 'Foo'), undef){ print "\nFor ", neat($o), "\n"; cmpthese -1 => { '_ARRAY0' => sub{ for(1 .. 10){ if(_ARRAY0($o)){ ; } } }, 'is_array_ref' => sub{ for(1 .. 10){ if(is_array_ref($o)){ ; } } }, 'ref() eq "ARRAY"' => sub{ for(1 ..10){ if(ref($o) eq 'ARRAY'){ ; } } }, }; } circle.yml100644001750001750 234613071222366 15270 0ustar00syoheisyohei000000000000Data-Util-0.66machine: environment: PATH: ~/.plenv/bin:~/.plenv/shims:$PATH timezone: Asia/Tokyo dependencies: cache_directories: - ~/.plenv pre: - | if [ ! -e ~/.plenv/bin/plenv ]; then git clone --depth=1 https://github.com/tokuhirom/plenv.git ~/.plenv eval "$(plenv init -)" git clone --depth=1 https://github.com/tokuhirom/Perl-Build.git ~/.plenv/plugins/perl-build/ for version in 5.24.0 5.22.2 5.16.3 5.12.5 5.10.1 do FLAGS="" if [ $version == "5.24.0" ]; then FLAGS="-Dusethreads" fi plenv install $version $FLAGS plenv global $version plenv install-cpanm done fi test: override: - plenv global 5.24.0 - cpanm --installdeps -n . - perl Build.PL && ./Build && ./Build test - plenv global 5.22.2 - cpanm --installdeps -n . - perl Build.PL && ./Build && ./Build test - plenv global 5.16.3 - cpanm --installdeps -n . - perl Build.PL && ./Build && ./Build test - plenv global 5.12.5 - cpanm --installdeps -n . - perl Build.PL && ./Build && ./Build test - plenv global 5.10.1 - cpanm --installdeps -n . - perl Build.PL && ./Build && ./Build test cpanfile100644001750001750 65313071222366 14767 0ustar00syoheisyohei000000000000Data-Util-0.66requires 'XSLoader', '0.02'; requires 'perl', '5.010'; on build => sub { requires 'Devel::PPPort', '3.19'; requires 'ExtUtils::MakeMaker', '6.59'; requires 'ExtUtils::ParseXS', '3.18'; requires 'Hash::Util::FieldHash::Compat'; requires 'Scope::Guard'; requires 'Test::Exception', '0.27'; requires 'Test::More', '0.62'; }; on configure => sub { requires 'Module::Build::XSUtil' => '>=0.02'; }; curry.pl100644001750001750 72613071222366 16420 0ustar00syoheisyohei000000000000Data-Util-0.66/example#!perl -w use strict; use Data::Util qw(:all); { package Foo; use Data::Dumper; use Data::Util qw(:all); use Carp qw(cluck); install_subroutine(__PACKAGE__, baz => curry(\0, 'bar', x => \1, y => \2, z => \3), ); sub bar{ my($self, %args) = @_; print Dumper \%args; } sub incr{ $_[1]++ } } Foo->baz(10, 20, 30); my $i = 0; install_subroutine __PACKAGE__, incr => curry('Foo', 'incr', *_); for (1 .. 3){ incr($i); print 'incr $i = ', $i, "\n"; } export_lexical.pl100644001750001750 116213071222366 20311 0ustar00syoheisyohei000000000000Data-Util-0.66/example#!perl -w use strict; use FindBin qw($Bin); use lib "$Bin/lib"; BEGIN{ package Foo; use feature 'say'; use Sub::Exporter::Lexical # in example/lib/Sub/Exporter/Lexical.pm exports => [qw(foo bar baz), ('A' .. 'Z')], ; sub foo{ say 'foo!' } sub bar{ say 'bar!' } sub baz{ say 'baz!' } $INC{'Foo.pm'} = __FILE__; package Bar; use Exporter qw(import); our @EXPORT = (qw(foo bar baz), ('A' .. 'Z')); sub foo{} sub bar{} sub baz{} $INC{'Bar.pm'} = __FILE__; } { use Foo qw(foo bar baz); foo; bar; baz; } eval{ foo() } or warn '! ', $@; eval{ bar() } or warn '! ', $@; eval{ baz() } or warn '! ', $@; Modifiers.pm100644001750001750 461513071222366 21205 0ustar00syoheisyohei000000000000Data-Util-0.66/example/lib/Methodpackage # this is an example for modify_subroutine()/subroutne_modifier(). Method::Modifiers; use strict; use warnings; our $VERSION = '0.66'; use Exporter qw(import); our @EXPORT = qw(before around after); our @EXPORT_OK = (@EXPORT, qw(add_method_modifier)); our %EXPORT_TAGS = ( all => \@EXPORT_OK, moose => \@EXPORT, ); use Data::Util (); sub _croak{ require Data::Util::Error; goto &Data::Util::Error::croak; } sub add_method_modifier{ my $into = shift; my $type = shift; my $modifier = pop; foreach my $name(@_){ my $method = Data::Util::get_code_ref($into, $name); if(!$method || !Data::Util::subroutine_modifier($method)){ unless($method){ $method = $into->can($name) or _croak(qq{The method '$name' is not found in the inheritance hierarchy for class $into}); } $method = Data::Util::modify_subroutine($method, $type => [$modifier]); no warnings 'redefine'; Data::Util::install_subroutine($into, $name => $method); } else{ # $method exists and is modified Data::Util::subroutine_modifier($method, $type => $modifier); } } return; } sub before{ my $into = caller; add_method_modifier($into, before => @_); } sub around{ my $into = caller; add_method_modifier($into, around => @_); } sub after{ my $into = caller; add_method_modifier($into, after => @_); } 1; __END__ =head1 NAME Method::Modifiers - Lightweight method modifiers =head1 SYNOPSIS package Foo; use warnings; use Data::Util qw(:all); use Method::Modifiers; before old_method => curry \&warnings::warnif, deprecated => q{"old_method" is deprecated, use "new_method" instead}; my $success = 0; after qw(foo bar baz) => sub{ $success++ }; around foo => sub{ my $next = shift; my $self = shift; $self->$next(map{ instance $_, 'Foo' } @_); }; =head1 DESCRIPTION This module is an implementation of C that provides C-like method modifiers. This is just a front-end of C and C See L for details. =head1 INTERFACE =head2 Default exported functions =over 4 =item before(method(s) => code) =item around(method(s) => code) =item after(method(s) => code) =back =head2 Exportable functions =over 4 =item add_method_modifier(class, modifer_type, method(s), modifier) =back =head1 SEE ALSO L. L. L. =cut Lexical.pm100644001750001750 327313071222366 21765 0ustar00syoheisyohei000000000000Data-Util-0.66/example/lib/Sub/Exporterpackage # this is an example for install_subroutine()/uninstall_subroutine(). Sub::Exporter::Lexical; use 5.008_001; use strict; use warnings; use Data::Util; use Carp (); sub import :method{ my $class = shift; my $exportee = caller; $class->setup_installer($exportee, @_); } sub setup_installer :method{ my($exporter, $exportee, %args) = @_; my $exportable_ref = Data::Util::mkopt_hash $args{exports}, 'setup', 'CODE'; while(my($name, $entity) = each %{$exportable_ref}){ unless($entity){ $exportable_ref->{$name} = Data::Util::get_code_ref($exportee, $name, -create); } } Data::Util::install_subroutine($exportee, import => sub :method{ my $class = shift; my $export_ref; if(@_){ $export_ref = {}; for my $name(@_){ $export_ref->{$name} = $exportable_ref->{$name} or Carp::croak "$name is not exportable in $exportee"; } } else{ $export_ref = $exportable_ref; } my $into = caller; Data::Util::install_subroutine($into, %{$export_ref}); $^H |= 0x020000; # HINT_LOCALIZE_HH my $cleaner = $^H{$exporter .'/'. $into} ||= bless [$into], $exporter; push @{$cleaner}, %{$export_ref}; return; }); } sub DESTROY :method{ my($self) = @_; Data::Util::uninstall_subroutine(@{$self}); } 1; __END__ =head1 NAME Sub::Exporter::Lexical - Exports subrtouines lexically =head1 SYNOPSIS package Foo; use Sub::Exporter::Lexical exports => [ qw(foo bar), baz => \&bar, # i.e. the synonym of bar ], ; # ... { use Foo; foo(...); # Foo::foo(...) bar(...); # Foo::bar(...) baz(...); # Foo::bar(...), too } # foo, bar and baz are uninstalled foo(); # fatal! bar(); # fatal! baz(); # fatal! =head1 SEE ALSO L. =cut modifier.pl100644001750001750 73613071222366 17053 0ustar00syoheisyohei000000000000Data-Util-0.66/example#!perl -w use strict; use Data::Util qw(:all); use Data::Dumper; use Carp qw(cluck); { sub foo { cluck('foo called'); print Dumper [foo => @_]; return (-1, -2); } sub bar { my $f = shift; print Dumper [bar => @_ ]; $f->(@_); }; sub baz { my $f = shift; print Dumper [baz => @_ ]; $f->(@_); }; } my $c = modify_subroutine( \&foo, before => [sub { print ":before\n" } ], around => [\&bar, \&baz], after => [sub { print ":after\n" } ], ); $c->(42); neat.pl100644001750001750 54513071222366 16202 0ustar00syoheisyohei000000000000Data-Util-0.66/example#!perl -w use strict; use Data::Util qw(neat); sub say{ print @_, "\n" } say neat "foo"; say neat "here is a very long string"; say neat \"bar"; say neat 3.14; say neat 42; say neat \0xFF; say neat *foo; say neat \*foo; say neat \&foo; say neat []; say neat { foo => "bar" }; say neat { "foo\n" => "bar\n" }; say neat bless {} => 'Foo'; say neat undef; synopsis.pl100644001750001750 46613071222366 17144 0ustar00syoheisyohei000000000000Data-Util-0.66/example#!perl -w # synopsis.pl use strict; use Data::Util qw(:all); # print the file for example open my $this, '<', __FILE__; print while <$this>; sub f{ printf "f(%s) called.\n", neat($_[0]); my $ary_ref = array_ref shift; } sub g{ f([undef, 42]); # pass f({foo => "bar\n"}); # FATAL } g(); __END__ Util.pm100644001750001750 2715513071222366 16223 0ustar00syoheisyohei000000000000Data-Util-0.66/lib/Datapackage Data::Util; use 5.008_001; use strict; #use warnings; our $VERSION = '0.66'; use Exporter; our @ISA = qw(Exporter); our $TESTING_PERL_ONLY; $TESTING_PERL_ONLY = $ENV{DATA_UTIL_PUREPERL} ? 1 : 0 unless defined $TESTING_PERL_ONLY; unless($TESTING_PERL_ONLY){ local $@; $TESTING_PERL_ONLY = !eval{ require XSLoader; XSLoader::load(__PACKAGE__, $VERSION); }; # if($@ && $ENV{DATA_UTIL_DEBUG}){ # warn $@; # } } require 'Data/Util/PurePerl.pm' # not to create the namespace if $TESTING_PERL_ONLY; our @EXPORT_OK = qw( is_scalar_ref is_array_ref is_hash_ref is_code_ref is_glob_ref is_rx is_regex_ref is_instance is_invocant is_value is_string is_number is_integer scalar_ref array_ref hash_ref code_ref glob_ref rx regex_ref instance invocant anon_scalar neat get_stash install_subroutine uninstall_subroutine get_code_info get_code_ref curry modify_subroutine subroutine_modifier mkopt mkopt_hash ); our %EXPORT_TAGS = ( all => \@EXPORT_OK, check => [qw( is_scalar_ref is_array_ref is_hash_ref is_code_ref is_glob_ref is_rx is_instance is_invocant is_value is_string is_number is_integer is_regex_ref )], validate => [qw( scalar_ref array_ref hash_ref code_ref glob_ref rx instance invocant regex_ref )], ); 1; __END__ =head1 NAME Data::Util - A selection of utilities for data and data types =head1 VERSION This document describes Data::Util version 0.66 =head1 SYNOPSIS use Data::Util qw(:validate); sub foo{ # they will die if invalid values are supplied my $sref = scalar_ref(shift); my $aref = array_ref(shift); my $href = hash_ref(shift); my $cref = code_ref(shift); my $gref = glob_ref(shift); my $rx = rx(shift); # regular expression my $obj = instance(shift, 'Foo'); # ... } use Data::Util qw(:check); sub bar{ my $x = shift; if(is_scalar_ref $x){ # $x is an array reference } # ... elsif(is_instance $x, 'Foo'){ # $x is an instance of Foo } # ... } # miscelaneous use Data::Util qw(:all); my $x = anon_scalar(); $x = anon_scalar($x); # OK my $stash = get_stash('Foo'); install_subroutine('Foo', hello => sub{ "Hello!\n" }, goodby => sub{ "Goodby!\n" }, ); print Foo::hello(); # Hello! my($pkg, $name) = get_code_info(\&Foo::hello); # => ('Foo', 'hello') my $fqn = get_code_info(\&Foo::hello); # => 'Foo::hello' my $code = get_code_ref('Foo', 'hello'); # => \&Foo::hello uninstall_subroutine('Foo', qw(hello goodby)); # simple format for errro messages (not the same as Data::Dumper) print neat("Hello!\n"); # => "Hello!\n" print neat(3.14); # => 3.14 print neat(undef); # => undef =head1 DESCRIPTION This module provides utility functions for data and data types, including functions for subroutines and symbol table hashes (stashes). This module makes for a pure Perl and XS implementation. However, if you want to use the full capacity of it, we recommend you to opt for the XS backend. There are many benchmarks in the F directory. =head1 INTERFACE =head2 Check functions Check functions are introduced by the C<:check> import tag, which check the argument type and return a bool. These functions also check for overloading magic, e.g. C<${}> corresponds to a SCALAR reference. =over 4 =item is_scalar_ref(value) Checks for a SCALAR reference. =item is_array_ref(value) Checks for an ARRAY reference. =item is_hash_ref(value) Checks for a HASH reference. =item is_code_ref(value) Checks for a CODE reference. =item is_glob_ref(value) Checks for a GLOB reference. =item is_rx(value) Checks for a regular expression reference generated by the C operator. =item is_instance(value, class) Checks for an instance of I. It is equivalent to the following statement: C<< Scalar::Util::blessed($value) && $value->isa($class) >>. =item is_invocant(value) Checks for an invocant, i.e. a blessed reference or existent package name. If I is a valid class name but does not exist, it will return false. =item is_value(value) Checks whether I is a primitive value, i.e. a defined, non-ref, and non-type-glob value. This function has no counterpart for validation. =item is_string(value) Checks whether I is a string with non-zero-length contents, equivalent to C<< is_value($value) && length($value) > 0 >>. This function has no counterpart for validation. =item is_number(value) Checks whether I is a number. Here, a B means that the perl parser can understand it and that the perl numeric converter (e.g. invoked by C<< sprintf '%g', $value >>) doesn't complain about it. It is similar to C but refuses C, C and C<"0 but true">. Note that C<9**9**9> makes C and C<9**9**9 - 9**9**9> makes C. This function has no counterpart for validation. =item is_integer(value) Checks whether I is an integer. An B is also a B, so this function refuses C and C. See also C. This function has no counterpart for validation. =back =head2 Validating functions Validating functions are introduced by the C<:validate> tag which checks for the argument and returns the first argument. These are like the C<:check> functions but dies if the argument type is invalid. These functions also checks overloading magic, e.g. C<${}> for a SCALAR reference. =over 4 =item scalar_ref(value) Validates a SCALAR reference. =item array_ref(value) Validates an ARRAY reference. =item hash_ref(value) Validates a HASH reference. =item code_ref(value) Validates a CODE reference. =item glob_ref(value) Validates a GLOB reference. =item rx(value) Validates a regular expression reference. =item instance(value, class) Validates an instance of I. =item invocant(value) Validates an invocant, i.e. a blessed reference or existent package name. If I is a valid class name and the class exists, then it returns the canonical class name, which is logically cleaned up. That is, it runs C<< $value =~ s/^::(?:main::)*//; >> before returning it. NOTE: Canonization is done so due to an inconsistency between Perl versions. For instance: package ::Foo; # OK my $x = bless {}, '::Foo'; # OK ref($x)->isa('Foo'); # Fatal The last code snippet causes a fatal error: C. However, C<< invocant(ref $x)->isa('Foo') >> is always OK. =back =head2 Miscellaneous utilities There are some other utility functions you can import from this module. =over 4 =item anon_scalar() Generates an anonymous scalar reference to C. =item anon_scalar(value) Generates an anonymous scalar reference to the copy of I. It is equivalent to C<< do{ my $tmp = $value; \$tmp; } >>. =item neat(value) Returns a neat string that is suitable to display. This is a smart version of C<>. =item get_stash(invocant) Returns the symbol table hash (also known as B) of I if the stash exists. =item install_subroutine(package, name => subr [, ...]) Installs I into I as I. It is similar to C<< do{ no strict 'refs'; *{$package.'::'.$name} = \&subr; } >>. In addition, if I is an anonymous subroutine, it is located into I as a named subroutine I<&package::name>. For example: install_subroutine($pkg, say => sub{ print @_, "\n" }); install_subroutine($pkg, one => \&_one, two => \&_two, ); # accepts a HASH reference install_subroutine($pkg, { say => sub{ print @_, "\n" }); # To re-install I, use C<< no warnings 'redefine' >> directive: no warnings 'redefine'; install_subroutine($package, $name => $subr); =item uninstall_subroutine(package, names...) Uninstalls I from I. It is similar to C, but uninstall multiple subroutines at a time. If you want to specify deleted subroutines, you can supply C<< name => \&subr >> pairs. For example: uninstall_subroutine('Foo', 'hello'); uninstall_subroutine('Foo', hello => \&Bar::hello); uninstall_subroutine($pkg, one => \&_one, two => \&_two, ); # accepts a HASH reference uninstall_subroutine(\$pkg, { hello => \&Bar::hello }); =item get_code_info(subr) Returns a pair of elements, the package name and the subroutine name of I. It is similar to C, but it returns the fully qualified name in scalar context. =item get_code_ref(package, name, flag?) Returns I<&package::name> if it exists, not touching the symbol in the stash. if I is a string C<-create>, it returns I<&package::name> regardless of its existence. That is, it is equivalent to C<< do{ no strict 'refs'; \&{package . '::' . $name} } >>. For example: $code = get_code_ref($pkg, $name); # like *{$pkg.'::'.$name}{CODE} $code = get_code_ref($pkg, $name, -create); # like \&{$pkg.'::'.$name} =item curry(subr, args and/or placeholders) Makes I curried and returns the curried subroutine. This is also considered as lightweight closures. See also L. =item modify_subroutine(subr, ...) Modifies I with subroutine modifiers and returns the modified subroutine. This is also considered as lightweight closures. I must be a code reference or callable object. Optional arguments: C<< before => [subroutine(s)] >> called before I. C<< around => [subroutine(s)] >> called around I. C<< after => [subroutine(s)] >> called after I. This seems a constructor of modified subroutines and C is property accessors, but it does not bless the modified subroutines. =item subroutine_modifier(subr) Returns whether I is a modified subroutine. =item subroutine_modifier(modified_subr, property) Gets I from I. Valid properties are: C, C, C. =item subroutine_modifier(modified_subr, modifier => [subroutine(s)]) Adds subroutine I to I. Valid modifiers are: C, C, C. =item mkopt(input, moniker, require_unique, must_be) Produces an array of an array reference from I. It is compatible with C. In addition to it, I can be a HASH reference with C<< name => type >> pairs. For example: my $optlist = mkopt(['foo', bar => [42]], $moniker, $uniq, { bar => 'ARRAY' }); # $optlist == [[foo => undef], [bar => [42]] =item mkopt_hash(input, moniker, must_be) Produces a hash reference from I. It is compatible with C. In addition to it, I can be a HASH reference with C<< name => type >> pairs. For example: my $optlist = mkopt(['foo', bar => [42]], $moniker, { bar => 'ARRAY' }); # $optlist == {foo => undef, bar => [42]} =back =head1 ENVIRONMENT VARIABLES =head2 DATA_UTIL_PUREPERL If true, C uses the pure Perl implementation. =head1 DEPENDENCIES Perl 5.10 or later. If you have a C compiler, you can use the XS backend. A pure Perl backend/implementation is also made available in case you have no C compiler handy (unlikely!). =head1 BUGS AND LIMITATIONS No bugs have been reported. Please report any bugs or feature requests to the author. =head1 SEE ALSO L. L. L. L. L. L. L. L. L. L. L =head1 AUTHOR Goro Fuji(gfx) Egfuji(at)cpan.orgE. =head1 LICENSE AND COPYRIGHT Copyright (c) 2008-2010, Goro Fuji Egfuji(at)cpan.orgE. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Util.xs100644001750001750 6463613071222366 16246 0ustar00syoheisyohei000000000000Data-Util-0.66/lib/Data// vim: set noexpandtab: /* Data-Util/DataUtil.xs */ #define NEED_mro_get_linear_isa #include "data-util.h" #define MY_CXT_KEY "Data::Util::_guts" XS_VERSION #define NotReached assert(((void)"PANIC: NOT REACHED", 0)) #define is_special_nv(nv) (nv == NV_INF || nv == -NV_INF || Perl_isnan(nv)) typedef struct{ GV* universal_isa; GV* croak; } my_cxt_t; START_MY_CXT; /* null magic virtual table to identify magic functions */ extern MGVTBL curried_vtbl; extern MGVTBL modified_vtbl; MGVTBL subr_name_vtbl; typedef enum{ T_NOT_REF, T_SV, T_AV, T_HV, T_CV, T_GV, T_IO, T_FM, T_RX, T_OBJECT, T_VALUE, T_STR, T_NUM, T_INT } my_type_t; static const char* const ref_names[] = { NULL, /* NOT_REF */ "a SCALAR reference", "an ARRAY reference", "a HASH reference", "a CODE reference", "a GLOB reference", NULL, /* IO */ NULL, /* FM */ "a regular expression reference", /* RX */ NULL /* OBJECT */ }; static void my_croak(pTHX_ const char* const fmt, ...) __attribute__format__(__printf__, pTHX_1, pTHX_2); static void my_croak(pTHX_ const char* const fmt, ...){ dMY_CXT; dSP; SV* message; va_list args; ENTER; SAVETMPS; if(!MY_CXT.croak){ Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvs("Data::Util::Error"), NULL, NULL); MY_CXT.croak = CvGV(get_cv("Data::Util::Error::croak", GV_ADD)); SvREFCNT_inc_simple_void_NN(MY_CXT.croak); } va_start(args, fmt); message = vnewSVpvf(fmt, &args); va_end(args); PUSHMARK(SP); mXPUSHs(message); PUTBACK; call_sv((SV*)MY_CXT.croak, G_VOID); NotReached; /* FREETMPS; LEAVE; */ } static void my_fail(pTHX_ const char* const name, SV* value){ my_croak(aTHX_ "Validation failed: you must supply %s, not %s", name, neat(value)); } static int S_nv_is_integer(pTHX_ NV const nv) { if(nv == (NV)(IV)nv){ return TRUE; } else { char buf[64]; /* Must fit sprintf/Gconvert of longest NV */ char* p; (void)Gconvert(nv, NV_DIG, 0, buf); p = &buf[0]; /* -?[0-9]+ */ if(*p == '-') p++; while(*p){ if(!isDIGIT(*p)){ return FALSE; } p++; } return TRUE; } } static int my_check_type_primitive(pTHX_ SV* const sv, const my_type_t t){ if(!SvOK(sv) || SvROK(sv) || isGV(sv)){ return FALSE; } switch(t){ case T_INT: /* check POK, NOK and IOK respectively */ if(SvPOKp(sv)){ int const num_type = grok_number(SvPVX(sv), SvCUR(sv), NULL); if(num_type && !strEQ(SvPVX(sv), "0 but true")){ return !(num_type & IS_NUMBER_NOT_INT); } } else if(SvNOKp(sv)){ NV const nv = SvNVX(sv); return S_nv_is_integer(aTHX_ nv); } else if(SvIOKp(sv)){ return TRUE; } break; case T_NUM: if(SvPOKp(sv)){ int const num_type = grok_number(SvPVX(sv), SvCUR(sv), NULL); if(num_type && !strEQ(SvPVX(sv), "0 but true")){ return !(num_type & (IS_NUMBER_INFINITY | IS_NUMBER_NAN)); } } else if(SvNOKp(sv)){ NV const nv = SvNVX(sv); return !is_special_nv(nv); } else if(SvIOKp(sv)){ return TRUE; } break; case T_STR: if(SvPOKp(sv)){ return SvCUR(sv) > 0; } /* fall throught */ default:/* T_VALUE */ return TRUE; } return FALSE; } static bool my_has_amagic_converter(pTHX_ SV* const sv, const my_type_t t){ const AMT* amt; const HV *stash; int o = 0; if ( (!SvAMAGIC(sv)) || (!(stash = SvSTASH(SvRV(sv)))) || (!Gv_AMG((HV*)stash)) ) { return FALSE; } amt = (AMT*)mg_find((SV*)stash, PERL_MAGIC_overload_table)->mg_ptr; assert(amt); assert(AMT_AMAGIC(amt)); switch(t){ case T_SV: o = to_sv_amg; break; case T_AV: o = to_av_amg; break; case T_HV: o = to_hv_amg; break; case T_CV: o = to_cv_amg; break; case T_GV: o = to_gv_amg; break; default: NotReached; } return amt->table[o] ? TRUE : FALSE; } #define check_type(sv, t) my_check_type(aTHX_ sv, t) static int my_check_type(pTHX_ SV* const sv, const my_type_t t){ if(!SvROK(sv)){ return FALSE; } if(SvOBJECT(SvRV(sv))){ if(t == T_RX){ /* regex? */ return SvRXOK(sv); } else{ SvGETMAGIC(sv); return my_has_amagic_converter(aTHX_ sv, t); } } switch(SvTYPE(SvRV(sv))){ case SVt_PVAV: return T_AV == t; case SVt_PVHV: return T_HV == t; case SVt_PVCV: return T_CV == t; case SVt_PVGV: return T_GV == t; case SVt_PVIO: return T_IO == t; case SVt_PVFM: return T_FM == t; default: NOOP; } return T_SV == t; } #define deref_av(sv) my_deref_av(aTHX_ sv) #define deref_hv(sv) my_deref_hv(aTHX_ sv) #define deref_cv(sv) my_deref_cv(aTHX_ sv) static AV* my_deref_av(pTHX_ SV* sv){ SvGETMAGIC(sv); if(my_has_amagic_converter(aTHX_ sv, T_AV)){ SV* const* sp = &sv; /* used in tryAMAGICunDEREF macro */ tryAMAGICunDEREF(to_av); } if(!(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV)){ my_fail(aTHX_ ref_names[T_AV], sv); } return (AV*)SvRV(sv); } static HV* my_deref_hv(pTHX_ SV* sv){ SvGETMAGIC(sv); if(my_has_amagic_converter(aTHX_ sv, T_HV)){ SV* const* sp = &sv; /* used in tryAMAGICunDEREF macro */ tryAMAGICunDEREF(to_hv); } if(!(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV)){ my_fail(aTHX_ ref_names[T_HV], sv); } return (HV*)SvRV(sv); } static CV* my_deref_cv(pTHX_ SV* sv){ SvGETMAGIC(sv); if(my_has_amagic_converter(aTHX_ sv, T_CV)){ SV* const* sp = &sv; /* used in tryAMAGICunDEREF macro */ tryAMAGICunDEREF(to_cv); } if(!(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)){ my_fail(aTHX_ ref_names[T_CV], sv); } return (CV*)SvRV(sv); } #define validate(sv, t) my_validate(aTHX_ sv, t) static SV* my_validate(pTHX_ SV* const sv, my_type_t const ref_type){ SvGETMAGIC(sv); if(!check_type(sv, ref_type)){ my_fail(aTHX_ ref_names[ref_type], sv); } return sv; } static SV* my_string(pTHX_ SV* const sv, const char* const name){ SvGETMAGIC(sv); if(!is_string(sv)) my_fail(aTHX_ name, sv); return sv; } static const char* my_canon_pkg(pTHX_ const char* name){ /* "::Foo" -> "Foo" */ if(name[0] == ':' && name[1] == ':'){ name += 2; } /* "main::main::main::Foo" -> "Foo" */ while(strnEQ(name, "main::", sizeof("main::")-1)){ name += sizeof("main::")-1; } return name; } static int my_isa_lookup(pTHX_ HV* const stash, const char* klass_name){ const char* const stash_name = my_canon_pkg(aTHX_ HvNAME_get(stash)); klass_name = my_canon_pkg(aTHX_ klass_name); if(strEQ(stash_name, klass_name)){ return TRUE; } else if(strEQ(klass_name, "UNIVERSAL")){ return TRUE; } else{ AV* const linearized_isa = mro_get_linear_isa(stash); SV** svp = AvARRAY(linearized_isa) + 1; /* skip this class */ SV** const end = svp + AvFILLp(linearized_isa); /* start + 1 + last index */ while(svp != end){ if(strEQ(klass_name, my_canon_pkg(aTHX_ SvPVX(*svp)))){ return TRUE; } svp++; } } return FALSE; } static int my_instance_of(pTHX_ SV* const x, SV* const klass){ if( !is_string(klass) ){ my_fail(aTHX_ "a class name", klass); } if( SvROK(x) && SvOBJECT(SvRV(x)) ){ dMY_CXT; HV* const stash = SvSTASH(SvRV(x)); GV* const isa = gv_fetchmeth_autoload(stash, "isa", sizeof("isa")-1, 0 /* special zero, not flags nor bool */); /* common cases */ if(isa == NULL || GvCV(isa) == GvCV(MY_CXT.universal_isa)){ return my_isa_lookup(aTHX_ stash, SvPV_nolen_const(klass)); } /* special cases */ /* call their own ->isa() method */ { int retval; dSP; ENTER; SAVETMPS; PUSHMARK(SP); EXTEND(SP, 2); PUSHs(x); PUSHs(klass); PUTBACK; call_sv((SV*)isa, G_SCALAR | G_METHOD); SPAGAIN; retval = SvTRUE(TOPs); (void)POPs; PUTBACK; FREETMPS; LEAVE; return retval; } } return FALSE; } #define type_isa(sv, type) my_type_isa(aTHX_ sv, type) static bool my_type_isa(pTHX_ SV* const sv, SV* const type){ const char* const typestr = SvPV_nolen_const(type); switch(typestr[0]){ case 'S': if(strEQ(typestr, "SCALAR")){ return check_type(sv, T_SV); } break; case 'A': if(strEQ(typestr, "ARRAY")){ return check_type(sv, T_AV); } break; case 'H': if(strEQ(typestr, "HASH")){ return check_type(sv, T_HV); } break; case 'C': if(strEQ(typestr, "CODE")){ return check_type(sv, T_CV); } break; case 'G': if(strEQ(typestr, "GLOB")){ return check_type(sv, T_GV); } break; } return my_instance_of(aTHX_ sv, type); } static void my_opt_add(pTHX_ AV* const result_av, HV* const result_hv, SV* const moniker, SV* const name, SV* const value, bool const with_validation, SV* vsv, AV* vav, HV* const vhv ){ if(with_validation && SvOK(value)){ if(vhv){ HE* const he = hv_fetch_ent(vhv, name, FALSE, 0U); vav = NULL; if(he){ SV* const sv = hv_iterval(vhv, he); if(check_type(sv, T_AV)){ vav = deref_av(sv); } else if(SvOK(sv)){ vsv = sv; } else{ goto store_pair; } } else{ goto store_pair; } } if(vav){ I32 const len = av_len(vav)+1; I32 i; for(i = 0; i < len; i++){ if(type_isa(value, *av_fetch(vav, i, TRUE))){ break; } } if(i == len) goto validation_failed; } else{ if(!type_isa(value, vsv)){ validation_failed: my_croak(aTHX_ "%s-ref values are not valid for %"SVf" in %"SVf" opt list", sv_reftype(SvRV(value), TRUE), name, moniker); } } } store_pair: if(result_av){ /* push @result, [$name => $value] */ SV* pair[2]; pair[0] = name; pair[1] = value; av_push(result_av, newRV_noinc((SV*) av_make(2, pair))); } else{ /* $result{$name} = $value */ (void)hv_store_ent(result_hv, name, newSVsv(value), 0U); } } static SV* my_mkopt(pTHX_ SV* const opt_list, SV* const moniker, const bool require_unique, SV* must_be, const my_type_t result_type){ SV* ret; AV* result_av = NULL; HV* result_hv = NULL; HV* vhv = NULL; /* validator HV */ AV* vav = NULL; /* validator AV */ bool const with_validation = SvOK(must_be) ? TRUE : FALSE; if(with_validation){ if(check_type(must_be, T_HV)){ vhv = deref_hv(must_be); } else if(check_type(must_be, T_AV)){ vav = deref_av(must_be); } else if(!is_string(must_be)){ my_fail(aTHX_ "type constraints", must_be); } } if(result_type == T_AV){ result_av = newAV(); ret = (SV*)result_av; } else{ result_hv = newHV(); ret = (SV*)result_hv; } sv_2mortal(ret); if(check_type(opt_list, T_AV)){ HV* seen = NULL; AV* const opt_av = deref_av(opt_list); I32 const len = av_len(opt_av) + 1; I32 i; if(require_unique){ seen = newHV(); sv_2mortal((SV*)seen); } for(i = 0; i < len; i++){ SV* const name = my_string(aTHX_ *av_fetch(opt_av, i, TRUE), "an option name"); SV* value; if(require_unique){ HE* const he = hv_fetch_ent(seen, name, TRUE, 0U); SV* const count = hv_iterval(seen, he); if(SvTRUE(count)){ my_croak(aTHX_ "Multiple definitions provided for %"SVf" in %"SVf" opt list", name, moniker); } sv_inc(count); /* count++ */ } if( (i+1) == len ){ /* last */ value = &PL_sv_undef; } else{ value = *av_fetch(opt_av, i+1, TRUE); if(SvROK(value) || !SvOK(value)){ i++; } else{ value = &PL_sv_undef; } } my_opt_add(aTHX_ result_av, result_hv, moniker, name, value, with_validation, must_be, vav, vhv); } } else if(check_type(opt_list, T_HV)){ HV* const opt_hv = deref_hv(opt_list); I32 keylen; char* key; SV* value; SV* const name = sv_newmortal(); hv_iterinit(opt_hv); while((value = hv_iternextsv(opt_hv, &key, &keylen))){ sv_setpvn(name, key, keylen); /* copied in my_opt_add */ if(!SvROK(value) && SvOK(value)){ value = &PL_sv_undef; } my_opt_add(aTHX_ result_av, result_hv, moniker, name, value, with_validation, must_be, vav, vhv); } } else if(SvOK(opt_list)){ my_fail(aTHX_ "an ARRAY or HASH reference", opt_list); } return newRV_inc(ret); } /* $code = curry($_, (my $tmp = $code_ref), *_) for @around; */ static SV* my_build_around_code(pTHX_ SV* code_ref, AV* const around){ I32 i; for(i = av_len(around); i >= 0; i--){ CV* current; MAGIC* mg; SV* const sv = validate(*av_fetch(around, i, TRUE), T_CV); AV* const params = newAV(); AV* const placeholders = newAV(); av_store(params, 0, newSVsv(sv)); /* base proc */ av_store(params, 1, newSVsv(code_ref)); /* first argument (next proc) */ av_store(params, 2, &PL_sv_undef); /* placeholder hole */ av_store(placeholders, 2, (SV*)PL_defgv); // *_ SvREFCNT_inc_simple_void_NN(PL_defgv); current = newXS(NULL /* anonymous */, XS_Data__Util_curried, __FILE__); mg = sv_magicext((SV*)current, (SV*)params, PERL_MAGIC_ext, &curried_vtbl, (const char*)placeholders, HEf_SVKEY); SvREFCNT_dec(params); /* because: refcnt++ in sv_magicext() */ SvREFCNT_dec(placeholders); /* because: refcnt++ in sv_magicext() */ CvXSUBANY(current).any_ptr = (void*)mg; code_ref = newRV_noinc((SV*)current); sv_2mortal(code_ref); } return newSVsv(code_ref); } static void my_gv_setsv(pTHX_ GV* const gv, SV* const sv){ ENTER; SAVETMPS; sv_setsv_mg((SV*)gv, sv_2mortal(newRV_inc((sv)))); FREETMPS; LEAVE; } static void my_install_sub(pTHX_ HV* const stash, const char* const name, STRLEN const namelen, SV* code_ref){ CV* const code = deref_cv(code_ref); GV* const gv = (GV*)*hv_fetch(stash, name, namelen, TRUE); if(!isGV(gv)) gv_init(gv, stash, name, namelen, GV_ADDMULTI); my_gv_setsv(aTHX_ gv, (SV*)code); /* *foo = \&bar */ if(CvANON(code) && CvGV(code) /* under construction? */ && isGV(CvGV(code)) /* released? */){ /* rename cv with gv */ CvGV_set(code, gv); CvANON_off(code); } } static void my_uninstall_sub(pTHX_ HV* const stash, const char* const name, STRLEN const namelen, SV* const specified_code_ref){ GV** const gvp = (GV**)hv_fetch(stash, name, namelen, FALSE); if(gvp){ GV* const gv = *gvp; CV* const specified_code = SvOK(specified_code_ref) ? deref_cv(specified_code_ref) : NULL; GV* newgv; CV* code; if(!isGV(gv)){ /* a subroutine stub or special constant*/ /* or perhaps a sub ref */ if(SvROK((SV*)gv)) { if(SvTYPE(SvRV(gv)) == SVt_PVCV) { if( specified_code && specified_code != (CV*)SvRV(gv) ) return; } else if(ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s uninstalled", name); } (void)hv_delete(stash, name, namelen, G_DISCARD); return; } if(!(code = GvCVu(gv))){ return; } /* when an uninstalled subroutine is supplied ... */ if( specified_code && specified_code != code ){ return; /* skip */ } if(CvCONST(code) && ckWARN(WARN_MISC)){ Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s uninstalled", name); } (void)hv_delete(stash, name, namelen, G_DISCARD); if(SvREFCNT(gv) == 0 || !( GvSV(gv) || GvAV(gv) || GvHV(gv) || GvIO(gv) || GvFORM(gv))){ return; /* no need to retrieve gv */ } newgv = (GV*)*hv_fetch(stash, name, namelen, TRUE); gv_init(newgv, stash, name, namelen, GV_ADDMULTI); /* vivify */ /* restore all slots other than GvCV */ if(GvSV(gv)) my_gv_setsv(aTHX_ newgv, GvSV(gv)); if(GvAV(gv)) my_gv_setsv(aTHX_ newgv, (SV*)GvAV(gv)); if(GvHV(gv)) my_gv_setsv(aTHX_ newgv, (SV*)GvHV(gv)); if(GvIO(gv)) my_gv_setsv(aTHX_ newgv, (SV*)GvIOp(gv)); if(GvFORM(gv)) my_gv_setsv(aTHX_ newgv, (SV*)GvFORM(gv)); } } static void initialize_my_cxt(pTHX_ my_cxt_t* const cxt){ cxt->universal_isa = CvGV(get_cv("UNIVERSAL::isa", GV_ADD)); SvREFCNT_inc_simple_void_NN(cxt->universal_isa); cxt->croak = NULL; } #define UNDEF &PL_sv_undef MODULE = Data::Util PACKAGE = Data::Util PROTOTYPES: DISABLE BOOT: { MY_CXT_INIT; initialize_my_cxt(aTHX_ &MY_CXT); } void CLONE(...) CODE: MY_CXT_CLONE; initialize_my_cxt(aTHX_ &MY_CXT); PERL_UNUSED_VAR(items); #define T_RX_deprecated T_RX void is_scalar_ref(x) SV* x ALIAS: is_scalar_ref = T_SV is_array_ref = T_AV is_hash_ref = T_HV is_code_ref = T_CV is_glob_ref = T_GV is_regex_ref = T_RX_deprecated is_rx = T_RX CODE: SvGETMAGIC(x); ST(0) = boolSV(check_type(x, (my_type_t)ix)); XSRETURN(1); void scalar_ref(x) SV* x ALIAS: scalar_ref = T_SV array_ref = T_AV hash_ref = T_HV code_ref = T_CV glob_ref = T_GV regex_ref = T_RX_deprecated rx = T_RX CODE: SvGETMAGIC(x); if(check_type(x, (my_type_t)ix)){ XSRETURN(1); /* return the first value */ } my_fail(aTHX_ ref_names[ix], x); void is_instance(x, klass) SV* x SV* klass CODE: SvGETMAGIC(x); SvGETMAGIC(klass); ST(0) = boolSV(my_instance_of(aTHX_ x, klass)); XSRETURN(1); void instance(x, klass) SV* x SV* klass CODE: SvGETMAGIC(x); SvGETMAGIC(klass); if( my_instance_of(aTHX_ x, klass) ){ XSRETURN(1); /* return $_[0] */ } my_croak(aTHX_ "Validation failed: you must supply an instance of %"SVf", not %s", klass, neat(x)); void invocant(x) SV* x ALIAS: is_invocant = 0 invocant = 1 PREINIT: bool result; CODE: SvGETMAGIC(x); if(SvROK(x)){ result = SvOBJECT(SvRV(x)) ? TRUE : FALSE; } else if(is_string(x)){ result = gv_stashsv(x, FALSE) ? TRUE : FALSE; } else{ result = FALSE; } if(ix == 0){ /* is_invocant() */ ST(0) = boolSV(result); XSRETURN(1); } else{ /* invocant() */ if(result){ /* XXX: do{ package ::Foo; ::Foo->something; } causes an fatal error */ if(!SvROK(x)){ dXSTARG; sv_setsv(TARG, x); /* copy the pv and flags */ sv_setpv(TARG, my_canon_pkg(aTHX_ SvPV_nolen_const(x))); ST(0) = TARG; } XSRETURN(1); } my_fail(aTHX_ "an invocant", x); } void is_value(x) SV* x ALIAS: is_value = T_VALUE is_string = T_STR is_number = T_NUM is_integer = T_INT CODE: SvGETMAGIC(x); ST(0) = boolSV(my_check_type_primitive(aTHX_ x, (my_type_t)ix)); XSRETURN(1); HV* get_stash(invocant) SV* invocant CODE: SvGETMAGIC(invocant); if(SvROK(invocant) && SvOBJECT(SvRV(invocant))){ RETVAL = SvSTASH(SvRV(invocant)); } else if(is_string(invocant)){ RETVAL = gv_stashsv(invocant, FALSE); } else{ RETVAL = NULL; } if(!RETVAL){ XSRETURN_UNDEF; } OUTPUT: RETVAL SV* anon_scalar(referent = undef) CODE: RETVAL = newRV_noinc(items == 0 ? newSV(0) : newSVsv(ST(0))); OUTPUT: RETVAL const char* neat(expr) SV* expr void install_subroutine(into, ...) SV* into PREINIT: HV* stash; int i; CODE: stash = gv_stashsv(my_string(aTHX_ into, "a package name"), TRUE); if(items == 2){ HV* const hv = deref_hv(ST(1)); I32 namelen; char* name; SV* code_ref; hv_iterinit(hv); while((code_ref = hv_iternextsv(hv, &name, &namelen))){ my_install_sub(aTHX_ stash, name, namelen, code_ref); } } else{ if( ((items-1) % 2) != 0 ){ my_croak(aTHX_ "Odd number of arguments for %s", GvNAME(CvGV(cv))); } for(i = 1; i < items; i += 2){ SV* const as = my_string(aTHX_ ST(i), "a subroutine name"); STRLEN namelen; const char* const name = SvPV_const(as, namelen); SV* const code_ref = ST(i+1); my_install_sub(aTHX_ stash, name, namelen, code_ref); } } void uninstall_subroutine(package, ...) SV* package PREINIT: HV* stash; int i; CODE: stash = gv_stashsv(my_string(aTHX_ package, "a package name"), FALSE); if(!stash) XSRETURN_EMPTY; if(items == 2 && SvROK(ST(1))){ HV* const hv = deref_hv(ST(1)); I32 namelen; char* name; SV* specified_code_ref; hv_iterinit(hv); while((specified_code_ref = hv_iternextsv(hv, &name, &namelen))){ my_uninstall_sub(aTHX_ stash, name, namelen, specified_code_ref); } } else{ for(i = 1; i < items; i++){ SV* const namesv = my_string(aTHX_ ST(i), "a subroutine name"); STRLEN namelen; const char* const name = SvPV_const(namesv, namelen); SV* specified_code_ref; if( (i+1) < items && SvROK(ST(i+1)) ){ i++; specified_code_ref = ST(i); } else{ specified_code_ref = &PL_sv_undef; } my_uninstall_sub(aTHX_ stash, name, namelen, specified_code_ref); } } mro_method_changed_in(stash); void get_code_info(code) CV* code PREINIT: GV* gv; HV* stash; PPCODE: if( (gv = CvGV(code)) && isGV_with_GP(gv) && (stash = (GvSTASH(gv))) && HvNAME_get(stash) ){ if(GIMME_V == G_ARRAY){ EXTEND(SP, 2); mPUSHs(newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U)); mPUSHs(newSVpvn_share(GvNAME(gv), GvNAMELEN(gv), 0U)); } else{ SV* const sv = newSVpvf("%s::%s", HvNAME_get(stash), GvNAME(gv)); mXPUSHs(sv); } } SV* get_code_ref(package, name, ...) SV* package SV* name INIT: I32 flags = 0; RETVAL = &PL_sv_undef; CODE: (void)my_string(aTHX_ package, "a package name"); (void)my_string(aTHX_ name, "a subroutine name"); if(items > 2){ /* with flags */ I32 i; for(i = 2; i < items; i++){ SV* const sv = my_string(aTHX_ ST(i), "a flag"); if(strEQ(SvPV_nolen_const(sv), "-create")){ flags |= GV_ADD; } else{ my_fail(aTHX_ "a flag", sv); } } } { HV* const stash = gv_stashsv(package, flags); if(stash){ STRLEN len; const char* const pv = SvPV_const(name, len); GV** const gvp = (GV**)hv_fetch(stash, pv, len, flags); GV* const gv = gvp ? *gvp : NULL; if(gv){ if(!isGV(gv)) gv_init(gv, stash, pv, len, GV_ADDMULTI); if(GvCVu(gv)){ RETVAL = newRV_inc((SV*)GvCV(gv)); } else if(flags & GV_ADD){ SV* const sv = Perl_newSVpvf(aTHX_ "%"SVf"::%"SVf, package, name); /* from Perl_get_cvn_flags() in perl.c */ CV* const cv = newSUB( start_subparse(FALSE, 0), newSVOP(OP_CONST, 0, sv), NULL, NULL); RETVAL = newRV_inc((SV*)cv); } } } } OUTPUT: RETVAL SV* curry(code, ...) SV* code PREINIT: CV* curried; AV* params; AV* placeholders; U16 is_method; I32 i; MAGIC* mg; CODE: SvGETMAGIC(code); is_method = check_type(code, T_CV) ? 0 : G_METHOD; params = newAV(); placeholders = newAV(); av_extend(params, items-1); av_extend(placeholders, items-1); for(i = 0; i < items; i++){ SV* const sv = ST(i); SvGETMAGIC(sv); if(SvROK(sv) && SvIOKp(SvRV(sv)) && !SvOBJECT(SvRV(sv))){ // \0, \1, ... av_store(params, i, &PL_sv_undef); av_store(placeholders, i, newSVsv(SvRV(sv))); } else if(sv == (SV*)PL_defgv){ // *_ (always *main::_) av_store(params, i, &PL_sv_undef); av_store(placeholders, i, sv); /* not copy */ SvREFCNT_inc_simple_void_NN(sv); } else{ av_store(params, i, sv); /* not copy */ av_store(placeholders, i, &PL_sv_undef); SvREFCNT_inc_simple_void_NN(sv); } } curried = newXS(NULL /* anonymous */, XS_Data__Util_curried, __FILE__); mg = sv_magicext((SV*)curried, (SV*)params, PERL_MAGIC_ext, &curried_vtbl, (const char*)placeholders, HEf_SVKEY); SvREFCNT_dec((SV*)params); /* refcnt++ in sv_magicext() */ SvREFCNT_dec((SV*)placeholders); /* refcnt++ in sv_magicext() */ mg->mg_private = is_method; CvXSUBANY(curried).any_ptr = mg; RETVAL = newRV_noinc((SV*)curried); OUTPUT: RETVAL SV* modify_subroutine(code, ...) SV* code PREINIT: CV* modified; AV* before; AV* around; AV* after; AV* modifiers; /* (before, around, after, original, current) */ I32 i; MAGIC* mg; CODE: validate(code, T_CV); if( ((items - 1) % 2) != 0 ){ my_croak(aTHX_ "Odd number of arguments for %s", GvNAME(CvGV(cv))); } before = newAV(); sv_2mortal((SV*)before); around = newAV(); sv_2mortal((SV*)around); after = newAV(); sv_2mortal((SV*)after ); for(i = 1; i < items; i += 2){ /* modifier_type => [subroutine(s)] */ SV* const mtsv = my_string(aTHX_ ST(i), "a modifier type"); const char* const modifier_type = SvPV_nolen_const(mtsv); AV* const subs = deref_av(ST(i+1)); I32 const subs_len = av_len(subs) + 1; AV* av = NULL; I32 j; if(strEQ(modifier_type, "before")){ av = before; } else if(strEQ(modifier_type, "around")){ av = around; } else if(strEQ(modifier_type, "after")){ av = after; } else{ my_fail(aTHX_ "a modifier type", mtsv); } av_extend(av, AvFILLp(av) + subs_len - 1); for(j = 0; j < subs_len; j++){ SV* const code_ref = newSVsv(validate(*av_fetch(subs, j, TRUE), T_CV)); av_push(av, code_ref); } } modifiers = newAV(); av_extend(modifiers, 3); av_store(modifiers, M_CURRENT, my_build_around_code(aTHX_ code, around)); av_store(modifiers, M_BEFORE, SvREFCNT_inc_simple_NN(before)); av_store(modifiers, M_AROUND, SvREFCNT_inc_simple_NN(around)); av_store(modifiers, M_AFTER, SvREFCNT_inc_simple_NN(after)); modified = newXS(NULL /* anonymous */, XS_Data__Util_modified, __FILE__); mg = sv_magicext((SV*)modified, (SV*)modifiers, PERL_MAGIC_ext, &modified_vtbl, NULL, 0); SvREFCNT_dec((SV*)modifiers); /* refcnt++ in sv_magicext() */ CvXSUBANY(modified).any_ptr = (void*)mg; RETVAL = newRV_noinc((SV*)modified); OUTPUT: RETVAL void subroutine_modifier(code, ...) CV* code PREINIT: /* Usage: subroutine_modifier(code) # check subroutine_modifier(code, property) # get subroutine_modifier(code, property, subs) # set */ MAGIC* mg; AV* modifiers; /* (before, around, after, original, current) */ SV* property; const char* property_pv; PPCODE: mg = mg_find_by_vtbl((SV*)code, &modified_vtbl); if(items == 1){ /* check only */ ST(0) = boolSV(mg); XSRETURN(1); } if(!mg){ my_fail(aTHX_ "a modified subroutine", ST(0) /* ref to code */); } modifiers = (AV*)mg->mg_obj; assert(modifiers); property = my_string(aTHX_ ST(1), "a modifier property"); property_pv = SvPV_nolen_const(property); if(strEQ(property_pv, "before") || strEQ(property_pv, "around") || strEQ(property_pv, "after")){ I32 const idx = strEQ(property_pv, "before") ? M_BEFORE : strEQ(property_pv, "around") ? M_AROUND : M_AFTER; AV* const av = (AV*)*av_fetch(modifiers, idx, FALSE); if(items != 2){ /* add */ I32 i; for(i = 2; i < items; i++){ SV* const code_ref = newSVsv(validate(ST(i), T_CV)); if(idx == M_AFTER){ av_push(av, code_ref); } else{ av_unshift(av, 1); av_store(av, 0, code_ref); } } if(idx == M_AROUND){ AV* const around = (AV*)sv_2mortal((SV*)av_make(items-2, &ST(2))); SV* const current = my_build_around_code(aTHX_ *av_fetch(modifiers, M_CURRENT, FALSE), around ); av_store(modifiers, M_CURRENT, current); } } XPUSHary(AvARRAY(av), 0, AvFILLp(av)+1); } else{ my_fail(aTHX_ "a modifier property", property); } #define mkopt(opt_list, moniker, require_unique, must_be) \ my_mkopt(aTHX_ opt_list, moniker, require_unique, must_be, T_AV) #define mkopt_hash(opt_list, moniker, must_be) \ my_mkopt(aTHX_ opt_list, moniker, TRUE, must_be, T_HV) SV* mkopt(opt_list = UNDEF, moniker = UNDEF, require_unique = FALSE, must_be = UNDEF) SV* opt_list SV* moniker bool require_unique SV* must_be SV* mkopt_hash(opt_list = UNDEF, moniker = UNDEF, must_be = UNDEF) SV* opt_list SV* moniker SV* must_be Curry.pod100644001750001750 245213071222366 17446 0ustar00syoheisyohei000000000000Data-Util-0.66/lib/Data/Util=head1 NAME Data::Util::Curry - Curries functions and methods =head1 SYNOPSIS use feature 'say'; use Data::Util qw(curry); sub sum{ my $total = 0; for my $x(@_){ $total += $x; } return $total; } # placeholder "\0" indicates a subscript of the arguments say curry(\&add, \0, 42)->(10); # 52 # placeholder "*_" indicates all the arguments say curry(\&add, *_)->(1 .. 10); # 55 # two subscripts and the rest of the arguments say curry(\&add, *_, \1, \0)->(1 .. 5); # 3 + 4 + 5 + 1 + 2 =head1 DESCRIPTION (todo) =head1 EXAMPLES =head2 Currying Functions curry(\&f, \0, 2)->(1); # f(1, 2) curry(\&f, 3, \0)->(4); # f(3, 4) curry(\&f, *_)->(5, 6); # f(5, 6) curry(\&f, \0, \1, *_)->(1, 2, 3, 4); # f(1, 2, 3, 4) curry(\&f, *_, \0, \1)->(1, 2, 3, 4); # f(3, 4, 1, 2) =head2 Currying Methods curry($obj, 'something', *_)->(1, 2); # $obj->something(1, 2) curry($obj, 'something', foo => \0, bar => \1)->(1, 2); # $obj->something(foo => 1, bar => 2) curry(\0, 'something', \1)->($obj, 42); # $obj->something(42) curry($obj, \0, *_)->('something', 1, 2); # $obj->something(1, 2) =head2 Argument Semantics sub incr{ $_[0]++ } my $i = 0; curry(\&incr, \0)->($i); # $i++ curry(\&incr, *_)->($i); # $i++ curry(\&incr, $i)->(); # $i++ =head1 SEE ALSO L. =cut Error.pm100644001750001750 264113071222366 17265 0ustar00syoheisyohei000000000000Data-Util-0.66/lib/Data/Utilpackage Data::Util::Error; use strict; use warnings; use Data::Util (); sub import{ my $class = shift; $class->fail_handler(scalar(caller) => @_) if @_; } my %FailHandler; sub fail_handler :method{ shift; # this class my $pkg = shift; my $h = $FailHandler{$pkg}; # old handler if(@_){ # set $FailHandler{$pkg} = Data::Util::code_ref(shift); } else{ # get require MRO::Compat if $] < 5.010_000; require mro if $] >= 5.011_000; foreach my $p(@{mro::get_linear_isa($pkg)}){ if(defined( $h = $FailHandler{$p} )){ last; } } } return $h; } sub croak{ require Carp; my $caller_pkg; my $i = 0; while( defined( $caller_pkg = caller $i) ){ if($caller_pkg ne 'Data::Util'){ last; } $i++; } my $fail_handler = __PACKAGE__->fail_handler($caller_pkg); local $Carp::CarpLevel = $Carp::CarpLevel + $i; die $fail_handler ? &{$fail_handler} : &Carp::longmess; } 1; __END__ =head1 NAME Data::Util::Error - Deals with class-specific error handlers in Data::Util =head1 SYNOPSIS package Foo; use Data::Util::Error sub{ Foo::InvalidArgument->throw_error(@_) }; use Data::Util qw(:validate); sub f{ my $x_ref = array_ref shift; # Foo::InvalidArgument is thrown if invalid # ... } =head1 Functions =over 4 =item Data::Util::Error->fail_handler() =item Data::Util::Error->fail_handler($handler) =item Data::Util::Error::croak(@args) =back =head1 SEE ALSO L. =cut JA.pod100644001750001750 5532113071222366 16657 0ustar00syoheisyohei000000000000Data-Util-0.66/lib/Data/Util =encoding utf-8 =head1 NAME Data::Util::JA - データとデータ型のためのユーティリティ集 =head1 VERSION This document describes Data::Util version 0.63 =for test_synopsis no warnings 'redefine'; =head1 SYNOPSIS use Data::Util qw(:validate); sub foo{ # they will die if invalid values are supplied my $sref = scalar_ref(shift); my $aref = array_ref(shift); my $href = hash_ref(shift); my $cref = code_ref(shift); my $gref = glob_ref(shift); my $rref = regex_ref(shift); my $obj = instance(shift, 'Foo'); # ... } use Data::Util qw(:check); sub bar{ my $x = shift; if(is_scalar_ref $x){ # $x is an array reference } # ... elsif(is_instance $x, 'Foo'){ # $x is an instance of Foo } # ... } # miscelaneous use Data::Util qw(:all); my $x = anon_scalar(); $x = anon_scalar($x); # OK my $stash = get_stash('Foo'); install_subroutine('Foo', hello => sub{ "Hello!\n" }, goodby => sub{ "Goodby!\n" }, ); print Foo::hello(); # Hello! my($pkg, $name) = get_code_info(\&Foo::hello); # => ('Foo', 'hello') my $fqn = get_code_info(\&Foo::hello); # => 'Foo::Hello' my $code = get_code_ref($fqn); # => \&Foo::hello uninstall_subroutine('Foo', qw(hello goodby)); print neat("Hello!\n"); # => "Hello!\n" print neat(3.14); # => 3.14 print neat(undef); # => undef =head1 DESCRIPTION このモジュールはデータとデータ型のためのユーティリティ関数を提供します。 ユーティリティはチェック関数群と検証関数群とその他の関数群があります。 チェック関数群は値の型を調べ，真偽値を返す機能を提供します。 検証関数群は値の型を調べ，真であればその値自身を返し， 偽であれば致命的エラーとなる機能を提供します。 その他の関数群は，無名スカラーリファレンスの生成やシンボルテーブルの操作， コードリファレンスの操作などの機能を提供します。 これらユーティリティはいずれもコードの繰り返しを避けるために設計されました。 このモジュールはXSとPure Perl双方で実装されており，Cコンパイラのある 環境ではXSバックエンドが，ない環境ではPure Perlバックエンドが使用されます。 なお，環境変数Cを真に設定することで，強制的にPure Perl バックエンドを使用することができます。 XSバックエンドは注意深く実装されており， Pure Perlバックエンドより2倍から10倍程度高速に動作します。 実際，XSバックエンドが提供するほぼ全ての関数は，等価のPure Perlコードを インラインで展開したコードよりも更に高速です。 ディストリビューションのFディレクトリにベンチマークがあります。 =head1 INTERFACE =head2 Check functions チェック関数群はC<:check>インポートタグによって導入できます。これらはある値 の型が目的の型であれば真を，そうでなければ偽を返します。 また，これらの関数はオーバーロードマジックも調べます。たとえば，C<${}>が オーバーロードされているオブジェクトは，スカラーリファレンスとして扱われます。 リファレンスの型チェックをする関数は，オブジェクトリファレンスに対しては， オーバーロードされていない限り常に偽を返します。 これは，オブジェクトの実装に依存するコードを書かないようにするためです。 =over 4 =item is_scalar_ref(value) スカラーリファレンスかどうかのチェックを行います。 =item is_array_ref(value) 配列リファレンスかどうかのチェックを行います。 =item is_hash_ref(value) ハッシュリファレンスかどうかのチェックを行います。 =item is_code_ref(value) コードリファレンスかどうかのチェックを行います。 =item is_glob_ref(value) グロブリファレンスかどうかのチェックを行います。 =item is_regex_ref(value) Cによって作られる正規表現かどうかのチェックを行います。 =item is_instance(value, class) Iのインスタンスかどうかのチェックを行います。 C<< Scalar::Util::blessed($value) && $value->isa($class) >>というコードと ほぼ等価です。 Iが未定義値またはリファレンスであれば致命的エラーとなります。 =item is_invocant(value) Iに対してメソッドを起動できるかどうかをチェックします。 =item is_value(value) Iがプリミティブ値かどうかをチェックします。すなわち，定義済みであり， リファレンスではなく，型グロブでもなければ真を返します。 この関数(およびC/C/C)は， オブジェクトリファレンスに対しては常に偽を返します。 たとえIが文字列化/数値化/真偽値化オーバーロードメソッドを 持っていたとしても，それはプリミティブ値としては判断しません。 この関数には検証を行う対応関数がありません。 =item is_string(value) Iがプリミティブ値であり， かつ文字列化したときに1文字以上の内容を持つ値かどうかをチェックします。 C<< do{ is_value($value) && length($value) > 0 } >>と同じです。 この関数には検証を行う対応関数がありません。 =item is_number(value) Iが数値かどうかをチェックします。 ここでB<数値>とは，数値コンテキスト(たとえばC<< sprintf '%g', $value >>） で警告を出さずに数値に変換可能であり， かつPerlプログラム中にリテラルとしておくことができる値という意味です。 すなわち，この関数はCと異なり， CやCはリテラルとしてプログラム中に置くことはできないため， 数値として扱いません。また，数値化したときに警告を出さない例外である C<"0 but true">も同じ理由で数値として扱いません。 この関数には検証を行う対応関数がありません。 =item is_integer(value) Iが整数かどうかをチェックします。これはCの判定に加えて， 整数値かどうかをチェックします。 この関数には検証を行う対応関数がありません。 =back =head2 Validating functions 検証関数はC<:validate>タグによって導入できます。これらはチェック関数と 同じ方法でチェックを行います。 ただし，その結果が真であれば第一引数をそのまま返し， 偽であれば致命的エラーとなります。 これらの関数もオーバーロードマジックを考慮します。 =over 4 =item scalar_ref(value) スカラーリファレンスかどうかの検証を行います。 =item array_ref(value) 配列リファレンスかどうかの検証を行います。 =item hash_ref(value) ハッシュリファレンスかどうかの検証を行います。 =item code_ref(value) コードリファレンスかどうかの検証を行います。 =item glob_ref(value) グロブリファレンスかどうかの検証を行います。 =item regex_ref(value) Cによって作られる正規表現かどうかの検証を行います。 =item instance(value, class) Iのインスタンスかどうかの検証を行います。 Iが未定義値またはリファレンスであれば致命的エラーとなります。 =item invocant(value) Iに対してメソッドを起動できるかどうかの検証を行います。 Iがクラス名である場合，そのクラス名を正規化した文字列を返します。 すなわち，C<"::Foo">やC<"main::Foo">を与えるとC<"Foo">を返します。 =back =head2 Micellaneous utilities その他，個別にインポートできるいくつかのユーティリティ関数があります。 =over 4 =item anon_scalar() Cを参照する匿名スカラーリファレンスを生成します。 =item anon_scalar(value) Iのコピーを参照する匿名スカラーリファレンスを生成します。 これはC<< do{ my $tmp = $value; \$value; } >>というコードと等価です。 =item neat(value) Iを表示に適するよう整形した文字列を返します。 C<< do{ defined($value) ? qq{"$value"} : 'undef' } >>を置き換える機能 として提供されますが，より高機能です。 =item get_stash(invocant) Iのスタッシュ B，つまりシンボルテーブルハッシュが 存在すれば，そのスタッシュを返します。 Iがオブジェクトリファレンスであれば，そのオブジェクトのパッケージの スタッシュを返します。 Iがパッケージ名であり，そのパッケージが既に存在すれば， そのパッケージのスタッシュを返します。 =item install_subroutine(package, name => subr [, ...]) サブルーチンIをIにIとしてインストールします。 C<< do{ no strict 'refs'; *{$package.'::'.$name} = \&subr; } >>というコードと ほぼ等価です。さらに，Iが匿名サブルーチンであれば，Iに 名前付きサブルーチンI<&package::name>として命名します(ただし，Pure Perl版のコードでは匿名サブルーチンの命名は行いません)。 サブルーチンを再インストールするときは，C<< no warnings 'redefine' >> ディレクティブを使ってください。 no warnings 'redefine'; install_subrouitne($package, $name => $subr); IかIが未定義値またはリファレンスであれば致命的エラーとなります。 Iがコードリファレンスでないときも致命的エラーとなりますが， オーバーロードマジックは考慮されます。 この関数はC<< no strict 'refs' >>を必要としないため，Bを犯す危険性がありません。strict無効化の誤謬とは，以下のような状況を指します。 my $property = ...; # ... no strict 'refs'; # simple read-only accessor *{$pkg . '::' . $sub_name} = sub{ my($self) = @_; return $self->{$property}; } これはオブジェクトのプロパティを参照するアクセサを生成するコードです。このアクセサは，正しく使う限りでは問題はありません。 しかし，このアクセサをクラスメソッドとして呼び出すと，問題が顕在化します。 つまりそのときC<$self>に入っているのはクラスを表す文字列であり， C<< $self->{$property} >>というコードはシンボリックリファレンスと解釈され， このアクセサが定義されたパッケージのグローバル変数としてデリファレンスされます。 これは多くの場合，単にCを返すだけでしょう。 C<>はまさにこのような誤ったシンボリックリファレンスの デリファレンスを検出するために用意されている機能なのですが，ここではその恩恵を 得ることができず，デバッグの難しいコードを生成してしまいます。 このケースでstrictの恩恵を得るためには，以下のように無名関数内で再度 Cを有効にする必要があります。 no strict 'refs'; *{$pkg . '::' . $sub_name} = sub{ use strict 'refs'; my($self) = @_; return $self->{$property}; } そこで，Cを使うともCを使用する必要がなくなります。 install_subroutine $pkg => ( $sub_name => sub{ my($self) = @_; return $self->{$property}; }, ); このstrict無効化の誤謬については，L<"Perlベストプラクティス"/18.10> I<「制約の無効化 - 制約または警告を無効にする場合は，明示的に，段階的に，最も狭いスコープで行う」> に解説があります。 =item uninstall_subroutine(package, name [=> code], ...) サブルーチンIをパッケージIから削除します。 C<< undef &subr >>がC<&subr>を未定義にして型グロブのコードスロットを そのままにするのに対して，Cは型グロブを シンボルテーブルから削除し，コードスロットを以外の値をシンボルテーブルに 戻します。 この挙動はCやCを実現するためのものです。 Iに対してIが与えられている場合は，C<&package::name>がIである 場合のみ削除します。すなわち，以下の二つのコードは等価です。 uninstall_subroutine($pkg, $name) if \&{$pkg . '::' . $name} == $code; uninstall_subroutine($pkg, $name => $code); この関数はCと同じアルゴリズムに基づいていますが， 複数のサブルーチンを一度に削除できます。 =item get_code_info(subr) サブルーチンIのパッケージと名前のペアを返します。 これはCとほぼ同じ機能です。 ただし，スカラーコンテキストでは完全修飾名を返します。 Iの名前が不明なときは，リストコンテキストでは空リストを， スカラーコンテキストではCを返します。 =item get_code_ref(package, name) I<\&package::name>が存在すれば，それを返します。 これはC<< do{ no strict 'refs'; *{$package . '::' . $name}{CODE} } >> に似ていますが，I<\&package::name>が存在しない場合でも I<*package::name>を生成しません。 第三引数としてC<"-create">を与えると，I<\&package::name>が存在しなくても スタブを生成してそれを返します。 これはC<< do{ no strict 'refs'; \&{$package . '::' . $name} } >>と同じです。 =item curry(subr, args and/or placeholders) サブルーチンIのカリー化を行います。 つまり特定の引数を固定したクロージャを生成します。 Iには，固定する引数か，カリー化サブルーチンの引数に 置き換えられるプレースホルダを渡します。プレースホルダには，添え字Iを参照 するC<\x>と，C<\x>で参照した最大の添え字の以降の引数リストを参照する C<*_>があります。 たとえば，以下のC<$closure>とC<$curried>は同じ機能を持つサブルーチンとなります。 my $class = 'Foo'; $closure = sub{ is_instance($_[0], $class) }; $curried = curry \&is_instance, \0, $class; $closure = sub{ install_subroutine($class, @_) }; $curried = curry \&install_subroutine, $class, *_; なお，C<*_>はC<\x>で参照しなかった引数リストではないので注意してください。 たとえば，C<< curry(\&subr, *_, \1)->(0, 1, 2, 3) >>というカリー化では， Cが呼び出され，カリー化されたサブルーチンに与えられた C<$_[0]>(つまり0)が無視されます。 カリー化はクロージャよりも生成・呼び出しが高速です。 より詳しいサンプルコードがLにあります。 =item modify_subroutine(subr, modifier_type => [subroutines], ...) サブルーチンIをIにしたがってIで修飾し， 無名関数Iとして返します。 IにはC, C, Cがあり，Cは Iの呼び出し前に，CはIの呼出し後に，Iに 与えられた引数で呼び出されます。CとCの戻り値は捨てられます。 CはIの入出力をフィルタリングするための修飾子です。 その際，呼び出順は，CとCは後で定義されたものが先に呼び出され (last-defined-first-called)，Cは先に定義されたものが先に呼び出されます(first-defined-first-called)。この呼び出し順はCでも同じ です。 たとえば： $modified = modify_subroutine(\&foo, around => [sub{ my $next = shift; do_something(); goto &{$next}; # continuation }]); $modified->(); $modified = modify_subroutine(\&foo, before => \@befores, around => \@arounds, after => \@afters, ); $modified->(); XSによる実装では，サブルーチン修飾子のコストが非常に安くなっています。 このディストリビューションに付属しているF (C/Cのデモ)のベンチマーク Fによれば，メソッド修飾のコストはほぼ次のようになります： with before modifier: 100% slower with after modifier: 100% slower with around modifier: 200% slower 特に，CとCはC疑似クラスによってメソッドを拡張するよりも高速です。 各修飾子については，Lに 詳しい解説があります。Lにも解説があります。 このモジュールが提供するAPIはこれらのモジュールより低水準ですが， 機能には互換性があります。 =item subroutine_modifier(modified, modifier_type => subroutines, ...) Cで生成したIを操作します。 引数をIのみ渡した場合は，そのIがCで 生成されたものかどうかを示す真偽値を返します。 if(subroutine_modifier $subr){ # $subrは修飾子つきサブルーチン } IとI(C, C, C) を渡すと，そのIに応じた修飾関数を返します。 @befores = subroutine_modifier $modified, 'before'; このほか，更に関数のリストを渡した場合には，IのIに その関数を追加します。 subroutine_modifier $modified, before => @befores; =item mkopt(input, moniker, require_unique, must_be) Iを元に名前と値のペア配列からなる配列リファレンスを作成します。 これはCに似ています。それに加えて，Iは 名前と型のペアからなるハッシュリファレンスでもかまいません。 For example: $array_ref = mkopt([qw(foo bar), baz => [42]], 'moniker'); # $array_ref == [ [foo => undef], [bar => undef], baz => [42] ] =item mkopt_hash(input, moniker, must_be) Iを元にハッシュリファレンスを作成します。 これはCに似ています。それに加えて，Iは 名前と型のペアからなるハッシュリファレンスでもかまいません。 For example: $hash_ref = mkopt([qw(foo bar), baz => [42]], 'moniker'); # $hash_ref == { foo => undef, bar => undef, baz => [42] } =back =head2 Error handling 検証関数によって放出される致命的エラーは，Cモジュールによって変更することができます。 package Foo; use Data::Util::Error sub{ Foo::InvalidArgument->throw(@_) }; use Data::Util qw(:validate); # ... このエラーハンドラはパッケージ毎に設定され，そのパッケージ内でCが発生させるエラーにはそのエラーハンドラが使われます。 =head1 DISCUSSIONS =head1 What is a X-reference? 「Xのリファレンス」とは何を指すのでしょうか。ここではハッシュリファレンスを例にとって考えます。 まず，判断要素は以下の3つを想定します。 =over 4 =item 1 C =item 2 C =item 3 C =back Cは非常に高速なので，実用上はこれで事足りることが多いと思われます。しかし，これはオーバーロードマジックを考慮しません。 Cを使うべきではありません。$xがオブジェクトである場合，オブジェクトの実装型を参照し，カプセル化を壊してしまうことになるからです。 そしてCが捕捉するのは，オブジェクトをある型のリファレンスとみなしてよい特殊なケースです。 なお，直接$xをハッシュリファレンスとみなして参照すること(C<< $x->{$key} >>)は避けるべきです。これは$xがハッシュリファレンスでない場合に正しく致命的エラーを発生させますが，ブレスされたハッシュリファレンスのときにはアクセスが成功します。しかし，そのアクセスの成功はオブジェクトの実装に依存しています。 さて，それではCは何を調べればいいのでしょうか。回答の一つはCが示しています。Version 0.35の時点では，Cは(1)を，Cは(2)と(3)をチェックします。しかし先に述べたように，(1)は高速ですがオーバーロードマジックを考慮しないので不完全であり，(2)はオブジェクトのカプセル化を壊すため使うべきではありません。このように考えると，Cは(1)と(3)によるチェックを行うのが正しい実装ということになります。 したがって，CではCとCを使ってリファレンスの型を調べます。C，C，C，Cも同様です。 =head1 ENVIRONMENT VARIABLES =head2 DATA_UTIL_PUREPERL 真であれば，Pure Perl版のバックエンドが使われます。 =head1 DEPENDENCIES Perl 5.10 or later. =head1 BUGS AND LIMITATIONS No bugs have been reported. Please report any bugs or feature requests to the author. =head1 SEE ALSO L. L. L. このモジュールのいくつかの機能は以下のモジュールの機能をXSに移植して 最適化したものであり，またいくつかはそれに加えて更に拡張を施したものです。 L. L. L. L. L. L. L. =head1 AUTHOR Goro Fuji (gfx) Egfuji(at)cpan.orgE =head1 LICENSE AND COPYRIGHT Copyright (c) 2008-2009, Goro Fuji (gfx) Egfuji(at)cpan.orgE. Some rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PurePerl.pm100644001750001750 3104713071222366 17754 0ustar00syoheisyohei000000000000Data-Util-0.66/lib/Data/Utilpackage Data::Util::PurePerl; die qq{Don't use Data::Util::PurePerl directly, use Data::Util instead.\n} # ' for poor editors if caller() ne 'Data::Util'; package Data::Util; use strict; use warnings; #use warnings::unused; use Scalar::Util (); use overload (); sub _croak{ require Data::Util::Error; goto &Data::Util::Error::croak; } sub _fail{ my($name, $value) = @_; _croak(sprintf 'Validation failed: you must supply %s, not %s', $name, neat($value)); } sub _overloaded{ return Scalar::Util::blessed($_[0]) && overload::Method($_[0], $_[1]); } sub is_scalar_ref{ return ref($_[0]) eq 'SCALAR' || ref($_[0]) eq 'REF' || _overloaded($_[0], '${}'); } sub is_array_ref{ return ref($_[0]) eq 'ARRAY' || _overloaded($_[0], '@{}'); } sub is_hash_ref{ return ref($_[0]) eq 'HASH' || _overloaded($_[0], '%{}'); } sub is_code_ref{ return ref($_[0]) eq 'CODE' || _overloaded($_[0], '&{}'); } sub is_glob_ref{ return ref($_[0]) eq 'GLOB' || _overloaded($_[0], '*{}'); } sub is_regex_ref{ return ref($_[0]) eq 'Regexp'; } sub is_rx{ return ref($_[0]) eq 'Regexp'; } sub is_instance{ my($obj, $class) = @_; _fail('a class name', $class) unless is_string($class); return Scalar::Util::blessed($obj) && $obj->isa($class); } sub is_invocant{ my($x) = @_; if(ref $x){ return !!Scalar::Util::blessed($x); } else{ return !!get_stash($x); } } sub scalar_ref{ return ref($_[0]) eq 'SCALAR' || ref($_[0]) eq 'REF' || _overloaded($_[0], '${}') ? $_[0] : _fail('a SCALAR reference', $_[0]); } sub array_ref{ return ref($_[0]) eq 'ARRAY' || _overloaded($_[0], '@{}') ? $_[0] : _fail('an ARRAY reference', $_[0]); } sub hash_ref{ return ref($_[0]) eq 'HASH' || _overloaded($_[0], '%{}') ? $_[0] : _fail('a HASH reference', $_[0]); } sub code_ref{ return ref($_[0]) eq 'CODE' || _overloaded($_[0], '&{}') ? $_[0] : _fail('a CODE reference', $_[0]); } sub glob_ref{ return ref($_[0]) eq 'GLOB' || _overloaded($_[0], '*{}') ? $_[0] : _fail('a GLOB reference', $_[0]); } sub regex_ref{ return ref($_[0]) eq 'Regexp' ? $_[0] : _fail('a regular expression reference', $_[0]); } sub rx{ return ref($_[0]) eq 'Regexp' ? $_[0] : _fail('a regular expression reference', $_[0]); } sub instance{ my($obj, $class) = @_; _fail('a class name', $class) unless is_string($class); return Scalar::Util::blessed($obj) && $obj->isa($class) ? $obj : _fail("an instance of $class", $obj); } sub invocant{ my($x) = @_; if(ref $x){ if(Scalar::Util::blessed($x)){ return $x; } } elsif(is_string($x)){ if(get_stash($x)){ $x =~ s/^:://; $x =~ s/(?:main::)+//; return $x; } } _fail('an invocant', $x); } sub is_value{ return defined($_[0]) && !ref($_[0]) && ref(\$_[0]) ne 'GLOB'; } sub is_string{ no warnings 'uninitialized'; return !ref($_[0]) && ref(\$_[0]) ne 'GLOB' && length($_[0]) > 0; } sub is_number{ return 0 if !defined($_[0]) || ref($_[0]); return $_[0] =~ m{ \A \s* [+-]? (?= \d | \.\d) \d* (\.\d*)? (?: [Ee] (?: [+-]? \d+) )? \s* \z }xms; } sub is_integer{ return 0 if !defined($_[0]) || ref($_[0]); return $_[0] =~ m{ \A \s* [+-]? \d+ \s* \z }xms; } sub get_stash{ my($invocant) = @_; if(Scalar::Util::blessed($invocant)){ no strict 'refs'; return \%{ref($invocant) . '::'}; } elsif(!is_string($invocant)){ return undef; } $invocant =~ s/^:://; my $pack = *main::; foreach my $part(split /::/, $invocant){ return undef unless $pack = $pack->{$part . '::'}; } return *{$pack}{HASH}; } sub anon_scalar{ my($s) = @_; return \$s; # not \$_[0] } sub neat{ my($s) = @_; if(ref $s){ if(ref($s) eq 'CODE'){ return sprintf '\\&%s(0x%x)', scalar(get_code_info($s)), Scalar::Util::refaddr($s); } elsif(ref($s) eq 'Regexp'){ return qq{qr{$s}}; } return overload::StrVal($s); } elsif(defined $s){ return "$s" if is_number($s); return "$s" if is_glob_ref(\$s); require B; return B::perlstring($s); } else{ return 'undef'; } } sub install_subroutine{ _croak('Usage: install_subroutine(package, name => code, ...)') unless @_; my $into = shift; is_string($into) or _fail('a package name', $into); my $param = mkopt_hash(@_ == 1 ? shift : \@_, 'install_subroutine', 'CODE'); while(my($as, $code) = each %{$param}){ defined($code) or _fail('a CODE reference', $code); my $slot = do{ no strict 'refs'; \*{ $into . '::' . $as } }; if(defined &{$slot}){ warnings::warnif(redefine => "Subroutine $as redefined"); } no warnings 'redefine'; *{$slot} = \&{$code}; } return; } sub uninstall_subroutine { _croak('Usage: uninstall_subroutine(package, name, ...)') unless @_; my $package = shift; is_string($package) or _fail('a package name', $package); my $stash = get_stash($package) or return 0; my $param = mkopt_hash(@_ == 1 && is_hash_ref($_[0]) ? shift : \@_, 'install_subroutine', 'CODE'); require B; while(my($name, $specified_code) = each %{$param}){ my $glob = $stash->{$name}; if(ref(\$glob) ne 'GLOB'){ if(ref $glob) { if(Scalar::Util::reftype $glob eq 'CODE'){ if(defined $specified_code && $specified_code != $glob) { next; } } else { warnings::warnif(misc => "Constant subroutine $name uninstalled"); } } delete $stash->{$name}; next; } my $code = *{$glob}{CODE}; if(not defined $code){ next; } if(defined $specified_code && $specified_code != $code){ next; } if(B::svref_2object($code)->CONST){ warnings::warnif(misc => "Constant subroutine $name uninstalled"); } delete $stash->{$name}; my $newglob = do{ no strict 'refs'; \*{$package . '::' . $name} }; # vivify # copy all the slot except for CODE foreach my $slot( qw(SCALAR ARRAY HASH IO FORMAT) ){ *{$newglob} = *{$glob}{$slot} if defined *{$glob}{$slot}; } } return; } sub get_code_info{ my($code) = @_; is_code_ref($code) or _fail('a CODE reference', $code); require B; my $gv = B::svref_2object(\&{$code})->GV; return unless $gv->isa('B::GV'); return wantarray ? ($gv->STASH->NAME, $gv->NAME) : join('::', $gv->STASH->NAME, $gv->NAME); } sub get_code_ref{ my($package, $name, @flags) = @_; is_string($package) or _fail('a package name', $package); is_string($name) or _fail('a subroutine name', $name); if(@flags){ if(grep{ $_ eq '-create' } @flags){ no strict 'refs'; return \&{$package . '::' . $name}; } else{ _fail('a flag', @flags); } } my $stash = get_stash($package) or return undef; if(defined(my $glob = $stash->{$name})){ if(ref(\$glob) eq 'GLOB'){ return *{$glob}{CODE}; } else{ # a stub or special constant no strict 'refs'; return *{$package . '::' . $name}{CODE}; } } return undef; } sub curry{ my $is_method = !is_code_ref($_[0]); my $proc; $proc = shift if !$is_method; my $args = \@_; my @tmpl; my $i = 0; my $max_ph = -1; my $min_ph = 0; foreach my $arg(@_){ if(is_scalar_ref($arg) && is_integer($$arg)){ push @tmpl, sprintf '$_[%d]', $$arg; if($$arg >= 0){ $max_ph = $$arg if $$arg > $max_ph; } else{ $min_ph = $$arg if $$arg < $min_ph; } } elsif(defined($arg) && (\$arg) == \*_){ push @tmpl, '@_[$max_ph .. $#_ + $min_ph]'; } else{ push @tmpl, sprintf '$args->[%d]', $i; } $i++; } $max_ph++; my($pkg, $file, $line, $hints, $bitmask) = (caller 0 )[0, 1, 2, 8, 9]; my $body = sprintf <<'END_CXT', $pkg, $line, $file; BEGIN{ $^H = $hints; ${^WARNING_BITS} = $bitmask; } package %s; #line %s %s END_CXT if($is_method){ my $selfp = shift @tmpl; $proc = shift @tmpl; $body .= sprintf q{ sub { my $self = %s; my $method = %s; $self->$method(%s); } }, $selfp, defined($proc) ? $proc : 'undef', join(q{,}, @tmpl); } else{ $body .= sprintf q{ sub { $proc->(%s) } }, join q{,}, @tmpl; } eval $body or die $@; } BEGIN{ our %modifiers; my $initializer; $initializer = sub{ require Hash::Util::FieldHash::Compat; Hash::Util::FieldHash::Compat::fieldhash(\%modifiers); undef $initializer; }; sub modify_subroutine{ my $code = code_ref shift; if((@_ % 2) != 0){ _croak('Odd number of arguments for modify_subroutine()'); } my %args = @_; my(@before, @around, @after); @before = map{ code_ref $_ } @{array_ref delete $args{before}} if exists $args{before}; @around = map{ code_ref $_ } @{array_ref delete $args{around}} if exists $args{around}; @after = map{ code_ref $_ } @{array_ref delete $args{after}} if exists $args{after}; if(%args){ _fail('a modifier property', join ', ', keys %args); } my %props = ( before => \@before, around => \@around, after => \@after, current_ref => \$code, ); #$code = curry($_, (my $tmp = $code), *_) for @around; for my $ar_code(reverse @around){ my $next = $code; $code = sub{ $ar_code->($next, @_) }; } my($pkg, $file, $line, $hints, $bitmask) = (caller 0)[0, 1, 2, 8, 9]; my $context = sprintf <<'END_CXT', $pkg, $line, $file; BEGIN{ $^H = $hints; ${^WARNING_BITS} = $bitmask; } package %s; #line %s %s(modify_subroutine) END_CXT my $modified = eval $context . q{sub{ $_->(@_) for @before; if(wantarray){ # list context my @ret = $code->(@_); $_->(@_) for @after; return @ret; } elsif(defined wantarray){ # scalar context my $ret = $code->(@_); $_->(@_) for @after; return $ret; } else{ # void context $code->(@_); $_->(@_) for @after; return; } }} or die $@; $initializer->() if $initializer; $modifiers{$modified} = \%props; return $modified; } my %valid_modifiers = map{ $_ => undef } qw(before around after); sub subroutine_modifier{ my $modified = code_ref shift; my $props_ref = $modifiers{$modified}; unless(@_){ # subroutine_modifier($subr) - only checking return defined $props_ref; } unless($props_ref){ # otherwise, it should be modified subroutines _fail('a modified subroutine', $modified); } my($name, @subs) = @_; (is_string($name) && exists $valid_modifiers{$name}) or _fail('a modifier property', $name); my $property = $props_ref->{$name}; if(@subs){ if($name eq 'after'){ push @{$property}, map{ code_ref $_ } @subs; } else{ unshift @{$property}, reverse map{ code_ref $_ } @subs; } if($name eq 'around'){ my $current_ref = $props_ref->{current_ref}; for my $ar(reverse @subs){ my $base = $$current_ref; $$current_ref = sub{ $ar->($base, @_) }; } } } return @{$property} if defined wantarray; return; } } # # mkopt() and mkopt_hash() are originated from Data::OptList # my %test_for = ( CODE => \&is_code_ref, HASH => \&is_hash_ref, ARRAY => \&is_array_ref, SCALAR => \&is_scalar_ref, GLOB => \&is_glob_ref, ); sub __is_a { my ($got, $expected) = @_; return scalar grep{ __is_a($got, $_) } @{$expected} if ref $expected; my $t = $test_for{$expected}; return defined($t) ? $t->($got) : is_instance($got, $expected); } sub mkopt{ my($opt_list, $moniker, $require_unique, $must_be) = @_; return [] unless defined $opt_list; $opt_list = [ map { $_ => (ref $opt_list->{$_} ? $opt_list->{$_} : ()) } keys %$opt_list ] if is_hash_ref($opt_list); is_array_ref($opt_list) or _fail('an ARRAY or HASH reference', $opt_list); my @return; my %seen; my $vh = is_hash_ref($must_be); my $validator = $must_be; if(defined($validator) && (!$vh && !is_array_ref($validator) && !is_string($validator))){ _fail('a type name, or ARRAY or HASH reference', $validator); } for(my $i = 0; $i < @$opt_list; $i++) { my $name = $opt_list->[$i]; my $value; is_string($name) or _fail("a name in $moniker opt list", $name); if($require_unique && $seen{$name}++) { _croak("Validation failed: Multiple definitions provided for $name in $moniker opt list") } if ($i == $#$opt_list) { $value = undef; } elsif(not defined $opt_list->[$i+1]) { $value = undef; $i++ } elsif(ref $opt_list->[$i+1]) { $value = $opt_list->[++$i] } else { $value = undef; } if (defined $value and defined( $vh ? ($validator = $must_be->{$name}) : $validator )){ unless(__is_a($value, $validator)) { _croak("Validation failed: ".ref($value)."-ref values are not valid for $name in $moniker opt list"); } } push @return, [ $name => $value ]; } return \@return; } sub mkopt_hash { my($opt_list, $moniker, $must_be) = @_; return {} unless $opt_list; my %hash = map { $_->[0] => $_->[1] } @{ mkopt($opt_list, $moniker, 1, $must_be) }; return \%hash; } 1; __END__ =head1 NAME Data::Util::PurePerl - The Pure Perl backend for Data::Util =head1 DESCRIPTION This module is a backend for C. Don't use this module directly; C instead. =cut minil.toml100644001750001750 33313071222366 15263 0ustar00syoheisyohei000000000000Data-Util-0.66name = "Data-Util" module_maker="ModuleBuild" allow_pureperl=1 c_source=['xs-src'] badges = ['circleci'] [XSUtil] needs_compiler_c99 = 1 generate_xshelper_h = "xs-src/xshelper.h" generate_ppport_h = "xs-src/ppport.h" 00_load.t100644001750001750 31413071222366 15123 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -wT use Test::More tests => 1; BEGIN { use_ok( 'Data::Util' ); } my $backend = $Data::Util::TESTING_PERL_ONLY ? 'PurePerl' : 'XS'; diag( "Testing Data::Util $Data::Util::VERSION ($backend)" ); 01_refs.t100644001750001750 457413071222366 15200 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; use Test::More tests => 47; use Test::Exception; use Data::Util qw(:check :validate); use Symbol qw(gensym); use constant PP_ONLY => exists $INC{'Data/Util/PurePerl.pm'}; diag "Testing ", PP_ONLY ? "PurePerl" : "XS"; sub lval_f :lvalue{ my $f; } ok is_scalar_ref(\''), 'is_scalar_ref'; ok is_scalar_ref(\lval_f()), 'is_scalar_ref (lvalue)'; ok is_scalar_ref(\\''), 'is_scalar_ref (ref)'; ok!is_scalar_ref(bless \do{my$o}), 'is_scalar_ref'; ok!is_scalar_ref({}), 'is_scalar_ref'; ok!is_scalar_ref(undef), 'is_scalar_ref'; ok!is_scalar_ref(*STDOUT{IO}), 'is_scalar_ref'; ok is_array_ref([]), 'is_array_ref'; ok!is_array_ref(bless []), 'is_array_ref'; ok!is_array_ref({}), 'is_array_ref'; ok!is_array_ref(undef), 'is_array_ref'; ok is_hash_ref({}), 'is_hash_ref'; ok!is_hash_ref(bless {}), 'is_hash_ref'; ok!is_hash_ref([]), 'is_hash_ref'; ok!is_hash_ref(undef), 'is_hash_ref'; ok is_code_ref(sub{}), 'is_code_ref'; ok!is_code_ref(bless sub{}), 'is_code_ref'; ok!is_code_ref({}), 'is_code_ref'; ok!is_code_ref(undef), 'is_code_ref'; ok is_glob_ref(gensym()), 'is_glob_ref'; ok!is_glob_ref(bless gensym()), 'is_glob_ref'; ok!is_glob_ref({}), 'is_glob_ref'; ok!is_glob_ref(undef), 'is_glob_ref'; ok is_regex_ref(qr/foo/), 'is_regex_ref'; ok!is_regex_ref({}), 'is_regex_ref'; ok is_rx(qr/foo/), 'is_rx'; ok!is_rx({}), 'is_rx'; SKIP:{ skip 'in testing perl only', 1 if PP_ONLY; ok!is_regex_ref(bless [], 'Regexp'), 'fake regexp'; } ok scalar_ref(\42), 'scalar_ref'; ok scalar_ref(\\42); throws_ok{ scalar_ref([]); } qr/Validation failed: you must supply a SCALAR reference/; throws_ok{ scalar_ref(undef); } qr/Validation failed/; throws_ok{ scalar_ref(42); } qr/Validation failed/; throws_ok{ scalar_ref('SCALAR'); } qr/Validation failed/; throws_ok{ scalar_ref(\*ok); } qr/Validation failed/; ok array_ref([]), 'array_ref'; throws_ok{ array_ref({foo => "bar"}); } qr/Validation failed/; ok hash_ref({}), 'hash_ref'; throws_ok{ hash_ref([]); } qr/Validation failed/; ok code_ref(sub{}), 'code_ref'; throws_ok{ code_ref([]); } qr/Validation failed/; ok glob_ref(gensym()), 'glob_ref'; throws_ok{ glob_ref('*glob'); } qr/Validation failed/; ok rx(qr/foo/), 'rx'; throws_ok{ rx([]); } qr/Validation failed/; SKIP:{ skip 'in testing perl only', 2 if PP_ONLY; dies_ok{ is_scalar_ref(); } 'not enough arguments'; dies_ok{ scalar_ref(); } 'not enought arguments'; } 02_inst.t100644001750001750 422513071222366 15210 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; use Test::More tests => 33; use Test::Exception; use Data::Util qw(is_instance instance); BEGIN{ package Foo; sub new{ bless {}, shift } package Bar; our @ISA = qw(Foo); package Foo_or_Bar; our @ISA = qw(Foo); package Baz; sub new{ bless {}, shift } sub isa{ my($x, $y) = @_; return $y eq 'Foo'; } package Broken; sub isa; # pre-declaration only package AL; sub new{ bless {}, shift } sub DESTROY{} sub isa; sub AUTOLOAD{ #our $AUTOLOAD; ::diag "$AUTOLOAD(@_)"; 1; } package AL_stubonly; sub new{ bless{}, shift; } sub DESTROY{}; sub isa; sub AUTOLOAD; } ok is_instance(Foo->new, 'Foo'), 'is_instance'; ok !is_instance(Foo->new, 'Bar'); ok is_instance(Foo->new, 'UNIVERSAL'), 'is_instance of UNIVERSAL'; ok is_instance(Bar->new, 'Foo'); ok is_instance(Bar->new, 'Bar'); ok is_instance(Baz->new, 'Foo'); ok !is_instance(Baz->new, 'Bar'); ok !is_instance(Baz->new, 'Baz'); ok is_instance(Foo_or_Bar->new, 'Foo'); ok!is_instance(Foo_or_Bar->new, 'Bar'); @Foo_or_Bar::ISA = qw(Bar); ok is_instance(Foo_or_Bar->new, 'Bar'), 'ISA changed dynamically'; # no object reference ok !is_instance('Foo', 'Foo'); ok !is_instance({}, 'Foo'); ok !is_instance({}, 'HASH'); dies_ok{ is_instance(Broken->new(), 'Broken') }; ok is_instance(AL->new, 'AL'); ok is_instance(AL->new, 'Foo'); dies_ok { is_instance(AL_stubonly->new, 'AL') }; isa_ok instance(Foo->new, 'Foo'), 'Foo', 'instance'; isa_ok instance(Bar->new, 'Foo'), 'Foo'; dies_ok{ instance(undef, 'Foo') }; dies_ok{ instance(1, 'Foo') }; dies_ok{ instance('', 'Foo') }; dies_ok{ instance({}, 'Foo') }; dies_ok{ instance(Foo->new, 'Bar') }; # error dies_ok{ is_instance('Foo', Foo->new()) } 'illigal argument order'; dies_ok{ is_instance([], []) } 'illigal use'; dies_ok{ is_instance() } 'not enough argument'; dies_ok{ is_instance([], undef) } 'uninitialized class'; dies_ok{ instance('Foo', Foo->new()) } 'illigal argument order'; dies_ok{ instance([], []) } 'illigal use'; dies_ok{ instance() } 'not enough argument'; dies_ok{ instance([], undef) } 'uninitialized class'; 03_gen.t100644001750001750 76713071222366 14774 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; use Test::More tests =>7; use Data::Util qw(anon_scalar); my $sref = \do{ my $anon }; is_deeply anon_scalar(), $sref, 'anon_scalar'; is_deeply anon_scalar(undef), $sref, 'anon_scalar'; is_deeply anon_scalar(10), \10; is_deeply anon_scalar('foo'), \'foo'; ok !Internals::SvREADONLY(${ anon_scalar(10) }), 'not readonly'; my $foo; # equivalent to "$foo = \do{ my $tmp = $foo }" $foo = anon_scalar $foo; is_deeply $foo, $sref; ok eval{ ${anon_scalar()} = 10; }, 'writable'; 04_overloaded.t100644001750001750 325213071222366 16360 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl-w use strict; use Test::More tests => 36; use Test::Exception; use Data::Util qw(:all); BEGIN{ package Foo; use overload fallback => 1; sub new{ bless {} => shift; } package MyArray; use overload '@{}' => 'as_array', fallback => 1; sub new{ bless {array => []} => shift; } sub as_array{ shift()->{array}; } package AnyRef; use overload '@{}' => 'as_array', '%{}' => 'as_hash', '${}' => 'as_scalar', '*{}' => 'as_glob', '&{}' => 'as_code', fallback => 1; my $s; my @a; my %h; my $gref; select select $gref; sub c{1} sub new{ bless {} => shift; } sub as_scalar{ \$s; } sub as_array{ \@a; } sub as_hash{ \%h; } sub as_glob{ $gref; } sub as_code{ \&c; } package DerivedAnyRef; our @ISA = qw(AnyRef); } # :check my $foo = Foo->new(); ok !is_array_ref($foo), 'check with overloaded'; ok !is_hash_ref($foo); my $ma = MyArray->new(); ok is_array_ref($ma); ok !is_hash_ref($ma); ok !is_scalar_ref($ma); ok !is_code_ref($ma); ok !is_glob_ref($ma); ok !is_regex_ref($ma); for my $ref(AnyRef->new(), DerivedAnyRef->new()){ ok is_array_ref($ref); ok is_hash_ref($ref); ok is_scalar_ref($ref); ok is_code_ref($ref); ok is_glob_ref($ref); } # :validate $foo = Foo->new(); dies_ok{ array_ref($foo); } 'validate with overloaded'; dies_ok{ hash_ref($foo); }; $ma = MyArray->new(); lives_and{ ok array_ref($ma); }; dies_ok{ hash_ref($ma) }; dies_ok{ scalar_ref($ma) }; dies_ok{ code_ref($ma) }; dies_ok{ glob_ref($ma) }; dies_ok{ regex_ref($ma) }; for my $ref(AnyRef->new(), DerivedAnyRef->new()){ lives_and{ ok array_ref($ref); ok hash_ref($ref); ok scalar_ref($ref); ok code_ref($ref); ok glob_ref($ref); }; } 05_get_stash.t100644001750001750 240013071222366 16210 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w # get_stash(), is_invocant(), invocant() use strict; use warnings FATAL => 'all'; use Test::More tests => 40; use Test::Exception; use Tie::Scalar; use Scalar::Util qw(blessed); use Data::Util qw(:all); #diag 'Testing ', $INC{'Data/Util/PurePerl.pm'} ? 'PurePerl' : 'XS'; sub get_stash_pp{ my($pkg) = @_; no strict 'refs'; if(blessed $pkg){ $pkg = ref $pkg; } return \%{$pkg . '::'}; } foreach my $pkg( qw(main strict Data::Util ::main::Data::Util), bless{}, 'Foo'){ is get_stash($pkg), get_stash_pp($pkg), sprintf 'get_stash(%s)', neat $pkg; ok is_invocant($pkg), 'is_invocant()'; ok invocant($pkg)->isa('UNIVERSAL'), 'invocant()'; } foreach my $pkg('not_exists', '', 1, undef, [], *ok){ ok !defined(get_stash $pkg), 'get_stash for ' . neat($pkg) . '(invalid value)'; ok !is_invocant($pkg), '!is_invocant()'; throws_ok{ invocant($pkg); } qr/Validation failed/, 'invocant() throws fatal error'; } my $x = tie my($ts), 'Tie::StdScalar', 'main'; is get_stash($ts), get_stash_pp('main'), 'for magic variable'; ok is_invocant($ts); ok invocant($ts); ok is_invocant($x), 'is_invocant() for an object'; is invocant($x), $x, 'invocant() for an object'; is invocant('::Data::Util'), 'Data::Util'; is invocant('main::Data::Util'), 'Data::Util'; 06_subroutine.t100644001750001750 613313071222366 16436 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; use Test::More tests =>32; use Test::Exception; use Data::Util qw(:all); use constant PP_ONLY => $INC{'Data/Util/PurePerl.pm'}; sub get_subname{ return scalar get_code_info(@_); } sub foo{ 42; } sub bar{ 52; } { package Base; sub foo{ 'Base::foo'; } package Foo; our @ISA = qw(Base); use Data::Util qw(install_subroutine); sub baz{} package Callable; use overload '&{}' => 'codify', ; sub new{ my $class = shift; bless {@_} => $class; } sub codify{ my $self = shift; $self->{code}; } } is_deeply get_subname(\&foo), 'main::foo', 'get_code_info()'; is_deeply [get_code_info(\&foo)], [qw(main foo)]; is_deeply get_subname(\&Foo::baz), 'Foo::baz', 'get_code_info()'; is_deeply [get_code_info(\&Foo::baz)], [qw(Foo baz)]; is_deeply get_subname(\&undefined_subr), 'main::undefined_subr'; is_deeply [get_code_info(\&undefined_subr)], [qw(main undefined_subr)]; no warnings 'redefine'; Foo->foo(); # touch the chache Foo->install_subroutine(foo => \&foo); is Foo::foo(), foo(), 'as function'; is(Foo->foo(), foo(), 'as method'); Foo->install_subroutine(foo => \&bar); is Foo::foo(), bar(), 'redefined'; Foo->install_subroutine(foo => sub{ 314 }); is Foo::foo(), 314, 'install anonymous subr'; SKIP:{ skip 'in testing perl only', 1 if PP_ONLY; is get_subname(\&Foo::foo), 'Foo::foo', '...named'; } Foo->install_subroutine(foo => \&foo); is Foo::foo(), foo(); SKIP:{ skip 'in testing perl only', 1 if PP_ONLY; is get_subname(\&Foo::foo), 'main::foo'; } { my $count = 0; Foo->install_subroutine(foo => sub{ ++$count }); } is Foo::foo(), 1, 'install closure'; is Foo::foo(), 2; SKIP:{ skip 'in testing perl only', 2 if PP_ONLY; Foo->install_subroutine(foo => sub{}); is get_subname(\&Foo::foo), 'Foo::foo', 'name an anonymous subr'; Foo->install_subroutine(bar => \&Foo::foo); is get_subname(\&Foo::bar), 'Foo::foo', 'does not name a named subr'; } # exception Foo->install_subroutine(foo => \&undefined_subr); dies_ok{ Foo->foo(); } 'install undefined subroutine'; Foo->install_subroutine(ov1 => Callable->new(code => sub{ 'overloaded' })); is Foo::ov1(), 'overloaded', 'overload'; Foo->install_subroutine(ov2 => Callable->new(code => sub{ die 'dies in codify' })); throws_ok{ Foo::ov2(); } qr/dies in codify/; dies_ok{ Foo->install_subroutine(ov3 => Callable->new(code => [])); }; dies_ok{ Foo->install_subroutine(ov4 => Callable->new(code => undef)); }; use warnings FATAL => 'redefine'; throws_ok{ get_code_info(undef); } qr/CODE reference/; throws_ok{ install_subroutine(); } qr/^Usage: /; dies_ok{ Foo->install_subroutine('foo'); }; throws_ok{ Data::Util::install_subroutine(undef, foo => \&foo); } qr/package name/; throws_ok{ Foo->install_subroutine(PI => 3.14); } qr/CODE reference/; throws_ok{ Foo->install_subroutine(undef, sub{}); } qr/\b name\b /xms; throws_ok{ Foo->install_subroutine([], sub{}); } qr/\b name\b /xms; # multiple installation install_subroutine(__PACKAGE__, f1 => sub{ 1 }, f2 => sub{ 2 }, f3 => sub{ 3 }); is f1(), 1, 'multiple installation(1)'; is f2(), 2, 'multiple installation(2)'; is f3(), 3, 'multiple installation(3)';; 08_mgvars.t100644001750001750 130513071222366 15534 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; use Test::More tests => 12; use Tie::Scalar; use Tie::Array; use Tie::Hash; use Data::Util qw(:check); BEGIN{ package Foo; sub new{ bless {} => shift; } } tie my($x), 'Tie::StdScalar', []; $x = []; ok is_array_ref($x); ok!is_hash_ref($x); $x = ''; ok is_scalar_ref(\$x); ok!is_array_ref($x); $x = Foo->new(); tie my($class), 'Tie::StdScalar', 'Foo'; ok!is_hash_ref($x); ok is_instance($x, $class); $class = 'Bar'; ok!is_instance($x, $class); $x = undef; ok!is_instance($x, $class); $x = {}; ok!is_instance($x, $class); $x = ''; ok!is_instance($x, $class); tie my(@arr), 'Tie::StdArray'; ok is_array_ref(\@arr); tie my(%hash), 'Tie::StdHash'; ok is_hash_ref(\%hash); 09_paranoia.t100644001750001750 300613071222366 16030 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; use Test::More; use Data::Util qw(is_instance); BEGIN{ if(exists $INC{'Data/Util/PurePerl.pm'}){ plan skip_all => 'For XS only'; } else{ plan tests => 26; } } local $SIG{__WARN__} = sub{}; # ignore BEGIN{ no warnings; sub UNIVERSAL::new{ bless {} => shift; } package Foo; our @ISA = (undef, 1, [], \&new, 'Base'); sub new{ bless {} => shift; } package X; our @ISA = qw(A); package Y; package Z; package Bar; our @ISA = qw(::X main::Y ::main::main::Z); my $instance = bless {} => '::main::main::Bar'; sub instance{ $instance } package main::Ax; package ::Bx; our @ISA = qw(Ax); package ::main::main::Cx; our @ISA = qw(Bx); } my $o = Foo->new(); ok is_instance($o, 'Foo'); ok is_instance($o, 'Base'); ok is_instance($o, 'UNIVERSAL'); @Foo::ISA = (); ok is_instance($o, 'Foo'); ok!(is_instance($o, 'Base')); ok is_instance($o, 'UNIVERSAL'); ok is_instance($o, '::Foo'); ok is_instance($o, 'main::Foo'); ok is_instance($o, 'main::main::Foo'); ok is_instance($o, '::main::main::UNIVERSAL'); ok!is_instance($o, '::::Foo'); ok!is_instance($o, 'Fooo'); ok!is_instance($o, 'FoO'); ok!is_instance($o, 'foo'); ok!is_instance($o, 'mai'); ok!is_instance($o, 'UNIVERSA'); $o = Bar->instance; ok is_instance($o, 'Bar'); ok is_instance($o, 'X'); ok is_instance($o, 'Y'); ok is_instance($o, 'Z'); ok is_instance($o, '::Z'); ok!is_instance($o, 'main'); ok!is_instance($o, 'main::'); ok is_instance(Cx->new, 'Ax'); ok is_instance(Cx->new, 'Bx'); ok is_instance(Cx->new, 'Cx'); 10_neat.t100644001750001750 226713071222366 15165 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use warnings 'FATAL'; use strict; use Test::More tests => 18; use Tie::Scalar; use Tie::Array; use Tie::Hash; sub foo{} { package Foo; use overload '""' => sub{ 'Foo!' }, fallback => 1; sub new{ bless {}, shift } } use Data::Util qw(neat); is neat(42), 42, 'neat()'; is neat(3.14), 3.14; is neat("foo"), q{"foo"}; is neat(undef), 'undef'; is neat(*ok), '*main::ok'; ok neat({'!foo' => '!bar'}); unlike neat({foo => 'bar', baz => 'bax'}), qr/undef/; like neat(\&foo), qr/^\\&main::foo\(.*\)$/; like neat(Foo->new(42)), qr/^Foo=HASH\(.+\)$/, 'for an overloaded object'; like neat(qr/foo/), qr/foo/, 'neat(qr/foo/) includes "foo"'; ok neat(+9**9**9), '+Inf'; ok neat(-9**9**9), '-Inf'; ok neat(9**9**9 - 9**9**9), 'NaN'; tie my $s, 'Tie::StdScalar', "foo"; is neat($s), q{"foo"}, 'for magical scalar'; my $x; $x = tie my @a, 'Tie::StdArray'; $x->[0] = 42; is neat($a[0]), 42, 'for magical scalar (aelem)'; $x = tie my %h, 'Tie::StdHash'; $x->{foo} = 'bar'; is neat($h{foo}), '"bar"', 'for magical scalar (helem)'; # recursive my @rec; push @rec, \@rec; ok neat(\@rec), 'neat(recursive array) is safe'; my %rec; $rec{self} = \%rec; ok neat(\%rec), 'neat(recursive hash) is safe'; 11_fail_handler.t100644001750001750 154713071222366 16647 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; use Test::More tests => 8; use Test::Exception; BEGIN{ use_ok 'Data::Util::Error'; } { package Foo; use Data::Util::Error \&fail; use Data::Util qw(:validate); sub f{ array_ref(@_); } sub fail{ 'FooError' } } { package Bar; use Data::Util::Error \&fail; use Data::Util qw(:validate); sub f{ array_ref(@_); } sub fail{ 'BarError' } } { package Baz; use base qw(Foo Bar); use Data::Util qw(:validate); sub g{ array_ref(@_); } } is( Data::Util::Error->fail_handler('Foo'), \&Foo::fail ); is( Data::Util::Error->fail_handler('Bar'), \&Bar::fail ); is( Data::Util::Error->fail_handler('Baz'), \&Foo::fail ); throws_ok{ Foo::f({}); } qr/FooError/; throws_ok{ Bar::f({}); } qr/BarError/; throws_ok{ Baz::g({}); } qr/FooError/; throws_ok{ Data::Util::Error->fail_handler(Foo => 'throw'); } qr/Validation failed/; 12_in_attr_handler.t100644001750001750 100613071222366 17363 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; use if ($] >= 5.011), 'Test::More', 'skip_all' => 'This test is for old perls'; use Test::More tests => 4; use Test::Exception; use Data::Util qw(get_code_info install_subroutine); use Attribute::Handlers; sub UNIVERSAL::Foo :ATTR(CODE, BEGIN){ my($pkg, $sym, $subr) = @_; lives_ok{ scalar get_code_info($subr); } 'get_code_info()'; lives_ok{ no warnings 'redefine'; install_subroutine 'main', 'foo', $subr; } 'install_subroutine()'; } sub f :Foo; my $anon = sub :Foo {}; 13_optlist.t100644001750001750 1062413071222366 15753 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; use Test::More tests => 48; use Test::Exception; use Data::Util qw(:all); use constant PP_ONLY => $INC{'Data/Util/PurePerl.pm'}; BEGIN{ package Foo; sub new{ bless {}, shift; } package MyArray; our @ISA = qw(Foo); use overload bool => sub{ 1 }, '@{}' => sub{ ['ARRAY'] }, ; package MyHash; our @ISA = qw(Foo); use overload bool => sub{ 1 }, '%{}' => sub{ +{ foo => 'ARRAY' } }, ; package BadHash; our @ISA = qw(Foo); use overload bool => sub{ 1 }, '%{}' => sub{ ['ARRAY'] }, ; } use constant true => 1; use constant false => 0; # mkopt is_deeply mkopt(undef), [], 'mkopt()'; is_deeply mkopt([]), []; is_deeply mkopt(['foo']), [ [foo => undef] ]; is_deeply mkopt([foo => undef]), [ [foo => undef] ]; is_deeply mkopt([foo => [42]]), [ [foo => [42]] ]; is_deeply mkopt([qw(foo bar baz)]), [ [foo => undef], [bar => undef], [baz => undef]]; is_deeply mkopt({foo => undef}), [ [foo => undef] ]; is_deeply mkopt({foo => [42]}), [ [foo => [42]] ]; is_deeply mkopt([qw(foo bar baz)], undef, true), [[foo => undef], [bar => undef], [baz => undef]], 'unique'; is_deeply mkopt([foo => [], qw(bar)], undef, false, 'ARRAY'), [[foo => []], [bar => undef]], 'validation'; is_deeply mkopt([foo => [], qw(bar)], undef, false, ['CODE', 'ARRAY']), [[foo => []], [bar => undef]]; is_deeply mkopt([foo => anon_scalar], undef, false, 'SCALAR'), [[foo => anon_scalar]]; is_deeply mkopt([foo => \&ok], undef, false, 'CODE'), [[foo => \&ok]]; is_deeply mkopt([foo => Foo->new], undef, false, 'Foo'), [[foo => Foo->new]]; is_deeply mkopt(MyArray->new()), [ [ARRAY => undef] ], 'overloaded data (ARRAY)'; is_deeply mkopt([foo => [], qw(bar)], undef, false, {foo => 'ARRAY'}), [[foo => []], [bar => undef]]; is_deeply mkopt([foo => [], bar => {}], undef, false, {foo => ['CODE', 'ARRAY'], bar => 'HASH'}), [[foo => []], [bar => {}]]; is_deeply mkopt([foo => [42]], undef, false, MyArray->new()), [[foo => [42]]], 'overloaded validator (ARRAY)'; is_deeply mkopt([foo => [42]], 'test', false, MyHash->new()), [[foo => [42]]], 'overloaded validator (HASH)'; dies_ok{ mkopt([foo => {}], 'test', false, MyHash->new()); }; # mkopt_hash is_deeply mkopt_hash(undef), {}, 'mkopt_hash()'; is_deeply mkopt_hash([]), {}; is_deeply mkopt_hash(['foo']), { foo => undef }; is_deeply mkopt_hash([foo => undef]), { foo => undef }; is_deeply mkopt_hash([foo => [42]]), { foo => [42] }; is_deeply mkopt_hash([qw(foo bar baz)]), { foo => undef, bar => undef, baz => undef }; is_deeply mkopt_hash({foo => undef}), { foo => undef }; is_deeply mkopt_hash({foo => [42]}), { foo => [42] }; is_deeply mkopt_hash([foo => [], qw(bar)], undef, 'ARRAY'), {foo => [], bar => undef}, 'validation'; is_deeply mkopt_hash([foo => [], qw(bar)], undef, ['CODE', 'ARRAY']), {foo => [], bar => undef}; is_deeply mkopt_hash([foo => Foo->new], undef, 'Foo'), {foo => Foo->new}; is_deeply mkopt_hash([foo => [], qw(bar)], undef, {foo => 'ARRAY'}), {foo => [], bar => undef}; is_deeply mkopt_hash([foo => [], bar => {}], undef, {foo => ['CODE', 'ARRAY'], bar => 'HASH'}), {foo => [], bar => {}}; # XS specific misc. check my $key = 'foo'; my $ref = mkopt([$key]); $ref->[0][0] .= 'bar'; is $key, 'foo'; $ref = mkopt_hash([$key]); $key .= 'bar'; is_deeply $ref, {foo => undef}; sub f{ return mkopt(@_); } { my $a = mkopt(my $foo = ['foo']); push @$foo, 42; my $b = mkopt(my $bar = ['bar']); push @$bar, 42; is_deeply $a, [[foo => undef]], '(use TARG)'; is_deeply $b, [[bar => undef]], '(use TARG)'; } # unique throws_ok{ mkopt [qw(foo foo)], "mkopt", 1; } qr/multiple definitions/i, 'unique-mkopt'; throws_ok{ mkopt_hash [qw(foo foo)], "mkopt", 1; } qr/multiple definitions/i, 'unique-mkopt_hash'; # validation throws_ok{ mkopt [foo => []], "test", 0, 'HASH'; } qr/ARRAY-ref values are not valid.* in test opt list/; throws_ok{ mkopt [foo => []], "test", 0, [qw(SCALAR CODE HASH GLOB)]; } qr/ARRAY-ref values are not valid.* in test opt list/; throws_ok{ mkopt [foo => []], "test", 0, 'Bar'; } qr/ARRAY-ref values are not valid.* in test opt list/; throws_ok{ mkopt [foo => Foo->new], "test", 0, 'Bar'; } qr/Foo-ref values are not valid.* in test opt list/; throws_ok{ mkopt [foo => Foo->new], "test", 0, ['CODE', 'Bar']; } qr/Foo-ref values are not valid.* in test opt list/; # bad uses dies_ok{ mkopt [], 'test', 0, anon_scalar(); }; dies_ok{ mkopt anon_scalar(); }; dies_ok{ mkopt_hash anon_scalar(); }; dies_ok{ mkopt(BadHash->new(), 'test'); }; 14_uninst_subr.t100644001750001750 405113071222366 16606 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; use Test::More tests => 23; use Test::Exception; use constant HAS_SCOPE_GUARD => eval{ require Scope::Guard }; use Data::Util qw(:all); { package Base; sub f{42}; package Derived; our @ISA = qw(Base); sub f; } sub foo(){ (42, 43) } my $before = \*foo; our $foo = 10; our @foo = (1, 2, 3); ok defined(&foo), 'before uninstalled'; ok __PACKAGE__->can('foo'), 'can'; uninstall_subroutine(__PACKAGE__, 'foo'); ok !__PACKAGE__->can('foo'), 'cannot'; is $foo, 10, 'remains other slots'; is_deeply \@foo, [1, 2, 3]; my $after = do{ no strict 'refs'; \*{'foo'} }; is *{$before}, *{$after}, 'compare globs directly'; uninstall_subroutine(__PACKAGE__, 'foo'); # ok uninstall_subroutine('Derived' => 'f'); is scalar(get_code_info(Derived->can('f'))), 'Base::f', 'uninstall subroutine stubs'; is(Derived->f(), 42); sub f1{} # f2 does not exist sub f3{} sub f4{} uninstall_subroutine(__PACKAGE__, qw(f1 f2), f3 => \&f3, f4 => \&f1, ); ok !__PACKAGE__->can('f1'); ok !__PACKAGE__->can('f2'); ok !__PACKAGE__->can('f3'), 'specify a matched subr (uninstalled)'; ok __PACKAGE__->can('f4'), 'specify an unmatched subr (not uninstalled)'; SKIP:{ skip 'requires Scope::Guard', 2 unless HAS_SCOPE_GUARD; my $i = 1; { my $s = Scope::Guard->new(sub{ $i--; pass 'closure released' }); install_subroutine(__PACKAGE__, closure => sub{ $s }); } uninstall_subroutine(__PACKAGE__, 'closure'); is $i, 0, 'closed values released'; } our $BAX = 42; { no warnings 'misc'; use constant BAR => 3.14; use constant BAZ => BAR * 2; is(BAR(), 3.14); uninstall_subroutine(__PACKAGE__, 'BAR', 'BAZ', 'BAX'); } is $BAX, 42; ok !__PACKAGE__->can('BAR'); ok !__PACKAGE__->can('BAZ'); lives_ok{ uninstall_subroutine('UndefinedPackage','foo'); }; throws_ok{ use constant FOO => 42; use warnings FATAL => 'misc'; uninstall_subroutine(__PACKAGE__, 'FOO'); } qr/Constant subroutine FOO uninstalled/; dies_ok{ uninstall_subroutine(undef, 'foo'); }; dies_ok{ uninstall_subroutine(__PACKAGE__, undef); }; throws_ok{ uninstall_subroutine(); } qr/^Usage: /; 15_curry.t100644001750001750 503013071222366 15376 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; use Test::More tests => 32; use Test::Exception; use constant HAS_SCOPE_GUARD => eval{ require Scope::Guard }; use Data::Util qw(:all); sub foo{ @_ } ok is_code_ref(curry(\&foo, 42)), 'curry()'; is_deeply [curry(\&foo, 42)->()], [42], 'without placeholders, in list context'; is_deeply [curry(\&foo, 42)->(38)], [42]; is_deeply [curry(\&foo, \0, 2)->(3)], [3, 2], 'with subscriptive placeholders'; is_deeply [curry(\&foo, \1, \0)->(2, 3)], [3, 2]; is_deeply [curry(\&foo, \0, 2, \1)->(1, 3)], [1, 2, 3]; is_deeply [curry(\&foo, \0, \0, \0)->(42)], [42, 42, 42]; is_deeply [scalar curry(\&foo, \(0 .. 2))->(1, 2, 3)], [3], 'in scalar context'; is_deeply [curry(\&foo, *_)->(1 .. 10)], [1 .. 10], 'with *_'; is_deeply [curry(\&foo, *_, 3)->(1, 2)], [1, 2, 3], '*_, x'; is_deeply [curry(\&foo, 1, *_)->(2, 3)], [1, 2, 3], 'x, *_'; is_deeply [curry(\&foo, *_, 1, *_)->(2, 3)], [2, 3, 1, 2, 3], '*_, x, *_'; is_deeply [curry(\&foo, *_, \0, \1)->(1, 2, 3, 4)], [3, 4, 1, 2], '*_, \\0, \\1'; is_deeply [curry(\&foo, \1, \0, *_)->(1, 2, 3, 4)], [2, 1, 3, 4], '\\0, \\1, *_'; { package Foo; sub new{ bless {}, shift } sub foo{ @_ } } my $o = Foo->new; is_deeply [curry($o, foo => 42)->()], [$o, 42], 'method curry'; is_deeply [curry($o, foo => \0)->(38)], [$o, 38]; is_deeply [curry($o, foo => *_)->(1, 2, 3)], [$o, 1, 2, 3]; is_deeply [curry(\0, foo => 1, 2, 3)->($o)], [$o, 1, 2, 3]; is_deeply [curry(\0, \1, *_)->($o, foo => 1, 2, 3)], [$o, 1, 2, 3]; is_deeply [curry(\1, \0, *_)->(foo => $o, 1, 2, 3)], [$o, 1, 2, 3]; # has normal argument semantics sub incr{ $_++ for @_; } { my $i = 0; curry(\&incr, $i)->(); is $i, 1, 'argument semantics (alias)'; curry(\&incr, \0)->($i); is $i, 2; curry(\&incr, *_)->($i); is $i, 3; } SKIP:{ skip 'requires Scope::Gurard for testing GC', 5 unless HAS_SCOPE_GUARD; my $i = 0; curry(\&foo, Scope::Guard->new(sub{ $i++ }))->() for 1 .. 3; is $i, 3, 'GC'; curry(\&foo, \0)->(Scope::Guard->new(sub{ $i++ })) for 1 .. 3; is $i, 6; curry(\&foo, *_)->(Scope::Guard->new(sub{ $i++ })) for 1 .. 3; is $i, 9; curry(Foo->new, 'foo', Scope::Guard->new(sub{ $i++ }))->() for 1 .. 3; is $i, 12; for(1 .. 3){ curry( Scope::Guard->new(sub{ $i++ }) ); } is $i, 15; } is_deeply [curry(\&foo, \undef)->(42)], [\undef], 'not a placeholder'; throws_ok { curry(\&undefined_function)->(); } qr/Undefined subroutine/; throws_ok { curry($o, 'undefined_method')->(); } qr/Can't locate object method/; dies_ok{ no warnings 'uninitialized'; curry(undef, undef)->(); } 'bad arguments'; 16_modify.t100644001750001750 1754613071222366 15561 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; use Test::More tests => 55; use Test::Exception; use constant HAS_SCOPE_GUARD => eval{ require Scope::Guard }; use Data::Util qw(:all); sub foo{ @_ } my @tags; sub before{ push @tags, 'before'; } sub around{ push @tags, 'around'; my $next = shift; $next->(@_) } sub after { push @tags, 'after'; } ok is_code_ref(modify_subroutine(\&foo)), 'modify_subroutine()'; my $w = modify_subroutine \&foo, before => [\&before], around => [\&around], after => [\&after]; lives_ok{ ok subroutine_modifier($w); ok !subroutine_modifier(\&foo); }; is_deeply [subroutine_modifier $w, 'before'], [\&before], 'getter:before'; is_deeply [subroutine_modifier $w, 'around'], [\&around], 'getter:around'; is_deeply [subroutine_modifier $w, 'after'], [\&after], 'getter:after'; is_deeply [scalar $w->(1 .. 10)], [10], 'call with scalar context'; is_deeply \@tags, [qw(before around after)]; @tags = (); is_deeply [$w->(1 .. 10)], [1 .. 10], 'call with list context'; is_deeply \@tags, [qw(before around after)]; $w = modify_subroutine \&foo; subroutine_modifier $w, before => \&before; @tags = (); is_deeply [$w->(1 .. 10)], [1 .. 10]; is_deeply \@tags, [qw(before)], 'add :before modifiers'; $w = modify_subroutine \&foo; subroutine_modifier $w, around => \&around; @tags = (); is_deeply [$w->(1 .. 10)], [1 .. 10]; is_deeply \@tags, [qw(around)], 'add :around modifiers'; $w = modify_subroutine \&foo; subroutine_modifier $w, after => \&after; @tags = (); is_deeply [$w->(1 .. 10)], [1 .. 10]; is_deeply \@tags, [qw(after)], 'add :after modifiers'; $w = modify_subroutine \&foo, before => [(\&before) x 10], around => [(\&around) x 10], after => [(\&after) x 10]; @tags = (); is_deeply [$w->(42)], [42]; is_deeply \@tags, [('before') x 10, ('around') x 10, ('after') x 10], 'with multiple modifiers'; subroutine_modifier $w, before => \&before, \&before; subroutine_modifier $w, around => \&around, \&around; subroutine_modifier $w, after => \&after, \&after; @tags = (); is_deeply [$w->(1 .. 10)], [1 .. 10]; is_deeply \@tags, [('before') x 12, ('around') x 12, ('after') x 12], 'add modifiers'; # calling order and copying sub f1{ push @tags, 'f1'; my $next = shift; $next->(@_); } sub f2{ push @tags, 'f2'; my $next = shift; $next->(@_); } sub f3{ push @tags, 'f3'; my $next = shift; $next->(@_); } sub before2{ push @tags, 'before2' } sub before3{ push @tags, 'before3' } sub after2 { push @tags, 'after2' } sub after3 { push @tags, 'after3' } # the order of around modifier $w = modify_subroutine \&foo, around => [ \&f1, \&f2, \&f3 ]; @tags = (); $w->(); is_deeply \@tags, [qw(f1 f2 f3)], ":around order (modify_subroutine)(@tags)"; $w = modify_subroutine \&foo; subroutine_modifier $w, around => \&f3, \&f2, \&f1; @tags = (); $w->(); is_deeply \@tags, [qw(f3 f2 f1)], ":around order (subroutine_modifier) (@tags)"; $w = modify_subroutine \&foo; subroutine_modifier $w, around => $_ for \&f1, \&f2, \&f3; @tags = (); $w->(); is_deeply \@tags, [qw(f3 f2 f1)], ":around order (subroutine_modifier) (@tags)"; # the order of before modifier $w = modify_subroutine \&foo, before => [\&before, \&before2, \&before3]; @tags = (); $w->(); is_deeply \@tags, [qw(before before2 before3)], ':before order (modify_subroutine)'; $w = modify_subroutine \&foo; subroutine_modifier $w, before => \&before, \&before2, \&before3; @tags = (); $w->(); is_deeply \@tags, [qw(before3 before2 before)], ':before order (subroutine_modifier)'; $w = modify_subroutine \&foo; subroutine_modifier $w, before => $_ for \&before, \&before2, \&before3; @tags = (); $w->(); is_deeply \@tags, [qw(before3 before2 before)], ":before order (subroutine_modifier) (@tags)"; # the order of after modifier $w = modify_subroutine \&foo, after => [\&after, \&after2, \&after3]; @tags = (); $w->(); is_deeply \@tags, [qw(after after2 after3)], ':after order (modify_subroutine)'; $w = modify_subroutine \&foo; subroutine_modifier $w, after => \&after, \&after2, \&after3; @tags = (); $w->(); is_deeply \@tags, [qw(after after2 after3)], ':after order (subroutine_modifier)'; $w = modify_subroutine \&foo; subroutine_modifier $w, after => $_ for \&after, \&after2, \&after3; @tags = (); $w->(); is_deeply \@tags, [qw(after after2 after3)], ":after order (subroutine_modifier) (@tags)"; # Moose compatibility $w = modify_subroutine \&foo; subroutine_modifier $w, before => $_ for \&before1, \&before2, \&before3; subroutine_modifier $w, around => $_ for \&around1, \&around2, \&around3; subroutine_modifier $w, after => $_ for \&after1, \&after2, \&after3; is_deeply [subroutine_modifier $w, 'before'], [\&before3, \&before2, \&before1], 'get before modifiers'; is_deeply [subroutine_modifier $w, 'around'], [\&around3, \&around2, \&around1], 'get around modifiers'; is_deeply [subroutine_modifier $w, 'after' ], [\&after1, \&after2, \&after3 ], 'get after modifiers'; # Copying possilbility $w = modify_subroutine \&foo, before => [subroutine_modifier $w, 'before'], around => [subroutine_modifier $w, 'around'], after => [subroutine_modifier $w, 'after' ]; is_deeply [subroutine_modifier $w, 'before'], [\&before3, \&before2, \&before1], 'copy before modifiers'; is_deeply [subroutine_modifier $w, 'around'], [\&around3, \&around2, \&around1], 'copy around modifiers'; is_deeply [subroutine_modifier $w, 'after' ], [\&after1, \&after2, \&after3 ], 'copy after modifiers'; # Contexts sub get_context{ push @tags, wantarray ? 'list' : defined(wantarray) ? 'scalar' : 'void'; } $w = modify_subroutine(\&foo, around => [\&get_context]); @tags = (); () = $w->(); is_deeply \@tags, [qw(list)], 'list context in around'; @tags = (); scalar $w->(); is_deeply \@tags, [qw(scalar)], 'scalar context in around'; @tags = (); $w->(); is_deeply \@tags, [qw(void)], 'void context in around'; # Modifier's args sub mutator{ $_[0]++; } $w = modify_subroutine(\&foo, before => [\&mutator]); my $n = 42; is_deeply [ $w->($n) ], [43]; # $n++ is $n, 43; # GC SKIP:{ skip 'requires Scope::Gurard for testing GC', 3 unless HAS_SCOPE_GUARD; @tags = (); for(1 .. 10){ my $gbefore = Scope::Guard->new(sub{ push @tags, 'before' }); my $garound = Scope::Guard->new(sub{ push @tags, 'around' }); my $gafter = Scope::Guard->new(sub{ push @tags, 'after' }); my $w = modify_subroutine \&foo, before => [sub{ $gbefore }], # encloses guard objects around => [sub{ $gafter }], after => [sub{ $gafter }]; } is_deeply [sort @tags], [sort((qw(after around before)) x 10)], 'closed values are released'; @tags = (); my $i = 0; for(1 .. 10){ my $gbefore = Scope::Guard->new(sub{ push @tags, 'before' }); my $garound = Scope::Guard->new(sub{ push @tags, 'around' }); my $gafter = Scope::Guard->new(sub{ push @tags, 'after' }); my $w = modify_subroutine \&foo, before => [sub{ $gbefore }], # encloses guard objects around => [sub{ $gafter }], after => [sub{ $gafter }]; $w->(Scope::Guard->new( sub{ $i++ } )); } is_deeply [sort @tags], [sort((qw(after around before)) x 10)], '... called and released'; is $i, 10, '... and the argument is also released'; } # FATAL dies_ok{ modify_subroutine(undef); }; dies_ok{ modify_subroutine(\&foo, []); }; dies_ok{ modify_subroutine(\&foo, before => [1]); }; dies_ok{ modify_subroutine(\&foo, around => [1]); }; dies_ok{ modify_subroutine(\&foo, after => [1]); }; $w = modify_subroutine(\&foo); throws_ok{ subroutine_modifier($w, 'foo'); } qr/Validation failed:.* a modifier property/; throws_ok{ subroutine_modifier($w, undef); } qr/Validation failed:.* a modifier property/; throws_ok{ subroutine_modifier($w, before => 'foo'); } qr/Validation failed:.* a CODE reference/; throws_ok{ subroutine_modifier($w, foo => sub{}); } qr/Validation failed:.* a modifier property/; throws_ok{ subroutine_modifier(\&foo, 'before'); } qr/Validation failed:.* a modified subroutine/; throws_ok{ subroutine_modifier(\&foo, before => sub{}); } qr/Validation failed:.* a modified subroutine/; 17_nsclean.t100644001750001750 101113071222366 15652 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; use Test::More tests => 10; use Test::Exception; use FindBin qw($Bin); use lib "$Bin/lib"; { package Foo; use NSClean; ::ok foo(), 'foo'; ::ok bar(), 'bar'; ::ok baz(), 'baz'; our $foo = 'a'; our @foo = 'b'; our %foo = (c => 'd'); } ok exists $Foo::{foo}, '*Foo::foo exists'; is_deeply eval q{\\$Foo::foo}, \'a'; is_deeply eval q{\\@Foo::foo}, ['b']; is_deeply eval q{\\%Foo::foo}, {c => 'd'}; is(Foo->can('foo'), undef); is(Foo->can('bar'), undef); is(Foo->can('baz'), \&Foo::baz); 18_is_value.t100644001750001750 334613071222366 16054 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; use Test::More tests => 100; use Test::Exception; use Data::Util qw(:all); use Tie::Scalar; use constant INF => 9**9**9; use constant NAN => sin(INF()); my $s; tie $s, 'Tie::StdScalar', 'magic'; foreach my $x('foo', '', 0, -100, 3.14, $s){ ok is_value($x), sprintf 'is_value(%s)', neat($x); } tie $s, 'Tie::StdScalar', \'magic'; foreach my $x(undef, [], *STDIN{IO}, *ok, $s){ ok !is_value($x), sprintf '!is_value(%s)', neat($x); } tie $s, 'Tie::StdScalar', 'magic'; foreach my $x('foo', 0, -100, 3.14, $s){ ok is_string($x), sprintf 'is_string(%s)', neat($x); } tie $s, 'Tie::StdScalar', \'magic'; foreach my $x('', undef, [], *STDIN{IO}, *ok, $s){ ok !is_string($x), sprintf '!is_string(%s)', neat($x); } tie $s, 'Tie::StdScalar', 1234; foreach my $x(0, 42, -42, 3.00, '0', '+0', '-0', ' -42', '+42 ', 2**30, $s){ ok is_integer($x), sprintf 'is_integer(%s)', neat($x); my $w; local $SIG{__WARN__} = sub{ $w = "@_" }; my $i = 0+$x; is $w, undef, 'numify-safe'; } tie $s, 'Tie::StdScalar', 'magic'; foreach my $x( undef, 3.14, '0.0', 'foo', (9**9**9), -(9**9**9), 'NaN', INF(), -INF(), NAN(), -NAN(), 1 != 1, *ok, [42], *STDIN{IO}, '0 but true', $s){ ok !is_integer($x), sprintf '!is_integer(%s)', neat($x); } tie $s, 'Tie::StdScalar', 123.456; foreach my $x(0, 1, -1, 3.14, '0', '+0', '-0', '0E0', ' 0.0', '1e-1', 2**32+0.1, $s){ ok is_number($x), sprintf 'is_number(%s)', neat($x); my $w; local $SIG{__WARN__} = sub{ $w = "@_" }; my $n = 0+$x; is $w, undef, 'numify-safe'; } tie $s, 'Tie::StdScalar', 'magic'; foreach my $x(undef, 'foo', 'Inf', '-Infinity', 'NaN', INF(), -INF(), NAN(), -NAN(), 1 != 1, '0 but true', *ok, [42], *STDIN{IO}, $s){ ok !is_number($x), sprintf '!is_number(%s)', neat($x); } 19_multiple_modifiers.t100644001750001750 314313071222366 20135 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl # this test comes from Class::Method::Modifiers use strict; use warnings; use Test::More tests => 2; use FindBin qw($Bin); use lib "$Bin/../example/lib"; my @seen; my @expected = qw/ before around-before orig around-after after /; my $child = Child->new(); $child->orig(); is_deeply(\@seen, \@expected, "multiple modifiers in one class"); @seen = (); @expected = qw/ beforer around-beforer before around-before orig around-after after around-afterer afterer /; my $childer = Childer->new(); $childer->orig(); is_deeply(\@seen, \@expected, "multiple modifiers subclassed with multiple modifiers"); BEGIN { package Parent; sub new { bless {}, shift } sub orig { push @seen, 'orig'; } } BEGIN { package Child; our @ISA = 'Parent'; use Method::Modifiers; after 'orig' => sub { push @seen, 'after'; }; around 'orig' => sub { my $orig = shift; push @seen, 'around-before'; $orig->(); push @seen, 'around-after'; }; before 'orig' => sub { push @seen, 'before'; }; } BEGIN { package Childer; our @ISA = 'Child'; use Method::Modifiers; after 'orig' => sub { push @seen, 'afterer'; }; around 'orig' => sub { my $orig = shift; push @seen, 'around-beforer'; $orig->(); push @seen, 'around-afterer'; }; before 'orig' => sub { push @seen, 'beforer'; }; } 20_lexical_sub.t100644001750001750 130213071222366 16516 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; use Test::More tests => 9; use Test::Exception; use FindBin qw($Bin); use lib "$Bin/../example/lib"; BEGIN{ package Foo; use Sub::Exporter::Lexical exports => [ qw(foo), bar => \&bar, baz => \&bar, ], ; sub foo{ 'foo' } sub bar{ 'bar' } $INC{'Foo.pm'} = __FILE__; } { use Foo; lives_ok{ is foo(), 'foo'; } 'call lexical sub'; lives_ok{ is bar(), 'bar'; } 'call lexical sub'; lives_ok{ is baz(), 'bar'; } 'call lexical sub'; } throws_ok{ isnt foo(), 'foo'; } qr/Undefined subroutine \&main::foo/; throws_ok{ isnt bar(), 'bar'; } qr/Undefined subroutine \&main::bar/; throws_ok{ isnt baz(), 'bar'; } qr/Undefined subroutine \&main::baz/;; 21_get_code_ref.t100644001750001750 300713071222366 16636 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; use Test::More tests => 26; use Test::Exception; use Data::Util qw(:all); sub stub; sub stub2; sub stub_with_attr :method; sub stub_with_proto (); use constant CONST => 42; is get_code_ref(__PACKAGE__, 'ok'), \&ok, 'get_code_ref'; is get_code_ref(__PACKAGE__, 'foobar'), undef; is ref(get_code_ref __PACKAGE__, 'stub'), 'CODE'; is ref(get_code_ref __PACKAGE__, 'stub_with_attr'), 'CODE'; is ref(get_code_ref __PACKAGE__, 'stub_with_proto'), 'CODE'; is ref(get_code_ref __PACKAGE__, 'CONST'), 'CODE'; is eval q{CONST}, 42; uninstall_subroutine __PACKAGE__, qw(stub stub2 stub_with_attr stub_with_proto); is get_code_ref(__PACKAGE__, 'stub'), undef; is get_code_ref(__PACKAGE__, 'stub2'), undef; is get_code_ref(__PACKAGE__, 'stub_with_attr'), undef; is get_code_ref(__PACKAGE__, 'stub_with_proto'), undef; is get_code_ref('FooBar', 'foo'), undef; is get_code_ref(42, 'foo'), undef; ok !exists $main::{"Nowhere::"}; ok !get_code_ref("Nowhere", "foo"); ok !exists $main::{"Nowhere::"}, 'not vivify a package'; ok !exists $main::{"nothing"}; ok !get_code_ref("main", "nothing"); ok !exists $main::{"nothing"}, 'not vivify a symbol'; ok !get_code_ref('FooBar', 'foo'); ok get_code_ref('FooBar', 'foo', -create), '-create'; ok get_code_ref('FooBar', 'foo'), '... created'; eval q{FooBar::foo()}; like $@, qr/Undefined subroutine \&FooBar::foo/, 'call a created stub'; dies_ok{ get_code_ref(); }; dies_ok{ get_code_ref undef, 'foo'; }; dies_ok{ get_code_ref __PACKAGE__, undef; }; 22_install2.t100644001750001750 127613071222366 15770 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; use Test::More tests => 8; use Test::Exception; use Data::Util qw(:all); install_subroutine(__PACKAGE__, { foo => sub{ 42 } }); lives_ok{ is __PACKAGE__->foo(), 42; }; uninstall_subroutine(__PACKAGE__, { foo => \&ok }); lives_ok{ is __PACKAGE__->foo(), 42; }; uninstall_subroutine(__PACKAGE__, { foo => undef }); throws_ok{ __PACKAGE__->foo(); } qr/Can't locate object method "foo" via package "main"/; install_subroutine(__PACKAGE__, { foo => sub{ 3.14 } }); lives_ok{ is __PACKAGE__->foo(), 3.14; }; uninstall_subroutine(__PACKAGE__, { foo => __PACKAGE__->can('foo') }); throws_ok{ __PACKAGE__->foo(); } qr/Can't locate object method "foo" via package "main"/; 23_largeargs.t100644001750001750 132613071222366 16204 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; use Test::More tests => 6; use Data::Util qw(:all); sub foo{ @_ } my @tags; sub before{ push @tags, 'before' . scalar @_; } sub around{ push @tags, 'around' . scalar @_; my $next = shift; $next->(@_) } sub after { push @tags, 'after' . scalar @_; } my $w = modify_subroutine \&foo, before => [\&before], around => [\&around], after => [\&after], ; @tags = (); is_deeply [$w->(1 .. 10)], [1 .. 10]; is_deeply \@tags, [qw(before10 around11 after10)] or diag "[@tags]"; @tags = (); is_deeply [$w->(1 .. 1000)], [1 .. 1000]; is_deeply \@tags, [qw(before1000 around1001 after1000)]; @tags = (); is_deeply [$w->(1 .. 5000)], [1 .. 5000]; is_deeply \@tags, [qw(before5000 around5001 after5000)]; 24_eval_in_modifiers.t100644001750001750 233313071222366 17713 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w # reported by nekoya package Person; use Data::Util qw/:all/; { no warnings 'redefine'; my $before = modify_subroutine( get_code_ref(__PACKAGE__, 'before_chk'), before => [ sub { eval "use Hoge" } ] ); my $after = modify_subroutine( get_code_ref(__PACKAGE__, 'after_chk'), after => [ sub { eval "use Hoge" } ] ); my $around = modify_subroutine( get_code_ref(__PACKAGE__, 'around_chk'), around => [ sub { my $orig = shift; my $self = shift; eval "use Hoge"; $self->$orig(@_); } ] ); install_subroutine(__PACKAGE__, 'before_chk' => $before); install_subroutine(__PACKAGE__, 'after_chk' => $after); install_subroutine(__PACKAGE__, 'around_chk' => $around); } sub new { bless {}, shift } sub before_chk { 'before checked' } sub after_chk { 'after checked' } sub around_chk { 'around checked' } package main; use strict; use warnings; use Test::More tests => 4; my $pp = Person->new; is $pp->before_chk, 'before checked', 'before check done'; is $pp->after_chk, 'after checked', 'after check done'; is $pp->around_chk, 'around checked', 'around check done'; ok 1, 'all tests finished'; NSClean.pm100644001750001750 70513071222366 16113 0ustar00syoheisyohei000000000000Data-Util-0.66/t/libpackage NSClean; use strict; use warnings; use Data::Util; sub import{ my $into = caller; Data::Util::install_subroutine($into, foo => sub{ 'foo' }, bar => sub{ 'bar' }, baz => sub{ 'baz' }, ); $^H = 0x020000; # HINT_LOCALIZE_HH $^H{(__PACKAGE__)} = __PACKAGE__->new(into => $into); } sub new{ my $class = shift; bless {@_}, $class; } sub DESTROY{ my($self) = @_; Data::Util::uninstall_subroutine($self->{into}, qw(foo bar)); } 1;pp00_load.t100644001750001750 31513071222366 15464 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -wT use Test::More tests => 2; BEGIN { $Data::Util::TESTING_PERL_ONLY = 1; use_ok( 'Data::Util' ); } my $backend = $Data::Util::TESTING_PERL_ONLY ? 'PurePerl' : 'XS'; is $backend, 'PurePerl'; pp01_refs.t100644001750001750 23213071222366 15503 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do "./$file"; die $@ if $@; pp02_inst.t100644001750001750 23213071222366 15522 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do "./$file"; die $@ if $@; pp03_gen.t100644001750001750 23213071222366 15317 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do "./$file"; die $@ if $@; pp04_overloaded.t100644001750001750 23213071222366 16673 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do "./$file"; die $@ if $@; pp05_get_stash.t100644001750001750 23213071222366 16531 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do "./$file"; die $@ if $@; pp06_subroutine.t100644001750001750 23213071222366 16750 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do "./$file"; die $@ if $@; pp08_mgvars.t100644001750001750 23213071222366 16052 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do "./$file"; die $@ if $@; pp10_neat.t100644001750001750 23213071222366 15473 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do "./$file"; die $@ if $@; pp11_fail_handler.t100644001750001750 23213071222366 17155 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do "./$file"; die $@ if $@; pp12_in_attr_handler.t100644001750001750 23213071222366 17703 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do "./$file"; die $@ if $@; pp13_optlist.t100644001750001750 23213071222366 16245 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do "./$file"; die $@ if $@; pp14_uninst_subr.t100644001750001750 23213071222366 17123 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do "./$file"; die $@ if $@; pp15_curry.t100644001750001750 23213071222366 15715 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do "./$file"; die $@ if $@; pp16_modify.t100644001750001750 23213071222366 16041 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do "./$file"; die $@ if $@; pp17_nsclean.t100644001750001750 23213071222366 16176 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do "./$file"; die $@ if $@; pp18_is_value.t100644001750001750 23213071222366 16363 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do "./$file"; die $@ if $@; pp19_multiple_modifiers.t100644001750001750 23213071222366 20451 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do "./$file"; die $@ if $@; pp20_lexical_sub.t100644001750001750 23213071222366 17037 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do "./$file"; die $@ if $@; pp21_get_code_ref.t100644001750001750 23213071222366 17153 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do "./$file"; die $@ if $@; pp22_install2.t100644001750001750 23213071222366 16277 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do "./$file"; die $@ if $@; pp23_largeargs.t100644001750001750 23213071222366 16517 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do "./$file"; die $@ if $@; pp24_eval_in_modifiers.t100644001750001750 23213071222366 20227 0ustar00syoheisyohei000000000000Data-Util-0.66/t#!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do "./$file"; die $@ if $@; typemap100644001750001750 23113071222366 14655 0ustar00syoheisyohei000000000000Data-Util-0.66### AV* T_AVREF HV* T_HVREF CV* T_CVREF ### INPUT T_AVREF $var = deref_av($arg); T_HVREF $var = deref_hv($arg); T_CVREF $var = deref_cv($arg); data-util.h100644001750001750 233313071222366 16554 0ustar00syoheisyohei000000000000Data-Util-0.66/xs-src/* Data-Util/data-util.h */ #include "xshelper.h" #include "mro_compat.h" #include "str_util.h" #ifndef SvRXOK #define SvRXOK(sv) ((SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVMG) && mg_find(SvRV(sv), PERL_MAGIC_qr)) ? TRUE : FALSE) #endif #define PUSHary(ary, start, len) STMT_START{ \ I32 i; \ I32 const length = (len); \ for(i = (start) ;i < length; i++){\ PUSHs(ary[i]); \ } \ } STMT_END #define XPUSHary(ary, start, len) STMT_START{ \ I32 i; \ I32 const length = (len); \ EXTEND(SP, length); \ for(i = (start) ;i < length; i++){\ PUSHs(ary[i]); \ } \ } STMT_END #define is_string(x) (SvOK(x) && !SvROK(x) && (SvPOKp(x) ? SvCUR(x) > 0 : TRUE)) #define neat(x) du_neat(aTHX_ x) const char* du_neat(pTHX_ SV* x); /* curry ingand modifiers */ /* modifier accessros */ enum{ M_BEFORE, M_AROUND, M_AFTER, M_CURRENT, M_LENGTH }; #define mg_find_by_vtbl(sv, vtbl) my_mg_find_by_vtbl(aTHX_ sv, vtbl) MAGIC* my_mg_find_by_vtbl(pTHX_ SV* const sv, const MGVTBL* const vtbl); XS(XS_Data__Util_curried); XS(XS_Data__Util_modified); misc_scalar.c100644001750001750 503613071222366 17146 0ustar00syoheisyohei000000000000Data-Util-0.66/xs-src/* neat.c */ #include "data-util.h" #define PV_LIMIT 20 static int is_identifier_cstr(const char* pv, const STRLEN len){ if(isIDFIRST(*pv)){ const char* const end = pv + len - 1 /* '\0' */; while(pv != end){ ++pv; if(!isALNUM(*pv)){ return FALSE; } } return TRUE; } return FALSE; } static void du_neat_cat(pTHX_ SV* const dsv, SV* x, const int level){ if(level > 2){ sv_catpvs(dsv, "..."); return; } if(SvRXOK(x)){ /* regex */ Perl_sv_catpvf(aTHX_ dsv, "qr{%"SVf"}", x); return; } else if(SvROK(x)){ x = SvRV(x); if(SvOBJECT(x)){ Perl_sv_catpvf(aTHX_ dsv, "%s=%s(0x%p)", sv_reftype(x, TRUE), sv_reftype(x, FALSE), x); return; } else if(SvTYPE(x) == SVt_PVAV){ I32 const len = av_len((AV*)x); sv_catpvs(dsv, "["); if(len >= 0){ SV** const svp = av_fetch((AV*)x, 0, FALSE); if(*svp){ du_neat_cat(aTHX_ dsv, *svp, level+1); } else{ sv_catpvs(dsv, "undef"); } if(len > 0){ sv_catpvs(dsv, ", ..."); } } sv_catpvs(dsv, "]"); } else if(SvTYPE(x) == SVt_PVHV){ I32 klen; char* key; SV* val; hv_iterinit((HV*)x); val = hv_iternextsv((HV*)x, &key, &klen); sv_catpvs(dsv, "{"); if(val){ if(!is_identifier_cstr(key, klen)){ SV* const sv = sv_newmortal(); key = pv_display(sv, key, klen, klen, PV_LIMIT); } Perl_sv_catpvf(aTHX_ dsv, "%s => ", key); du_neat_cat(aTHX_ dsv, val, level+1); if(hv_iternext((HV*)x)){ sv_catpvs(dsv, ", ..."); } } sv_catpvs(dsv, "}"); } else if(SvTYPE(x) == SVt_PVCV){ GV* const gv = CvGV((CV*)x); Perl_sv_catpvf(aTHX_ dsv, "\\&%s::%s(0x%p)", HvNAME(GvSTASH(gv)), GvNAME(gv), x); } else{ sv_catpvs(dsv, "\\"); du_neat_cat(aTHX_ dsv, x, level+1); } } else if(isGV(x)){ sv_catsv(dsv, x); } else if(SvOK(x)){ if(SvPOKp(x)){ STRLEN cur; char* const pv = SvPV(x, cur); /* pv_sisplay requires char*, not const char* */ SV* const sv = sv_newmortal(); pv_display(sv, pv, cur, cur, PV_LIMIT); sv_catsv(dsv, sv); } else{ NV const nv = SvNV(x); if(nv == NV_INF){ sv_catpvs(dsv, "+Inf"); } else if(nv == -NV_INF){ sv_catpvs(dsv, "-Inf"); } else if(Perl_isnan(nv)){ sv_catpvs(dsv, "NaN"); } else{ Perl_sv_catpvf(aTHX_ dsv, "%"NVgf, nv); } } } else{ sv_catpvs(dsv, "undef"); } } const char* du_neat(pTHX_ SV* x){ SV* const dsv = newSV(100); sv_2mortal(dsv); sv_setpvs(dsv, ""); ENTER; SAVETMPS; SvGETMAGIC(x); du_neat_cat(aTHX_ dsv, x, 0); FREETMPS; LEAVE; return SvPVX(dsv); } mro_compat.h100644001750001750 624013071222366 17031 0ustar00syoheisyohei000000000000Data-Util-0.66/xs-src/* ---------------------------------------------------------------------------- mro_compat.h - Provides mro functions for XS Automatically created by Devel::MRO/0.01, running under perl 5.10.0 Copyright (c) 2008, Goro Fuji . This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. ---------------------------------------------------------------------------- Usage: #include "mro_compat.h" Functions: AV* mro_get_linear_isa(HV* stash) UV mro_get_pkg_gen(HV* stash) void mro_method_changed_in(HV* stash) See "perldoc mro" for details. */ #ifndef mro_get_linear_isa #define mro_get_linear_isa(stash) my_mro_get_linear_isa(aTHX_ stash) #define mro_method_changed_in(stash) ((void)stash, (void)PL_sub_generation++) #define mro_get_pkg_gen(stash) ((void)stash, PL_sub_generation) #if defined(NEED_mro_get_linear_isa) && !defined(NEED_mro_get_linear_isa_GLOBAL) static AV* my_mro_get_linear_isa(pTHX_ HV* const stash); static #else extern AV* my_mro_get_linear_isa(pTHX_ HV* const stash); #endif /* !NEED_mro_get_linear_isa */ #if defined(NEED_mro_get_linear_isa) || defined(NEED_mro_get_linear_isa_GLOBAL) #define ISA_CACHE "::LINEALIZED_ISA_CACHE::" AV* my_mro_get_linear_isa(pTHX_ HV* const stash){ GV* const cachegv = *(GV**)hv_fetchs(stash, ISA_CACHE, TRUE); AV* isa; SV* gen; CV* get_linear_isa; if(!isGV(cachegv)) gv_init(cachegv, stash, ISA_CACHE, sizeof(ISA_CACHE)-1, TRUE); isa = GvAVn(cachegv); #ifdef GvSVn gen = GvSVn(cachegv); #else gen = GvSV(cachegv); #endif if(SvIOK(gen) && SvIVX(gen) == (IV)mro_get_pkg_gen(stash)){ return isa; /* returns the cache if available */ } else{ SvREADONLY_off(isa); av_clear(isa); } get_linear_isa = get_cv("mro::get_linear_isa", FALSE); if(!get_linear_isa){ ENTER; SAVETMPS; Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvs("MRO::Compat"), NULL, NULL); get_linear_isa = get_cv("mro::get_linear_isa", TRUE); FREETMPS; LEAVE; } { SV* avref; dSP; ENTER; SAVETMPS; PUSHMARK(SP); mXPUSHp(HvNAME(stash), strlen(HvNAME(stash))); PUTBACK; call_sv((SV*)get_linear_isa, G_SCALAR); SPAGAIN; avref = POPs; PUTBACK; if(SvROK(avref) && SvTYPE(SvRV(avref)) == SVt_PVAV){ AV* const av = (AV*)SvRV(avref); I32 const len = AvFILLp(av) + 1; I32 i; for(i = 0; i < len; i++){ HV* const stash = gv_stashsv(AvARRAY(av)[i], FALSE); if(stash) av_push(isa, newSVpv(HvNAME(stash), 0)); } SvREADONLY_on(isa); } else{ Perl_croak(aTHX_ "mro::get_linear_isa() didn't return an ARRAY reference"); } FREETMPS; LEAVE; } sv_setiv(gen, (IV)mro_get_pkg_gen(stash)); return GvAV(cachegv); } #undef ISA_CACHE #endif /* !(defined(NEED_mro_get_linear_isa) || defined(NEED_mro_get_linear_isa_GLOBAL)) */ #else /* !mro_get_linear_isa */ /* NOTE: Because ActivePerl 5.10.0 does not provide Perl_mro_meta_init(), which is used in HvMROMETA() macro, this mro_get_pkg_gen() refers to xhv_mro_meta directly. */ #ifndef mro_get_pkg_gen #define mro_get_pkg_gen(stash) (HvAUX(stash)->xhv_mro_meta ? HvAUX(stash)->xhv_mro_meta->pkg_gen : (U32)0) #endif #endif /* mro_get_linear_isa */ str_util.h100644001750001750 110613071222366 16532 0ustar00syoheisyohei000000000000Data-Util-0.66/xs-src#ifndef SCALAR_UTIL_REF_STR_UTIL_H #define SCALAR_UTIL_REF_STR_UTIL_H #ifdef INLINE_STR_EQ #undef strnEQ STATIC_INLINE int strnEQ(const char* const x, const char* const y, size_t const n){ size_t i; for(i = 0; i < n; i++){ if(x[i] != y[i]){ return FALSE; } } return TRUE; } #undef strEQ STATIC_INLINE int strEQ(const char* const x, const char* const y){ size_t i; for(i = 0; ; i++){ if(x[i] != y[i]){ return FALSE; } else if(x[i] == '\0'){ return TRUE; /* y[i] is also '\0' */ } } return TRUE; /* not reached */ } #endif /* !INLINE_STR_EQ */ #endif subs.c100644001750001750 1442713071222366 15666 0ustar00syoheisyohei000000000000Data-Util-0.66/xs-src/* Data-Util/subs.c XS code templates for curry() and modify_subroutine() */ #include "data-util.h" MGVTBL curried_vtbl; MGVTBL modified_vtbl; MAGIC* my_mg_find_by_vtbl(pTHX_ SV* const sv, const MGVTBL* const vtbl){ MAGIC* mg; for(mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic){ if(mg->mg_virtual == vtbl){ break; } } return mg; } XS(XS_Data__Util_curried){ dVAR; dXSARGS; MAGIC* const mg = (MAGIC*)XSANY.any_ptr; // mg_find_by_vtbl((SV*)cv, &curried_vtbl); assert(mg); SP -= items; /* NOTE: Curried subroutines have two properties, "params" and "phs"(placeholders). Geven a curried subr created by "curry(\&f, $x, *_, $y, \0)": params: [ $x, undef, $y, undef] phs: [undef, *_, undef, 0] Here the curried subr is called with arguments. Firstly, the arguments are set to params, expanding subscriptive placeholders, but the placeholder "*_" is set to the end of params. params: [ $x, undef, $y, $_[0], @_ ] Then, params are pushed into SP, expanding "*_". SP: [ $x, @_[1..$#_], $y, $_[0] ] Finally, params are cleand up. params: [ $x, undef, $y, undef ] */ { AV* const params = (AV*)mg->mg_obj; SV** params_ary = AvARRAY(params); I32 const len = AvFILLp(params) + 1; AV* const phs = (AV*)mg->mg_ptr; /* placeholders */ SV**const phs_ary = AvARRAY(phs); I32 max_ph = -1; /* max placeholder index */ I32 min_ph = items; /* min placeholder index */ SV** sph = NULL; // indicates *_ U16 const is_method = mg->mg_private; /* G_METHOD */ I32 push_size = len - 1; /* -1: proc */ register I32 i; SV* proc; /* fill in params */ for(i = 0; i < len; i++){ SV* const ph = phs_ary[i]; if (!ph){ continue; } if(isGV(ph)){ /* symbolic placeholder *_ */ if(!sph){ I32 j; if(AvMAX(params) < (len + items)){ av_extend(params, len + items); params_ary = AvARRAY(params); /* maybe realloc()-ed */ } /* All the arguments @_ is pushed into the end of params, not calling SvREFCNT_inc(). */ sph = ¶ms_ary[len]; for(j = 0; j < items; j++){ /* NOTE: no need to SvREFCNT_inc(ST(j)), * bacause AvFILLp(params) remains len-1. * That's okey. */ sph[j] = ST(j); } } push_size += items; } else if(SvIOKp(ph)){ /* subscriptive placeholders */ IV p = SvIVX(ph); if(p >= 0){ if(p > max_ph) max_ph = p; } else{ /* negative index */ p += items; if(p < 0){ Perl_croak(aTHX_ PL_no_aelem, (int)p); } if(p < min_ph) min_ph = p; } if(p <= items){ /* NOTE: no need to SvREFCNT_inc(params_ary[i]), * because it removed from params_ary before call_sv() */ params_ary[i] = ST(p); } } } PUSHMARK(SP); EXTEND(SP, push_size); if(is_method){ PUSHs( params_ary[0] ); /* invocant */ proc = params_ary[1]; /* method */ i = 2; } else{ proc = params_ary[0]; /* code ref */ i = 1; } for(/* i is initialized above */; i < len; i++){ if(phs_ary[i] && isGV(phs_ary[i])){ /* warn("#sph %d - %d", (int)max_ph+1, (int)min_ph); //*/ PUSHary(sph, max_ph + 1, min_ph); } else{ PUSHs(params_ary[i]); } } PUTBACK; /* NOTE: need to clean up params before call_sv(), because call_sv() might die */ for(i = 0; i < len; i++){ if(phs_ary[i] && SvIOKp(phs_ary[i])){ /* NOTE: no need to SvREFCNT_dec(params_ary[i]) */ params_ary[i] = &PL_sv_undef; } } /* G_EVAL to workaround RT #69939 */ call_sv(proc, GIMME_V | is_method | G_EVAL); if(SvTRUEx(ERRSV)){ croak(NULL); /* rethrow */ } } } /* call an av of cv with args_ary */ static void my_call_av(pTHX_ AV* const subs, SV** const args_ary, I32 const args_len){ I32 const subs_len = AvFILLp(subs) + 1; I32 i; for(i = 0; i < subs_len; i++){ dSP; PUSHMARK(SP); XPUSHary(args_ary, 0, args_len); PUTBACK; /* G_EVAL to workaround RT #69939 */ call_sv(AvARRAY(subs)[i], G_VOID | G_DISCARD | G_EVAL); if(SvTRUEx(ERRSV)){ croak(NULL); } } } XS(XS_Data__Util_modified){ dVAR; dXSARGS; MAGIC* const mg = (MAGIC*)XSANY.any_ptr; // mg_find_by_vtbl((SV*)cv, &modified_vtbl); assert(mg); SP -= items; { AV* const subs_av = (AV*)mg->mg_obj; AV* const before = (AV*)AvARRAY(subs_av)[M_BEFORE]; SV* const current = (SV*)AvARRAY(subs_av)[M_CURRENT]; AV* const after = (AV*)AvARRAY(subs_av)[M_AFTER]; I32 i; dXSTARG; AV* const args = (AV*)TARG; SV** args_ary; (void)SvUPGRADE(TARG, SVt_PVAV); if(AvMAX(args) < items){ av_extend(args, items); } args_ary = AvARRAY(args); for(i = 0; i < items; i++){ args_ary[i] = ST(i); /* no need to SvREFCNT_inc() */ } PUTBACK; my_call_av(aTHX_ before, args_ary, items); SPAGAIN; PUSHMARK(SP); XPUSHary(args_ary, 0, items); PUTBACK; call_sv(current, GIMME_V); my_call_av(aTHX_ after, args_ary, items); } /* no need to XSRETURN(n) */ } 01_pod.t100644001750001750 21413071222366 15156 0ustar00syoheisyohei000000000000Data-Util-0.66/xt#!perl -w use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); 02_pod-coverage.t100644001750001750 62013071222366 16751 0ustar00syoheisyohei000000000000Data-Util-0.66/xt#!perl -w use Test::More; eval "use Test::Pod::Coverage 1.04"; plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; local $SIG{__WARN__} = sub{ 1 }; # not to concern about 'redefine' warnings for my $module (all_modules()) { next if $module =~ m/PurePerl$/; pod_coverage_ok($module, { also_private => [qw(unimport regex_ref is_regex_ref)], }); } done_testing; 03_synopsis.t100644001750001750 22313071222366 16265 0ustar00syoheisyohei000000000000Data-Util-0.66/xt#!perl -w use strict; use Test::More; eval q{use Test::Synopsis}; plan skip_all => 'Test::Synopsis required for testing' if $@; all_synopsis_ok(); 07_threads.t100644001750001750 260613071222366 16063 0ustar00syoheisyohei000000000000Data-Util-0.66/xt#!perl -w use strict; use constant HAS_THREADS => eval{ require threads }; use Test::More; BEGIN{ if($INC{'Devel/Cover.pm'}){ plan skip_all => '(under -d:Cover)'; } if(HAS_THREADS){ plan tests => 17; } else{ plan skip_all => 'requires threads'; } } use threads; use threads 'yield'; use threads::shared; use Data::Util qw(:all); BEGIN{ package Foo; sub new{ bless {} => shift; } package Bar; our @ISA = qw(Foo); package Baz; sub new{ bless [] => shift; } } { ok is_instance(Foo->new, 'Foo'), 'in the main thread'; ok is_instance(Bar->new, 'Foo'); ok !is_instance(Baz->new, 'Foo'); } my $thr1 = async{ yield; ok is_instance(Foo->new, 'Foo'), 'in a thread (1)'; yield; ok is_instance(Bar->new, 'Foo'); yield; ok !is_instance(Baz->new, 'Foo'); eval{ instance(Foo->new, 'Bar'); }; like $@, qr/Validation failed/; return 1; }; my $thr2 = async{ yield; ok is_instance(Foo->new, 'Foo'), 'in a thread (2)'; yield; ok is_instance(Bar->new, 'Foo'); yield; ok !is_instance(Baz->new, 'Foo'); eval{ instance(Foo->new, 'Bar'); }; like $@, qr/Validation failed/; return 1; }; { ok is_instance(Foo->new, 'Foo'), 'in the main thread'; ok is_instance(Bar->new, 'Foo'); ok !is_instance(Baz->new, 'Foo'); eval { instance(Foo->new, 'Bar'); }; like $@, qr/Validation failed/; } ok $thr2->join(), 'join a thread (2)'; ok $thr1->join(), 'join a thread (1)'; pp07_threads.t100644001750001750 23213071222366 16374 0ustar00syoheisyohei000000000000Data-Util-0.66/xt#!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do "./$file"; die $@ if $@; META.yml100644001750001750 266113071222366 14555 0ustar00syoheisyohei000000000000Data-Util-0.66--- abstract: 'A selection of utilities for data and data types' author: - 'Goro Fuji(gfx) .' build_requires: Devel::PPPort: '3.19' ExtUtils::MakeMaker: '6.59' ExtUtils::ParseXS: '3.18' Hash::Util::FieldHash::Compat: '0' Scope::Guard: '0' Test::Exception: '0.27' Test::More: '0.62' configure_requires: Module::Build: '0.4005' Module::Build::XSUtil: '0.03' dynamic_config: 0 generated_by: 'Minilla/v3.0.10, 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: Data-Util no_index: directory: - t - xt - inc - share - eg - examples - author - builder provides: Data::Util: file: lib/Data/Util.pm version: '0.66' Data::Util::Error: file: lib/Data/Util/Error.pm Data::Util::PurePerl: file: lib/Data/Util/PurePerl.pm requires: XSLoader: '0.02' perl: '5.010' resources: bugtracker: https://github.com/gfx/Perl-Data-Util/issues homepage: https://github.com/gfx/Perl-Data-Util repository: git://github.com/gfx/Perl-Data-Util.git version: '0.66' x_contributors: - 'Fuji Goro ' - 'Fuji, Goro ' - 'Tokuhiro Matsuno ' - 'Fuji, Goro (gfx) ' - 'Patrice Clement ' - 'Syohei YOSHIDA ' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' MANIFEST100644001750001750 343113071222366 14431 0ustar00syoheisyohei000000000000Data-Util-0.66Build.PL Changes LICENSE META.json README.md benchmark/Common.pm benchmark/curry_bench.pl benchmark/export_bench.pl benchmark/gen_bench.pl benchmark/get_code_ref_bench.pl benchmark/get_stash_bench.pl benchmark/install_subr_bench.pl benchmark/instance_bench.pl benchmark/invocant_bench.pl benchmark/methext_bench.pl benchmark/mkopt_bench.pl benchmark/modifier_bench.pl benchmark/modify_bench.pl benchmark/number_bench.pl benchmark/ref_bench.pl circle.yml cpanfile example/curry.pl example/export_lexical.pl example/lib/Method/Modifiers.pm example/lib/Sub/Exporter/Lexical.pm example/modifier.pl example/neat.pl example/synopsis.pl lib/Data/Util.pm lib/Data/Util.xs lib/Data/Util/Curry.pod lib/Data/Util/Error.pm lib/Data/Util/JA.pod lib/Data/Util/PurePerl.pm minil.toml t/00_load.t t/01_refs.t t/02_inst.t t/03_gen.t t/04_overloaded.t t/05_get_stash.t t/06_subroutine.t t/08_mgvars.t t/09_paranoia.t t/10_neat.t t/11_fail_handler.t t/12_in_attr_handler.t t/13_optlist.t t/14_uninst_subr.t t/15_curry.t t/16_modify.t t/17_nsclean.t t/18_is_value.t t/19_multiple_modifiers.t t/20_lexical_sub.t t/21_get_code_ref.t t/22_install2.t t/23_largeargs.t t/24_eval_in_modifiers.t t/lib/NSClean.pm t/pp00_load.t t/pp01_refs.t t/pp02_inst.t t/pp03_gen.t t/pp04_overloaded.t t/pp05_get_stash.t t/pp06_subroutine.t t/pp08_mgvars.t t/pp10_neat.t t/pp11_fail_handler.t t/pp12_in_attr_handler.t t/pp13_optlist.t t/pp14_uninst_subr.t t/pp15_curry.t t/pp16_modify.t t/pp17_nsclean.t t/pp18_is_value.t t/pp19_multiple_modifiers.t t/pp20_lexical_sub.t t/pp21_get_code_ref.t t/pp22_install2.t t/pp23_largeargs.t t/pp24_eval_in_modifiers.t typemap xs-src/data-util.h xs-src/misc_scalar.c xs-src/mro_compat.h xs-src/str_util.h xs-src/subs.c xt/01_pod.t xt/02_pod-coverage.t xt/03_synopsis.t xt/07_threads.t xt/pp07_threads.t META.yml MANIFEST