Class-InsideOut-1.14/000755 000765 000024 00000000000 13070235143 014635 5ustar00davidstaff000000 000000 Class-InsideOut-1.14/Changes000644 000765 000024 00000020100 13070235143 016121 0ustar00davidstaff000000 000000 Revision history for Perl module Class::InsideOut 1.14 2017-04-02 13:52:18-04:00 America/New_York Fixed: - Passes tests when '.' is not in @INC. 1.13 2013-04-25 13:59:42 America/New_York Added: - allow set_hook and get_hook to be blessed or overloaded objects 1.12 2013-04-24 21:02:39 America/New_York Docs: - Typos fixed Other: - Issue tracker is now GitHub 1.11 2013-01-23 21:33:13 America/New_York Bug fixes: - fixed tests for recent, XS-only Scalar::Util Other: - converted distribution management to Dist::Zilla 1.10 Mon Aug 24 20:44:46 EDT 2009 Bug fixes: - changed method of calling Exporter::import() to avoid confusing DProf - fixed detection of missing 'weaken' function in newer Scalar::Util (fixes test t/15_no_weaken_fallback.t) (RT#47623) Other: - cleanup: eliminate test warning from bogus superclass in a test class - docs: Noted that set_hooks aren't called by new() (RT#48106) 1.09 Fri Jan 4 18:42:41 EST 2008 - bugfix: allow use of upper or mixed case property accessors (David Schmitt) - testfix: tests will now pass on Perl 5.005 -- though 5.005 is not recommended due to the lack of weak references - pod: added a note about using "our" instead of "my" for properties - critic: various cleanups to about Perl::Critic level 5 - moved author tests to xt directory for CPANTS compatibility 1.08 Thu Aug 23 07:12:33 EDT 2007 - STORABLE_attach warns instead of dying if it can't provide a singleton back to Storable, leaving Storable to croak instead; on 5.6.2 (and possibly older Perls), this change works around Storable dying during cleanup if STORABLE_attach dies inside an eval() - thread tests skip on perl < 5.8.5 due to unexplained thread failures; perl585delta alludes to thread fixes when weak references are in use and this may be related - removed "use warnings" from singleton test files for back compatibility - moved pod/coverage tests to t_extra/ and stopped depending on an environment variable to allow them to run - changed to the Apache License, version 2.0; (it's clearer, relicensable, and is explicit about contributions) 1.07 Fri Aug 10 07:41:00 EDT 2007 - fixes for using ":storable" with older versions of Exporter that required tags to come first. Now we just strip it during import. 1.06 Mon Feb 12 19:34:59 EST 2007 - all tests involving Storable now skip if Storable isn't installed (instead of only a few) (David Cantrell) 1.05 Sun Feb 11 16:29:16 EST 2007 - fixed optional new method with hash reference (RT#24839) 1.04 Thu Jan 18 21:47:19 EST 2007 - added 'readonly' accessor-creator 1.0301 Wed Nov 15 06:08:47 EST 2006 - removing email address for bug reports to (hopefully) cut down on RT ticket spam 1.03 Wed Oct 11 10:55:28 EDT 2006 - thread tests skip if thread creation fails - added an examples directory with a reference to some of the objects used in testing 1.02 Tue Aug 15 09:26:11 EDT 2006 - fixed duplicate property name checking (RT#20997) 1.01 Thu Jul 27 12:30:54 EDT 2006 - register() now handles standard cases with "sufficiently advanced technology" and does the right thing - optional simple "new" constructor added - changed "foreign" inheritance to "black-box" inheritance in Pod 1.00 Fri May 12 21:25:34 EDT 2006 - removed Data::Dump::Streamer support attempts until RT#19060 can be addressed 0.90_02 Thu May 4 00:56:04 EDT 2006 - fixed up META.yml and a pod typo 0.90_01 Wed May 3 20:47:34 EDT 2006 - *API CHANGE* renamed serialization hooks to FREEZE and THAW - added support for STORABLE_attach for singletons - improved test coverage - refactored some of the test classes - refactored STORABLE_* code - refactored documentation - added draft (non-working) support for serialization with Data::Dump::Streamer 0.14 Thu Mar 16 23:07:22 EST 2006 - Fixed test bug where thread test wouldn't properly skip for Win32 Perl 5.6 (with ithreads enabled for pseudofork but no threads.pm) - Improved handling of "die" in set_hook and get_hook callbacks 0.13 Fri Mar 10 10:32:08 EST 2006 - Test for Scalar::Util::weaken fallback had a bug that would fail on Perl versions prior to 5.6. Fixed to be fully backwards compatible. 0.12 Wed Mar 8 21:58:58 EST 2006 - Added workaround for unavailable Scalar::Util::weaken; gives warning about not running thread-safe; added missing weaken skips to thread/fork test files - property/public/private arguments are now validated. Property names must be identifiers; Property options must be given as hash references; Duplicate property names are not permitted. - options argument checked for proper format; option values are checked for validity - register argument checked for blessed reference - added optional pod/pod_coverage tests (skipped by default) 0.11 Sat Jan 28 11:09:50 EST 2006 - tweaked Build.PL; dropped Test::More dependency to 0.45 to help pass ActiveState automated tests (0.45 first to offer thread safety and in the 5.008 core); fixed copy/paste error for cleanup - documentation cleanup; fixed links; restructured Pod for options; softened alpha warnings as we get closer to a stable API 0.10 Fri Jan 27 01:41:38 EST 2006 - added "set_hook" and "get_hook" option for custom accessor/mutator manipulations - added ":all" and ":std" tags - cleaned up or reorganized documentation in places; revised synopsis to be shorter 0.09 Fri Jan 20 14:55:14 EST 2006 - added basic accessor generation as an option for property declarations; added aliases "public" and "private" as shortcuts to property options - added per-class default options for properties - added support for user-written freeze and thaw hooks - documentation updates: typo safety requires strict (Steven Lembark); caching refaddr() to minimize overhead; new features documented 0.08 Wed Jan 18 10:50:13 EST 2006 - BACKWARDS INCOMPATIBLE CHANGE: property definitions now require a label in addition to the property hash - Class::ISA results are now cached when first used; also minor optimization of reftype switching in STORABLE_* methods (Adam Kennedy) - foreign inheritance test now checks for IO::File or skips - documentation cleanup and trailing whitespace removal (Ron Savage) 0.07 Mon Jan 9 09:48:46 EST 2006 - Storable support tested with references, grouped references and circular references; references external to the freeze are cloned - documentation cleanup 0.06 Sun Jan 8 23:07:22 EST 2006 - DESTROY cleans up all Class::InsideOut properties in the @ISA tree; updated documentation on object destruction for clarity; fixes diamond-pattern inheritance memory leaks without requiring a DEMOLISH method - added first-draft support of serialization with Storable for objects based on scalars, arrays and hashes; tested on data values only; not yet tested on values with references or objects, particularly circular reference chains - CLONE no longer exported; all refaddr index cleanup handled globally in Class::InsideOut::CLONE rather than in class-specific methods 0.05 Fri Jan 6 09:07:07 EST 2006 - added caveats on usage and current limitations - more documentation tweaks 0.04 Thu Jan 5 21:44:30 EST 2006 - major documentation update 0.03 Thu Jan 5 18:41:05 EST 2006 - thread test no longer dies if threads are not configured - added DEMOLISH support for custom destruction actions - added id() as optional alias for refaddr - documentation tweaks 0.02 Thu Jan 5 00:51:01 EST 2006 - basic property and object registration with automatic CLONE and DESTROY 0.01 Wed Jan 4 12:06:51 EST 2006 - placeholder Class-InsideOut-1.14/CONTRIBUTING.mkdn000644 000765 000024 00000006604 13070235143 017425 0ustar00davidstaff000000 000000 ## HOW TO CONTRIBUTE Thank you for considering contributing to this distribution. This file contains instructions that will help you work with the source code. The distribution is managed with Dist::Zilla. This means that many of the usual files you might expect are not in the repository, but are generated at release time, as is much of the documentation. Some generated files are kept in the repository as a convenience (e.g. Makefile.PL or cpanfile). Generally, **you do not need Dist::Zilla to contribute patches**. You do need Dist::Zilla to create a tarball. See below for guidance. ### Getting dependencies If you have App::cpanminus 1.6 or later installed, you can use `cpanm` to satisfy dependencies like this: $ cpanm --installdeps . Otherwise, look for either a `Makefile.PL` or `cpanfile` file for a list of dependencies to satisfy. ### Running tests You can run tests directly using the `prove` tool: $ prove -l $ prove -lv t/some_test_file.t For most of my distributions, `prove` is entirely sufficient for you to test any patches you have. I use `prove` for 99% of my testing during development. ### Code style and tidying Please try to match any existing coding style. If there is a `.perltidyrc` file, please install Perl::Tidy and use perltidy before submitting patches. If there is a `tidyall.ini` file, you can also install Code::TidyAll and run `tidyall` on a file or `tidyall -a` to tidy all files. ### Patching documentation Much of the documentation Pod is generated at release time. Some is generated boilerplate; other documentation is built from pseudo-POD directives in the source like C<=method> or C<=func>. If you would like to submit a documentation edit, please limit yourself to the documentation you see. If you see typos or documentation issues in the generated docs, please email or open a bug ticket instead of patching. ### Where to send patches and pull requests If you found this distribution on Github, sending a pull-request is the best way to contribute. If a pull-request isn't possible, a bug ticket with a patch file is the next best option. As a last resort, an email to the author(s) is acceptable. ## Installing and using Dist::Zilla Dist::Zilla is not required for contributing, but if you'd like to learn more, this section will get you up to speed. Dist::Zilla is a very powerful authoring tool, optimized for maintaining a large number of distributions with a high degree of automation, but it has a large dependency chain, a bit of a learning curve and requires a number of author-specific plugins. To install it from CPAN, I recommend one of the following approaches for the quickest installation: # using CPAN.pm, but bypassing non-functional pod tests $ cpan TAP::Harness::Restricted $ PERL_MM_USE_DEFAULT=1 HARNESS_CLASS=TAP::Harness::Restricted cpan Dist::Zilla # using cpanm, bypassing *all* tests $ cpanm -n Dist::Zilla In either case, it's probably going to take about 10 minutes. Go for a walk, go get a cup of your favorite beverage, take a bathroom break, or whatever. When you get back, Dist::Zilla should be ready for you. Then you need to install any plugins specific to this distribution: $ cpan `dzil authordeps` $ dzil authordeps | cpanm Once installed, here are some dzil commands you might try: $ dzil build $ dzil test $ dzil xtest You can learn more about Dist::Zilla at http://dzil.org/ Class-InsideOut-1.14/cpanfile000644 000765 000024 00000003226 13070235143 016344 0ustar00davidstaff000000 000000 requires "Carp" => "0"; requires "Class::ISA" => "0"; requires "Exporter" => "0"; requires "Scalar::Util" => "1.09"; requires "Storable" => "0"; requires "overload" => "0"; requires "perl" => "5.008"; requires "strict" => "0"; requires "vars" => "0"; on 'test' => sub { requires "DynaLoader" => "0"; requires "ExtUtils::MakeMaker" => "0"; requires "File::Spec" => "0"; requires "IO::File" => "0"; requires "Test::More" => "0.45"; requires "XSLoader" => "0"; requires "lib" => "0"; requires "perl" => "5.008"; requires "threads" => "0"; requires "warnings" => "0"; }; on 'test' => sub { recommends "CPAN::Meta" => "2.120900"; }; on 'configure' => sub { requires "ExtUtils::MakeMaker" => "6.17"; requires "perl" => "5.006"; }; on 'develop' => sub { requires "Dist::Zilla" => "5"; requires "Dist::Zilla::Plugin::ReleaseStatus::FromVersion" => "0"; requires "Dist::Zilla::Plugin::RemovePrereqs" => "0"; requires "Dist::Zilla::PluginBundle::DAGOLDEN" => "0.072"; requires "English" => "0"; requires "File::Spec" => "0"; requires "File::Temp" => "0"; requires "IO::Handle" => "0"; requires "IPC::Open3" => "0"; requires "Pod::Coverage::TrustPod" => "0"; requires "Pod::Wordlist" => "0"; requires "Software::License::Apache_2_0" => "0"; requires "Test::CPAN::Meta" => "0"; requires "Test::MinimumVersion" => "0"; requires "Test::More" => "0"; requires "Test::Pod" => "1.41"; requires "Test::Pod::Coverage" => "1.08"; requires "Test::Portability::Files" => "0"; requires "Test::Spelling" => "0.12"; requires "Test::Version" => "1"; requires "blib" => "1.01"; requires "perl" => "5.006"; requires "warnings" => "0"; }; Class-InsideOut-1.14/dist.ini000644 000765 000024 00000001124 13070235143 016277 0ustar00davidstaff000000 000000 name = Class-InsideOut author = David Golden license = Apache_2_0 copyright_holder = David A. Golden copyright_year = 2006 [@DAGOLDEN] :version = 0.072 stopwords = Etheridge stopwords = Inkster stopwords = Perlmonks stopwords = ROADMAP stopwords = Subclasses stopwords = accessable stopwords = dclone stopwords = demerphq stopwords = deregistered stopwords = destructor stopwords = initializers stopwords = jdhedden stopwords = readonly stopwords = rethrown stopwords = xdg [ReleaseStatus::FromVersion] testing = second_decimal_odd [RemovePrereqs] remove = Types::Standard Class-InsideOut-1.14/examples/000755 000765 000024 00000000000 13070235143 016453 5ustar00davidstaff000000 000000 Class-InsideOut-1.14/lib/000755 000765 000024 00000000000 13070235143 015403 5ustar00davidstaff000000 000000 Class-InsideOut-1.14/LICENSE000644 000765 000024 00000026357 13070235143 015657 0ustar00davidstaff000000 000000 This software is Copyright (c) 2006 by David A. Golden. This is free software, licensed under: The Apache License, Version 2.0, January 2004 Apache License Version 2.0, January 2004 http://www.apache.org/licenses/ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 1. Definitions. "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and (b) You must cause any modified files to carry prominent notices stating that You changed the files; and (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and (d) If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. END OF TERMS AND CONDITIONS APPENDIX: How to apply the Apache License to your work. To apply the Apache License to your work, attach the following boilerplate notice, with the fields enclosed by brackets "[]" replaced with your own identifying information. (Don't include the brackets!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a file or class name and description of purpose be included on the same "printed page" as the copyright notice for easier identification within third-party archives. Copyright [yyyy] [name of copyright owner] Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. Class-InsideOut-1.14/Makefile.PL000644 000765 000024 00000003236 13070235143 016613 0ustar00davidstaff000000 000000 # This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.009. use strict; use warnings; use 5.008; use ExtUtils::MakeMaker 6.17; my %WriteMakefileArgs = ( "ABSTRACT" => "a safe, simple inside-out object construction kit", "AUTHOR" => "David Golden ", "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => "6.17" }, "DISTNAME" => "Class-InsideOut", "LICENSE" => "apache", "MIN_PERL_VERSION" => "5.008", "NAME" => "Class::InsideOut", "PREREQ_PM" => { "Carp" => 0, "Class::ISA" => 0, "Exporter" => 0, "Scalar::Util" => "1.09", "Storable" => 0, "overload" => 0, "strict" => 0, "vars" => 0 }, "TEST_REQUIRES" => { "DynaLoader" => 0, "ExtUtils::MakeMaker" => 0, "File::Spec" => 0, "IO::File" => 0, "Test::More" => "0.45", "XSLoader" => 0, "lib" => 0, "threads" => 0, "warnings" => 0 }, "VERSION" => "1.14", "test" => { "TESTS" => "t/*.t" } ); my %FallbackPrereqs = ( "Carp" => 0, "Class::ISA" => 0, "DynaLoader" => 0, "Exporter" => 0, "ExtUtils::MakeMaker" => 0, "File::Spec" => 0, "IO::File" => 0, "Scalar::Util" => "1.09", "Storable" => 0, "Test::More" => "0.45", "XSLoader" => 0, "lib" => 0, "overload" => 0, "strict" => 0, "threads" => 0, "vars" => 0, "warnings" => 0 ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { delete $WriteMakefileArgs{TEST_REQUIRES}; delete $WriteMakefileArgs{BUILD_REQUIRES}; $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; WriteMakefile(%WriteMakefileArgs); Class-InsideOut-1.14/MANIFEST000644 000765 000024 00000003262 13070235143 015771 0ustar00davidstaff000000 000000 # This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.009. CONTRIBUTING.mkdn Changes LICENSE MANIFEST META.json META.yml Makefile.PL README Todo cpanfile dist.ini examples/README lib/Class/InsideOut.pm lib/Class/InsideOut/Manual/About.pod lib/Class/InsideOut/Manual/Advanced.pod perlcritic.rc t/00-report-prereqs.dd t/00-report-prereqs.t t/01_load.t t/02_register.t t/03_properties.t t/04_threaded.t t/05_forking.t t/06_export_ok.t t/07_synopsis_obj.t t/08_DEMOLISH.t t/09_foreign.t t/10_storable_values.t t/11_storable_refs.t t/12_storable_hooks.t t/13_options.t t/14_accessor_hooks.t t/15_no_weaken_fallback.t t/16_property_argument_checking.t t/17_option_argument_checking.t t/18_register_argument_checking.t t/19_storable_singleton.t t/20_storable_singleton_error.t t/21_optional_new.t t/22_readonly.t t/23_accessor_hooks_blessed.t t/24_accessor_hooks_overloaded.t t/25_accessor_hooks_typetiny.t t/Object/Animal.pm t/Object/Animal/Antelope.pm t/Object/Animal/JackRabbit.pm t/Object/Animal/Jackalope.pm t/Object/Array.pm t/Object/Foreign.pm t/Object/Friends.pm t/Object/Hash.pm t/Object/Hooked.pm t/Object/HookedBlessed.pm t/Object/HookedOverloaded.pm t/Object/HookedTT.pm t/Object/ReadOnly.pm t/Object/RegisterClassname.pm t/Object/RegisterRef.pm t/Object/Scalar.pm t/Object/Singleton/Hooked.pm t/Object/Singleton/MissingConstructor.pm t/Object/Singleton/Simple.pm t/Object/Synopsis.pm t/Object/Trivial.pm t/Object/WithNew.pm t/Object/WithNew/Inherited.pm t/data/testdata.txt xt/author/00-compile.t xt/author/critic.t xt/author/pod-coverage.t xt/author/pod-spell.t xt/author/pod-syntax.t xt/author/portability.t xt/author/test-version.t xt/release/distmeta.t xt/release/minimum-version.t Class-InsideOut-1.14/META.json000644 000765 000024 00000006334 13070235143 016264 0ustar00davidstaff000000 000000 { "abstract" : "a safe, simple inside-out object construction kit", "author" : [ "David Golden " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.009, CPAN::Meta::Converter version 2.150010", "license" : [ "apache_2_0" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Class-InsideOut", "no_index" : { "directory" : [ "corpus", "examples", "t", "xt" ], "package" : [ "DB" ] }, "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.17", "perl" : "5.006" } }, "develop" : { "requires" : { "Dist::Zilla" : "5", "Dist::Zilla::Plugin::ReleaseStatus::FromVersion" : "0", "Dist::Zilla::Plugin::RemovePrereqs" : "0", "Dist::Zilla::PluginBundle::DAGOLDEN" : "0.072", "English" : "0", "File::Spec" : "0", "File::Temp" : "0", "IO::Handle" : "0", "IPC::Open3" : "0", "Pod::Coverage::TrustPod" : "0", "Pod::Wordlist" : "0", "Software::License::Apache_2_0" : "0", "Test::CPAN::Meta" : "0", "Test::MinimumVersion" : "0", "Test::More" : "0", "Test::Pod" : "1.41", "Test::Pod::Coverage" : "1.08", "Test::Portability::Files" : "0", "Test::Spelling" : "0.12", "Test::Version" : "1", "blib" : "1.01", "perl" : "5.006", "warnings" : "0" } }, "runtime" : { "requires" : { "Carp" : "0", "Class::ISA" : "0", "Exporter" : "0", "Scalar::Util" : "1.09", "Storable" : "0", "overload" : "0", "perl" : "5.008", "strict" : "0", "vars" : "0" } }, "test" : { "recommends" : { "CPAN::Meta" : "2.120900" }, "requires" : { "DynaLoader" : "0", "ExtUtils::MakeMaker" : "0", "File::Spec" : "0", "IO::File" : "0", "Test::More" : "0.45", "XSLoader" : "0", "lib" : "0", "perl" : "5.008", "threads" : "0", "warnings" : "0" } } }, "provides" : { "Class::InsideOut" : { "file" : "lib/Class/InsideOut.pm", "version" : "1.14" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/dagolden/class-insideout/issues" }, "homepage" : "https://github.com/dagolden/class-insideout", "repository" : { "type" : "git", "url" : "https://github.com/dagolden/class-insideout.git", "web" : "https://github.com/dagolden/class-insideout" } }, "version" : "1.14", "x_authority" : "cpan:DAGOLDEN", "x_contributors" : [ "Karen Etheridge ", "Toby Inkster " ], "x_serialization_backend" : "Cpanel::JSON::XS version 3.0225" } Class-InsideOut-1.14/META.yml000644 000765 000024 00000002427 13070235143 016113 0ustar00davidstaff000000 000000 --- abstract: 'a safe, simple inside-out object construction kit' author: - 'David Golden ' build_requires: DynaLoader: '0' ExtUtils::MakeMaker: '0' File::Spec: '0' IO::File: '0' Test::More: '0.45' XSLoader: '0' lib: '0' perl: '5.008' threads: '0' warnings: '0' configure_requires: ExtUtils::MakeMaker: '6.17' perl: '5.006' dynamic_config: 0 generated_by: 'Dist::Zilla version 6.009, CPAN::Meta::Converter version 2.150010' license: apache meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Class-InsideOut no_index: directory: - corpus - examples - t - xt package: - DB provides: Class::InsideOut: file: lib/Class/InsideOut.pm version: '1.14' requires: Carp: '0' Class::ISA: '0' Exporter: '0' Scalar::Util: '1.09' Storable: '0' overload: '0' perl: '5.008' strict: '0' vars: '0' resources: bugtracker: https://github.com/dagolden/class-insideout/issues homepage: https://github.com/dagolden/class-insideout repository: https://github.com/dagolden/class-insideout.git version: '1.14' x_authority: cpan:DAGOLDEN x_contributors: - 'Karen Etheridge ' - 'Toby Inkster ' x_serialization_backend: 'YAML::Tiny version 1.69' Class-InsideOut-1.14/perlcritic.rc000644 000765 000024 00000001166 13070235143 017327 0ustar00davidstaff000000 000000 severity = 5 verbose = 8 [Variables::ProhibitPunctuationVars] allow = $@ $! [TestingAndDebugging::ProhibitNoStrict] allow = refs [Variables::ProhibitEvilVariables] variables = $DB::single # Turn these off [-BuiltinFunctions::ProhibitStringyEval] [-ControlStructures::ProhibitPostfixControls] [-ControlStructures::ProhibitUnlessBlocks] [-Documentation::RequirePodSections] [-InputOutput::ProhibitInteractiveTest] [-References::ProhibitDoubleSigils] [-RegularExpressions::RequireExtendedFormatting] [-InputOutput::ProhibitTwoArgOpen] [-Modules::ProhibitEvilModules] # Turn this on [Lax::ProhibitStringyEval::ExceptForRequire] Class-InsideOut-1.14/README000644 000765 000024 00000036216 13070235143 015525 0ustar00davidstaff000000 000000 NAME Class::InsideOut - a safe, simple inside-out object construction kit VERSION version 1.14 SYNOPSIS package My::Class; use Class::InsideOut qw( public readonly private register id ); public name => my %name; # accessor: name() readonly ssn => my %ssn; # read-only accessor: ssn() private age => my %age; # no accessor sub new { register( shift ) } sub greeting { my $self = shift; return "Hello, my name is $name{ id $self }"; } DESCRIPTION This is a simple, safe and streamlined toolkit for building inside-out objects. Unlike most other inside-out object building modules already on CPAN, this module aims for minimalism and robustness: * Does not require derived classes to subclass it * Uses no source filters, attributes or "CHECK" blocks * Supports any underlying object type including black-box inheritance * Does not leak memory on object destruction * Overloading-safe * Thread-safe for Perl 5.8.5 or better * "mod_perl" compatible * Makes no assumption about inheritance or initializer needs It provides the minimal support necessary for creating safe inside-out objects and generating flexible accessors. Additional documentation * Class::InsideOut::Manual::About -- Guide to the inside-out technique, the "Class::InsideOut" philosophy, and other inside-out implementations * Class::InsideOut::Manual::Advanced -- Advanced topics including customizing accessors, black-box inheritance, serialization and thread safety USAGE Importing "Class::InsideOut" "Class::InsideOut" automatically imports several critical methods into the calling package, including "DESTROY" and support methods for serializing objects with "Storable". These methods are intimately tied to correct functioning of inside-out objects and will always be imported regardless of whether additional functions are requested. Additional functions may be imported as usual by including them as arguments to "use". For example: use Class::InsideOut qw( register public ); public name => my %name; sub new { register( shift ) } As a shortcut, "Class::InsideOut" supports two tags for importing sets of functions: * ":std" provides "id", "private", "public", "readonly" and "register" * ":all" imports all functions (including an optional constructor) Note: Automatic imports can be bypassed via "require" or by passing an empty list to "use Class::InsideOut". There is almost no circumstance in which this is a good idea. Object properties and accessors Object properties are declared with the "public", "readonly" and "private" functions. They must be passed a label and the lexical hash that will be used to store object properties: public name => my %name; readonly ssn => my %ssn; private age => my %age; Properties for an object are accessed through an index into the lexical hash based on the memory address of the object. This memory address *must* be obtained via "Scalar::Util::refaddr". The alias "id" may be imported for brevity. $name{ refaddr $self } = "James"; $ssn { id $self } = 123456789; $age { id $self } = 32; Tip: since "refaddr" and "id" are function calls, it may be efficient to store the value once at the beginning of a method, particularly if it is being called repeatedly, e.g. within a loop. Object properties declared with "public" will have an accessor created with the same name as the label. If the accessor is passed an argument, the property will be set to the argument. The accessor always returns the value of the property. # Outside the class $person = My::Class->new; $person->name( "Larry" ); Object properties declared with "readonly" will have a read-only accessor created. The accessor will die if passed an argument to set the property value. The property may be set directly in the hash from within the class package as usual. # Inside the class $ssn { id $person } = 987654321; # Inside or outside the class $person->ssn( 123456789 ); # dies Property accessors may also be hand-written by declaring the property "private" and writing whatever style of accessor is desired. For example: sub age { $age{ id $_[0] } } sub set_age { $age{ id $_[0] } = $_[1] } Hand-written accessors will be very slightly faster as generated accessors hold a reference to the property hash rather than accessing the property hash directly. It is also possible to use a package hash instead of a lexical hash to store object properties: public name => our %name; However, this makes private object data accessable outside the class and incurs a slight performance penalty when accessing the property hash directly; it is not recommended to do this unless you really need it for some specialized reason. Object construction "Class::InsideOut" provides no default constructor method as there are many possible ways of constructing an inside-out object. This avoids constraining users to any particular object initialization or superclass initialization methodology. By using the memory address of the object as the index for properties, *any* type of reference may be used as the basis for an inside-out object with "Class::InsideOut". sub new { my $class = shift; my $self = \( my $scalar ); # anonymous scalar # my $self = {}; # anonymous hash # my $self = []; # anonymous array # open my $self, "<", $filename; # filehandle reference bless $self, $class; register( $self ); } However, to ensure that the inside-out object is thread-safe, the "register" function *must* be called on the newly created object. The "register" function may also be called with just the class name for the common case of blessing an anonymous scalar. register( $class ); # same as register( bless \(my $s), $class ) As a convenience, "Class::InsideOut" provides an optional "new" constructor for simple objects. This constructor automatically initializes the object from key/value pairs passed to the constructor for all keys matching the name of a property (including otherwise "private" or "readonly" properties). A more advanced technique for object construction uses another object, usually a superclass object, as the object reference. See "black-box inheritance" in Class::InsideOut::Manual::Advanced. Object destruction "Class::InsideOut" automatically exports a special "DESTROY" function. This function cleans up object property memory for all declared properties the class and for all "Class::InsideOut" based classes in the @ISA array to avoid memory leaks or data collision. Additionally, if a user-supplied "DEMOLISH" function is available in the same package, it will be called with the object being destroyed as its argument. "DEMOLISH" can be used for custom destruction behavior such as updating class properties, closing sockets or closing database connections. Object properties will not be deleted until after "DEMOLISH" returns. # Sample DEMOLISH: Count objects demolished (for whatever reason) my $objects_destroyed; sub DEMOLISH { $objects_destroyed++; } "DEMOLISH" will only be called if it exists for an object's actual class. "DEMOLISH" will not be inherited and "DEMOLISH" will not be called automatically for any superclasses. "DEMOLISH" should manage any necessary calls to superclass "DEMOLISH" methods. As with "new", implementation details are left to the user based on the user's approach to object inheritance. Depending on how the inheritance chain is constructed and how "DEMOLISH" is being used, users may wish to entirely override superclass "DEMOLISH" methods, rely upon "SUPER::DEMOLISH", or may prefer to walk the entire @ISA tree: use Class::ISA; sub DEMOLISH { my $self = shift; # class specific demolish actions # DEMOLISH for all parent classes, but only once my @parents = Class::ISA::super_path( __PACKAGE__ ); my %called; for my $p ( @parents ) { my $demolish = $p->can('DEMOLISH'); $demolish->($self) if not $called{ $demolish }++; } } FUNCTIONS "id" $name{ id $object } = "Larry"; This is a shorter, mnemonic alias for "Scalar::Util::refaddr". It returns the memory address of an object (just like "refaddr") as the index to access the properties of an inside-out object. "new" My::Class->new( name => "Larry", age => 42 ); This simplistic constructor is provided as a convenience and is only exported on request. When called as a class method, it returns a blessed anonymous scalar. Arguments will be used to initialize all matching inside-out class properties in the @ISA tree. The argument may be a hash or hash reference. Note: Properties are set directly, not via accessors. This means "set_hook" functions will not be called. For more robust argument checking, you will need to implement your own constructor. "options" Class::InsideOut::options( \%new_options ); %current_options = Class::InsideOut::options(); The "options" function sets default options for use with all subsequent property definitions for the calling package. If called without arguments, this function will return the options currently in effect. When called with a hash reference of options, these will be joined with the existing defaults, overriding any options of the same name. "private" private weight => my %weight; private haircolor => my %hair_color, { %options }; This is an alias to "property" that also sets the privacy option to 'private'. It will override default options or options passed as an argument. "property" property name => my %name; property rank => my %rank, { %options }; Declares an inside-out property. Two arguments are required and a third is optional. The first is a label for the property; this label will be used for introspection and generating accessors and thus must be a valid perl identifier. The second argument must be the lexical hash that will be used to store data for that property. Note that the "my" keyword can be included as part of the argument rather than as a separate statement. The property will be tracked for memory cleanup during object destruction and for proper thread-safety. If a third, optional argument is provided, it must be a reference to a hash of options that will be applied to the property and will override any default options that have been set. "public" public height => my %height; public age => my %age, { %options }; This is an alias to "property" that also sets the privacy option to 'public'. It will override default options or options passed as an argument. "readonly" readonly ssn => my %ssn; readonly fingerprint => my %fingerprint, { %options }; This is an alias to "property" that sets the privacy option to 'public' and adds a "set_hook" option that dies if an attempt is made to use the accessor to change the property. It will override default options or options passed as an argument. "register" register( bless( $object, $class ) ); # register the object register( $reference, $class ); # automatic bless register( $class ); # automatic blessed scalar Registers objects for thread-safety. This should be called as part of a constructor on a object blessed into the current package. Returns the resulting object. When called with only a class name, "register" will bless an anonymous scalar reference into the given class. When called with both a reference and a class name, "register" will bless the reference into the class. OPTIONS Options customize how properties are generated. Options may be set as a default with the "options" function or passed as a hash reference to "public", "private" or "property". Valid options include: "privacy" property rank => my %rank, { privacy => 'public' }; property serial => my %serial, { privacy => 'private' }; If the *privacy* option is set to *public*, an accessor will be created with the same name as the label. If the accessor is passed an argument, the property will be set to the argument. The accessor always returns the value of the property. "get_hook" public list => my %list, { get_hook => sub { @$_ } }; Defines an accessor hook for when values are retrieved. $_ is locally aliased to the property value for the object. *The return value of the hook is passed through as the return value of the accessor.* See "Customizing Accessors" in Class::InsideOut::Manual::Advanced for details. The hook must be a coderef, including blessed coderefs and overloaded objects. "set_hook" public age => my %age, { set_hook => sub { /^\d+$/ or die "must be an integer" } }; Defines an accessor hook for when values are set. The hook subroutine receives the entire argument list. $_ is locally aliased to the first argument for convenience. The property receives the value of $_. See "Customizing Accessors" in Class::InsideOut::Manual::Advanced for details. The hook must be a coderef, including blessed coderefs and overloaded objects. SEE ALSO Programmers seeking a more full-featured approach to inside-out objects are encouraged to explore Object::InsideOut. Other implementations are also noted in Class::InsideOut::Manual::About. KNOWN LIMITATIONS Requires weak reference support (Perl >= 5.6) and Scalar::Util::weaken() to avoid memory leaks and to provide thread-safety. ROADMAP Features slated for after the 1.0 release include: * Adding support for Data::Dump::Streamer serialization hooks * Adding additional accessor styles (e.g. get_name()/set_name()) * Further documentation revisions and clarification SUPPORT Bugs / Feature Requests Please report any bugs or feature requests through the issue tracker at . You will be notified automatically of any progress on your issue. Source Code This is open source software. The code repository is available for public review and contribution under the terms of the license. git clone https://github.com/dagolden/class-insideout.git AUTHOR David Golden CONTRIBUTORS * Karen Etheridge * Toby Inkster COPYRIGHT AND LICENSE This software is Copyright (c) 2006 by David A. Golden. This is free software, licensed under: The Apache License, Version 2.0, January 2004 Class-InsideOut-1.14/t/000755 000765 000024 00000000000 13070235143 015100 5ustar00davidstaff000000 000000 Class-InsideOut-1.14/Todo000644 000765 000024 00000004757 13070235143 015502 0ustar00davidstaff000000 000000 TODO list for Perl module Class::InsideOut # Todos after 1.0 - change to Apache license - add support for new DDS serialization hooks - test DDS on other serialization tests - document DDS support - accessor style options - write FAQs - expand documentation (cookbook? quick-start? notes on writing Builders) - document some internal introspection functions (e.g. _evert/_revert) # Possible todos depending on demand - class accessors via "public foo => my $foo"; - add public introspection methods (property list and options?) - accessor privacy => "protected" and matching property alias - look into support for cloning tied objects(?) in the blessed hash(?) - pre-clone user hook?? (waiting for someone to say they need it) - BUILD method #--------------------------------------------------------------------------# # Thoughts about property accessor styles and options #--------------------------------------------------------------------------# # have to be careful of interrelationship between style and custom prefixes; # maybe don't allow custom prefixes at all Class::InsideOut::options( accessor_style => 'perl', # default # "combined"; "perl" => foo() and foo(x) # "get_set"; "java" => get_foo() and set_foo(x) # "eiffel" => foo() and set_foo(x) get_prefix => 'get_', # maybe don't bother (YAGNI) set_prefix => 'set_', # maybe don't bother (YAGNI) privacy => 'public', # create accessors for everything given to properties # or 'readonly' or 'protected' or 'private' set_hook => \&coderef, # mutator argument filtered through this # will catch die message for error set_returns => 'self' # or 'newvalue' or 'oldvalue' ); #--------------------------------------------------------------------------# # FAQ ideas #--------------------------------------------------------------------------# * Security (c.f use perl post) * advisory encapsulation * Why "public *foo*" separate from "my %foo" (e.g. for "my %foo_of") * Another advantage of InsideOut over accessors -- can use as Lvalue for things like increments: $count_of{ id $self } #--------------------------------------------------------------------------# # Cookbook ideas #--------------------------------------------------------------------------# * Outside-in pattern * Property aliasing: ( should work, but what about Storable? ) assets => my %assets; wealth => my %assets; Class-InsideOut-1.14/xt/000755 000765 000024 00000000000 13070235143 015270 5ustar00davidstaff000000 000000 Class-InsideOut-1.14/xt/author/000755 000765 000024 00000000000 13070235143 016572 5ustar00davidstaff000000 000000 Class-InsideOut-1.14/xt/release/000755 000765 000024 00000000000 13070235143 016710 5ustar00davidstaff000000 000000 Class-InsideOut-1.14/xt/release/distmeta.t000644 000765 000024 00000000172 13070235143 020707 0ustar00davidstaff000000 000000 #!perl # This file was automatically generated by Dist::Zilla::Plugin::MetaTests. use Test::CPAN::Meta; meta_yaml_ok(); Class-InsideOut-1.14/xt/release/minimum-version.t000644 000765 000024 00000000266 13070235143 022237 0ustar00davidstaff000000 000000 #!perl use Test::More; eval "use Test::MinimumVersion"; plan skip_all => "Test::MinimumVersion required for testing minimum versions" if $@; all_minimum_version_ok( qq{5.010} ); Class-InsideOut-1.14/xt/author/00-compile.t000644 000765 000024 00000002663 13070235143 020633 0ustar00davidstaff000000 000000 use 5.006; use strict; use warnings; # this test was generated with Dist::Zilla::Plugin::Test::Compile 2.056 use Test::More; plan tests => 2; my @module_files = ( 'Class/InsideOut.pm' ); # fake home for cpan-testers use File::Temp; local $ENV{HOME} = File::Temp::tempdir( CLEANUP => 1 ); my @switches = ( -d 'blib' ? '-Mblib' : '-Ilib', ); use File::Spec; use IPC::Open3; use IO::Handle; open my $stdin, '<', File::Spec->devnull or die "can't open devnull: $!"; my @warnings; for my $lib (@module_files) { # see L my $stderr = IO::Handle->new; diag('Running: ', join(', ', map { my $str = $_; $str =~ s/'/\\'/g; q{'} . $str . q{'} } $^X, @switches, '-e', "require q[$lib]")) if $ENV{PERL_COMPILE_TEST_DEBUG}; my $pid = open3($stdin, '>&STDERR', $stderr, $^X, @switches, '-e', "require q[$lib]"); binmode $stderr, ':crlf' if $^O eq 'MSWin32'; my @_warnings = <$stderr>; waitpid($pid, 0); is($?, 0, "$lib loaded ok"); shift @_warnings if @_warnings and $_warnings[0] =~ /^Using .*\bblib/ and not eval { require blib; blib->VERSION('1.01') }; if (@_warnings) { warn @_warnings; push @warnings, @_warnings; } } is(scalar(@warnings), 0, 'no warnings found') or diag 'got warnings: ', ( Test::More->can('explain') ? Test::More::explain(\@warnings) : join("\n", '', @warnings) ); Class-InsideOut-1.14/xt/author/critic.t000644 000765 000024 00000000435 13070235143 020236 0ustar00davidstaff000000 000000 #!perl use strict; use warnings; use Test::More; use English qw(-no_match_vars); eval "use Test::Perl::Critic"; plan skip_all => 'Test::Perl::Critic required to criticise code' if $@; Test::Perl::Critic->import( -profile => "perlcritic.rc" ) if -e "perlcritic.rc"; all_critic_ok(); Class-InsideOut-1.14/xt/author/pod-coverage.t000644 000765 000024 00000000334 13070235143 021332 0ustar00davidstaff000000 000000 #!perl # This file was automatically generated by Dist::Zilla::Plugin::PodCoverageTests. use Test::Pod::Coverage 1.08; use Pod::Coverage::TrustPod; all_pod_coverage_ok({ coverage_class => 'Pod::Coverage::TrustPod' }); Class-InsideOut-1.14/xt/author/pod-spell.t000644 000765 000024 00000000713 13070235143 020657 0ustar00davidstaff000000 000000 use strict; use warnings; use Test::More; # generated by Dist::Zilla::Plugin::Test::PodSpelling 2.007004 use Test::Spelling 0.12; use Pod::Wordlist; add_stopwords(); all_pod_files_spelling_ok( qw( bin lib ) ); __DATA__ About Advanced Class David Etheridge Golden Inkster InsideOut Karen Manual Perlmonks ROADMAP Subclasses Toby accessable dagolden dclone demerphq deregistered destructor ether initializers jdhedden lib readonly rethrown tonyink xdg Class-InsideOut-1.14/xt/author/pod-syntax.t000644 000765 000024 00000000252 13070235143 021064 0ustar00davidstaff000000 000000 #!perl # This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests. use strict; use warnings; use Test::More; use Test::Pod 1.41; all_pod_files_ok(); Class-InsideOut-1.14/xt/author/portability.t000644 000765 000024 00000000322 13070235143 021316 0ustar00davidstaff000000 000000 use strict; use warnings; use Test::More; eval 'use Test::Portability::Files'; plan skip_all => 'Test::Portability::Files required for testing portability' if $@; options(test_one_dot => 0); run_tests(); Class-InsideOut-1.14/xt/author/test-version.t000644 000765 000024 00000000637 13070235143 021427 0ustar00davidstaff000000 000000 use strict; use warnings; use Test::More; # generated by Dist::Zilla::Plugin::Test::Version 1.09 use Test::Version; my @imports = qw( version_all_ok ); my $params = { is_strict => 0, has_version => 1, multiple => 0, }; push @imports, $params if version->parse( $Test::Version::VERSION ) >= version->parse('1.002'); Test::Version->import(@imports); version_all_ok; done_testing; Class-InsideOut-1.14/t/00-report-prereqs.dd000644 000765 000024 00000006452 13070235143 020627 0ustar00davidstaff000000 000000 do { my $x = { 'configure' => { 'requires' => { 'ExtUtils::MakeMaker' => '6.17', 'perl' => '5.006' } }, 'develop' => { 'requires' => { 'Dist::Zilla' => '5', 'Dist::Zilla::Plugin::ReleaseStatus::FromVersion' => '0', 'Dist::Zilla::Plugin::RemovePrereqs' => '0', 'Dist::Zilla::PluginBundle::DAGOLDEN' => '0.072', 'English' => '0', 'File::Spec' => '0', 'File::Temp' => '0', 'IO::Handle' => '0', 'IPC::Open3' => '0', 'Pod::Coverage::TrustPod' => '0', 'Pod::Wordlist' => '0', 'Software::License::Apache_2_0' => '0', 'Test::CPAN::Meta' => '0', 'Test::MinimumVersion' => '0', 'Test::More' => '0', 'Test::Pod' => '1.41', 'Test::Pod::Coverage' => '1.08', 'Test::Portability::Files' => '0', 'Test::Spelling' => '0.12', 'Test::Version' => '1', 'blib' => '1.01', 'perl' => '5.006', 'warnings' => '0' } }, 'runtime' => { 'requires' => { 'Carp' => '0', 'Class::ISA' => '0', 'Exporter' => '0', 'Scalar::Util' => '1.09', 'Storable' => '0', 'overload' => '0', 'perl' => '5.008', 'strict' => '0', 'vars' => '0' } }, 'test' => { 'recommends' => { 'CPAN::Meta' => '2.120900' }, 'requires' => { 'DynaLoader' => '0', 'ExtUtils::MakeMaker' => '0', 'File::Spec' => '0', 'IO::File' => '0', 'Test::More' => '0.45', 'XSLoader' => '0', 'lib' => '0', 'perl' => '5.008', 'threads' => '0', 'warnings' => '0' } } }; $x; }Class-InsideOut-1.14/t/00-report-prereqs.t000644 000765 000024 00000012714 13070235143 020501 0ustar00davidstaff000000 000000 #!perl use strict; use warnings; # This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.025 use Test::More tests => 1; use ExtUtils::MakeMaker; use File::Spec; # from $version::LAX my $lax_version_re = qr/(?: undef | (?: (?:[0-9]+) (?: \. | (?:\.[0-9]+) (?:_[0-9]+)? )? | (?:\.[0-9]+) (?:_[0-9]+)? ) | (?: v (?:[0-9]+) (?: (?:\.[0-9]+)+ (?:_[0-9]+)? )? | (?:[0-9]+)? (?:\.[0-9]+){2,} (?:_[0-9]+)? ) )/x; # hide optional CPAN::Meta modules from prereq scanner # and check if they are available my $cpan_meta = "CPAN::Meta"; my $cpan_meta_pre = "CPAN::Meta::Prereqs"; my $HAS_CPAN_META = eval "require $cpan_meta; $cpan_meta->VERSION('2.120900')" && eval "require $cpan_meta_pre"; ## no critic # Verify requirements? my $DO_VERIFY_PREREQS = 1; sub _max { my $max = shift; $max = ( $_ > $max ) ? $_ : $max for @_; return $max; } sub _merge_prereqs { my ($collector, $prereqs) = @_; # CPAN::Meta::Prereqs object if (ref $collector eq $cpan_meta_pre) { return $collector->with_merged_prereqs( CPAN::Meta::Prereqs->new( $prereqs ) ); } # Raw hashrefs for my $phase ( keys %$prereqs ) { for my $type ( keys %{ $prereqs->{$phase} } ) { for my $module ( keys %{ $prereqs->{$phase}{$type} } ) { $collector->{$phase}{$type}{$module} = $prereqs->{$phase}{$type}{$module}; } } } return $collector; } my @include = qw( ); my @exclude = qw( ); # Add static prereqs to the included modules list my $static_prereqs = do 't/00-report-prereqs.dd'; # Merge all prereqs (either with ::Prereqs or a hashref) my $full_prereqs = _merge_prereqs( ( $HAS_CPAN_META ? $cpan_meta_pre->new : {} ), $static_prereqs ); # Add dynamic prereqs to the included modules list (if we can) my ($source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; if ( $source && $HAS_CPAN_META && (my $meta = eval { CPAN::Meta->load_file($source) } ) ) { $full_prereqs = _merge_prereqs($full_prereqs, $meta->prereqs); } else { $source = 'static metadata'; } my @full_reports; my @dep_errors; my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs; # Add static includes into a fake section for my $mod (@include) { $req_hash->{other}{modules}{$mod} = 0; } for my $phase ( qw(configure build test runtime develop other) ) { next unless $req_hash->{$phase}; next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING}); for my $type ( qw(requires recommends suggests conflicts modules) ) { next unless $req_hash->{$phase}{$type}; my $title = ucfirst($phase).' '.ucfirst($type); my @reports = [qw/Module Want Have/]; for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) { next if $mod eq 'perl'; next if grep { $_ eq $mod } @exclude; my $file = $mod; $file =~ s{::}{/}g; $file .= ".pm"; my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC; my $want = $req_hash->{$phase}{$type}{$mod}; $want = "undef" unless defined $want; $want = "any" if !$want && $want == 0; my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required"; if ($prefix) { my $have = MM->parse_version( File::Spec->catfile($prefix, $file) ); $have = "undef" unless defined $have; push @reports, [$mod, $want, $have]; if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) { if ( $have !~ /\A$lax_version_re\z/ ) { push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)"; } elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) { push @dep_errors, "$mod version '$have' is not in required range '$want'"; } } } else { push @reports, [$mod, $want, "missing"]; if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) { push @dep_errors, "$mod is not installed ($req_string)"; } } } if ( @reports ) { push @full_reports, "=== $title ===\n\n"; my $ml = _max( map { length $_->[0] } @reports ); my $wl = _max( map { length $_->[1] } @reports ); my $hl = _max( map { length $_->[2] } @reports ); if ($type eq 'modules') { splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl]; push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports; } else { splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl]; push @full_reports, map { sprintf(" %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports; } push @full_reports, "\n"; } } } if ( @full_reports ) { diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports; } if ( @dep_errors ) { diag join("\n", "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n", "The following REQUIRED prerequisites were not satisfied:\n", @dep_errors, "\n" ); } pass; # vim: ts=4 sts=4 sw=4 et: Class-InsideOut-1.14/t/01_load.t000644 000765 000024 00000001153 13070235143 016504 0ustar00davidstaff000000 000000 use strict; use lib "."; my (@api, @not_api); BEGIN { @api = qw( options private property public register id _properties _object_count _leaking_memory CLONE ); @not_api = qw( DESTROY STORABLE_freeze STORABLE_thaw ); } use Test::More tests => 1 + @api + @not_api ; $|++; # keep stdout and stderr in order on Win32 BEGIN { use_ok( 'Class::InsideOut' ); } can_ok( 'Class::InsideOut', $_ ) for @api; for ( @not_api ) { ok( ! Class::InsideOut->can( $_ ), "$_ not part of the API" ); } Class-InsideOut-1.14/t/02_register.t000644 000765 000024 00000002735 13070235143 017421 0ustar00davidstaff000000 000000 use strict; use lib "."; use Test::More 0.45; use Class::InsideOut (); $|++; # try to keep stdout and stderr in order on Win32 #--------------------------------------------------------------------------# my @classes = qw( t::Object::Trivial t::Object::RegisterRef t::Object::RegisterClassname ); my %objects_of; #--------------------------------------------------------------------------# plan tests => 1 + ( 8 * @classes ); is( Class::InsideOut::_object_count(), 0, "no objects registered" ); my $expected_count; # Build objects for each class for my $class ( @classes ) { require_ok( $class ); my $o; ok( ($o = $class->new()) && $o->isa($class), "Creating a $class object" ); push @{$objects_of{$class}}, $o; $expected_count++; ok( ($o = $class->new()) && $o->isa($class), "Creating another $class object" ); push @{$objects_of{$class}}, $o; $expected_count++; is( Class::InsideOut::_object_count(), $expected_count, "object count correct" ); } # Teardown objects for my $class ( @classes ) { while ( @{$objects_of{$class}} ) { my $o = shift @{$objects_of{$class}}; Class::InsideOut::_deregister( $o ) if $] < 5.006; undef $o; ok( ! defined $o, "Destroying an object" ); $expected_count--; is( Class::InsideOut::_object_count(), $expected_count, "object count correct" ); } } Class-InsideOut-1.14/t/03_properties.t000644 000765 000024 00000004415 13070235143 017767 0ustar00davidstaff000000 000000 use strict; use lib "."; use Test::More; use Class::InsideOut (); $|++; # keep stdout and stderr in order on Win32 plan tests => 15; #--------------------------------------------------------------------------# my $class = "t::Object::Animal::Jackalope"; # sort alpha my $properties = { "t::Object::Animal" => { nickname=> "public", #20997: Duplicate property name name => "public", species => "public", Genus => "public", # David Schmitt: uppercase! }, "t::Object::Animal::Antelope" => { color => "public", panicked => "private", points => "public", }, "t::Object::Animal::JackRabbit" => { speed => "public", }, "t::Object::Animal::Jackalope" => { kills => "public", sidekick => "private", whiskers => "private", }, }; my ($o, $p); #--------------------------------------------------------------------------# require_ok( $class ); is_deeply( Class::InsideOut::_properties( $class ), $properties, "$class has/inherited its expected properties" ); is( Class::InsideOut::_object_count( $class ), 0, "$class has no objects registered" ); ok( ($o = $class->new()) && $o->isa($class), "Creating a $class object" ); ok( ($p = $class->new()) && $p->isa($class), "Creating another $class object" ); is( $o->name( "Larry" ), "Larry", "Setting a name for the first object" ); is( $p->name( "Damian" ), "Damian", "Setting a name for the second object" ); isnt( $o->name, $p->name, "Objects have different names" ); is( $o->color( "brown" ), "brown", "Setting a color for the first object" ); is( $o->speed( "42" ), "42", "Setting a speed for the first object" ); is( $o->points( 13 ), 13, "Setting points for the first object" ); is( $p->kills( "23" ), "23", "Setting a kill-count for the second object" ); Class::InsideOut::_deregister( $o ) if $] < 5.006; undef $o; ok( ! defined $o, "Destroying the first object" ); Class::InsideOut::_deregister( $p ) if $] < 5.006; undef $p; ok( ! defined $p, "Destroying the second object" ); my @leaks = Class::InsideOut::_leaking_memory; is( scalar @leaks, 0, "$class is not leaking memory" ) or diag "Leaks detected in:\n" . join( "\n", map { q{ } . $_ } @leaks ); Class-InsideOut-1.14/t/04_threaded.t000644 000765 000024 00000004730 13070235143 017354 0ustar00davidstaff000000 000000 use strict; use lib "."; use Config; # keep stdout and stderr in order on Win32 BEGIN { $|=1; my $oldfh = select(STDERR); $| = 1; select($oldfh); } # If running under threads, Test::More must load *after* threads.pm # so load Test::More only if needed to bail out or only after loading # threads.pm BEGIN { # don't run without threads configured if ( ! $Config{useithreads} ) { require Test::More; Test::More::plan( skip_all => "perl ithreads not available" ); } # don't run for Perl prior to 5.8 (with CLONE) (even if # threads *are* configured) if( $] < 5.008005 ) { require Test::More; Test::More::plan( skip_all => "thread support requires perl 5.8.5" ); } # don't run without Scalar::Util::weaken() eval "use Scalar::Util 'weaken'"; if( $@ =~ /\AWeak references are not implemented/ ) { require Test::More; Test::More::plan( skip_all => "Scalar::Util::weaken() is required for thread-safety" ); } # don't run this at all under Devel::Cover if ( $ENV{HARNESS_PERL_SWITCHES} && $ENV{HARNESS_PERL_SWITCHES} =~ /Devel::Cover/ ) { require Test::More; Test::More::plan( skip_all => "Devel::Cover not compatible with threads" ); } } use threads; use Test::More tests => 10; #--------------------------------------------------------------------------# my $class = "t::Object::Animal"; my $subclass = "t::Object::Animal::Antelope"; my ($o, $p); #--------------------------------------------------------------------------# require_ok( $class ); require_ok( $subclass ); ok( ($o = $class->new()) && $o->isa($class), "Creating a $class object" ); ok( ($p = $subclass->new()) && $p->isa($subclass), "Creating a $subclass object" ); is( $o->name( "Larry" ), "Larry", "Setting a name for the superclass object in the parent" ); is( $p->name( "Harry" ), "Harry", "Setting a name for the subclass object in the parent" ); is( $p->color( "brown" ), "brown", "Setting a color for the subclass object in the parent" ); my $thr = threads->new( sub { is( $o->name, "Larry", "got right superclass object name in thread"); is( $p->name, "Harry", "got right subclass object name in thread"); is( $p->color, "brown", "got right subclass object name in thread"); } ); SKIP: { skip "Couldn't create a thread", 3 unless defined $thr; $thr->join; } Class-InsideOut-1.14/t/05_forking.t000644 000765 000024 00000004367 13070235143 017242 0ustar00davidstaff000000 000000 use strict; use lib "."; use Config; use Test::More; $|++; # try to keep stdout and stderr in order on Win32 #--------------------------------------------------------------------------# # If Win32, fork() is done with threads, so we need various things if ( $^O eq 'MSWin32' ) { # don't run this at all under Devel::Cover if ( $ENV{HARNESS_PERL_SWITCHES} && $ENV{HARNESS_PERL_SWITCHES} =~ /Devel::Cover/ ) { plan skip_all => "Devel::Cover not compatible with Win32 pseudo-fork"; } # skip if threads not available for some reasons if ( ! $Config{useithreads} ) { plan skip_all => "Win32 fork() support requires threads"; } # skip if perl < 5.8 if ( $] < 5.008 ) { plan skip_all => "Win32 fork() support requires perl 5.8"; } # skip if Scalar::Util::weaken isn't available eval "use Scalar::Util 'weaken'"; if( $@ =~ /\AWeak references are not implemented/ ) { plan skip_all => "Win32 fork() support requires Scalar::Util::weaken()"; } } # Otherwise, we're going to run the tests. plan tests => 10; #--------------------------------------------------------------------------# my $class = "t::Object::Animal"; my $subclass = "t::Object::Animal::Antelope"; my ($o, $p); #--------------------------------------------------------------------------# require_ok( $class ); require_ok( $subclass ); ok( ($o = $class->new()) && $o->isa($class), "Creating a $class object" ); ok( ($p = $subclass->new()) && $p->isa($subclass), "Creating a $subclass object" ); is( $o->name( "Larry" ), "Larry", "Setting a name for the superclass object in the parent" ); is( $p->name( "Harry" ), "Harry", "Setting a name for the subclass object in the parent" ); is( $p->color( "brown" ), "brown", "Setting a color for the subclass object in the parent" ); my $child_pid = fork; if ( ! $child_pid ) { # we're in the child is( $o->name, "Larry", "got right superclass object name in child"); is( $p->name, "Harry", "got right subclass object name in child"); is( $p->color, "brown", "got right subclass object name in child"); exit; } waitpid $child_pid, 0; # current Test::More object counter is off due to child Test::More->builder->current_test( 10 ); Class-InsideOut-1.14/t/06_export_ok.t000644 000765 000024 00000003227 13070235143 017610 0ustar00davidstaff000000 000000 use strict; use lib "."; use Test::More; my @export_std = qw( id private public register ); my @export_rest = qw( options property ); my @additional = qw( DESTROY STORABLE_freeze STORABLE_thaw ); my @all_methods = ( @export_std, @export_rest, @additional ); plan tests => 3 + @all_methods # export_ok tests + 3 + @export_std + @additional # :std tests + 3 + @all_methods # :all tests ; $|++; # keep stdout and stderr in order on Win32 #--------------------------------------------------------------------------# package export_ok_test; use Test::More; pass( "setting package to 'export_ok_test'" ); require_ok( 'Class::InsideOut' ); Class::InsideOut->import( @export_std, @export_rest ); pass( "Importing all \@EXPORT_OK functions" ); can_ok( 'export_ok_test', $_ ) for (@export_std, @export_rest, @additional); #--------------------------------------------------------------------------# package export_tags_std_test; use Test::More; pass( "setting package to 'export_tags_std_test'" ); require_ok( 'Class::InsideOut' ); Class::InsideOut->import( ":std" ); pass( "Importing ':std' tag" ); can_ok( 'export_tags_std_test', $_ ) for (@export_std, @additional); #--------------------------------------------------------------------------# package export_tags_all_test; use Test::More; pass( "setting package to 'export_tags_all_test'" ); require_ok( 'Class::InsideOut' ); Class::InsideOut->import( ":all" ); pass( "Importing ':all' tag" ); can_ok( 'export_tags_all_test', $_ ) for (@all_methods); Class-InsideOut-1.14/t/07_synopsis_obj.t000644 000765 000024 00000002737 13070235143 020325 0ustar00davidstaff000000 000000 use strict; use lib "."; use Test::More; use Class::InsideOut (); $|++; # keep stdout and stderr in order on Win32 plan tests => 12; #--------------------------------------------------------------------------# my $class = "t::Object::Synopsis"; my $properties = { "t::Object::Synopsis" => { name => "public", ssn => "private", age => "public", initials => "public", }, }; my ($o, $p); #--------------------------------------------------------------------------# require_ok( $class ); is_deeply( Class::InsideOut::_properties( $class ), $properties, "$class has/inherited its expected properties" ); is( Class::InsideOut::_object_count( $class ), 0, "$class has no objects registered" ); ok( ($o = $class->new()) && $o->isa($class), "Creating a $class object" ); ok( ($p = $class->new()) && $p->isa($class), "Creating another $class object" ); $o->name( "Larry" ); is( $o->name(), "Larry", "Setting a name for the first object" ); $p->name( "Damian" ); is( $p->name(), "Damian", "Setting a name for the second object" ); isnt( $o->name, $p->name, "Objects have different names" ); is( $o->greeting, "Hello, my name is Larry", "Object greeting correct" ); undef $o; ok( ! defined $o, "Destroying the first object" ); undef $p; ok( ! defined $p, "Destroying the second object" ); ok( ! Class::InsideOut::_leaking_memory( $class ), "$class is not leaking memory" ); Class-InsideOut-1.14/t/08_DEMOLISH.t000644 000765 000024 00000002324 13070235143 017001 0ustar00davidstaff000000 000000 use strict; use lib "."; use Test::More; use Class::InsideOut (); $|++; # keep stdout and stderr in order on Win32 plan tests => 9; #--------------------------------------------------------------------------# my $class = "t::Object::Animal"; my $subclass = "t::Object::Animal::Antelope"; my ($o, $p); #--------------------------------------------------------------------------# require_ok( $class ); require_ok( $subclass ); ok( ($o = $class->new()) && $o->isa($class), "Creating a $class object" ); ok( ($p = $subclass->new()) && $p->isa($subclass), "Creating a $subclass object" ); is( $t::Object::Animal::animal_count, 2, "Count of animals is 2" ); Class::InsideOut::_deregister( $p ) if $] < 5.006; undef $p; ok( ! defined $p, "Destroying the subclass object" ); ok( ! scalar @t::Object::Animal::subclass_errors, "Subclass shouldn't inherit superclass DEMOLISH" ) or do { diag " DEMOLISH improperly called by $_" for @t::Object::Animal::subclass_errors; }; Class::InsideOut::_deregister( $o ) if $] < 5.006; undef $o; ok( ! defined $o, "Destroying the first object" ); is( $t::Object::Animal::animal_count, 1, "${class}::DEMOLISH decremented the count of animals to 1" ); Class-InsideOut-1.14/t/09_foreign.t000644 000765 000024 00000001664 13070235143 017235 0ustar00davidstaff000000 000000 use strict; use lib "."; use Test::More; use File::Spec; use Class::InsideOut (); $|++; # keep stdout and stderr in order on Win32 eval { require IO::File }; if ( $@ ) { plan skip_all => "IO::File not installed"; } eval { require File::Spec }; if ( $@ ) { plan skip_all => "File::Spec not installed"; } plan tests => 5; #--------------------------------------------------------------------------# my $class = "t::Object::Foreign"; my $filename = File::Spec->catfile( qw( t data testdata.txt ) ); my $o; #--------------------------------------------------------------------------# require_ok( $class ); ok( ($o = $class->new( $filename )) && $o->isa($class), "Creating a $class object" ); ok( $o->isa( "IO::File" ), "Object isa IO::File" ); my $line = <$o>; chomp $line; is( $line, "one", "Read a line from the $class object" ); $o->name( "Larry" ); is( $o->name(), "Larry", "Setting a name for the object" ); Class-InsideOut-1.14/t/10_storable_values.t000644 000765 000024 00000011634 13070235143 020764 0ustar00davidstaff000000 000000 use strict; use lib "."; use Test::More; use Class::InsideOut (); use Scalar::Util qw( refaddr reftype ); $|++; # try to keep stdout and stderr in order on Win32 # Need Storable 2.04 ( relatively safe STORABLE_freeze support ) eval { require Storable and Storable->VERSION( 2.04 ) }; if ( $@ ) { plan skip_all => "Storable >= 2.04 not installed", } sub check_version { my ($class, $version) = @_; eval { require $class and $class->VERSION($version) }; return $@ eq q{} ? 0 : 1; } my @serializers = ( { class => "Storable", version => 3.04, freeze => sub { Storable::freeze( shift ) }, thaw => sub { Storable::thaw( shift ) }, }, ); my @classes = qw( t::Object::Scalar t::Object::Array t::Object::Hash t::Object::Animal::Jackalope ); my %custom_prop_for_class = ( "t::Object::Scalar" => { age => "32" }, "t::Object::Array" => { height => "72 inches" }, "t::Object::Hash" => { weight => "190 lbs" }, "t::Object::Animal::Jackalope" => { color => "white", speed => "60 mph", points => 13, kills => 23, }, ); my $prop_count; $prop_count++ for map { keys %$_ } values %custom_prop_for_class; my $tests_per_serializer = ( 1 + (11 * @classes) + (2 * $prop_count) ); plan tests => @serializers * $tests_per_serializer; #--------------------------------------------------------------------------# # Setup test data #--------------------------------------------------------------------------# my %content_for_type = ( SCALAR => \do { my $s = 3.14159 }, ARRAY => [1, 1, 2, 3, 5, 8 ], HASH => { 1 => 1, 2 => 4, 3 => 9, 4 => 16 }, ); my %names_for_class = ( "t::Object::Scalar" => "Larry", "t::Object::Array" => "Moe", "t::Object::Hash" => "Curly", "t::Object::Animal::Jackalope" => "Fred", ); #--------------------------------------------------------------------------# # tests #--------------------------------------------------------------------------# for my $s ( @serializers ) { SKIP: { skip "$s->{class} $s->{version} required", $tests_per_serializer unless check_version( $s->{class}, $s->{version} ); require_ok( $s->{class} ); for my $class ( @classes ) { no strict 'refs'; require_ok( $class ); my $o; # create the object ok( $o = $class->new(), "... Creating $class object" ); # note the underlying type my $type; ok( $type = reftype($o), "... Object is reftype $type" ); # set a name my $name = $names_for_class{ $class }; $o->name( $name ); is( $o->name(), $name, "... Setting 'name' to '$name'" ); # set class-specific properties for my $prop ( keys %{ $custom_prop_for_class{ $class } } ) {; my $val = $custom_prop_for_class{ $class }{ $prop }; $o->$prop( $val ); is( $o->$prop(), $val, "... Setting custom '$prop' property to $val" ); } # store class-specific data in the reference my $data = $content_for_type{ $type }; for ( reftype $o ) { /SCALAR/ && do { $$o = $$data; last }; /ARRAY/ && do { @$o = @$data; last }; /HASH/ && do { %$o = %$data; last }; } pass( "... Loading base $type with data" ); # freeze object my ( $frozen, $thawed ); ok( $frozen = $s->{freeze}->( $o ), "... Freezing object" ); # thaw object ok( $thawed = $s->{thaw}->( $frozen ), "... Thawing object" ); isnt( refaddr $o, refaddr $thawed, "... Thawed object is a copy" ); # check name is( $thawed->name(), $name, "... Property 'name' for thawed object is correct?" ) ; # check class-specific properties for my $prop ( keys %{ $custom_prop_for_class{ $class } } ) {; my $val = $custom_prop_for_class{ $class }{ $prop }; is( $thawed->$prop(), $val, "... Property '$prop' for thawed objects is correct?" ); } # check thawed contents is_deeply( $thawed, $data, "... Thawed object contents are correct" ); my @leaks = Class::InsideOut::_leaking_memory; ok( ! scalar @leaks, "... $class not leaking memory" ) or diag "Leaks in: @leaks"; }; } } Class-InsideOut-1.14/t/11_storable_refs.t000644 000765 000024 00000022416 13070235143 020425 0ustar00davidstaff000000 000000 use strict; use lib "."; BEGIN { # don't run without Scalar::Util::weaken() eval "use Scalar::Util 'weaken'"; if( $@ =~ /\AWeak references are not implemented/ ) { require Test::More; Test::More::plan( skip_all => "Can't test storable refs without Scalar::Util::weaken" ); } } use Test::More; use Class::InsideOut (); use Scalar::Util qw( refaddr reftype weaken isweak ); # Need Storable 2.04 ( relatively safe STORABLE_freeze support ) eval { require Storable and Storable->VERSION( 2.04 ) }; if ( $@ ) { plan skip_all => "Storable >= 2.04 not installed", } sub check_version { my ($class, $version) = @_; eval { require $class and $class->VERSION($version) }; return $@ eq q{} ? 0 : 1; } my @serializers = ( { class => "Storable", version => 3.04, freeze => sub { Storable::freeze( shift ) }, thaw => sub { Storable::thaw( shift ) }, }, ); my $tests_per_serializer = 68; plan tests => @serializers * $tests_per_serializer; my $class = "t::Object::Friends"; for my $s ( @serializers ) { SKIP: { skip "$s->{class} $s->{version} required", $tests_per_serializer unless check_version( $s->{class}, $s->{version} ); require_ok( $s->{class} ); # Setup test data and variables my ($alice, $bob, $charlie); my ($alice2, $bob2, $charlie2); my ( $frozen, $thawed ); my @friends; # start tests require_ok( $class ); # create the objects ok( $alice = $class->new( { name => "Alice" } ), "Creating $class object 'Alice'" ); ok( $bob = $class->new( { name => "Bob" } ), "Creating $class object 'Bob'" ); ok( $bob->friends( $alice ), "Making Bob friends with Alice" ); ok( $charlie = $class->new( { name => "Charlie" } ), "Creating $class object 'charlie'" ); ok( $charlie->friends( $alice, $bob ), "Making Charlie friends with Alice and Bob" ); ok( $charlie->has_friend( $bob ), "Confirming 'has_friend' method works" ); # Freezing just Bob should clone Alice # freeze object ok( $frozen = $s->{freeze}->( $bob ), "Freezing Bob" ); # thaw object ok( $bob2 = $s->{thaw}->( $frozen ), "... Thawing the frozen Bob" ); is( ref $bob2, $class, "... Thawed Bob is a $class" ); isnt( refaddr $bob2, refaddr $bob, "... Thawed Bob is a new object" ); # check name is( $bob2->name(), "Bob", "... Thawed Bob is also named Bob (hereafter Bob2)" ); # check reference copy ok( ! $bob2->has_friend( $alice ), "... Bob2 is not friends with Alice" ); is( @friends = $bob2->friends, 1, "... Bob2 still has 1 friend" ); isa_ok( $friends[0], $class, "... Bob2's friend" ); is( $friends[0]->name, "Alice", "... Bob2's friend is also named 'Alice'" ); # Freezing Bob and Alice together should preserve relationship # freeze object ok( $frozen = $s->{freeze}->( [ $bob, $alice ] ), "Freezing Bob and Alice together" ); # thaw object ($bob2, $alice2) = @{ $s->{thaw}->( $frozen ) }; pass( "... Thawing the frozen Bob and Alice" ); is( ref $bob2, $class, "... Thawed Bob is a $class" ); is( ref $alice2, $class, "... Thawed Alice is a $class" ); isnt( refaddr $bob2, refaddr $bob, "... Thawed Bob is a new object" ); # check name is( $bob2->name(), "Bob", "... Thawed Bob is also named Bob (hereafter Bob2)" ); isnt( refaddr $bob2, refaddr $bob, "... Bob2 is not Bob" ); is( $alice2->name(), "Alice", "... Other thawed object is named Alice (hereafter Alice2)" ); isnt( refaddr $alice2, refaddr $alice, "... Alice2 is not Alice" ); # check reference copy ok( ! $bob2->has_friend( $alice ), "... Bob2 is not friends with Alice" ); is( @friends = $bob2->friends, 1, "... Bob2 still has 1 friend" ); is( refaddr $friends[0], refaddr $alice2, "... Bob2's friend is Alice2" ); # Freezing Charlie and Bob and Alice together should preserve all # relationships # freeze object ok( $frozen = $s->{freeze}( [ $bob, $alice, $charlie ] ), "Freezing Charlie, Bob and Alice together" ); # thaw object ($bob2, $alice2, $charlie2) = @{ $s->{thaw}->( $frozen ) }; pass( "... Thawing the frozen Charlie, Bob and Alice" ); is( ref $charlie2, $class, "... Thawed Bob is a $class" ); is( ref $bob2, $class, "... Thawed Bob is a $class" ); is( ref $bob2, $class, "... Thawed Alice is a $class" ); isnt( refaddr $bob2, refaddr $bob, "... Thawed Bob is a new object" ); # check name is( $charlie2->name(), "Charlie", "... One thawed object is also named Charlie (hereafter Charlie2)" ); isnt( refaddr $charlie2, refaddr $charlie, "... Charlie2 is not Charlie" ); is( $bob2->name(), "Bob", "... Another thawed object is also named Bob (hereafter Bob2)" ); isnt( refaddr $bob2, refaddr $bob, "... Bob2 is not Bob" ); is( $alice2->name(), "Alice", "... Another thawed object is named Alice (hereafter Alice2)" ); isnt( refaddr $alice2, refaddr $alice, "... Alice2 is not Alice" ); # check reference copy ok( ! $bob2->has_friend( $alice ), "... Bob2 is not friends with Alice" ); ok( ! $charlie2->has_friend( $alice ), "... Charlie2 is not friends with Alice" ); ok( ! $charlie2->has_friend( $bob ), "... Charlie2 is not friends with Bob" ); is( @friends = $charlie2->friends, 2, "... Charlie2 still has 2 friends" ); ok( $charlie2->has_friend( $alice2 ), "... Charlie2 has Alice2 as a friend" ); ok( $charlie2->has_friend( $bob2 ), "... Charlie2 has Bob2 as a friend" ); ok( $bob2->has_friend( $alice2 ), "... Bob2 has Alice2 as a friend" ); # storing Alice inside herself !! push @$alice, $alice; weaken( $alice->[0] ); ok( isweak( $alice->[0] ), "Storing a weak reference to Alice inside Alice (!!)" ); # freeze object ok( $frozen = $s->{freeze}->( $alice ), "Freezing Alice" ); # thaw object ok( $alice2 = $s->{thaw}( $frozen ), "... Thawing the frozen Alice as Alice2" ); is( ref $alice2, $class, "... Thawed Alice is a $class" ); is( $alice2->[0], $alice2, "... Found Alice2 inside Alice2 (Lewis Carroll eat your heart out!)" ); ok( ! isweak( $alice2->[0] ), "... Reference to Alice2 isn't weak -- limitation of Storable" ); shift @$alice; is( @$alice, 0, "Removing Alice from herself" ); # let's make alice a narcissist and clone her! ok( $alice->friends( $alice ), "Making Alice friends with herself (!!)" ); # freeze object ok( $alice2 = $s->{thaw}->( $s->{freeze}->( $alice ) ), "Cloning Alice into Alice2 (with dclone)" ); is( ref $alice2, $class, "... Thawed Alice is a $class" ); isnt( refaddr $alice2, refaddr $alice, "... Alice2 is a new object" ); # check reference copy ok( ! $alice2->has_friend( $alice ), "... Alice2 is not friends with Alice" ); ok( $alice2->has_friend( $alice2 ), "... Alice2 is friends with Alice2" ); # Bilateral friendship between Alice and Bob $alice->friends( undef ); is( scalar $alice->friends, 0, "Alice is no longer friends with herself (try therapy?)" ); ok( $alice->friends( $bob ), "Making Alice friends with Bob" ); # freeze object ok( $alice2 = $s->{thaw}->( $s->{freeze}->( $alice ) ), "Cloning Alice into Alice2 (with dclone)" ); is( ref $bob2, $class, "... Thawed Alice is a $class" ); ok( ! $alice2->has_friend( $bob ), "... Alice2 is not friends with Bob" ); ($bob2) = $alice2->friends; is( $bob2->name, "Bob", "... Alice2 does have a friend named Bob (hereafter Bob2)" ); ok( $bob2->has_friend( $alice2 ), "... Bob2 is friends with Alice2" ); } } Class-InsideOut-1.14/t/12_storable_hooks.t000644 000765 000024 00000003161 13070235143 020606 0ustar00davidstaff000000 000000 use strict; use lib "."; use Test::More; use Class::InsideOut (); use Scalar::Util qw( refaddr reftype ); $|++; # keep stdout and stderr in order on Win32 my $class = "t::Object::Animal::Jackalope"; my $gp_class = "t::Object::Animal"; # Need Storable 2.04 ( relatively safe STORABLE_freeze support ) eval { require Storable and Storable->VERSION( 2.04 ) }; if ( $@ ) { plan skip_all => "Storable >= 2.04 not installed", } else { plan tests => 10; } #--------------------------------------------------------------------------# # tests #--------------------------------------------------------------------------# require_ok( $class ); my $o; # create the object ok( $o = $class->new(), "... Creating $class object" ); # note the underlying type my $type; ok( $type = reftype($o), "... Object is reftype $type" ); # freeze object my ( $frozen, $thawed ); ok( $frozen = Storable::freeze( $o ), "... Freezing object" ); # check that hooks worked { no strict 'refs'; is( ${ $class . "::freezings"}, 1, "... $class freeze hook updated freeze count" ); is( ${ $gp_class . "::freezings"}, 1, "... $gp_class freeze hook updated freeze count (diamond pattern)" ); } # thaw object ok( $thawed = Storable::thaw( $frozen ), "... Thawing object" ); isnt( refaddr $o, refaddr $thawed, "... Thawed object is a copy" ); # check that hooks worked { no strict 'refs'; is( ${ $class . "::thawings"}, 1, "... $class thaw hook updated thaw count" ); is( ${ $gp_class . "::thawings"}, 1, "... $gp_class thaw hook updated thaw count (diamond pattern)" ); } Class-InsideOut-1.14/t/13_options.t000644 000765 000024 00000000622 13070235143 017263 0ustar00davidstaff000000 000000 use strict; use lib "."; use Test::More tests => 5; $|++; # keep stdout and stderr in order on Win32 BEGIN { use_ok( 'Class::InsideOut', 'options' ); } can_ok( 'main', 'options' ); is_deeply( { options() }, {}, "No options set" ); ok( options( {privacy => 'public'} ), "Setting options" ); is_deeply( { options() }, { privacy => 'public' } , "options() provides current options" ); Class-InsideOut-1.14/t/14_accessor_hooks.t000644 000765 000024 00000005637 13070235143 020611 0ustar00davidstaff000000 000000 use strict; use lib "."; use Test::More; # keep stdout and stderr in order on Win32 BEGIN { $|=1; my $oldfh = select(STDERR); $| = 1; select($oldfh); } #--------------------------------------------------------------------------# my $class = "t::Object::Hooked"; my $properties = { $class => { integer => "public", uppercase => "public", word => "public", list => "public", reverser => "public", write_only => "public", }, }; my ($o, @got, $got); #--------------------------------------------------------------------------# plan tests => 21; require_ok( $class ); is_deeply( Class::InsideOut::_properties( $class ), $properties, "$class has/inherited its expected properties" ); ok( ($o = $class->new()) && $o->isa($class), "Creating a $class object" ); #--------------------------------------------------------------------------# eval { $o->integer(3.14) }; my $err = $@; like( $err, '/integer\(\) must be an integer at/i', "integer(3.14) dies" ); my $at_count = () = $err =~ /at/g; is( $at_count, 1, "'at' count correct" ); eval { $o->integer(42) }; is( $@, q{}, "integer(42) lives" ); is( $o->integer, 42, "integer() == 42" ); #--------------------------------------------------------------------------# eval { $o->word("^^^^") }; like( $@, '/word\(\) must be a Perl word at/i', "word(^^^^) dies" ); eval { $o->word("apple") }; is( $@, q{}, "word(apple) lives" ); is( $o->word, 'apple', "word() eq 'apple'" ); #--------------------------------------------------------------------------# eval { $o->uppercase("banana") }; is( $@, q{}, "uppercase(banana) lives" ); is( $o->uppercase, 'BANANA', "uppercase() eq 'BANANA'" ); #--------------------------------------------------------------------------# # list(@array) eval { $o->list(qw(foo bar bam)) }; is( $@, q{}, "list(qw(foo bar bam)) lives" ); is_deeply( [ $o->list ], [qw(foo bar bam)], "list() gives qw(foo bar bam)" ); # list(\@array) eval { $o->list( [qw(foo bar bam)] ) }; is( $@, q{}, "list( [qw(foo bar bam)] ) lives" ); is_deeply( [ $o->list ], [qw(foo bar bam)], "list() gives qw(foo bar bam)" ); #--------------------------------------------------------------------------# eval { $o->reverser(qw(foo bar bam)) }; is( $@, q{}, "reverser(qw(foo bar bam)) lives" ); # reverser in list context @got = $o->reverser; is_deeply( \@got, [qw(bam bar foo)], "reverser() in list context gives qw(bam bar foo)" ); # reverser in scalar context $got = $o->reverser; is( $got, 'mabraboof', "reverser() in scalar context gives mabraboof" ); #--------------------------------------------------------------------------# eval { $o->write_only( 23 ) }; is( $@, q{}, "write_only lives on write" ); eval { $got = $o->write_only() }; like( $@, '/write_only\(\) is write-only at/i', "write only dies on write (and was caught)" ); Class-InsideOut-1.14/t/15_no_weaken_fallback.t000644 000765 000024 00000003275 13070235143 021366 0ustar00davidstaff000000 000000 use strict; use lib "."; use Test::More; $|++; # keep stdout and stderr in order on Win32 # Devel::Cover doesn't seem to actually track coverage for the hacks # used here, so we'll skip it. if ( $ENV{HARNESS_PERL_SWITCHES} && $ENV{HARNESS_PERL_SWITCHES} =~ /Devel::Cover/ ) { plan skip_all => "no_weaken_fallback tests not compatible with Devel::Cover"; } # find what Scalar::Util we have my $rc = system($^X, '-e', 'use Scalar::Util; Scalar::Util->VERSION(1.2303)'); if ( ! $rc ) { plan skip_all => "Your Scalar::Util is XS only"; } # Overload DynaLoader and XSLoader to fake lack of XS for Scalar::Util # (which actually calls List::Util) BEGIN { no strict 'refs'; local $^W; require DynaLoader; my $bootstrap_orig = *{"DynaLoader::bootstrap"}{CODE}; *DynaLoader::bootstrap = sub { die if $_[0] =~ /(Scalar|List)::Util/; goto $bootstrap_orig; }; # XSLoader entered Core in Perl 5.6 if ( $] >= 5.006 ) { require XSLoader; my $xsload_orig = *{"XSLoader::load"}{CODE}; *XSLoader::load = sub { die if $_[0] =~ /(Scalar|List)::Util/; goto $xsload_orig; }; } } plan tests => 3; #--------------------------------------------------------------------------# my $class = "t::Object::Trivial"; #--------------------------------------------------------------------------# my $warning; { local $^W = 1; local $SIG{__WARN__} = sub { $warning = shift }; eval "require $class"; } is( $@, q{}, "require $class succeeded without XS" ); ok( $warning, "caught a warning" ); like( $warning, '/Scalar::Util::weaken/', "Saw warning for Scalar::Util::weaken unavailable" ); Class-InsideOut-1.14/t/16_property_argument_checking.t000644 000765 000024 00000004361 13070235143 023220 0ustar00davidstaff000000 000000 use strict; use lib "."; local $^W = 1; use Test::More; # keep stdout and stderr in order on Win32 BEGIN { $|=1; my $oldfh = select(STDERR); $| = 1; select($oldfh); } #--------------------------------------------------------------------------# # property() argument cases #--------------------------------------------------------------------------# my @property_cases = ( { label => q{invalid property name: bad symbols}, args => q{'test#data' => my %testdata}, error => q{invalid property name}, }, { label => q{invalid property name: leading number}, args => q{'1testdata' => my %testdata}, error => q{invalid property name}, }, { label => q{invalid property name: object}, args => q{[] => my %testdata}, error => q{invalid property name}, }, { label => q{invalid property store: not a hashref}, args => q{testdata => my @testdata}, error => q{must be hash}, }, { label => q{invalid property options: passed arrayref, not a hashref}, args => q{testdata => my %testdata, []}, error => q{must be a hash reference}, }, { label => q{invalid property options: passed scalar, not a hashref}, args => q{testdata => my %testdata, 'foo'}, error => q{must be a hash reference}, }, ); #--------------------------------------------------------------------------# # Begin tests #--------------------------------------------------------------------------# plan tests => 2 + 3 * @property_cases; require_ok( "Class::InsideOut" ); for my $fcn ( qw( property public private ) ) { for my $case ( @property_cases ) { eval( "Class::InsideOut::$fcn " . $case->{args}); like( $@, "/$case->{error}/i", "$fcn: $case->{label}"); } } #--------------------------------------------------------------------------# # Special cases #--------------------------------------------------------------------------# # Duplicate names eval << 'END_EVAL'; Class::InsideOut::property twin => my %twin; Class::InsideOut::property twin => my %double; END_EVAL like( $@, "/duplicate property name/i", "Duplicate property name detected" ); Class-InsideOut-1.14/t/17_option_argument_checking.t000644 000765 000024 00000003476 13070235143 022653 0ustar00davidstaff000000 000000 use strict; use lib "."; local $^W = 1; use Test::More; # keep stdout and stderr in order on Win32 BEGIN { $|=1; my $oldfh = select(STDERR); $| = 1; select($oldfh); } #--------------------------------------------------------------------------# # option() argument cases #--------------------------------------------------------------------------# my @cases = ( { label => q{invalid options argument: array is not a hash}, args => q{ [ qw( foo bar ) ] }, error => q{invalid options argument}, }, { label => q{invalid options argument: scalar is not a hash}, args => q{ 'foo' => 'bar' }, error => q{invalid options argument}, }, { label => q{invalid options argument: unknown option}, args => q{ { privacy => 'public', not_an_option => 1} }, error => q{invalid option 'not_an_option'}, }, { label => q{invalid options argument: bad 'privacy' option}, args => q{ { privacy => 'yes'} }, error => q{invalid option 'privacy'.+?yes}, }, { label => q{invalid options argument: bad 'set_hook' option}, args => q{ { set_hook => 'foo' } }, error => q{invalid option 'set_hook'.+code}, }, { label => q{invalid options argument: bad 'get_hook' option}, args => q{ { get_hook => 'foo' } }, error => q{invalid option 'get_hook'.+code}, }, ); #--------------------------------------------------------------------------# # Begin tests #--------------------------------------------------------------------------# plan tests => 1 + @cases; require_ok( "Class::InsideOut" ); for my $case ( @cases ) { eval( "Class::InsideOut::options( " . $case->{args} . ")" ); like( $@, "/$case->{error}/i", "$case->{label}"); } Class-InsideOut-1.14/t/18_register_argument_checking.t000644 000765 000024 00000002062 13070235143 023156 0ustar00davidstaff000000 000000 use strict; use lib "."; local $^W = 1; use Test::More; # keep stdout and stderr in order on Win32 BEGIN { $|=1; my $oldfh = select(STDERR); $| = 1; select($oldfh); } #--------------------------------------------------------------------------# # option() argument cases #--------------------------------------------------------------------------# my @cases = ( { label => q{invalid call to register: no argument}, args => q{}, error => q{empty argument list}, }, { label => q{invalid register argument: reference with no class name}, args => q{ {} }, error => q{must be an object or class name}, }, ); #--------------------------------------------------------------------------# # Begin tests #--------------------------------------------------------------------------# plan tests => 1 + @cases; require_ok( "Class::InsideOut" ); for my $case ( @cases ) { eval( "Class::InsideOut::register( " . $case->{args} . ")" ); like( $@, "/$case->{error}/i", "$case->{label}"); } Class-InsideOut-1.14/t/19_storable_singleton.t000644 000765 000024 00000005202 13070235143 021472 0ustar00davidstaff000000 000000 use strict; use lib "."; local $^W = 1; use Test::More; use Scalar::Util qw( refaddr ); use Class::InsideOut (); $|++; # keep stdout and stderr in order on Win32 (maybe) my %constructors_for = ( 't::Object::Singleton::Simple' => 'new', 't::Object::Singleton::Hooked' => 'get_instance', ); # Need Storable 2.14 ( STORABLE_attach support ) eval { require Storable and Storable->VERSION( 2.14 ) }; if ( $@ ) { plan skip_all => "Storable >= 2.14 needed for singleton support", } else { plan tests => 12 * scalar keys %constructors_for; } #--------------------------------------------------------------------------# my $name = "Neo"; my $name2 = "Mr. Smith"; #--------------------------------------------------------------------------# for my $class ( keys %constructors_for ) { require_ok( $class ); my $o; # create the object my $new = $class->can( $constructors_for{$class} ); ok( $o = $new->($class), "... Creating $class object" ); # set a name $o->name( $name ); is( $o->name(), $name, "... Setting 'name' to '$name'" ); # freeze object my ( $frozen, $thawed ); ok( $frozen = Storable::freeze( $o ), "... Freezing $class object" ); # set a name $o->name( $name2); is( $o->name(), $name2, "... Setting 'name' to '$name2'" ); # thaw object ok( $thawed = Storable::thaw( $frozen ), "... Thawing $class object" ); is( refaddr $o, refaddr $thawed, "... Thawed $class object is the singleton" ); # check it is( $thawed->name(), $name2, "... Thawed $class object 'name' is '$name2'" ); # destroy the singleton { no strict 'refs'; Class::InsideOut::_deregister( $o ) if $] < 5.006; ${"$class\::self"} = $thawed = $o = undef; is( ${"$class\::self"}, undef, "... Destroying $class singleton manually" ); my @leaks = Class::InsideOut::_leaking_memory; is( scalar @leaks, 0, "... $class is not leaking memory" ) or diag "Leaks detected in:\n" . join( "\n", map { q{ } . $_ } @leaks ); } # recreate it ok( $thawed = Storable::thaw( $frozen ), "... Re-thawing $class object again (recreating)" ); # check it if ( $class eq "t::Object::Singleton::Hooked" ) { is( $thawed->name(), $name, "... Re-thawed $class object 'name' is '$name'" ); } else { # regular singleton doesn't reinitialize is( $thawed->name(), undef, "... Re-thawed $class object 'name' is undef" ); } } Class-InsideOut-1.14/t/20_storable_singleton_error.t000644 000765 000024 00000003133 13070235143 022674 0ustar00davidstaff000000 000000 use strict; use lib "."; local $^W = 1; use Test::More; use Scalar::Util qw( refaddr ); $|++; # keep stdout and stderr in order on Win32 (maybe) my %constructors_for = ( 't::Object::Singleton::MissingConstructor' => 'get_it', ); # Need Storable 2.14 ( STORABLE_attach support ) eval { require Storable and Storable->VERSION( 2.14 ) }; if ( $@ ) { plan skip_all => "Storable >= 2.14 needed for singleton support", } else { plan tests => 6 * scalar keys %constructors_for; } #--------------------------------------------------------------------------# my $name = "Neo"; #--------------------------------------------------------------------------# for my $class ( keys %constructors_for ) { require_ok( $class ); my $o; # create the object my $new = $class->can( $constructors_for{$class} ); ok( $o = $new->($class), "... Creating $class object" ); # set a name $o->name( $name ); is( $o->name(), $name, "... Setting 'name' to '$name'" ); # freeze object my ( $frozen, $thawed ); ok( $frozen = Storable::freeze( $o ), "... Freezing $class object" ); # thaw object -- should die because no "new()" and no # STORABLE_attach_hook my $error; eval { local $SIG{__WARN__} = sub { $error = shift }; $thawed = Storable::thaw( $frozen ); }; like( $@, "/STORABLE_attach did not return a $class\/", "... Thawing without constructor throws error" ); like( $error, "/Error attaching to $class\/", "... Warning message seen" ); } Class-InsideOut-1.14/t/21_optional_new.t000644 000765 000024 00000004135 13070235143 020270 0ustar00davidstaff000000 000000 use strict; use lib "."; use Test::More; select STDERR; $|++; select STDOUT; $|++; #--------------------------------------------------------------------------# my $class = "t::Object::WithNew::Inherited"; my %properties = ( name => "Larry", age => 42, ); #--------------------------------------------------------------------------# my @cases = ( { label => q{new()}, args => [], }, { label => q{new( %hash )}, args => [ %properties ], }, { label => q{new( \%hash )}, args => [\%properties ], }, ); my @error_cases = ( { label => q{new( qw/foo/ ) croaks}, args => [ qw/foo/ ], error => q{must be a hash or hash reference}, }, { label => q{new( qw/foo bar bam/ ) croaks}, args => [ qw/foo bar bam/ ], error => q{must be a hash or hash reference}, }, { label => q{new( [ qw/foo bar/ ] ) croaks}, args => [ [qw/foo bar/] ], error => q{must be a hash or hash reference}, }, ); plan tests => 2 + 2 + 5 * (@cases - 1) + @error_cases; #--------------------------------------------------------------------------# # test initialization #--------------------------------------------------------------------------# require_ok( $class ); can_ok( $class, 'new' ); for my $case ( @cases ) { my $o; ok( $o = $class->new( @{$case->{args}} ), $case->{label} ); isa_ok( $o, $class ); next unless scalar @{ $case->{args} }; is( $o->name(), "Larry", "name property initialized correctly" ); is( $o->reveal_age, 42, "age property initialized correctly" ); is( $o->t::Object::WithNew::reveal_age(), 42, "superclass age property initialized correctly" ); } #--------------------------------------------------------------------------# # error tests #--------------------------------------------------------------------------# for my $case ( @error_cases ) { eval { $class->new( @{ $case->{args} } ) }; like( $@, "/$case->{error}/i", "$case->{label}"); } Class-InsideOut-1.14/t/22_readonly.t000644 000765 000024 00000002072 13070235143 017406 0ustar00davidstaff000000 000000 use strict; use lib "."; use Test::More; # keep stdout and stderr in order on Win32 select STDERR; $|++; select STDOUT; $|++; #--------------------------------------------------------------------------# my $class = "t::Object::ReadOnly"; my $properties = { $class => { name => "public", age => "public", }, }; my ($o, @got, $got); #--------------------------------------------------------------------------# plan tests => 6; require_ok( $class ); is_deeply( Class::InsideOut::_properties( $class ), $properties, "$class has/inherited its expected properties" ); ok( ($o = $class->new( name => "Larry" )) && $o->isa($class), "Creating a $class object" ); #--------------------------------------------------------------------------# is( $o->name, "Larry", "initialized readonly accessor readable and correct" ); is( $o->age, undef, "uninitialized readonly accessor returns undef" ); eval { $o->age(23) }; my $err = $@; like( $err, '/age\(\) is read-only/i', "readonly accessor dies if given an argument" ); Class-InsideOut-1.14/t/23_accessor_hooks_blessed.t000644 000765 000024 00000005646 13070235143 022312 0ustar00davidstaff000000 000000 use strict; use lib "."; use Test::More; # keep stdout and stderr in order on Win32 BEGIN { $|=1; my $oldfh = select(STDERR); $| = 1; select($oldfh); } #--------------------------------------------------------------------------# my $class = "t::Object::HookedBlessed"; my $properties = { $class => { integer => "public", uppercase => "public", word => "public", list => "public", reverser => "public", write_only => "public", }, }; my ($o, @got, $got); #--------------------------------------------------------------------------# plan tests => 21; require_ok( $class ); is_deeply( Class::InsideOut::_properties( $class ), $properties, "$class has/inherited its expected properties" ); ok( ($o = $class->new()) && $o->isa($class), "Creating a $class object" ); #--------------------------------------------------------------------------# eval { $o->integer(3.14) }; my $err = $@; like( $err, '/integer\(\) must be an integer at/i', "integer(3.14) dies" ); my $at_count = () = $err =~ /at/g; is( $at_count, 1, "'at' count correct" ); eval { $o->integer(42) }; is( $@, q{}, "integer(42) lives" ); is( $o->integer, 42, "integer() == 42" ); #--------------------------------------------------------------------------# eval { $o->word("^^^^") }; like( $@, '/word\(\) must be a Perl word at/i', "word(^^^^) dies" ); eval { $o->word("apple") }; is( $@, q{}, "word(apple) lives" ); is( $o->word, 'apple', "word() eq 'apple'" ); #--------------------------------------------------------------------------# eval { $o->uppercase("banana") }; is( $@, q{}, "uppercase(banana) lives" ); is( $o->uppercase, 'BANANA', "uppercase() eq 'BANANA'" ); #--------------------------------------------------------------------------# # list(@array) eval { $o->list(qw(foo bar bam)) }; is( $@, q{}, "list(qw(foo bar bam)) lives" ); is_deeply( [ $o->list ], [qw(foo bar bam)], "list() gives qw(foo bar bam)" ); # list(\@array) eval { $o->list( [qw(foo bar bam)] ) }; is( $@, q{}, "list( [qw(foo bar bam)] ) lives" ); is_deeply( [ $o->list ], [qw(foo bar bam)], "list() gives qw(foo bar bam)" ); #--------------------------------------------------------------------------# eval { $o->reverser(qw(foo bar bam)) }; is( $@, q{}, "reverser(qw(foo bar bam)) lives" ); # reverser in list context @got = $o->reverser; is_deeply( \@got, [qw(bam bar foo)], "reverser() in list context gives qw(bam bar foo)" ); # reverser in scalar context $got = $o->reverser; is( $got, 'mabraboof', "reverser() in scalar context gives mabraboof" ); #--------------------------------------------------------------------------# eval { $o->write_only( 23 ) }; is( $@, q{}, "write_only lives on write" ); eval { $got = $o->write_only() }; like( $@, '/write_only\(\) is write-only at/i', "write only dies on write (and was caught)" ); Class-InsideOut-1.14/t/24_accessor_hooks_overloaded.t000644 000765 000024 00000006031 13070235143 023003 0ustar00davidstaff000000 000000 use strict; use lib "."; use Test::More; # keep stdout and stderr in order on Win32 BEGIN { $|=1; my $oldfh = select(STDERR); $| = 1; select($oldfh); } #--------------------------------------------------------------------------# my $class = "t::Object::HookedOverloaded"; my $properties = { $class => { integer => "public", uppercase => "public", word => "public", list => "public", reverser => "public", write_only => "public", }, }; my ($o, @got, $got); BEGIN { my $has_tt = eval 'use 5.008003; 1'; $has_tt or plan skip_all => 'test requires Perl 5.8.3'; } #--------------------------------------------------------------------------# plan tests => 21; require_ok( $class ); is_deeply( Class::InsideOut::_properties( $class ), $properties, "$class has/inherited its expected properties" ); ok( ($o = $class->new()) && $o->isa($class), "Creating a $class object" ); #--------------------------------------------------------------------------# eval { $o->integer(3.14) }; my $err = $@; like( $err, '/integer\(\) must be an integer at/i', "integer(3.14) dies" ); my $at_count = () = $err =~ /at/g; is( $at_count, 1, "'at' count correct" ); eval { $o->integer(42) }; is( $@, q{}, "integer(42) lives" ); is( $o->integer, 42, "integer() == 42" ); #--------------------------------------------------------------------------# eval { $o->word("^^^^") }; like( $@, '/word\(\) must be a Perl word at/i', "word(^^^^) dies" ); eval { $o->word("apple") }; is( $@, q{}, "word(apple) lives" ); is( $o->word, 'apple', "word() eq 'apple'" ); #--------------------------------------------------------------------------# eval { $o->uppercase("banana") }; is( $@, q{}, "uppercase(banana) lives" ); is( $o->uppercase, 'BANANA', "uppercase() eq 'BANANA'" ); #--------------------------------------------------------------------------# # list(@array) eval { $o->list(qw(foo bar bam)) }; is( $@, q{}, "list(qw(foo bar bam)) lives" ); is_deeply( [ $o->list ], [qw(foo bar bam)], "list() gives qw(foo bar bam)" ); # list(\@array) eval { $o->list( [qw(foo bar bam)] ) }; is( $@, q{}, "list( [qw(foo bar bam)] ) lives" ); is_deeply( [ $o->list ], [qw(foo bar bam)], "list() gives qw(foo bar bam)" ); #--------------------------------------------------------------------------# eval { $o->reverser(qw(foo bar bam)) }; is( $@, q{}, "reverser(qw(foo bar bam)) lives" ); # reverser in list context @got = $o->reverser; is_deeply( \@got, [qw(bam bar foo)], "reverser() in list context gives qw(bam bar foo)" ); # reverser in scalar context $got = $o->reverser; is( $got, 'mabraboof', "reverser() in scalar context gives mabraboof" ); #--------------------------------------------------------------------------# eval { $o->write_only( 23 ) }; is( $@, q{}, "write_only lives on write" ); eval { $got = $o->write_only() }; like( $@, '/write_only\(\) is write-only at/i', "write only dies on write (and was caught)" ); Class-InsideOut-1.14/t/25_accessor_hooks_typetiny.t000644 000765 000024 00000006021 13070235143 022544 0ustar00davidstaff000000 000000 use strict; use lib "."; use Test::More; # keep stdout and stderr in order on Win32 BEGIN { $|=1; my $oldfh = select(STDERR); $| = 1; select($oldfh); } #--------------------------------------------------------------------------# my $class = "t::Object::HookedTT"; my $properties = { $class => { integer => "public", uppercase => "public", word => "public", list => "public", reverser => "public", write_only => "public", }, }; my ($o, @got, $got); BEGIN { my $has_tt = eval 'use 5.008003; require Type::Tiny;'; $has_tt or plan skip_all => 'test requires Perl 5.8.3 and Type::Tiny'; } #--------------------------------------------------------------------------# plan tests => 20; require_ok( $class ); is_deeply( Class::InsideOut::_properties( $class ), $properties, "$class has/inherited its expected properties" ); ok( ($o = $class->new()) && $o->isa($class), "Creating a $class object" ); #--------------------------------------------------------------------------# eval { $o->integer(3.14) }; my $err = $@; like( $err, '/integer\(\) value "3.14" did not pass type constraint "Int"/i', "integer(3.14) dies" ); eval { $o->integer(42) }; is( $@, q{}, "integer(42) lives" ); is( $o->integer, 42, "integer() == 42" ); #--------------------------------------------------------------------------# eval { $o->word("^^^^") }; like( $@, '/word\(\) value "\^\^\^\^" did not pass type constraint/i', "word(^^^^) dies" ); eval { $o->word("apple") }; is( $@, q{}, "word(apple) lives" ); is( $o->word, 'apple', "word() eq 'apple'" ); #--------------------------------------------------------------------------# eval { $o->uppercase("banana") }; is( $@, q{}, "uppercase(banana) lives" ); is( $o->uppercase, 'BANANA', "uppercase() eq 'BANANA'" ); #--------------------------------------------------------------------------# # list(@array) eval { $o->list(qw(foo bar bam)) }; is( $@, q{}, "list(qw(foo bar bam)) lives" ); is_deeply( [ $o->list ], [qw(foo bar bam)], "list() gives qw(foo bar bam)" ); # list(\@array) eval { $o->list( [qw(foo bar bam)] ) }; is( $@, q{}, "list( [qw(foo bar bam)] ) lives" ); is_deeply( [ $o->list ], [qw(foo bar bam)], "list() gives qw(foo bar bam)" ); #--------------------------------------------------------------------------# eval { $o->reverser(qw(foo bar bam)) }; is( $@, q{}, "reverser(qw(foo bar bam)) lives" ); # reverser in list context @got = $o->reverser; is_deeply( \@got, [qw(bam bar foo)], "reverser() in list context gives qw(bam bar foo)" ); # reverser in scalar context $got = $o->reverser; is( $got, 'mabraboof', "reverser() in scalar context gives mabraboof" ); #--------------------------------------------------------------------------# eval { $o->write_only( 23 ) }; is( $@, q{}, "write_only lives on write" ); eval { $got = $o->write_only() }; like( $@, '/write_only\(\) is write-only at/i', "write only dies on write (and was caught)" ); Class-InsideOut-1.14/t/data/000755 000765 000024 00000000000 13070235143 016011 5ustar00davidstaff000000 000000 Class-InsideOut-1.14/t/Object/000755 000765 000024 00000000000 13070235143 016306 5ustar00davidstaff000000 000000 Class-InsideOut-1.14/t/Object/Animal/000755 000765 000024 00000000000 13070235143 017507 5ustar00davidstaff000000 000000 Class-InsideOut-1.14/t/Object/Animal.pm000644 000765 000024 00000001746 13070235143 020055 0ustar00davidstaff000000 000000 package t::Object::Animal; use strict; use Class::InsideOut; use Scalar::Util qw( refaddr ); Class::InsideOut::options( { privacy => 'public', } ); Class::InsideOut::property( nickname => my %nickname ); #20997: Duplicate property name Class::InsideOut::property( name => my %name ); Class::InsideOut::property( species => my %species ); Class::InsideOut::property( Genus => my %genus ); # Globals for testing use vars qw( $animal_count @subclass_errors $freezings $thawings ); sub new { my $class = shift; my $self = bless \do {my $s}, $class; Class::InsideOut::register($self); $name{ refaddr $self } = undef; $species{ refaddr $self } = undef; $animal_count++; return $self; } sub DEMOLISH { my $self = shift; $animal_count--; if ( ref $self ne "t::Object::Animal" ) { push @subclass_errors, ref $self; } } sub FREEZE { my $self = shift; $freezings++; } sub THAW { my $self = shift; $thawings++; } 1; Class-InsideOut-1.14/t/Object/Array.pm000644 000765 000024 00000000270 13070235143 017721 0ustar00davidstaff000000 000000 package t::Object::Array; use strict; use Class::InsideOut qw( public register ); public name => my %name; public height => my %height; sub new { register( bless [], shift ) } 1; Class-InsideOut-1.14/t/Object/Foreign.pm000644 000765 000024 00000000572 13070235143 020241 0ustar00davidstaff000000 000000 package t::Object::Foreign; use strict; use Class::InsideOut qw( register public id ); BEGIN { require IO::File; @t::Object::Foreign::ISA = 'IO::File'; } public name => my %name; sub new { my ($class, $filename) = @_; my $self = IO::File->new; $self->open( $filename ) if defined $filename && length $filename; register( bless $self, $class ); } 1; Class-InsideOut-1.14/t/Object/Friends.pm000644 000765 000024 00000002207 13070235143 020237 0ustar00davidstaff000000 000000 package t::Object::Friends; use strict; use Class::InsideOut qw( public private register id ); public name => my %name; private friends => my %friends; sub new { my ($class, $args) = @_; my $self = []; bless $self, $class; # initialize from constructor if ( ref $args eq 'HASH' ) { $name { id $self } = $args->{name}; if ( defined $args->{friends} ) { if ( ref $args->{friends} eq 'ARRAY' ) { $friends{ id $self } = $args->{friends}; } else { $friends{ id $self } = [ $args->{friends} ]; } } } # register the object for thread-safety register( $self ); } # pass undef as first arg to clear the list sub friends { my ($self, @friends) = @_; if ( @friends ) { if ( ! defined $friends[0] ) { $friends{ id $self } = []; } else { $friends{ id $self } = [ @friends ]; } return $self; } return @{ $friends{ id $self } }; } sub has_friend { my ( $self, $obj ) = @_; return scalar grep { $_ == $obj } @{ $friends{ id $self } }; } 1; Class-InsideOut-1.14/t/Object/Hash.pm000644 000765 000024 00000000267 13070235143 017534 0ustar00davidstaff000000 000000 package t::Object::Hash; use strict; use Class::InsideOut qw( public register ); public name => my %name; public weight => my %weight; sub new { register( bless {}, shift ) } 1; Class-InsideOut-1.14/t/Object/Hooked.pm000644 000765 000024 00000001644 13070235143 020062 0ustar00davidstaff000000 000000 package t::Object::Hooked; use Class::InsideOut ':std'; # $_ has the first argument in it for convenience public integer => my %integer, { set_hook => sub { /\A\d+\z/ or die "must be an integer\n" }, }; # first argument is also available directly public word => my %word, { set_hook => sub { $_[0] =~ /\A\w+\z/ or die "must be a Perl word\n" }, }; # Changing $_ changes what gets stored public uppercase => my %uppercase, { set_hook => sub { $_[0] = uc }, }; # Full @_ is available, but only first gets stored public list => my %list, { set_hook => sub { $_ = ref $_ eq 'ARRAY' ? $_ : [ @_ ] }, get_hook => sub { @$_ }, }; public reverser => my %reverser, { set_hook => sub { $_ = (ref $_ eq 'ARRAY') ? $_ : [ @_ ] }, get_hook => sub { reverse @$_ } }; public write_only => my %only_only, { get_hook => sub { die "is write-only\n" } }; sub new { register( bless {}, shift ); } 1; Class-InsideOut-1.14/t/Object/HookedBlessed.pm000644 000765 000024 00000002002 13070235143 021351 0ustar00davidstaff000000 000000 package t::Object::HookedBlessed; sub mysub (&) { bless $_[0], 't::Object::HookedBlessed::mysub'; } use Class::InsideOut ':std'; # $_ has the first argument in it for convenience public integer => my %integer, { set_hook => mysub { /\A\d+\z/ or die "must be an integer\n" }, }; # first argument is also available directly public word => my %word, { set_hook => mysub { $_[0] =~ /\A\w+\z/ or die "must be a Perl word\n" }, }; # Changing $_ changes what gets stored public uppercase => my %uppercase, { set_hook => mysub { $_[0] = uc }, }; # Full @_ is available, but only first gets stored public list => my %list, { set_hook => mysub { $_ = ref $_ eq 'ARRAY' ? $_ : [ @_ ] }, get_hook => mysub { @$_ }, }; public reverser => my %reverser, { set_hook => mysub { $_ = (ref $_ eq 'ARRAY') ? $_ : [ @_ ] }, get_hook => mysub { reverse @$_ } }; public write_only => my %only_only, { get_hook => mysub { die "is write-only\n" } }; sub new { register( bless {}, shift ); } 1; Class-InsideOut-1.14/t/Object/HookedOverloaded.pm000644 000765 000024 00000002137 13070235143 022065 0ustar00davidstaff000000 000000 package t::Object::HookedOverloaded; sub mysub (&) { package t::Object::HookedOverloaded::mysub; use overload q[&{}] => sub { shift->{code} }, fallback => 1; bless { code => $_[0] }; } use Class::InsideOut ':std'; # $_ has the first argument in it for convenience public integer => my %integer, { set_hook => mysub { /\A\d+\z/ or die "must be an integer\n" }, }; # first argument is also available directly public word => my %word, { set_hook => mysub { $_[0] =~ /\A\w+\z/ or die "must be a Perl word\n" }, }; # Changing $_ changes what gets stored public uppercase => my %uppercase, { set_hook => mysub { $_[0] = uc }, }; # Full @_ is available, but only first gets stored public list => my %list, { set_hook => mysub { $_ = ref $_ eq 'ARRAY' ? $_ : [ @_ ] }, get_hook => mysub { @$_ }, }; public reverser => my %reverser, { set_hook => mysub { $_ = (ref $_ eq 'ARRAY') ? $_ : [ @_ ] }, get_hook => mysub { reverse @$_ } }; public write_only => my %only_only, { get_hook => mysub { die "is write-only\n" } }; sub new { register( bless {}, shift ); } 1; Class-InsideOut-1.14/t/Object/HookedTT.pm000644 000765 000024 00000001705 13070235143 020330 0ustar00davidstaff000000 000000 package t::Object::HookedTT; use Class::InsideOut ':std'; use Types::Standard -types; # $_ has the first argument in it for convenience public integer => my %integer, { set_hook => Int }; # first argument is also available directly public word => my %word, { set_hook => StrMatch[qr/\A\w+\z/] }; # Changing $_ changes what gets stored my $UC = (StrMatch[qr/\A[A-Z]+\z/])->plus_coercions(Str, q{uc $_}); public uppercase => my %uppercase, { set_hook => sub { $_ = $UC->coercion->($_) }, }; # Full @_ is available, but only first gets stored public list => my %list, { set_hook => sub { $_ = ArrayRef->check($_) ? $_ : [ @_ ] }, get_hook => sub { @$_ }, }; public reverser => my %reverser, { set_hook => sub { $_ = ArrayRef->check($_) ? $_ : [ @_ ] }, get_hook => sub { reverse @$_ } }; public write_only => my %only_only, { get_hook => sub { die "is write-only\n" } }; sub new { register( bless {}, shift ); } 1; Class-InsideOut-1.14/t/Object/ReadOnly.pm000644 000765 000024 00000000176 13070235143 020365 0ustar00davidstaff000000 000000 package t::Object::ReadOnly; use Class::InsideOut qw/readonly new/; readonly name => my %name; readonly age => my %age; 1; Class-InsideOut-1.14/t/Object/RegisterClassname.pm000644 000765 000024 00000000203 13070235143 022252 0ustar00davidstaff000000 000000 package t::Object::RegisterClassname; use strict; use Class::InsideOut; sub new { Class::InsideOut::register( shift ); } 1; Class-InsideOut-1.14/t/Object/RegisterRef.pm000644 000765 000024 00000000200 13070235143 021055 0ustar00davidstaff000000 000000 package t::Object::RegisterRef; use strict; use Class::InsideOut; sub new { Class::InsideOut::register( {}, shift); } 1; Class-InsideOut-1.14/t/Object/Scalar.pm000644 000765 000024 00000000332 13070235143 020047 0ustar00davidstaff000000 000000 package t::Object::Scalar; #@ISA = qw( Bogus::Superclass ); use strict; use Class::InsideOut qw( public register ); public name => my %name; public age => my %age; sub new { register( bless \(my $s), shift) } 1; Class-InsideOut-1.14/t/Object/Singleton/000755 000765 000024 00000000000 13070235143 020250 5ustar00davidstaff000000 000000 Class-InsideOut-1.14/t/Object/Synopsis.pm000644 000765 000024 00000001037 13070235143 020474 0ustar00davidstaff000000 000000 package t::Object::Synopsis; use strict; use Class::InsideOut ':std'; # public, private, register and id public name => my %name; # accessor: name() private ssn => my %ssn; # no accessor public age => my %age, { set_hook => sub { /^\d+$/ or die "must be an integer" } }; public initials => my %initials, { set_hook => sub { $_ = uc $_ } }; sub new { register( bless \(my $s), shift ); } sub greeting { my $self = shift; return "Hello, my name is $name{ id $self }"; } 1; Class-InsideOut-1.14/t/Object/Trivial.pm000644 000765 000024 00000000210 13070235143 020247 0ustar00davidstaff000000 000000 package t::Object::Trivial; use strict; use Class::InsideOut; sub new { Class::InsideOut::register( bless \(my $s), shift); } 1; Class-InsideOut-1.14/t/Object/WithNew/000755 000765 000024 00000000000 13070235143 017673 5ustar00davidstaff000000 000000 Class-InsideOut-1.14/t/Object/WithNew.pm000644 000765 000024 00000000251 13070235143 020227 0ustar00davidstaff000000 000000 package t::Object::WithNew; use Class::InsideOut qw/ :std new /; public name => my %name; private age => my %age; sub reveal_age { return $age{ id shift }; } 1; Class-InsideOut-1.14/t/Object/WithNew/Inherited.pm000644 000765 000024 00000000402 13070235143 022140 0ustar00davidstaff000000 000000 package t::Object::WithNew::Inherited; BEGIN { require t::Object::WithNew; @t::Object::WithNew::Inherited::ISA = 't::Object::WithNew'; } use Class::InsideOut qw/ :std /; private age => my %age; sub reveal_age { return $age{ id shift }; } 1; Class-InsideOut-1.14/t/Object/Singleton/Hooked.pm000644 000765 000024 00000001023 13070235143 022013 0ustar00davidstaff000000 000000 package t::Object::Singleton::Hooked; use strict; use Class::InsideOut qw( public register id :singleton ); public name => my %name; use vars qw/$self/; sub get_instance { $self ||= register( bless \(my $s), shift); return $self; } sub ATTACH { my ($class, $cloning, $data) = @_; if ( $self ) { return $self; } else { my $obj = $class->get_instance(); my $package = __PACKAGE__; $name{ id $obj } = $data->{properties}{$package}{name}; return $obj; } } 1; Class-InsideOut-1.14/t/Object/Singleton/MissingConstructor.pm000644 000765 000024 00000000424 13070235143 024465 0ustar00davidstaff000000 000000 package t::Object::Singleton::MissingConstructor; use strict; use Class::InsideOut qw( public register :singleton ); BEGIN { public name => my %name; } my $self = register( bless \(my $s), __PACKAGE__); # weirdly named constructor sub get_it { return $self } 1; Class-InsideOut-1.14/t/Object/Singleton/Simple.pm000644 000765 000024 00000000360 13070235143 022036 0ustar00davidstaff000000 000000 package t::Object::Singleton::Simple; use strict; use Class::InsideOut qw( public register :singleton ); public name => my %name; use vars qw/ $self /; sub new { $self ||= register( bless \(my $s), shift); return $self; } 1; Class-InsideOut-1.14/t/Object/Animal/Antelope.pm000644 000765 000024 00000000767 13070235143 021626 0ustar00davidstaff000000 000000 package t::Object::Animal::Antelope; BEGIN { require t::Object::Animal; @t::Object::Animal::Antelope::ISA = 't::Object::Animal'; } use Class::InsideOut qw( property public id ); # superclass is handling new() Class::InsideOut::options( { privacy => 'private' } ); # should override default options above property color => my %color, { privacy => 'public' }; # should revert back to defaults property panicked => my %panicked; # should override default public points => my %points; 1; Class-InsideOut-1.14/t/Object/Animal/Jackalope.pm000644 000765 000024 00000001165 13070235143 021741 0ustar00davidstaff000000 000000 package t::Object::Animal::Jackalope; BEGIN { for ( 't::Object::Animal::Antelope', 't::Object::Animal::JackRabbit' ) { eval "require $_"; push @t::Object::Animal::Jackalope::ISA, $_; } } use Class::InsideOut qw( private property id ); # superclass is handling new() Class::InsideOut::options( { privacy => 'public' } ); property kills => my %kills; private whiskers => my %whiskers; private sidekick => my %sidekick, { privacy => 'public' }; use vars qw( $freezings $thawings ); sub FREEZE { my $self = shift; $freezings++; } sub THAW { my $self = shift; $thawings++; } 1; Class-InsideOut-1.14/t/Object/Animal/JackRabbit.pm000644 000765 000024 00000000424 13070235143 022041 0ustar00davidstaff000000 000000 package t::Object::Animal::JackRabbit; BEGIN { require t::Object::Animal; @t::Object::Animal::JackRabbit::ISA = 't::Object::Animal'; } use Class::InsideOut qw( property id ); # superclass is handling new() property speed => my %speed, { privacy => "public" }; 1; Class-InsideOut-1.14/t/data/testdata.txt000644 000765 000024 00000000016 13070235143 020360 0ustar00davidstaff000000 000000 one two three Class-InsideOut-1.14/lib/Class/000755 000765 000024 00000000000 13070235143 016450 5ustar00davidstaff000000 000000 Class-InsideOut-1.14/lib/Class/InsideOut/000755 000765 000024 00000000000 13070235143 020353 5ustar00davidstaff000000 000000 Class-InsideOut-1.14/lib/Class/InsideOut.pm000644 000765 000024 00000076663 13070235143 020733 0ustar00davidstaff000000 000000 package Class::InsideOut; use strict; # ABSTRACT: a safe, simple inside-out object construction kit our $VERSION = '1.14'; use vars qw/@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS/; @ISA = qw ( Exporter ); @EXPORT = qw ( ); # nothing by default @EXPORT_OK = qw ( new id options private property public readonly register ); %EXPORT_TAGS = ( "std" => [ qw( id private public readonly register ) ], "new" => [ qw( new ) ], "all" => [ @EXPORT_OK ], "singleton" => [], # just a flag for import() ); use Carp; use Exporter; use Class::ISA; use Scalar::Util 1.09 qw( refaddr reftype blessed ); # Check for XS Scalar::Util with weaken() or warn and fallback # syntax of error changed in Scalar::Util so we check both versions BEGIN { eval { Scalar::Util->import( "weaken" ) }; if ( $@ =~ /\AWeak references|weaken is only available/ ) { warn "Scalar::Util::weaken unavailable: " . "Class::InsideOut will not be thread-safe and will leak memory\n"; *weaken = sub { return @_ }; } } #--------------------------------------------------------------------------# # Class data #--------------------------------------------------------------------------# my %PROP_DATA_FOR; # class => { prop_name => property hashrefs } my %PUBLIC_PROPS_FOR; # class => { prop_name => 1 } my %CLASS_ISA; # class => [ list of self and @ISA tree ] my %OPTIONS; # class => { default accessor options } my %OBJECT_REGISTRY; # refaddr => weak object reference #--------------------------------------------------------------------------# # option validation parameters #--------------------------------------------------------------------------# # Private but global so related classes can define their own valid options # if they need them. Modify at your own risk. Done this way so as to # avoid creating class functions to do the same basic thing use vars qw( %_OPTION_VALIDATION ); sub __coderef { return 1 if reftype($_[0])||"" eq 'CODE'; # Avoid loading overload.pm unless we'd have to die otherwise require overload; return 1 if overload::Overloaded($_[0]) && overload::Method($_[0], q[&{}]); die "must be a code reference"; } %_OPTION_VALIDATION = ( privacy => sub { my $v = shift; $v =~ /public|private/ or die "'$v' is not a valid privacy setting" }, set_hook => \&__coderef, get_hook => \&__coderef, ); #--------------------------------------------------------------------------# # public functions #--------------------------------------------------------------------------# sub import { no strict 'refs'; my $caller = caller; *{ "$caller\::DESTROY" } = _gen_DESTROY( $caller ); # check for ":singleton" and do export attach instead of thaw if ( grep { $_ eq ":singleton" } @_ ) { *{ "$caller\::STORABLE_freeze" } = _gen_STORABLE_freeze( $caller, 1 ); *{ "$caller\::STORABLE_attach" } = _gen_STORABLE_attach( $caller ); @_ = grep { $_ ne ':singleton' } @_; # strip it back out } else { *{ "$caller\::STORABLE_freeze" } = _gen_STORABLE_freeze( $caller, 0 ); *{ "$caller\::STORABLE_thaw" } = _gen_STORABLE_thaw( $caller ); } local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; &Exporter::import; } BEGIN { *id = \&Scalar::Util::refaddr; } sub options { my $opt = shift; my $caller = caller; _check_options( $opt ) if defined $opt; return %{ $OPTIONS{ $caller } = _merge_options( $caller, $opt ) }; } sub new { my $class = shift; croak "new() must be called as a class method" if ref $class; my $self = register( $class ); return $self unless @_; # initialization croak "Arguments to new must be a hash or hash reference" if ( @_ == 1 && ! ( ref $_[0] && reftype($_[0]) eq 'HASH' ) ) || ( @_ > 1 && @_ % 2 ); my %args = (@_ == 1) ? %{$_[0]} : @_; for my $prop ( keys %args ) { for my $c ( _class_tree( $class ) ) { my $properties = $PROP_DATA_FOR{ $c }; next unless $properties; if ( exists $properties->{$prop} ) { $properties->{$prop}{ refaddr $self } = $args{$prop}; } } } return $self; } sub private($\%;$) { ## no critic -- prototype &_check_property; $_[2] ||= {}; $_[2] = { %{$_[2]}, privacy => 'private' }; goto &_install_property; } sub property($\%;$) { ## no critic -- prototype &_check_property; goto &_install_property; } sub public($\%;$) { ## no critic -- prototype &_check_property; $_[2] ||= {}; $_[2] = { %{$_[2]}, privacy => 'public' }; goto &_install_property; } sub readonly($\%;$) { ## no critic -- prototype &_check_property; $_[2] ||= {}; $_[2] = { %{$_[2]}, privacy => 'public', set_hook => sub { die "is read-only\n" } }; goto &_install_property; } sub register { my ($obj); if ( @_ == 0 ) { # register() croak "Invalid call to register(): empty argument list" } elsif ( @_ == 1 ) { # register( OBJECT | CLASSNAME ) if ( blessed $_[0] ) { $obj = shift; } elsif ( ref \$_[0] eq 'SCALAR' ) { $obj = \(my $scalar); bless $obj, shift; } else { croak "Invalid argument '$_[0]' to register(): " . "must be an object or class name" } } else { # register( REFERENCE/OBJECT, CLASSNAME ) $obj = shift; bless $obj, shift; # ok to rebless } weaken( $OBJECT_REGISTRY{ refaddr $obj } = $obj ); return $obj; } #--------------------------------------------------------------------------# # private functions for implementation #--------------------------------------------------------------------------# # Registering is global to avoid having to register objects for each class. # CLONE is not exported but CLONE in Class::InsideOut updates all registered # objects for all properties across all classes sub CLONE { my $class = shift; # assemble references to all properties for all classes my @properties = map { values %$_ } values %PROP_DATA_FOR; for my $old_id ( keys %OBJECT_REGISTRY ) { # retrieve the new object and id my $object = $OBJECT_REGISTRY{ $old_id }; my $new_id = refaddr $object; # for all properties, relocate data to the new id if # the property has data under the old id for my $prop ( @properties ) { next unless exists $prop->{ $old_id }; $prop->{ $new_id } = $prop->{ $old_id }; delete $prop->{ $old_id }; } # update the registry to the new, cloned object weaken ( $OBJECT_REGISTRY{ $new_id } = $object ); _deregister( $old_id ); } } sub _check_options{ my ($opt) = @_; local $Carp::CarpLevel = $Carp::CarpLevel + 1; croak "Invalid options argument '$opt': must be a hash reference" if ref $opt ne 'HASH'; my @valid_keys = keys %_OPTION_VALIDATION; for my $key ( keys %$opt ) { croak "Invalid option '$key': unknown option" if ! grep { $_ eq $key } @valid_keys; eval { $_OPTION_VALIDATION{$key}->( $opt->{$key} ) }; croak "Invalid option '$key': $@" if $@; } return; } sub _check_property { my ($label, $hash, $opt) = @_; local $Carp::CarpLevel = $Carp::CarpLevel + 1; croak "Invalid property name '$label': must be a perl identifier" if $label !~ /\A[a-z_]\w*\z/i; croak "Duplicate property name '$label'" if grep { $_ eq $label } keys %{ $PROP_DATA_FOR{ caller(1) } }; _check_options( $opt ) if defined $opt; return; } sub _class_tree { my $class = shift; $CLASS_ISA{ $class } ||= [ Class::ISA::self_and_super_path( $class ) ]; return @{ $CLASS_ISA{ $class } }; } # take either object or object id sub _deregister { my ($arg) = @_; my $obj_id = ref $arg ? refaddr $arg : $arg; delete $OBJECT_REGISTRY{ $obj_id }; return; } # turn object into hash -- see _revert() sub _evert { my ( $obj ) = @_; # Extract properties to save my %property_vals; for my $c ( _class_tree( ref $obj) ) { next unless exists $PROP_DATA_FOR{ $c }; my $properties = $PROP_DATA_FOR{ $c }; for my $prop ( keys %$properties ) { my $value = exists $properties->{$prop}{ refaddr $obj } ? $properties->{$prop}{ refaddr $obj } : undef ; $property_vals{$c}{$prop} = $value; } } # extract object reference contents (by type) my $type = reftype $obj; my $contents = $type eq 'SCALAR' ? \do{ my $s = $$obj } : $type eq 'ARRAY' ? [ @$obj ] : $type eq 'HASH' ? { %$obj } : undef # other types not supported ; # assemble reference to hand back return { class => ref $obj, type => $type, contents => $contents, properties => \%property_vals }; } sub _gen_accessor { my ($ref) = @_; return sub { my $obj = shift; my $obj_id = refaddr $obj; $ref->{ $obj_id } = shift if (@_); return $ref->{ $obj_id }; }; } sub _gen_hook_accessor { my ($ref, $name, $get_hook, $set_hook) = @_; return sub { my ($obj,@args) = @_; my $obj_id = refaddr $obj; if (@args) { local *_ = \($args[0]); if ($set_hook) { eval { $set_hook->(@args) }; if ( $@ ) { chomp $@; croak "$name() $@" } $ref->{ $obj_id } = shift @args; } else { $ref->{ $obj_id } = shift @args; } } elsif ($get_hook) { local $_ = $ref->{ $obj_id }; my ( $value, @value ); if ( wantarray ) { @value = eval { $get_hook->() }; } else { $value = eval { $get_hook->() }; } if ( $@ ) { chomp $@; croak "$name() $@" } return wantarray ? @value : $value; } else { return $ref->{ $obj_id }; } }; } sub _gen_DESTROY { my $class = shift; return sub { my $obj = shift; my $obj_id = refaddr $obj; # cache for later property deletes # Call a custom DEMOLISH hook if one exists. my $demolish; { no strict 'refs'; $demolish = *{ "$class\::DEMOLISH" }{CODE}; } $demolish->($obj) if defined $demolish; # Clean up properties in all Class::InsideOut parents for my $c ( _class_tree( $class ) ) { next unless exists $PROP_DATA_FOR{ $c }; delete $_->{ $obj_id } for values %{ $PROP_DATA_FOR{ $c } }; } # XXX this global registry could be deleted repeatedly # in superclasses -- SUPER::DESTROY shouldn't be called by DEMOLISH # it should only call SUPER::DEMOLISH if need be; still, # rest of the destructor doesn't need the registry, so early deletion # by a subclass should be safe _deregister( $obj ); return; }; } sub _gen_STORABLE_attach { my $class = shift; return sub { my ( $class, $cloning, $serialized ) = @_; require Storable; my $data = Storable::thaw( $serialized ); # find a user attach hook my $hook; { no strict 'refs'; $hook = *{ "$class\::ATTACH" }{CODE}; } # try user hook to recreate, otherwise new(), otherwise give up if ( defined $hook ) { return $hook->($class, $cloning, $data); } elsif ( $class->can( "new" ) ) { return $class->new(); } else { warn "Error attaching to $class:\n" . "Couldn't find STORABLE_attach_hook() or new() in $class\n"; return; } }; } sub _gen_STORABLE_freeze { my ($class, $singleton) = @_; return sub { my ( $obj, $cloning ) = @_; # Call STORABLE_freeze_hooks in each class if they exists for my $c ( _class_tree( ref $obj ) ) { my $hook; { no strict 'refs'; $hook = *{ "$c\::FREEZE" }{CODE}; } $hook->($obj) if defined $hook; } # Extract properties to save my $data = _evert( $obj ); if ( $singleton ) { # can't return refs, so freeze data as string and return require Storable; return Storable::freeze( $data ); } else { # return $serialized, @refs # serialized string doesn't matter -- all data has been moved into # the additional ref return 'BOGUS', $data; } }; } sub _gen_STORABLE_thaw { my $class = shift; return sub { my ( $obj, $cloning, $serialized, $data ) = @_; _revert( $data, $obj ); # Call STORABLE_thaw_hooks in each class if they exists for my $c ( _class_tree( ref $obj ) ) { my $hook; { no strict 'refs'; $hook = *{ "$c\::THAW" }{CODE}; } $hook->($obj) if defined $hook; } return; }; } sub _install_property{ my ($label, $hash, $opt) = @_; my $caller = caller(0); # we get here via "goto", so caller(0) is right $PROP_DATA_FOR{ $caller }{$label} = $hash; my $options = _merge_options( $caller, $opt ); if ( exists $options->{privacy} && $options->{privacy} eq 'public' ) { no strict 'refs'; *{ "$caller\::$label" } = ($options->{set_hook} || $options->{get_hook}) ? _gen_hook_accessor( $hash, $label, $options->{get_hook}, $options->{set_hook} ) : _gen_accessor( $hash ) ; $PUBLIC_PROPS_FOR{ $caller }{ $label } = 1; } return; } sub _merge_options { my ($class, $new_options) = @_; my @merged; push @merged, %{ $OPTIONS{ $class } } if defined $OPTIONS{ $class }; push @merged, %$new_options if defined $new_options; return { @merged }; } sub _revert { my ( $data, $obj ) = @_; my $contents = $data->{contents}; if ( defined $obj ) { # restore contents to the pregenerated object for ( reftype $obj ) { /SCALAR/ ? do { $$obj = $$contents } : /ARRAY/ ? do { @$obj = @$contents } : /HASH/ ? do { %$obj = %$contents } : do {} ; } } else { # just use the contents as the reference # and bless it back into an object $obj = $contents; } bless $obj, $data->{class}; # restore properties for my $c ( _class_tree( ref $obj ) ) { my $properties = $PROP_DATA_FOR{ $c }; next unless $properties; for my $prop ( keys %$properties ) { my $value = $data->{properties}{ $c }{ $prop }; $properties->{$prop}{ refaddr $obj } = $value; } } # register object register( $obj ); return $obj; } #--------------------------------------------------------------------------# # private functions for use in testing #--------------------------------------------------------------------------# sub _object_count { return scalar( keys %OBJECT_REGISTRY ); } sub _properties { my $class = shift; my %properties; for my $c ( _class_tree( $class ) ) { next if not exists $PROP_DATA_FOR{ $c }; for my $p ( keys %{ $PROP_DATA_FOR{ $c } } ) { $properties{$c}{$p} = exists $PUBLIC_PROPS_FOR{$c}{$p} ? "public" : "private"; } } return \%properties; } sub _leaking_memory { my %leaks; for my $class ( keys %PROP_DATA_FOR ) { for my $prop ( values %{ $PROP_DATA_FOR{ $class } } ) { for my $obj_id ( keys %$prop ) { $leaks{ $class }++ if not exists $OBJECT_REGISTRY{ $obj_id }; } } } return keys %leaks; } 1; # modules must return true __END__ =pod =encoding UTF-8 =head1 NAME Class::InsideOut - a safe, simple inside-out object construction kit =head1 VERSION version 1.14 =head1 SYNOPSIS package My::Class; use Class::InsideOut qw( public readonly private register id ); public name => my %name; # accessor: name() readonly ssn => my %ssn; # read-only accessor: ssn() private age => my %age; # no accessor sub new { register( shift ) } sub greeting { my $self = shift; return "Hello, my name is $name{ id $self }"; } =head1 DESCRIPTION This is a simple, safe and streamlined toolkit for building inside-out objects. Unlike most other inside-out object building modules already on CPAN, this module aims for minimalism and robustness: =over =item * Does not require derived classes to subclass it =item * Uses no source filters, attributes or C<<< CHECK >>> blocks =item * Supports any underlying object type including black-box inheritance =item * Does not leak memory on object destruction =item * Overloading-safe =item * Thread-safe for Perl 5.8.5 or better =item * C<<< mod_perl >>> compatible =item * Makes no assumption about inheritance or initializer needs =back It provides the minimal support necessary for creating safe inside-out objects and generating flexible accessors. =head2 Additional documentation =over =item * L -- Guide to the inside-out technique, the C<<< Class::InsideOut >>> philosophy, and other inside-out implementations =item * L -- Advanced topics including customizing accessors, black-box inheritance, serialization and thread safety =back =head1 USAGE =head2 Importing C<<< Class::InsideOut >>> C<<< Class::InsideOut >>> automatically imports several critical methods into the calling package, including C<<< DESTROY >>> and support methods for serializing objects with C<<< Storable >>>. These methods are intimately tied to correct functioning of inside-out objects and will always be imported regardless of whether additional functions are requested. Additional functions may be imported as usual by including them as arguments to C<<< use >>>. For example: use Class::InsideOut qw( register public ); public name => my %name; sub new { register( shift ) } As a shortcut, C<<< Class::InsideOut >>> supports two tags for importing sets of functions: =over =item * C<<< :std >>> provides C<<< id >>>, C<<< private >>>, C<<< public >>>, C<<< readonly >>> and C<<< register >>> =item * C<<< :all >>> imports all functions (including an optional constructor) =back B: Automatic imports can be bypassed via C<<< require >>> or by passing an empty list to C<<< use Class::InsideOut >>>. There is almost no circumstance in which this is a good idea. =head2 Object properties and accessors Object properties are declared with the C<<< public >>>, C<<< readonly >>> and C<<< private >>> functions. They must be passed a label and the lexical hash that will be used to store object properties: public name => my %name; readonly ssn => my %ssn; private age => my %age; Properties for an object are accessed through an index into the lexical hash based on the memory address of the object. This memory address I be obtained via C<<< Scalar::Util::refaddr >>>. The alias C<<< id >>> may be imported for brevity. $name{ refaddr $self } = "James"; $ssn { id $self } = 123456789; $age { id $self } = 32; B: since C<<< refaddr >>> and C<<< id >>> are function calls, it may be efficient to store the value once at the beginning of a method, particularly if it is being called repeatedly, e.g. within a loop. Object properties declared with C<<< public >>> will have an accessor created with the same name as the label. If the accessor is passed an argument, the property will be set to the argument. The accessor always returns the value of the property. # Outside the class $person = My::Class->new; $person->name( "Larry" ); Object properties declared with C<<< readonly >>> will have a read-only accessor created. The accessor will die if passed an argument to set the property value. The property may be set directly in the hash from within the class package as usual. # Inside the class $ssn { id $person } = 987654321; # Inside or outside the class $person->ssn( 123456789 ); # dies Property accessors may also be hand-written by declaring the property C<<< private >>> and writing whatever style of accessor is desired. For example: sub age { $age{ id $_[0] } } sub set_age { $age{ id $_[0] } = $_[1] } Hand-written accessors will be very slightly faster as generated accessors hold a reference to the property hash rather than accessing the property hash directly. It is also possible to use a package hash instead of a lexical hash to store object properties: public name => our %name; However, this makes private object data accessable outside the class and incurs a slight performance penalty when accessing the property hash directly; it is not recommended to do this unless you really need it for some specialized reason. =head2 Object construction C<<< Class::InsideOut >>> provides no default constructor method as there are many possible ways of constructing an inside-out object. This avoids constraining users to any particular object initialization or superclass initialization methodology. By using the memory address of the object as the index for properties, I type of reference may be used as the basis for an inside-out object with C<<< Class::InsideOut >>>. sub new { my $class = shift; my $self = \( my $scalar ); # anonymous scalar # my $self = {}; # anonymous hash # my $self = []; # anonymous array # open my $self, "<", $filename; # filehandle reference bless $self, $class; register( $self ); } However, to ensure that the inside-out object is thread-safe, the C<<< register >>> function I be called on the newly created object. The C<<< register >>> function may also be called with just the class name for the common case of blessing an anonymous scalar. register( $class ); # same as register( bless \(my $s), $class ) As a convenience, C<<< Class::InsideOut >>> provides an optional C<<< new >>> constructor for simple objects. This constructor automatically initializes the object from keyEvalue pairs passed to the constructor for all keys matching the name of a property (including otherwise "private" or "readonly" properties). A more advanced technique for object construction uses another object, usually a superclass object, as the object reference. See "black-box inheritance" in L. =head2 Object destruction C<<< Class::InsideOut >>> automatically exports a special C<<< DESTROY >>> function. This function cleans up object property memory for all declared properties the class and for all C<<< Class::InsideOut >>> based classes in the C<<< @ISA >>> array to avoid memory leaks or data collision. Additionally, if a user-supplied C<<< DEMOLISH >>> function is available in the same package, it will be called with the object being destroyed as its argument. C<<< DEMOLISH >>> can be used for custom destruction behavior such as updating class properties, closing sockets or closing database connections. Object properties will not be deleted until after C<<< DEMOLISH >>> returns. # Sample DEMOLISH: Count objects demolished (for whatever reason) my $objects_destroyed; sub DEMOLISH { $objects_destroyed++; } C<<< DEMOLISH >>> will only be called if it exists for an object's actual class. C<<< DEMOLISH >>> will not be inherited and C<<< DEMOLISH >>> will not be called automatically for any superclasses. C<<< DEMOLISH >>> should manage any necessary calls to superclass C<<< DEMOLISH >>> methods. As with C<<< new >>>, implementation details are left to the user based on the user's approach to object inheritance. Depending on how the inheritance chain is constructed and how C<<< DEMOLISH >>> is being used, users may wish to entirely override superclass C<<< DEMOLISH >>> methods, rely upon C<<< SUPER::DEMOLISH >>>, or may prefer to walk the entire C<<< @ISA >>> tree: use Class::ISA; sub DEMOLISH { my $self = shift; # class specific demolish actions # DEMOLISH for all parent classes, but only once my @parents = Class::ISA::super_path( __PACKAGE__ ); my %called; for my $p ( @parents ) { my $demolish = $p->can('DEMOLISH'); $demolish->($self) if not $called{ $demolish }++; } } =head1 FUNCTIONS =head2 C<<< id >>> $name{ id $object } = "Larry"; This is a shorter, mnemonic alias for C<<< Scalar::Util::refaddr >>>. It returns the memory address of an object (just like C<<< refaddr >>>) as the index to access the properties of an inside-out object. =head2 C<<< new >>> My::Class->new( name => "Larry", age => 42 ); This simplistic constructor is provided as a convenience and is only exported on request. When called as a class method, it returns a blessed anonymous scalar. Arguments will be used to initialize all matching inside-out class properties in the C<<< @ISA >>> tree. The argument may be a hash or hash reference. Note: Properties are set directly, not via accessors. This means C<<< set_hook >>> functions will not be called. For more robust argument checking, you will need to implement your own constructor. =head2 C<<< options >>> Class::InsideOut::options( \%new_options ); %current_options = Class::InsideOut::options(); The C<<< options >>> function sets default options for use with all subsequent property definitions for the calling package. If called without arguments, this function will return the options currently in effect. When called with a hash reference of options, these will be joined with the existing defaults, overriding any options of the same name. =head2 C<<< private >>> private weight => my %weight; private haircolor => my %hair_color, { %options }; This is an alias to C<<< property >>> that also sets the privacy option to 'private'. It will override default options or options passed as an argument. =head2 C<<< property >>> property name => my %name; property rank => my %rank, { %options }; Declares an inside-out property. Two arguments are required and a third is optional. The first is a label for the property; this label will be used for introspection and generating accessors and thus must be a valid perl identifier. The second argument must be the lexical hash that will be used to store data for that property. Note that the C<<< my >>> keyword can be included as part of the argument rather than as a separate statement. The property will be tracked for memory cleanup during object destruction and for proper thread-safety. If a third, optional argument is provided, it must be a reference to a hash of options that will be applied to the property and will override any default options that have been set. =head2 C<<< public >>> public height => my %height; public age => my %age, { %options }; This is an alias to C<<< property >>> that also sets the privacy option to 'public'. It will override default options or options passed as an argument. =head2 C<<< readonly >>> readonly ssn => my %ssn; readonly fingerprint => my %fingerprint, { %options }; This is an alias to C<<< property >>> that sets the privacy option to 'public' and adds a C<<< set_hook >>> option that dies if an attempt is made to use the accessor to change the property. It will override default options or options passed as an argument. =head2 C<<< register >>> register( bless( $object, $class ) ); # register the object register( $reference, $class ); # automatic bless register( $class ); # automatic blessed scalar Registers objects for thread-safety. This should be called as part of a constructor on a object blessed into the current package. Returns the resulting object. When called with only a class name, C<<< register >>> will bless an anonymous scalar reference into the given class. When called with both a reference and a class name, C<<< register >>> will bless the reference into the class. =head1 OPTIONS Options customize how properties are generated. Options may be set as a default with the C<<< options >>> function or passed as a hash reference to C<<< public >>>, C<<< private >>> or C<<< property >>>. Valid options include: =head2 C<<< privacy >>> property rank => my %rank, { privacy => 'public' }; property serial => my %serial, { privacy => 'private' }; If the I option is set to I, an accessor will be created with the same name as the label. If the accessor is passed an argument, the property will be set to the argument. The accessor always returns the value of the property. =head2 C<<< get_hook >>> public list => my %list, { get_hook => sub { @$_ } }; Defines an accessor hook for when values are retrieved. C<<< $_ >>> is locally aliased to the property value for the object. I See "Customizing Accessors" in L for details. The hook must be a coderef, including blessed coderefs and overloaded objects. =head2 C<<< set_hook >>> public age => my %age, { set_hook => sub { /^\d+$/ or die "must be an integer" } }; Defines an accessor hook for when values are set. The hook subroutine receives the entire argument list. C<<< $_ >>> is locally aliased to the first argument for convenience. The property receives the value of C<<< $_ >>>. See "Customizing Accessors" in L for details. The hook must be a coderef, including blessed coderefs and overloaded objects. =head1 SEE ALSO Programmers seeking a more full-featured approach to inside-out objects are encouraged to explore L. Other implementations are also noted in L. =head1 KNOWN LIMITATIONS Requires weak reference support (Perl E= 5.6) and Scalar::Util::weaken() to avoid memory leaks and to provide thread-safety. =head1 ROADMAP Features slated for after the 1.0 release include: =over =item * Adding support for L serialization hooks =item * Adding additional accessor styles (e.g. get_name()Eset_name()) =item * Further documentation revisions and clarification =back =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan =head1 SUPPORT =head2 Bugs / Feature Requests Please report any bugs or feature requests through the issue tracker at L. You will be notified automatically of any progress on your issue. =head2 Source Code This is open source software. The code repository is available for public review and contribution under the terms of the license. L git clone https://github.com/dagolden/class-insideout.git =head1 AUTHOR David Golden =head1 CONTRIBUTORS =for stopwords Karen Etheridge Toby Inkster =over 4 =item * Karen Etheridge =item * Toby Inkster =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2006 by David A. Golden. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut Class-InsideOut-1.14/lib/Class/InsideOut/Manual/000755 000765 000024 00000000000 13070235143 021570 5ustar00davidstaff000000 000000 Class-InsideOut-1.14/lib/Class/InsideOut/Manual/About.pod000644 000765 000024 00000013142 13070235143 023347 0ustar00davidstaff000000 000000 # PODNAME: Class::InsideOut::Manual::About # ABSTRACT: guide to this and other implementations of the inside-out technique __END__ =pod =encoding UTF-8 =head1 NAME Class::InsideOut::Manual::About - guide to this and other implementations of the inside-out technique =head1 VERSION version 1.14 =head1 DESCRIPTION This manual provides an overview of the inside-out technique and its application within C<<< Class::InsideOut >>> and other modules. It also provides a list of references for further study. =head2 Inside-out object basics Inside-out objects use the blessed reference as an index into lexical data structures holding object properties, rather than using the blessed reference itself as a data structure. $self->{ name } = "Larry"; # classic, hash-based object $name{ refaddr $self } = "Larry"; # inside-out The inside-out approach offers three major benefits: =over =item * Enforced encapsulation: object properties cannot be accessed directly from outside the lexical scope that declared them =item * Making the property name part of a lexical variable rather than a hash-key means that typos in the name will be caught as compile-time errors (if using L) =item * If the memory address of the blessed reference is used as the index, the reference can be of any type =back In exchange for these benefits, robust implementation of inside-out objects can be quite complex. C<<< Class::InsideOut >>> manages that complexity. =head2 Philosophy of C<<< Class::InsideOut >>> C<<< Class::InsideOut >>> provides a set of tools for building safe inside-out classes with maximum flexibility. It aims to offer minimal restrictions beyond those necessary for robustness of the inside-out technique. All capabilities necessary for robustness should be automatic. Anything that can be optional should be. The design should not introduce new restrictions unrelated to inside-out objects, such as attributes and C<<< CHECK >>> blocks that cause problems for C<<< mod_perl >>> or the use of source filters for syntactic sugar. As a result, only a few things are mandatory: =over =item * Properties must be based on hashes and declared via C<<< property >>> =item * Property hashes must be keyed on the C<<< Scalar::Util::refaddr >>> =item * C<<< register >>> must be called on all new objects =back All other implementation details, including constructors, initializers and class inheritance management are left to the user (though a very simple constructor is available as a convenience). This does requires some additional work, but maximizes freedom. C<<< Class::InsideOut >>> is intended to be a base class providing only fundamental features. Subclasses of C<<< Class::InsideOut >>> could be written that build upon it to provide particular styles of constructor, destructor and inheritance support. =head2 Other modules on CPAN =over =item * L -- This is perhaps the most full-featured, robust implementation of inside-out objects currently on CPAN. It is highly recommended if a more full-featured inside-out object builder is needed. Its array-based mode is faster than hash-based implementations, but black-box inheritance is handled via delegation, which imposes certain limitations. =back =over =item * L -- Despite the name, this does not reflect currently known best practices for inside-out objects. Does not provide thread-safety with CLONE and doesn't support black-box inheritance. Has a robust inheritanceEinitialization system. =back =over =item * L -- Generates accessors with encapsulated storage using a flyweight inside-out variant. Lexicals properties are hidden; accessors must be used everywhere. Not thread-safe. =back =over =item * L -- The original inside-out implementation, but missing some key features like thread-safety. Also, uses source filters to provide Perl-6-like object syntax. Not thread-safe. =back =over =item * L -- Not a very robust implementation. Not thread-safe. Not overloading-safe. Has a steep learning curve for the Class::MakeMethods system. =back =over =item * L -- My own original thought experiment with 'outside-in' objects and local variable aliasing. Not safe for any production use and offers very weak encapsulation. =back =head2 References for further study Much of the Perl community discussion of inside-out objects has taken place on Perlmonks (L). My scratchpad there has a fairly comprehensive list of articles (L). Some of the more informative articles include: =over =item * Abigail-II. "Re: WhereEWhen is OO useful?". July 1, 2002. L =item * Abigail-II. "Re: Tutorial: Introduction to Object-Oriented Programming". December 11, 2002. L =item * demerphq. "Yet Another Perl Object Model (Inside Out Objects)". December 14, 2002. L =item * xdg. "Threads and fork and CLONE, oh my!". August 11, 2005. L =item * jdhedden. "Anti-inside-out-object-ism". December 9, 2005. L =back =head1 SEE ALSO =over =item * L =item * L =back =head1 AUTHOR David Golden =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2006 by David A. Golden. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut Class-InsideOut-1.14/lib/Class/InsideOut/Manual/Advanced.pod000644 000765 000024 00000022242 13070235143 024003 0ustar00davidstaff000000 000000 # PODNAME: Class::InsideOut::Manual::Advanced # ABSTRACT: guide to advanced usage __END__ =pod =encoding UTF-8 =head1 NAME Class::InsideOut::Manual::Advanced - guide to advanced usage =head1 VERSION version 1.14 =head1 DESCRIPTION This manual provides further documentation for advanced usage of Class::InsideOut. =head2 Customizing accessors C<<< Class::InsideOut >>> supports custom subroutine hooks to modify the behavior of accessors. Hooks are passed as property options: C<<< set_hook >>> and C<<< get_hook >>>. The C<<< set_hook >>> is called when the accessor is called with an argument. The hook subroutine receives the entire argument list. Just before the hook is called, C<<< $_ >>> is locally aliased to the first argument for convenience. When the C<<< set_hook >>> returns, the property is set equal to C<<< $_ >>>. This feature is useful for on-the-fly modification of the value that will be stored. public initials => my %initials, { set_hook => sub { $_ = uc $_ } }; public tags => my %tags, { set_hook => sub { $_ = [ @_ ] } # stores arguments in a reference }; If the C<<< set_hook >>> dies, the error is caught and rethrown with a preamble that includes the name of the accessor. The error should end with a newline to prevent C<<< die >>> from adding 'at ... filename line N'. The correct location will be added when the error is rethrown with C<<< croak >>>: public height => my %height, { set_hook => sub { /^\d+$/ or die "must be a positive integer" } }; # dies with "height() must be a positive integer at ..." $person->height(3.5); I>> function is ignored.> This simplifies syntax in the case where C<<< die >>> is used to validate input. The C<<< get_hook >>> is called when the accessor is called without an argument. Just before the hook is called, C<<< $_ >>> is set equal to the property value of the object for convenience. The hook is called in the same context (i.e. list versus scalar) as the accessor. I public tags => my %tags, { set_hook => sub { $_ = [ @_ ] }, # stores arguments in a reference get_hook => sub { @$_ } # return property as a list }; Because C<<< $_ >>> is a copy, not an alias, of the property value, it can be modified directly, if necessary, without affecting the underlying property. As with C<<< set_hook >>>, the C<<< get_hook >>> can die to indicate an error condition and errors are handled similarly. This could be used as a way to implement a protected property: sub _protected { die "is protected\n" unless caller(2)->isa(__PACKAGE__) } public hidden => my %hidden, { get_hook => \&_protected, set_hook => \&_protected, } Accessor hooks can be set as a global default with the C<<< options >>> function, though they may still be overridden with options passed to specific properties. =head2 Black-box inheritance Because inside-out objects built with C<<< Class::InsideOut >>> can use any type of reference for the object, inside-out objects can be built from other objects. This is useful to extend a superclass without needing to know whether it is based on hashes, array, or other types of blessed references. use base 'IO::File'; sub new { my ($class, $filename) = @_; my $self = IO::File->new( $filename ); register( $self, $class ); } In the example above, C<<< IO::File >>> is a superclass. The object is an C<<< IO::File >>> object, re-blessed into the inside-out class. The resulting object can be used directly anywhere an C<<< IO::File >>> object would be, without interfering with any of its own inside-out functionality. Classes using black-box inheritance should consider providing a C<<< DEMOLISH >>> function that calls the black-box class destructor explicitly. =head2 Serialization C<<< Class::InsideOut >>> automatically imports C<<< STORABLE_freeze >>> and C<<< STORABLE_thaw >>> methods to provide serialization support with L.Due to limitations of C<<< Storable >>>, this serialization will only work for objects based on scalars, arrays or hashes. References to objects within the object being frozen will result in clones upon thawing unless the other references are included in the same freeze operation. (See C<<< Storable >>> for details.) # assume $alice and $bob are objects $alice->friends( $bob ); $bob->friends( $alice ); $alice2 = Storable::dclone( $alice ); # $bob was cloned, too, thanks to the reference die if $alice2->has_friend( $bob ); # doesn't die # get alice2's friend ($bob2) = $alice2->friends(); # preserved relationship between bob2 and alice2 die unless $bob2->has_friend( $alice2 ); # doesn't die C<<< Class::InsideOut >>> also allows customizing freeze and thaw hooks. When an object is frozen, if its class or any superclass provides a C<<< FREEZE >>> method, they are each called with the object as an argument I to the rest of the freezing process. This allows for custom preparation for freezing, such as writing a cache to disk, closing network connections, or disconnecting database handles. Likewise, when a serialized object is thawed, if its class or any superclass provides a C<<< THAW >>> method, they are each called I the object has been thawed with the thawed object as an argument. C<<< Class::InsideOut >>> also supports serialization of singleton objects for recent versions of C<<< Storable >>> (2.14 or later) that support C<<< STORABLE_attach >>>. Users must signal that C<<< STORABLE_attach >>> should be used instead of C<<< STORABLE_thaw >>> by adding C<<< :singleton >>> to their import line as follows: use Class::InsideOut qw( :std :singleton ); When attaching, the singleton object will be recreated in one of two ways: 1. If the singleton class contains an C<<< ATTACH >>> method, it will be called with three arguments: the class name, a flag for whether this is part of a dclone, and a data structure representing the object: $data = { class => ref $obj, # class name type => $type, # object reference type contents => $contents, # object reference contents properties => \%property_vals, # HoH of classes and properties } C<<< contents >>> is a reference of the same type as C<<< type >>>. C<<< properties >>> is a multi-level hash, with the names of the class and any superclasses as top-level keys and property labels as second-level keys. This data may be used to reconstruct or reattach to the singleton. The C<<< ATTACH >>> method should return the singleton. 2. If no C<<< ATTACH >>> routine is found, but the class has or inherits a C<<< new >>> method, then C<<< new >>> will be called with no arguments and the result will be returned as the singleton. =head2 Thread-safety Because C<<< Class::InsideOut >>> uses memory addresses as indices to object properties, special handling is necessary for use with threads. When a new thread is created, the Perl interpreter is cloned, and all objects in the new thread will have new memory addresses. Starting with Perl 5.8, if a C<<< CLONE >>> function exists in a package, it will be called when a thread is created to provide custom responses to thread cloning. (See L for details.) To avoid bugs in the implementation of threading, Perl 5.8.5 or later is strongly recommended. C<<< Class::InsideOut >>> itself has a C<<< CLONE >>> function that automatically fixes up properties in a new thread to reflect the new memory addresses for all classes created with C<<< Class::InsideOut >>>. C<<< register >>> must be called on all newly constructed inside-out objects to register them for use in C<<< Class::InsideOut::CLONE >>>. Users are strongly encouraged not to define their own C<<< CLONE >>> functions as they may interfere with the operation of C<<< Class::InsideOut::CLONE >>> and leave objects in an undefined state. Future versions may support a user-defined CLONE hook, depending on demand. B C<<< fork >>> on Perl for Win32 is emulated using threads since Perl 5.6. (See L.) As Perl 5.6 did not support C<<< CLONE >>>, inside-out objects that use memory addresses (e.g. C<<< Class::InsideOut >>>) are not fork-safe for Win32 on Perl 5.6. Win32 Perl 5.8 C<<< fork >>> is supported. The technique for thread-safety requires creating weak references using C<<< Scalar::Util::weaken() >>>, which is implemented in XS. If the XS-version of L is not installed or if run on an older version of Perl without support for weak references, C<<< Class::InsideOut >>> will issue a warning and continue without thread-safety. Also, objects will leak memory unless manually deregistered with a private function: # destroying an object when weaken() isn't availalbe Class::InsideOut::_deregister( $obj ); undef $obj; =head1 SEE ALSO =over =item * L =item * L =back =head1 AUTHOR David Golden =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2006 by David A. Golden. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut Class-InsideOut-1.14/examples/README000644 000765 000024 00000000434 13070235143 017334 0ustar00davidstaff000000 000000 For examples, see the objects used in testing located in t/Object/. In particular, t/Object/Animal.pm and the subclasses in t/Object/Animal/ show typical object inheritance techniques. For an example of foreign/black-box inheritance of an IO::File object, see t/Object/Foreign.pm.