Class-InsideOut-1.13/000755 000765 000024 00000000000 12136267433 014645 5ustar00davidstaff000000 000000 Class-InsideOut-1.13/Changes000644 000765 000024 00000017721 12136267433 016150 0ustar00davidstaff000000 000000 Revision history for Perl module Class::InsideOut 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.13/CONTRIBUTING000644 000765 000024 00000003257 12136267433 016506 0ustar00davidstaff000000 000000 README.PATCHING 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 than many of the usual files you might expect are not in the repository, but are generated at release time (e.g. Makefile.PL). However, you can run tests directly using the 'prove' tool: $ prove -l $ prove -lv t/some_test_file.t For most distributions, 'prove' is entirely sufficent for you to test any patches you have. You may need to satisfy some dependencies. See the included META.json file for a list. If you install App::mymeta_requires from CPAN, it's easy to satisfy any that you are missing by piping the output to your favorite CPAN client: $ mymeta-requires | cpanm $ cpan `mymeta-requires` Likewise, much of the documentation Pod is generated at release time. Depending on the distribution, some documentation may be written in a Pod dialect called WikiDoc. (See Pod::WikiDoc on CPAN.) 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. Dist::Zilla is a very powerful authoring tool, but requires a number of author-specific plugins. If you would like to use it for contributing, install it from CPAN, then run one of the following commands, depending on your CPAN client: $ 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.13/dist.ini000644 000765 000024 00000001161 12136267433 016310 0ustar00davidstaff000000 000000 name = Class-InsideOut author = David Golden license = Apache_2_0 copyright_holder = David A. Golden copyright_year = 2006 [@DAGOLDEN] :version = 0.038 AutoMetaResources.bugtracker.rt = 0 AutoMetaResources.bugtracker.github = user:dagolden 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 [RemovePrereqs] remove = Types::Standard Class-InsideOut-1.13/examples/000755 000765 000024 00000000000 12136267433 016463 5ustar00davidstaff000000 000000 Class-InsideOut-1.13/lib/000755 000765 000024 00000000000 12136267433 015413 5ustar00davidstaff000000 000000 Class-InsideOut-1.13/LICENSE000644 000765 000024 00000026357 12136267433 015667 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.13/Makefile.PL000644 000765 000024 00000003474 12136267433 016627 0ustar00davidstaff000000 000000 use strict; use warnings; use 5.008; use ExtUtils::MakeMaker 6.30; my %WriteMakefileArgs = ( "ABSTRACT" => "a safe, simple inside-out object construction kit", "AUTHOR" => "David Golden ", "BUILD_REQUIRES" => {}, "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => "6.30" }, "DISTNAME" => "Class-InsideOut", "EXE_FILES" => [], "LICENSE" => "apache", "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" => { "Config" => 0, "DynaLoader" => 0, "ExtUtils::MakeMaker" => 0, "File::Find" => 0, "File::Spec" => 0, "File::Spec::Functions" => 0, "File::Temp" => 0, "IO::File" => 0, "List::Util" => 0, "Test::More" => "0.45", "XSLoader" => 0, "threads" => 0, "warnings" => 0 }, "VERSION" => "1.13", "test" => { "TESTS" => "t/*.t" } ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { my $tr = delete $WriteMakefileArgs{TEST_REQUIRES}; my $br = $WriteMakefileArgs{BUILD_REQUIRES}; for my $mod ( keys %$tr ) { if ( exists $br->{$mod} ) { $br->{$mod} = $tr->{$mod} if $tr->{$mod} > $br->{$mod}; } else { $br->{$mod} = $tr->{$mod}; } } } unless ( eval { ExtUtils::MakeMaker->VERSION(6.56) } ) { my $br = delete $WriteMakefileArgs{BUILD_REQUIRES}; my $pp = $WriteMakefileArgs{PREREQ_PM}; for my $mod ( keys %$br ) { if ( exists $pp->{$mod} ) { $pp->{$mod} = $br->{$mod} if $br->{$mod} > $pp->{$mod}; } else { $pp->{$mod} = $br->{$mod}; } } } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; WriteMakefile(%WriteMakefileArgs); Class-InsideOut-1.13/MANIFEST000644 000765 000024 00000003070 12136267433 015776 0ustar00davidstaff000000 000000 CONTRIBUTING Changes LICENSE MANIFEST META.json META.yml Makefile.PL README Todo dist.ini examples/README lib/Class/InsideOut.pm lib/Class/InsideOut/Manual/About.pod lib/Class/InsideOut/Manual/Advanced.pod perlcritic.rc t/00-compile.t 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/critic.t xt/author/pod-spell.t xt/release/distmeta.t xt/release/minimum-version.t xt/release/pod-coverage.t xt/release/pod-syntax.t xt/release/portability.t xt/release/test-version.t Class-InsideOut-1.13/META.json000644 000765 000024 00000004627 12136267433 016277 0ustar00davidstaff000000 000000 { "abstract" : "a safe, simple inside-out object construction kit", "author" : [ "David Golden " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 4.300034, CPAN::Meta::Converter version 2.130880", "license" : [ "apache_2_0" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Class-InsideOut", "no_index" : { "directory" : [ "t", "xt", "examples", "corpus" ], "package" : [ "DB" ] }, "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.30" } }, "develop" : { "requires" : { "Pod::Coverage::TrustPod" : "0", "Test::CPAN::Meta" : "0", "Test::Pod" : "1.41", "Test::Pod::Coverage" : "1.08" } }, "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" : { "requires" : { "Config" : "0", "DynaLoader" : "0", "ExtUtils::MakeMaker" : "0", "File::Find" : "0", "File::Spec" : "0", "File::Spec::Functions" : "0", "File::Temp" : "0", "IO::File" : "0", "List::Util" : "0", "Test::More" : "0.45", "XSLoader" : "0", "threads" : "0", "warnings" : "0" } } }, "provides" : { "Class::InsideOut" : { "file" : "lib/Class/InsideOut.pm", "version" : "1.13" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/dagolden/class-insideout/issues" }, "homepage" : "https://metacpan.org/release/Class-InsideOut", "repository" : { "type" : "git", "url" : "git://github.com/dagolden/class-insideout.git", "web" : "https://github.com/dagolden/class-insideout" } }, "version" : "1.13", "x_contributors" : [ "Karen Etheridge ", "Toby Inkster " ] } Class-InsideOut-1.13/META.yml000644 000765 000024 00000002315 12136267433 016117 0ustar00davidstaff000000 000000 --- abstract: 'a safe, simple inside-out object construction kit' author: - 'David Golden ' build_requires: Config: 0 DynaLoader: 0 ExtUtils::MakeMaker: 0 File::Find: 0 File::Spec: 0 File::Spec::Functions: 0 File::Temp: 0 IO::File: 0 List::Util: 0 Test::More: 0.45 XSLoader: 0 threads: 0 warnings: 0 configure_requires: ExtUtils::MakeMaker: 6.30 dynamic_config: 0 generated_by: 'Dist::Zilla version 4.300034, CPAN::Meta::Converter version 2.130880' license: apache meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Class-InsideOut no_index: directory: - t - xt - examples - corpus package: - DB provides: Class::InsideOut: file: lib/Class/InsideOut.pm version: 1.13 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://metacpan.org/release/Class-InsideOut repository: git://github.com/dagolden/class-insideout.git version: 1.13 x_contributors: - 'Karen Etheridge ' - 'Toby Inkster ' Class-InsideOut-1.13/perlcritic.rc000644 000765 000024 00000001072 12136267433 017333 0ustar00davidstaff000000 000000 severity = 5 verbose = 8 [Variables::ProhibitPunctuationVars] allow = $@ $! [TestingAndDebugging::ProhibitNoStrict] allow = refs # 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.13/README000644 000765 000024 00000036214 12136267433 015533 0ustar00davidstaff000000 000000 NAME Class::InsideOut - a safe, simple inside-out object construction kit VERSION version 1.13 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 git://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.13/t/000755 000765 000024 00000000000 12136267433 015110 5ustar00davidstaff000000 000000 Class-InsideOut-1.13/Todo000644 000765 000024 00000004757 12136267433 015512 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.13/xt/000755 000765 000024 00000000000 12136267433 015300 5ustar00davidstaff000000 000000 Class-InsideOut-1.13/xt/author/000755 000765 000024 00000000000 12136267433 016602 5ustar00davidstaff000000 000000 Class-InsideOut-1.13/xt/release/000755 000765 000024 00000000000 12136267433 016720 5ustar00davidstaff000000 000000 Class-InsideOut-1.13/xt/release/distmeta.t000644 000765 000024 00000000217 12136267433 020717 0ustar00davidstaff000000 000000 #!perl use Test::More; eval "use Test::CPAN::Meta"; plan skip_all => "Test::CPAN::Meta required for testing META.yml" if $@; meta_yaml_ok(); Class-InsideOut-1.13/xt/release/minimum-version.t000644 000765 000024 00000000266 12136267433 022247 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.13/xt/release/pod-coverage.t000644 000765 000024 00000000527 12136267433 021464 0ustar00davidstaff000000 000000 #!perl use Test::More; eval "use Test::Pod::Coverage 1.08"; plan skip_all => "Test::Pod::Coverage 1.08 required for testing POD coverage" if $@; eval "use Pod::Coverage::TrustPod"; plan skip_all => "Pod::Coverage::TrustPod required for testing POD coverage" if $@; all_pod_coverage_ok({ coverage_class => 'Pod::Coverage::TrustPod' }); Class-InsideOut-1.13/xt/release/pod-syntax.t000644 000765 000024 00000000212 12136267433 021206 0ustar00davidstaff000000 000000 #!perl use Test::More; eval "use Test::Pod 1.41"; plan skip_all => "Test::Pod 1.41 required for testing POD" if $@; all_pod_files_ok(); Class-InsideOut-1.13/xt/release/portability.t000644 000765 000024 00000000332 12136267433 021445 0ustar00davidstaff000000 000000 #!perl 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.13/xt/release/test-version.t000644 000765 000024 00000000643 12136267433 021552 0ustar00davidstaff000000 000000 use strict; use warnings; use Test::More; # generated by Dist::Zilla::Plugin::Test::Version 0.002004 BEGIN { eval "use Test::Version; 1;" or die $@; } my @imports = ( 'version_all_ok' ); my $params = { is_strict => 0, has_version => 1, }; 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.13/xt/author/critic.t000644 000765 000024 00000000435 12136267433 020246 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.13/xt/author/pod-spell.t000644 000765 000024 00000000721 12136267433 020666 0ustar00davidstaff000000 000000 use strict; use warnings; use Test::More; # generated by Dist::Zilla::Plugin::Test::PodSpelling 2.004003 eval "use Test::Spelling 0.12; use Pod::Wordlist::hanekomu; 1" or die $@; add_stopwords(); all_pod_files_spelling_ok( qw( bin lib ) ); __DATA__ Etheridge Inkster Perlmonks ROADMAP Subclasses accessable dclone demerphq deregistered destructor initializers jdhedden readonly rethrown xdg David Golden dagolden lib Class InsideOut Manual About Advanced Class-InsideOut-1.13/t/00-compile.t000644 000765 000024 00000003100 12136267433 017134 0ustar00davidstaff000000 000000 #!perl use strict; use warnings; use Test::More; use File::Find; use File::Temp qw{ tempdir }; my @modules; find( sub { return if $File::Find::name !~ /\.pm\z/; my $found = $File::Find::name; $found =~ s{^lib/}{}; $found =~ s{[/\\]}{::}g; $found =~ s/\.pm$//; # nothing to skip push @modules, $found; }, 'lib', ); sub _find_scripts { my $dir = shift @_; my @found_scripts = (); find( sub { return unless -f; my $found = $File::Find::name; # nothing to skip open my $FH, '<', $_ or do { note( "Unable to open $found in ( $! ), skipping" ); return; }; my $shebang = <$FH>; return unless $shebang =~ /^#!.*?\bperl\b\s*$/; push @found_scripts, $found; }, $dir, ); return @found_scripts; } my @scripts; do { push @scripts, _find_scripts($_) if -d $_ } for qw{ bin script scripts }; my $plan = scalar(@modules) + scalar(@scripts); $plan ? (plan tests => $plan) : (plan skip_all => "no tests to run"); { # fake home for cpan-testers local $ENV{HOME} = tempdir( CLEANUP => 1 ); like( qx{ $^X -Ilib -e "require $_; print '$_ ok'" }, qr/^\s*$_ ok/s, "$_ loaded ok" ) for sort @modules; SKIP: { eval "use Test::Script 1.05; 1;"; skip "Test::Script needed to test script compilation", scalar(@scripts) if $@; foreach my $file ( @scripts ) { my $script = $file; $script =~ s!.*/!!; script_compiles( $file, "$script script compiles" ); } } } Class-InsideOut-1.13/t/00-report-prereqs.t000644 000765 000024 00000003235 12136267433 020507 0ustar00davidstaff000000 000000 #!perl use strict; use warnings; use Test::More tests => 1; use ExtUtils::MakeMaker; use File::Spec::Functions; use List::Util qw/max/; my @modules = qw( Carp Class::ISA Config DynaLoader Exporter ExtUtils::MakeMaker File::Find File::Spec File::Spec::Functions File::Temp IO::File List::Util Scalar::Util Storable Test::More XSLoader overload perl strict threads vars warnings ); # replace modules with dynamic results from MYMETA.json if we can # (hide CPAN::Meta from prereq scanner) my $cpan_meta = "CPAN::Meta"; if ( -f "MYMETA.json" && eval "require $cpan_meta" ) { ## no critic if ( my $meta = eval { CPAN::Meta->load_file("MYMETA.json") } ) { my $prereqs = $meta->prereqs; delete $prereqs->{develop}; my %uniq = map {$_ => 1} map { keys %$_ } map { values %$_ } values %$prereqs; $uniq{$_} = 1 for @modules; # don't lose any static ones @modules = sort keys %uniq; } } my @reports = [qw/Version Module/]; for my $mod ( @modules ) { next if $mod eq 'perl'; my $file = $mod; $file =~ s{::}{/}g; $file .= ".pm"; my ($prefix) = grep { -e catfile($_, $file) } @INC; if ( $prefix ) { my $ver = MM->parse_version( catfile($prefix, $file) ); $ver = "undef" unless defined $ver; # Newer MM should do this anyway push @reports, [$ver, $mod]; } else { push @reports, ["missing", $mod]; } } if ( @reports ) { my $vl = max map { length $_->[0] } @reports; my $ml = max map { length $_->[1] } @reports; splice @reports, 1, 0, ["-" x $vl, "-" x $ml]; diag "Prerequisite Report:\n", map {sprintf(" %*s %*s\n",$vl,$_->[0],-$ml,$_->[1])} @reports; } pass; # vim: ts=2 sts=2 sw=2 et: Class-InsideOut-1.13/t/01_load.t000644 000765 000024 00000001136 12136267433 016515 0ustar00davidstaff000000 000000 use strict; 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.13/t/02_register.t000644 000765 000024 00000002720 12136267433 017423 0ustar00davidstaff000000 000000 use strict; 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.13/t/03_properties.t000644 000765 000024 00000004400 12136267433 017771 0ustar00davidstaff000000 000000 use strict; 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.13/t/04_threaded.t000644 000765 000024 00000004713 12136267433 017365 0ustar00davidstaff000000 000000 use strict; 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.13/t/05_forking.t000644 000765 000024 00000004352 12136267433 017244 0ustar00davidstaff000000 000000 use strict; 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.13/t/06_export_ok.t000644 000765 000024 00000003212 12136267433 017612 0ustar00davidstaff000000 000000 use strict; 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.13/t/07_synopsis_obj.t000644 000765 000024 00000002722 12136267433 020327 0ustar00davidstaff000000 000000 use strict; 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.13/t/08_DEMOLISH.t000644 000765 000024 00000002307 12136267433 017012 0ustar00davidstaff000000 000000 use strict; 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.13/t/09_foreign.t000644 000765 000024 00000001647 12136267433 017246 0ustar00davidstaff000000 000000 use strict; 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.13/t/10_storable_values.t000644 000765 000024 00000011617 12136267433 020775 0ustar00davidstaff000000 000000 use strict; 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.13/t/11_storable_refs.t000644 000765 000024 00000022401 12136267433 020427 0ustar00davidstaff000000 000000 use strict; 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.13/t/12_storable_hooks.t000644 000765 000024 00000003144 12136267433 020617 0ustar00davidstaff000000 000000 use strict; 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.13/t/13_options.t000644 000765 000024 00000000605 12136267433 017274 0ustar00davidstaff000000 000000 use strict; 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.13/t/14_accessor_hooks.t000644 000765 000024 00000005622 12136267433 020613 0ustar00davidstaff000000 000000 use strict; 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.13/t/15_no_weaken_fallback.t000644 000765 000024 00000003260 12136267433 021370 0ustar00davidstaff000000 000000 use strict; 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.13/t/16_property_argument_checking.t000644 000765 000024 00000004344 12136267433 023231 0ustar00davidstaff000000 000000 use strict; 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.13/t/17_option_argument_checking.t000644 000765 000024 00000003461 12136267433 022655 0ustar00davidstaff000000 000000 use strict; 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.13/t/18_register_argument_checking.t000644 000765 000024 00000002045 12136267433 023167 0ustar00davidstaff000000 000000 use strict; 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.13/t/19_storable_singleton.t000644 000765 000024 00000005165 12136267433 021512 0ustar00davidstaff000000 000000 use strict; 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.13/t/20_storable_singleton_error.t000644 000765 000024 00000003116 12136267433 022705 0ustar00davidstaff000000 000000 use strict; 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.13/t/21_optional_new.t000644 000765 000024 00000004120 12136267433 020272 0ustar00davidstaff000000 000000 use strict; 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.13/t/22_readonly.t000644 000765 000024 00000002055 12136267433 017417 0ustar00davidstaff000000 000000 use strict; 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.13/t/23_accessor_hooks_blessed.t000644 000765 000024 00000005631 12136267433 022314 0ustar00davidstaff000000 000000 use strict; 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.13/t/24_accessor_hooks_overloaded.t000644 000765 000024 00000006014 12136267433 023014 0ustar00davidstaff000000 000000 use strict; 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.13/t/25_accessor_hooks_typetiny.t000644 000765 000024 00000006004 12136267433 022555 0ustar00davidstaff000000 000000 use strict; 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.13/t/data/000755 000765 000024 00000000000 12136267433 016021 5ustar00davidstaff000000 000000 Class-InsideOut-1.13/t/Object/000755 000765 000024 00000000000 12136267433 016316 5ustar00davidstaff000000 000000 Class-InsideOut-1.13/t/Object/Animal/000755 000765 000024 00000000000 12136267433 017517 5ustar00davidstaff000000 000000 Class-InsideOut-1.13/t/Object/Animal.pm000644 000765 000024 00000001746 12136267433 020065 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.13/t/Object/Array.pm000644 000765 000024 00000000270 12136267433 017731 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.13/t/Object/Foreign.pm000644 000765 000024 00000000572 12136267433 020251 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.13/t/Object/Friends.pm000644 000765 000024 00000002207 12136267433 020247 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.13/t/Object/Hash.pm000644 000765 000024 00000000267 12136267433 017544 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.13/t/Object/Hooked.pm000644 000765 000024 00000001644 12136267433 020072 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.13/t/Object/HookedBlessed.pm000644 000765 000024 00000002002 12136267433 021361 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.13/t/Object/HookedOverloaded.pm000644 000765 000024 00000002137 12136267433 022075 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.13/t/Object/HookedTT.pm000644 000765 000024 00000001705 12136267433 020340 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.13/t/Object/ReadOnly.pm000644 000765 000024 00000000176 12136267433 020375 0ustar00davidstaff000000 000000 package t::Object::ReadOnly; use Class::InsideOut qw/readonly new/; readonly name => my %name; readonly age => my %age; 1; Class-InsideOut-1.13/t/Object/RegisterClassname.pm000644 000765 000024 00000000203 12136267433 022262 0ustar00davidstaff000000 000000 package t::Object::RegisterClassname; use strict; use Class::InsideOut; sub new { Class::InsideOut::register( shift ); } 1; Class-InsideOut-1.13/t/Object/RegisterRef.pm000644 000765 000024 00000000200 12136267433 021065 0ustar00davidstaff000000 000000 package t::Object::RegisterRef; use strict; use Class::InsideOut; sub new { Class::InsideOut::register( {}, shift); } 1; Class-InsideOut-1.13/t/Object/Scalar.pm000644 000765 000024 00000000332 12136267433 020057 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.13/t/Object/Singleton/000755 000765 000024 00000000000 12136267433 020260 5ustar00davidstaff000000 000000 Class-InsideOut-1.13/t/Object/Synopsis.pm000644 000765 000024 00000001037 12136267433 020504 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.13/t/Object/Trivial.pm000644 000765 000024 00000000210 12136267433 020257 0ustar00davidstaff000000 000000 package t::Object::Trivial; use strict; use Class::InsideOut; sub new { Class::InsideOut::register( bless \(my $s), shift); } 1; Class-InsideOut-1.13/t/Object/WithNew/000755 000765 000024 00000000000 12136267433 017703 5ustar00davidstaff000000 000000 Class-InsideOut-1.13/t/Object/WithNew.pm000644 000765 000024 00000000251 12136267433 020237 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.13/t/Object/WithNew/Inherited.pm000644 000765 000024 00000000402 12136267433 022150 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.13/t/Object/Singleton/Hooked.pm000644 000765 000024 00000001023 12136267433 022023 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.13/t/Object/Singleton/MissingConstructor.pm000644 000765 000024 00000000424 12136267433 024475 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.13/t/Object/Singleton/Simple.pm000644 000765 000024 00000000360 12136267433 022046 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.13/t/Object/Animal/Antelope.pm000644 000765 000024 00000000767 12136267433 021636 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.13/t/Object/Animal/Jackalope.pm000644 000765 000024 00000001165 12136267433 021751 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.13/t/Object/Animal/JackRabbit.pm000644 000765 000024 00000000424 12136267433 022051 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.13/t/data/testdata.txt000644 000765 000024 00000000016 12136267433 020370 0ustar00davidstaff000000 000000 one two three Class-InsideOut-1.13/lib/Class/000755 000765 000024 00000000000 12136267433 016460 5ustar00davidstaff000000 000000 Class-InsideOut-1.13/lib/Class/InsideOut/000755 000765 000024 00000000000 12136267433 020363 5ustar00davidstaff000000 000000 Class-InsideOut-1.13/lib/Class/InsideOut.pm000644 000765 000024 00000076615 12136267433 020740 0ustar00davidstaff000000 000000 package Class::InsideOut; use strict; # ABSTRACT: a safe, simple inside-out object construction kit our $VERSION = '1.13'; # VERSION 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.13 =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 git://github.com/dagolden/class-insideout.git =head1 AUTHOR David Golden =head1 CONTRIBUTORS =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.13/lib/Class/InsideOut/Manual/000755 000765 000024 00000000000 12136267433 021600 5ustar00davidstaff000000 000000 Class-InsideOut-1.13/lib/Class/InsideOut/Manual/About.pod000644 000765 000024 00000013334 12136267433 023362 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.13 =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 CONTRIBUTORS =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.13/lib/Class/InsideOut/Manual/Advanced.pod000644 000765 000024 00000022434 12136267433 024016 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.13 =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 CONTRIBUTORS =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.13/examples/README000644 000765 000024 00000000434 12136267433 017344 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.