Object-InsideOut-4.05/0000755000175000001440000000000013377136477014257 5ustar jdheddenusersObject-InsideOut-4.05/META.json0000664000175000001440000000234713377136477015710 0ustar jdheddenusers{ "abstract" : "Comprehensive inside-out object support module", "author" : [ "Jerry D. Hedden " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Object-InsideOut", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "B" : "0", "Config" : "0", "Data::Dumper" : "2.131", "Exception::Class" : "1.32", "Scalar::Util" : "1.23", "Test::More" : "0.98", "attributes" : "0", "overload" : "0", "strict" : "0", "warnings" : "0" } } }, "release_status" : "stable", "version" : "4.05", "x_serialization_backend" : "JSON::PP version 2.97001" } Object-InsideOut-4.05/Changes0000644000175000001440000003737313377136466015565 0ustar jdheddenusersRevision history for Perl extension Object::InsideOut. 4.05 Tue Nov 27 03:42:46 2018 - Fix for non-threaded Perl 4.04 Wed Mar 1 04:59:11 2017 - Fix for threads::shared < 0.96 4.03 Sun Feb 26 17:14:40 2017 - Update to use threads::shared::is_shared 4.02 Thu Aug 27 00:57:06 2015 - Remove errant debugging code - D'oh! 3.99 Sat Aug 22 00:35:03 2015 - Fix array_ref subtype checking on assignment 3.98 Thu Oct 3 19:04:26 2013 - User string compare for version checks 3.97 Thu Nov 15 13:34:15 2012 - Fix for panic during destroy from Krzysztof Lewicki 3.96 Mon Oct 1 12:22:50 2012 - Tweaks in tests for changes in core warning messages 3.95 Tue Jul 24 13:30:57 2012 - Delete on arrays is deprecated (removed last vestage) 3.94 Wed May 9 17:29:23 EDT 2012 - Delete on arrays is deprecated 3.93 Mon Apr 9 13:45:35 2012 - Allow :Handle to work with non-OIO classes per contribution by Damian Conway 3.92 Tue Mar 6 14:42:27 2012 - Added readonly fields per contribution by Damian Conway 3.91 Wed Feb 22 16:35:09 2012 - Added sequential defaults per contribution by Damian Conway - Extended delegator capabilities per contribution by Damian Conway 3.89 Thu Feb 16 19:08:31 2012 - Added generated defaults per contribution by Damian Conway 3.88 Thu Jan 26 14:56:59 2012 - Update build prereqs 3.87 Thu Jan 19 13:46:51 2012 - Added missing test file for delegators 3.86 Thu Jan 19 04:37:33 2012 - Added delegators per contribution by Damian Conway 3.85 Wed Jan 11 06:01:11 2012 - Fix some 'used only once' warnings 3.84 Tue Oct 11 22:42:26 2011 - Fixed bug in string dump of objects 3.83 Thu Oct 6 23:53:04 2011 - Fix bug with NOT_SHARED in threads::shared app - Document error caused by returning non-shared objects from threads 3.82 Tue Sep 27 23:28:33 2011 - Fix obj ID reuse for shared objects in threaded app - Documented limitation regarding removing shared internal objects 3.81 Tue Mar 22 02:20:49 2011 - Faster initialization (from O(n^3) to O(n)) 3.79 Fri Dec 24 18:06:02 2010 - Bundle update 3.78 Fri Dec 24 15:35:25 2010 - POD update 3.77 Tue Dec 21 14:29:37 2010 - Test fixes for $@ changes - Test change for ??? syntax error 3.76 Mon Nov 15 00:01:50 2010 - Skip some more shared tests under 5.8.8 and prior 3.75 Tue Nov 9 15:01:06 2010 - Skip some shared tests under 5.8.8 and prior 3.74 Tue Nov 9 02:16:45 2010 - threads::shared version number in test 3.73 Mon Nov 8 18:53:00 2010 - Fix obj ID handling for shared objects in threaded app 3.72 Mon Oct 18 21:15:53 2010 - Fix obj ID handling for non-shared objects in threaded app 3.71 Wed Oct 13 18:25:20 2010 - Fixed a memory leak 3.69 Tue Sep 28 20:38:53 2010 - Fix test counts in t/27-exception.t 3.68 Thu Sep 23 17:09:21 2010 - POD note to 'use threads' in DBI applications [bug #58394] - Allow warnings for unhandled args 3.67 Mon May 17 23:22:44 2010 - More fixes for $@ changes 3.66 Fri May 14 13:31:04 2010 - More fixes for $@ changes 3.65 Fri May 7 19:05:34 2010 - Fix tests for $@ changes that will be coming with Perl 5.14 3.64 Mon Mar 8 17:59:51 2010 - Added tests related to shared object destruction 3.63 Fri Mar 5 13:11:48 EST 2010 - Fix for shared object destruction bug 3.62 Thu Mar 4 04:24:02 2010 - Extended the change in v3.59 to Perl 5.8.9 3.61 Wed Mar 3 21:37:19 2010 - Code cleanup 3.59 Wed Mar 3 19:11:50 2010 - Fixed shared object destruction when using Thread::Queue 3.58 Wed Dec 23 12:45:55 2009 - Support type checking for scalar refs 3.57 Thu Nov 5 01:42:26 2009 - Check args to ->isa()/->can() 3.56 Wed Jul 29 19:11:02 2009 - Changed label that was a keyword 3.55 Fri May 8 11:38:53 2009 - Upgraded dependencies to Exception::Class 1.29 3.54 Wed Feb 18 18:04:51 2009 - Doc update only 3.53 Wed Feb 18 15:34:20 2009 - Handle unnamed fields when using Storable - Cache some object initialization activities 3.52 Mon Oct 27 11:16:19 2008 - Upgraded dependencies to Exception::Class 1.26 3.51 Thu Oct 23 20:18:23 2008 - Fix issues with Exception::Class 1.25 3.49 Fri Oct 17 18:33:46 2008 - Call all :Destroy methods before deleting field data 3.48 Wed Oct 15 20:05:20 2008 - Fix runtime loading of classes with multiple inheritance 3.47 Mon Oct 6 18:50:26 2008 - Proper implementation of ->isa()/->can() 3.46 Fri Oct 3 21:01:59 2008 - Support Test::MockObject 3.45 Fri Jul 11 18:58:46 2008 - Don't clone deep internally held objects 3.44 Fri Jul 11 17:39:35 2008 - Don't clone internally held objects 3.43 Tue Jun 24 18:05:10 2008 - Added 'scalar' type checking 3.42 Fri Jun 13 17:35:27 2008 - End all tests with exit(0) and fix SKIPs - Recommended modules in META.yml 3.41 Fri May 16 11:16:30 EDT 2008 - Changed function shared_clone() to clone_shared() in Util.pm - Handle circular refs when cloning data 3.39 Mon Mar 10 20:25:30 2008 - Catch unhandled params to ->new() 3.38 Tue Feb 26 16:54:46 2008 - No shared copying if no threads 3.37 Tue Feb 19 19:01:56 2008 - Fix another preformance issue with reclaiming object IDs - Fix testing under Perl 5.8.0 3.36 Fri Feb 15 19:45:37 2008 - Shared copies of refs of refs 3.35 Fri Dec 21 15:18:29 2007 - Set min threads::shared version when overloading '==' operator for shared objects - Added a countdown indicator to Term::YAPI 3.34 Wed Nov 28 01:47:52 2007 - Fix preformance issue with reclaiming object IDs 3.33 Fri Nov 9 13:16:56 2007 - Fix overload tests 3.32 Thu Nov 8 21:57:28 2007 - Skip overload test file if no threads 3.31 Thu Nov 8 19:22:42 2007 - Overload the '==' operator for shared objects 3.29 Wed Nov 7 18:20:56 2007 - Fix to dump (Bug #30527) - Additional fix to UNIVERSAL::isa call (Bug #30533) 3.28 Wed Nov 7 01:34:02 2007 - Fix to UNIVERSAL::isa call (Bug #30533) 3.27 Sat Nov 3 01:23:30 2007 - Make :Default({}) work as expected - Added ->endtime() method to Term::YAPI 3.26 Mon Sep 17 23:59:28 2007 - Support ANSI color sequences in Term::YAPI 3.25 Tue Sep 11 17:29:00 2007 - Capability to install Term::YAPI (fixed) 3.24 Tue Sep 11 17:07:07 2007 - Capability to install Term::YAPI 3.23 Tue Sep 11 16:17:44 2007 - Localize error vars in DESTROY 3.22 Fri Sep 7 19:34:23 2007 - Enhancements to Term::YAPI in examples dir - POD spelling test (maintainer only) 3.21 Fri Aug 17 15:46:35 2007 - Faster object creation 3.19 Tue Jun 26 16:19:02 2007 - Less use of BEGIN blocks - Fixed a threads::shared issue 3.18 Fri Jun 8 18:31:32 2007 - Fixed secure mode breakage caused by MRMA upgrade 3.17 Fri May 11 19:43:53 2007 - Fix for pseudo-forks 3.16 Thu May 10 17:41:38 2007 - Minor mod for CPAN's PAUSE indexer 3.15 Thu May 10 17:19:55 2007 - Modified (and documented) object initialization sequence - Improved file versioning - Subversion repository on Google 3.14 Mon Mar 26 15:35:57 EDT 2007 - Fix to Foreign.pm (courtesy of Michael Houghton) - Updated version numbers in POD 3.13 Mon Mar 19 09:36:46 EDT 2007 - Fix recursion bug caused by bad :Automethod 3.12 Thu Mar 15 08:07:53 EDT 2007 - Fix for classes permissions 3.11 Sun Feb 18 19:22:45 EST 2007 - Handle pseudo-forks 3.09 Fri Feb 16 22:21:05 EST 2007 - Exemptions for :Restricted/:Private accessors 3.08 Wed Dec 27 09:13:28 EST 2006 - Apply defaults before :Init is called - Do initialize() in CLONE_SKIP - Fix to handling :Default values 3.07 Wed Dec 20 08:22:30 EST 2006 - Fixed bug with :Name attribute 3.06 Mon Dec 11 15:03:13 EST 2006 - Updates to Bundle::Object::InsideOut - Skip certain tests under 5.8.0 3.05 Fri Dec 8 20:02:17 EST 2006 - Catch when threads::shared loaded after OIO initialized 3.04 Fri Dec 8 13:17:51 EST 2006 - Added :Default(...) for :Field's 3.03 Thu Dec 7 13:41:40 EST 2006 - Fixed ->can() for cumulative/chained automethods - Fixed using overloads with :Cumulative/:Chained 3.01 Tue Dec 5 16:36:42 EST 2006 - :Restricted/:Private classes - Exemptions for :Restricted :Cumulative/:Chained - Separate POD file - Internal code rework 2.25 Thu Nov 30 13:29:36 EST 2006 - Exemptions for :Restricted/:Private - Partial compatibility with Attribute::Params::Validate 2.24 Mon Nov 27 14:58:01 EST 2006 - Catch missing 'name' param in field attributes 2.23 Tue Nov 14 16:08:13 EST 2006 - Rework of :Cumulative/:Chained code 2.22 Tue Nov 14 13:43:53 EST 2006 - Fixed using :Restricted with :Cumulative/:Chained 2.21 Mon Nov 13 10:09:24 EST 2006 - Added subtype-checking for list/array/array_ref - Improvements to Term::YAPI in examples dir 2.19 Thu Nov 2 14:07:17 EST 2006 - Added more dependencies to Bundle::Object::InsideOut 2.18 Wed Nov 1 07:51:27 EST 2006 - Fixes to Bundle::Object::InsideOut syntax 2.17 Tue Oct 31 13:07:01 EST 2006 - Added Bundle::Object::InsideOut 2.16 Mon Oct 23 13:30:32 EDT 2006 - Another fix for the :Type attribute - Noted in POD that the PPM version of Want is bad 2.15 Fri Oct 20 15:46:06 EDT 2006 - Fixed bug with :Type attribute 2.14 Tue Oct 17 11:38:26 EDT 2006 - Fixed bug with 'require' on empty classes 2.12 Fri Oct 13 14:42:50 EDT 2006 - Metadata requires Perl 5.8.0 or later 2.08 Wed Oct 11 15:18:36 EDT 2006 - Runtime inheritance with ->add_class 2.07 Tue Oct 10 15:47:44 EDT 2006 - Added :SECURE mode 2.06 Mon Oct 9 16:04:09 EDT 2006 - Added :hash_only flag - Added SECURITY section to POD 2.05 Fri Oct 6 15:42:30 EDT 2006 - Implemented :MergeArgs for methods 2.04 Tue Oct 3 15:01:30 EDT 2006 - Removed :lvalue method from meta tests 2.03 Tue Oct 3 14:40:26 EDT 2006 - Added introspection - Document My::Class->create_field() - Added examples/YAPI.pm - Added POD tests 2.02 Sat Sep 23 17:57:11 EST 2006 - Completed redesign on field attributes (Backwards compatibility maintained. See POD for details.) - Support argument preprocessing on set accessors - Fixed handling of weak fields in dump() - Want module not used by default (Still required for :lvalue accessors) - Removed 'process_args' from Object::InsideOut::Util (Hope no one was using it. It wasn't documented.) 2.01 Tue Sep 19 11:00:15 EDT 2006 - Started redesign on field attributes Changed :Field(..., 'Weak' => 1) To :Field(...) :Weak Changed :Field(..., 'Deep' => 1), etc. To :Field(...) :Deep Changed :Field(..., 'Name' => 'foo') To :Field(...) :Name(foo) (Multiple attributes can be line wrapped! See POD.) - Optimized 'set' accessor code - Added option to suppress use of Want module - Documented that attribute handlers need to come first in a class 1.52 Fri Sep 1 15:58:25 EDT 2006 - Support class-specified attribute handlers - Made Want module optional 1.51 Wed Aug 30 11:08:30 EDT 2006 - Added 'All/Std_All'+'Arg' field declarations keywords - More method chaining support - Require Want 0.12 or later - Document $SIG{'__DIE__'} interference issues 1.49 Tue Aug 8 14:15:43 EDT 2006 - Support for :lvalue accessor generation 1.48 Thu Aug 3 12:15:20 EDT 2006 - Reworked multiple error handling 1.47 Tue Aug 1 15:50:28 EDT 2006 - Workaround Perl's "in cleanup" bug 1.46 Thu Jul 27 16:56:35 EDT 2006 - Fix masking of $@ by 'eval's in :DESTROY subroutines - Documented limitation with namespace 'DB' 1.45 Tue Jun 27 14:09:44 EDT 2006 - Added :PreInit subroutines 1.44 Fri Jun 23 13:57:15 EDT 2006 - Fix file versioning for PAUSE 1.43 Fri Jun 23 12:56:29 EDT 2006 - Moved exception code to Exception.pm - Versioned all .pm files - Caution against returning objects from threads 1.42 Thu May 4 11:26:15 EDT 2006 - Fixed object ID reclamation 1.41 Thu Apr 27 11:53:01 EDT 2006 - Documented that cloning does not clone internally held objects 1.39 Thu Apr 27 11:11:01 EDT 2006 - Fixed bug whereby cloning was duplicating objects 1.38 Sun Mar 5 21:39:00 EST 2006 - Bug fix for standard accessors with private permissions 1.37 Wed Feb 15 13:58:15 EST 2006 - Parameter preprocessing (courtesy of Berkan Eskikaya) 1.36 Wed Feb 8 11:43:14 EST 2006 - Support 'weakened' fields 1.35 Fri Feb 3 11:59:38 EST 2006 - Workaround for Perl 5.8.4/5.8.5 bug 1.34 Wed Feb 1 17:28:09 EST 2006 - Insure proper 'import' for 'threads::shared' in Util.pm - Fix for Storable bug (courtesy of Matthijs Bomhoff) - Delayed loading for various OIO features - Added singleton class example to POD - Documented 'use base' cases in POD 1.33 Wed Jan 18 23:24:43 EST 2006 - Compatible with Exporter - example in POD 1.32 Wed Jan 18 13:36:31 EST 2006 - Compatible with Attribute::Handlers 1.31 Sat Jan 14 04:33:22 EST 2006 - Fix to module importation bug (#17055) - Documented that Object::InsideOut objects are 'readonly' - Documented direct data fetching in class code 1.29 Mon Jan 9 09:29:54 EST 2006 - Added 'private' and 'restricted' acessors 1.28 Fri Jan 6 16:01:41 EST 2006 - Exported methods don't override parents' methods - Internal: Removed 'caller_level' in ->die() 1.27 Wed Dec 28 08:57:06 EST 2005 - Added '::storable' flag 1.26 Wed Dec 21 13:54:26 EST 2005 - Suppress import() invoked via inheritance - Only put 'Object::InsideOut' in base class @ISAs 1.25 Wed Dec 21 09:55:17 EST 2005 - Use 'B' module to find subroutine names - Changed author's email address - Test fixes for Perl 5.6.X bug 1.24 Fri Dec 16 10:21:00 2005 - Support foreign classes that only export object methods 1.23 Mon Dec 12 10:04:30 2005 - Deep object cloning, and deep field cloning - Handle creating shared objects when using Storable 1.22 Fri Dec 09 12:55:00 2005 - Support object serialization using the Storable module 1.21 Thu Dec 08 11:47:20 2005 - Minor fix to :Field declaration handling code 1.19 Thu Dec 08 10:41:10 2005 - Store clone of :InitArgs 'Default's if ref 1.18 Wed Dec 07 11:59:35 2005 - Can inherit from non-Object::InsideOut classes - create_field() requires 3 args 1.17 Fri Dec 02 12:29:40 2005 - Handle ->class::method(), ->SUPER::method(), and ->class::SUPER::method() in :Automethods - Handle ->can('class::method') and ->can('class::SUPER::method') 1.16 Thu Dec 01 13:51:50 2005 - Preclude name collisions in ->dump() - Added installation check for Scalar::Util::weaken() 1.15 Tue Nov 29 13:16:40 2005 - Added create_field() for dynamic field creation 1.14 Wed Nov 23 08:15:30 2005 - User-specified 'set' method return type - Removed deprecated _DUMP and INITIALIZE 1.13 Mon Nov 21 11:10:00 2005 - POD fixup 1.12 Mon Nov 21 11:03:00 2005 - Support custom type checking for initializers and accessors 1.11 Fri Nov 18 08:41:00 2005 - Eliminated internal use of each() 1.1 Thu Nov 17 13:53:20 2005 - Fixed bug with each(%{$obj}) on results object - Filled in 'holes' in POD - Workable version numbering 1.04.00 Wed Nov 16 16:24:00 2005 - Added chaining and accumulation for :Automethods - Chained methods don't return a results object in scalar context 1.03.00 Tue Nov 15 11:03:40 2005 - Changed structure for object serialization output 1.02.00 Tue Nov 15 10:13:05 2005 - Added ->set() method for object sharing support 1.01.00 Mon Nov 14 14:49:40 2005 - Added object serialization support - deprecated _DUMP 1.00.00 Fri Nov 11 15:27:00 2005 - Can now use array-based object fields - up to 40% faster - Deprecated INITIALIZE - no longer needed 0.07.00 Thu Nov 10 08:50:00 2005 - Verify ${} is not overloaded - Require Scalar::Util 1.10 or later, and Test::More 0.50 or later - Verified on Perl 5.6.0 through 5.9.2 0.06.00 Thu Nov 03 14:44:20 2005 - Handle ->can('SUPER::method') 0.05.00 Thu Nov 03 10:48:05 2005 - More tests (and fixes to a couple of bugs they turned up) 0.04.00 Wed Nov 02 16:05:00 2005 - Added specifier for 'standard' (i.e., get_X/set_X) accessor methods - More tests (and fixes to a couple of bugs they turned up) 0.03.00 Tue Nov 01 15:41:00 2005 - Added :Chained method attribute - Renamed Cumulative.pm to Results.pm - Added INITIALIZE() subroutine to overcome CHECK/INIT phase issues with mod_perl and with runtime loading of classes 0.02.00 Mon Oct 31 14:27:30 2005 - Error trapping on user-supplied subroutines - Added Build.PL 0.01.00 Mon Oct 31 13:15:00 2005 - Initial release Object-InsideOut-4.05/MANIFEST0000644000175000001440000000355613377136500015404 0ustar jdheddenusersMANIFEST README Changes Makefile.PL Build.PL lib/Bundle/Object/InsideOut.pm lib/Object/InsideOut.pm lib/Object/InsideOut.pod lib/Object/InsideOut/Autoload.pm lib/Object/InsideOut/Chained.pm lib/Object/InsideOut/Cumulative.pm lib/Object/InsideOut/Dump.pm lib/Object/InsideOut/Dynamic.pm lib/Object/InsideOut/Exception.pm lib/Object/InsideOut/Foreign.pm lib/Object/InsideOut/Metadata.pm lib/Object/InsideOut/Overload.pm lib/Object/InsideOut/Secure.pm lib/Object/InsideOut/Universal.pm lib/Object/InsideOut/Util.pm lib/Object/InsideOut/attributes.pm lib/Object/InsideOut/lvalue.pm t/00-load.t t/01-basic.t t/01a-basic.t t/02-auto.t t/03-threads.t t/03a-threads.t t/04-shared.t t/04a-shared.t t/05-require.t t/05-require.pm t/05a-require.t t/05a-require.pm t/06-id.t t/07-dump.t t/07a-dump.t t/08-access.t t/09-chained.t t/09a-chained.t t/09b-chained.t t/10-cumulative.t t/10a-cumulative.t t/10b-cumulative.t t/11-coercion.t t/12-super.t t/13-pump.t t/14-auto_cc.t t/15-type.t t/15a-type.t t/16-return.t t/17-dynamic.t t/18-inherit.t t/18a-inherit.t t/19-storable.t t/20-clone.t t/21-import.t t/22-import.t t/23-weak.t t/24-preproc.t t/25-access.t t/26-preinit.t t/27-exception.t t/28-lvalue.t t/29-non_lvalue.t t/30-all.t t/31-attr.t t/32-meta.t t/33-hash_only.t t/34-secure.t t/34a-secure.t t/35-add_class.t t/36-require.t t/37-class_perm.t t/38-combined.t t/39-fork.t t/40-normalize.t t/41-def.t t/42-sh_obj.t t/43-overload.t t/44-data.t t/45-unused.t t/46-singleton.t t/46a-singleton.t t/47-sh_reuse.t t/48-not_shared.t t/49-delegators.t t/49a-delegators-non-OIO.t t/50-active_defs.t t/51-readonly.t t/99-pod.t t/test.pl t/EmptyParent.pm t/ErrorParent.pm t/Imp1.pm t/Imp2.pm t/Parent.pm t/Req1.pm t/Req2.pm t/Req3.pm examples/YAPI.pm META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Object-InsideOut-4.05/lib/0000755000175000001440000000000013377136477015025 5ustar jdheddenusersObject-InsideOut-4.05/lib/Bundle/0000755000175000001440000000000013377136477016236 5ustar jdheddenusersObject-InsideOut-4.05/lib/Bundle/Object/0000755000175000001440000000000013377136477017444 5ustar jdheddenusersObject-InsideOut-4.05/lib/Bundle/Object/InsideOut.pm0000644000175000001440000000465613377136466021716 0ustar jdheddenuserspackage Bundle::Object::InsideOut; use strict; use warnings; our $VERSION = '4.05'; $VERSION = eval $VERSION; 1; __END__ =head1 NAME Bundle::Object::InsideOut - A bundle of modules for full Object::InsideOut support =head1 SYNOPSIS perl -MCPAN -e "install Bundle::Object::InsideOut" =head1 CONTENTS Test::Harness 3.42 - Used for module testing Test::Simple 1.302140 - Used for module testing Scalar::Util 1.50 - Used by Object::InsideOut Pod::Escapes 1.07 - Used by Pod::Simple Pod::Simple 3.35 - Used by Test::Pod Test::Pod 1.52 - Checks POD syntax Devel::Symdump 2.18 - Used by Pod::Coverage File::Spec 3.75 - Used by Pod::Parser Pod::Parser 1.63 - Used by Pod::Coverage Pod::Coverage 0.23 - Used by Test::Pod::Coverage Test::Pod::Coverage 1.10 - Tests POD coverage threads 2.22 - Support for threads threads::shared 1.58 - Support for sharing objects between threads Want 0.29 - :lvalue accessor support Data::Dumper 2.172 - Object serialization support Storable 3.11 - Object serialization support Devel::StackTrace 2.03 - Used by Exception::Class Class::Data::Inheritable 0.08 - Used by Exception::Class Exception::Class 1.44 - Error handling Object::InsideOut 4.05 - Inside-out object support URI 1.74 - Used by LWP::UserAgent HTML::Tagset 3.20 - Used by LWP::UserAgent HTML::Parser 3.72 - Used by LWP::UserAgent LWP::UserAgent 6.36 - Used by Math::Random::MT::Auto Win32::API 0.82 - Used by Math::Random::MT::Auto (Win XP only) Math::Random::MT::Auto 6.23 - Support for :SECURE mode =head1 DESCRIPTION This bundle includes all the modules used to test and support Object::InsideOut. =head1 CAVEATS For ActivePerl on Win XP, if L doesn't install using CPAN, then try installing it using PPM: ppm install Win32-API Obviously, Win32::API will not install on all platforms - just Windows and Cygwin. =head1 AUTHOR Jerry D. Hedden, Sjdhedden AT cpan DOT orgE> =head1 COPYRIGHT AND LICENSE Copyright 2006 - 2012 Jerry D. Hedden. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Object-InsideOut-4.05/lib/Object/0000755000175000001440000000000013377136477016233 5ustar jdheddenusersObject-InsideOut-4.05/lib/Object/InsideOut/0000755000175000001440000000000013377136477020136 5ustar jdheddenusersObject-InsideOut-4.05/lib/Object/InsideOut/Universal.pm0000644000175000001440000001753513377136466022455 0ustar jdheddenuserspackage Object::InsideOut; { use strict; use warnings; no warnings 'redefine'; # Install versions of UNIVERSAL::can/isa that understands :Automethod and # foreign inheritance sub install_UNIVERSAL { my ($GBL) = @_; *Object::InsideOut::can = sub { my ($thing, $method) = @_; return if (! defined($thing)); # Metadata call for methods if (@_ == 1) { my $meths = Object::InsideOut::meta(shift)->get_methods(); return (wantarray()) ? (keys(%$meths)) : [ keys(%$meths) ]; } return if (! defined($method)); # First, try the original UNIVERSAL::can() my $code; if ($method =~ /^SUPER::/) { # Superclass WRT caller my $caller = caller(); eval { $code = $thing->Object::InsideOut::SUPER::can($caller.'::'.$method) }; } else { eval { $code = $thing->Object::InsideOut::SUPER::can($method) }; } if ($code) { return ($code); } # Handle various calling methods my ($class, $super); if ($method !~ /::/) { # Ordinary method check # $obj->can('x'); $class = ref($thing) || $thing; } elsif ($method !~ /SUPER::/) { # Fully-qualified method check # $obj->can('FOO::x'); ($class, $method) = $method =~ /^(.+)::([^:]+)$/; } elsif ($method =~ /^SUPER::/) { # Superclass method check # $obj->can('SUPER::x'); $class = caller(); $method =~ s/SUPER:://; $super = 1; } else { # Qualified superclass method check # $obj->can('Foo::SUPER::x'); ($class, $method) = $method =~ /^(.+)::SUPER::([^:]+)$/; $super = 1; } my $heritage = $$GBL{'heritage'}; my $automethods = $$GBL{'sub'}{'auto'}; # Next, check with heritage objects and Automethods my ($code_type, $code_dir, %code_refs); foreach my $pkg (@{$$GBL{'tree'}{'bu'}{$class}}) { # Skip self's class if SUPER if ($super && $class eq $pkg) { next; } # Check heritage if (exists($$heritage{$pkg})) { no warnings; foreach my $pkg2 (keys(%{$$heritage{$pkg}{'cl'}})) { if ($code = $pkg2->can($method)) { return ($code); } } } # Check with the Automethods if (my $automethod = $$automethods{$pkg}) { # Call the Automethod to get a code ref local $CALLER::_ = $_; local $_ = $method; local $SIG{'__DIE__'} = 'OIO::trap'; if (my ($code, $ctype) = $automethod->($thing)) { if (ref($code) ne 'CODE') { # Not a code ref OIO::Code->die( 'message' => ':Automethod did not return a code ref', 'Info' => ":Automethod in package '$pkg' invoked for method '$method'"); } if (defined($ctype)) { my ($type, $dir) = $ctype =~ /(\w+)(?:[(]\s*(.*)\s*[)])?/; if ($type && $type =~ /CUM/i) { if ($code_type) { $type = ':Cumulative'; $dir = ($dir && $dir =~ /BOT/i) ? 'bottom up' : 'top down'; if ($code_type ne $type || $code_dir ne $dir) { # Mixed types my ($pkg2) = keys(%code_refs); OIO::Code->die( 'message' => 'Inconsistent code types returned by :Automethods', 'Info' => "Class '$pkg' returned type $type($dir), and class '$pkg2' returned type $code_type($code_dir)"); } } else { $code_type = ':Cumulative'; $code_dir = ($dir && $dir =~ /BOT/i) ? 'bottom up' : 'top down'; } $code_refs{$pkg} = $code; next; } if ($type && $type =~ /CHA/i) { if ($code_type) { $type = ':Chained'; $dir = ($dir && $dir =~ /BOT/i) ? 'bottom up' : 'top down'; if ($code_type ne $type || $code_dir ne $dir) { # Mixed types my ($pkg2) = keys(%code_refs); OIO::Code->die( 'message' => 'Inconsistent code types returned by :Automethods', 'Info' => "Class '$pkg' returned type $type($dir), and class '$pkg2' returned type $code_type($code_dir)"); } } else { $code_type = ':Chained'; $code_dir = ($dir && $dir =~ /BOT/i) ? 'bottom up' : 'top down'; } $code_refs{$pkg} = $code; next; } # Unknown automethod code type OIO::Code->die( 'message' => "Unknown :Automethod code type: $ctype", 'Info' => ":Automethod in package '$pkg' invoked for method '$method'"); } if ($code_type) { # Mixed types my ($pkg2) = keys(%code_refs); OIO::Code->die( 'message' => 'Inconsistent code types returned by :Automethods', 'Info' => "Class '$pkg' returned an 'execute immediately' type, and class '$pkg2' returned type $code_type($code_dir)"); } # Just a one-shot - return it return ($code); } } } if ($code_type) { my $tree = ($code_dir eq 'bottom up') ? $$GBL{'tree'}{'bu'} : $$GBL{'tree'}{'td'}; $code = ($code_type eq ':Cumulative') ? create_CUMULATIVE($method, $tree, \%code_refs) : create_CHAINED($method, $tree, \%code_refs); return ($code); } return; # Can't }; *Object::InsideOut::isa = sub { my ($thing, $type) = @_; return ('') if (! defined($thing)); # Metadata call for classes if (@_ == 1) { return Object::InsideOut::meta($thing)->get_classes(); } # Workaround for Perl bug #47233 return ('') if (! defined($type)); # Try original UNIVERSAL::isa() if (my $isa = eval { $thing->Object::InsideOut::SUPER::isa($type) }) { return ($isa); } # Next, check heritage foreach my $pkg (@{$$GBL{'tree'}{'bu'}{ref($thing) || $thing}}) { if (exists($$GBL{'heritage'}{$pkg})) { foreach my $pkg (keys(%{$$GBL{'heritage'}{$pkg}{'cl'}})) { if (my $isa = $pkg->isa($type)) { return ($isa); } } } } return (''); # Isn't }; # Stub ourself out *Object::InsideOut::install_UNIVERSAL = sub { }; } } # End of package's lexical scope # Ensure correct versioning ($Object::InsideOut::VERSION eq '4.05') or die("Version mismatch\n"); # EOF Object-InsideOut-4.05/lib/Object/InsideOut/attributes.pm0000644000175000001440000000462013377136466022662 0ustar jdheddenuserspackage Object::InsideOut; { use strict; use warnings; no warnings 'redefine'; sub install_ATTRIBUTES { my ($GBL) = @_; *Object::InsideOut::MODIFY_SCALAR_ATTRIBUTES = sub { my ($pkg, $scalar, @attrs) = @_; # Call attribute handlers in the class tree if (exists($$GBL{'attr'}{'MOD'}{'SCALAR'})) { @attrs = CHECK_ATTRS('SCALAR', $pkg, $scalar, @attrs); } # If using Attribute::Handlers, send it any unused attributes if (@attrs && Attribute::Handlers::UNIVERSAL->can('MODIFY_SCALAR_ATTRIBUTES')) { return (Attribute::Handlers::UNIVERSAL::MODIFY_SCALAR_ATTRIBUTES($pkg, $scalar, @attrs)); } # Return any unused attributes return (@attrs); }; *Object::InsideOut::CHECK_ATTRS = sub { my ($type, $pkg, $ref, @attrs) = @_; # Call attribute handlers in the class tree foreach my $class (@{$$GBL{'tree'}{'bu'}{$pkg}}) { if (my $handler = $$GBL{'attr'}{'MOD'}{$type}{$class}) { local $SIG{'__DIE__'} = 'OIO::trap'; @attrs = $handler->($pkg, $ref, @attrs); return if (! @attrs); } } return (@attrs); # Return remaining attributes }; *Object::InsideOut::FETCH_ATTRS = sub { my ($type, $stash, $ref) = @_; my @attrs; # Call attribute handlers in the class tree if (exists($$GBL{'attr'}{'FETCH'}{$type})) { foreach my $handler (@{$$GBL{'attr'}{'FETCH'}{$type}}) { local $SIG{'__DIE__'} = 'OIO::trap'; push(@attrs, $handler->($stash, $ref)); } } return (@attrs); }; # Stub ourself out *Object::InsideOut::install_ATTRIBUTES = sub { }; } add_meta('Object::InsideOut', { 'MODIFY_SCALAR_ATTRIBUTES' => {'hidden' => 1}, 'CHECK_ATTRS' => {'hidden' => 1}, 'FETCH_ATTRS' => {'hidden' => 1}, }); sub FETCH_SCALAR_ATTRIBUTES :Sub { return (FETCH_ATTRS('SCALAR', @_)); } sub FETCH_HASH_ATTRIBUTES :Sub { return (FETCH_ATTRS('HASH', @_)); } sub FETCH_ARRAY_ATTRIBUTES :Sub { return (FETCH_ATTRS('ARRAY', @_)); } sub FETCH_CODE_ATTRIBUTES :Sub { return (FETCH_ATTRS('CODE', @_)); } } # End of package's lexical scope # Ensure correct versioning ($Object::InsideOut::VERSION eq '4.05') or die("Version mismatch\n"); # EOF Object-InsideOut-4.05/lib/Object/InsideOut/Cumulative.pm0000644000175000001440000002056313377136466022616 0ustar jdheddenuserspackage Object::InsideOut; { use strict; use warnings; no warnings 'redefine'; my $GBL = {}; sub generate_CUMULATIVE :Sub(Private) { ($GBL) = @_; my $g_cu = $$GBL{'sub'}{'cumu'}; my $cumu_td = $$g_cu{'new'}{'td'} || []; my $cumu_bu = $$g_cu{'new'}{'bu'} || []; delete($$g_cu{'new'}); if (! exists($$g_cu{'td'})) { $$GBL{'sub'}{'cumu'} = { td => {}, # 'Top down' bu => {}, # 'Bottom up' restrict => {}, # :Restricted }; $g_cu = $$GBL{'sub'}{'cumu'}; } my $cu_td = $$g_cu{'td'}; my $cu_bu = $$g_cu{'bu'}; my $cu_restr = $$g_cu{'restrict'}; # Get names for :CUMULATIVE methods my (%cum_loc); while (my $info = shift(@{$cumu_td})) { $$info{'name'} ||= sub_name($$info{'code'}, ':CUMULATIVE', $$info{'loc'}); my $package = $$info{'pkg'}; my $name = $$info{'name'}; $cum_loc{$name}{$package} = $$info{'loc'}; $$cu_td{$name}{$package} = $$info{'wrap'}; if (exists($$info{'exempt'})) { push(@{$$cu_restr{$package}{$name}}, sort grep {$_} split(/[,'\s]+/, $$info{'exempt'} || '')); } } # Get names for :CUMULATIVE(BOTTOM UP) methods while (my $info = shift(@{$cumu_bu})) { $$info{'name'} ||= sub_name($$info{'code'}, ':CUMULATIVE(BOTTOM UP)', $$info{'loc'}); my $package = $$info{'pkg'}; my $name = $$info{'name'}; # Check for conflicting definitions of 'name' if ($$cu_td{$name}) { foreach my $other_package (keys(%{$$cu_td{$name}})) { if ($other_package->isa($package) || $package->isa($other_package)) { my ($pkg, $file, $line) = @{$cum_loc{$name}{$other_package}}; my ($pkg2, $file2, $line2) = @{$$info{'loc'}}; OIO::Attribute->die( 'location' => $$info{'loc'}, 'message' => "Conflicting definitions for cumulative method '$name'", 'Info' => "Declared as :CUMULATIVE in class '$pkg' (file '$file', line $line), but declared as :CUMULATIVE(BOTTOM UP) in class '$pkg2' (file '$file2' line $line2)"); } } } $$cu_bu{$name}{$package} = $$info{'wrap'}; if (exists($$info{'exempt'})) { push(@{$$cu_restr{$package}{$name}}, sort grep {$_} split(/[,'\s]+/, $$info{'exempt'} || '')); } } # Propagate restrictions my $reapply = 1; my $trees = $$GBL{'tree'}{'td'}; while ($reapply) { $reapply = 0; foreach my $pkg (keys(%{$cu_restr})) { foreach my $class (keys(%{$trees})) { next if (! grep { $_ eq $pkg } @{$$trees{$class}}); foreach my $p (@{$$trees{$class}}) { foreach my $n (keys(%{$$cu_restr{$pkg}})) { if (exists($$cu_restr{$p}{$n})) { next if ($$cu_restr{$p}{$n} == $$cu_restr{$pkg}{$n}); my $equal = (@{$$cu_restr{$p}{$n}} == @{$$cu_restr{$pkg}{$n}}); if ($equal) { for (1..@{$$cu_restr{$p}{$n}}) { if ($$cu_restr{$pkg}{$n}[$_-1] ne $$cu_restr{$p}{$n}[$_-1]) { $equal = 0; last; } } } if (! $equal) { my %restr = map { $_ => 1 } @{$$cu_restr{$p}{$n}}, @{$$cu_restr{$pkg}{$n}}; $$cu_restr{$pkg}{$n} = [ sort(keys(%restr)) ]; $reapply = 1; } } else { $reapply = 1; } $$cu_restr{$p}{$n} = $$cu_restr{$pkg}{$n}; } } } } } no warnings 'redefine'; no strict 'refs'; # Implement :CUMULATIVE methods foreach my $name (keys(%{$cu_td})) { my $code = create_CUMULATIVE($name, $trees, $$cu_td{$name}); foreach my $package (keys(%{$$cu_td{$name}})) { *{$package.'::'.$name} = $code; add_meta($package, $name, 'kind', 'cumulative'); if (exists($$cu_restr{$package}{$name})) { add_meta($package, $name, 'restrict', 1); } } } # Implement :CUMULATIVE(BOTTOM UP) methods foreach my $name (keys(%{$cu_bu})) { my $code = create_CUMULATIVE($name, $$GBL{'tree'}{'bu'}, $$cu_bu{$name}); foreach my $package (keys(%{$$cu_bu{$name}})) { *{$package.'::'.$name} = $code; add_meta($package, $name, 'kind', 'cumulative (bottom up)'); if (exists($$cu_restr{$package}{$name})) { add_meta($package, $name, 'restrict', 1); } } } } # Returns a closure back to initialize() that is used to setup CUMULATIVE # and CUMULATIVE(BOTTOM UP) methods for a particular method name. sub create_CUMULATIVE :Sub(Private) { # $name - method name # $tree - either $GBL{'tree'}{'td'} or $GBL{'tree'}{'bu'} # $code_refs - hash ref by package of code refs for a particular method name my ($name, $tree, $code_refs) = @_; return sub { my $class = ref($_[0]) || $_[0]; if (! $class) { OIO::Method->die('message' => "Must call '$name' as a method"); } my $list_context = wantarray; my (@results, @classes); # Caller must be in class hierarchy my $restr = $$GBL{'sub'}{'cumu'}{'restrict'}; if ($restr && exists($$restr{$class}{$name})) { my $caller = caller(); if (! ((grep { $_ eq $caller } @{$$restr{$class}{$name}}) || $caller->isa($class) || $class->isa($caller))) { OIO::Method->die('message' => "Can't call restricted method '$class->$name' from class '$caller'"); } } # Accumulate results foreach my $pkg (@{$$tree{$class}}) { if (my $code = $$code_refs{$pkg}) { local $SIG{'__DIE__'} = 'OIO::trap'; my @args = @_; if (defined($list_context)) { push(@classes, $pkg); if ($list_context) { # List context push(@results, $code->(@args)); } else { # Scalar context push(@results, scalar($code->(@args))); } } else { # void context $code->(@args); } } } # Return results if (defined($list_context)) { if ($list_context) { # List context return (@results); } # Scalar context - returns object return (Object::InsideOut::Results->new('VALUES' => \@results, 'CLASSES' => \@classes)); } }; } } # End of package's lexical scope package Object::InsideOut::Results; { use strict; use warnings; our $VERSION = '4.05'; $VERSION = eval $VERSION; use Object::InsideOut 4.05; use Object::InsideOut::Metadata 4.05; my @VALUES :Field :Arg(VALUES); my @CLASSES :Field :Arg(CLASSES); my @HASHES :Field; sub as_string :Stringify { return (join('', grep(defined, @{$VALUES[${$_[0]}]}))); } sub count :Numerify { return (scalar(@{$VALUES[${$_[0]}]})); } sub have_any :Boolify { return (@{$VALUES[${$_[0]}]} > 0); } sub values :Arrayify { return ($VALUES[${$_[0]}]); } sub as_hash :Hashify { my $self = $_[0]; if (! defined($HASHES[$$self])) { my %hash; @hash{@{$CLASSES[$$self]}} = @{$VALUES[$$self]}; $self->set(\@HASHES, \%hash); } return ($HASHES[$$self]); } # Our metadata add_meta('Object::InsideOut::Results', { 'new' => {'hidden' => 1}, 'create_field' => {'hidden' => 1}, 'add_class' => {'hidden' => 1}, }); } # End of package's lexical scope # Ensure correct versioning ($Object::InsideOut::VERSION eq '4.05') or die("Version mismatch\n"); # EOF Object-InsideOut-4.05/lib/Object/InsideOut/Metadata.pm0000644000175000001440000005337313377136466022225 0ustar jdheddenuserspackage Object::InsideOut::Metadata; { use strict; use warnings; our $VERSION = '4.05'; $VERSION = eval $VERSION; # Stores method metadata # Initialized with our own metadata my %METADATA = ( 'Object::InsideOut::Metadata' => { 'add_meta' => {'hidden' => 1}, 'AUTOLOAD' => {'hidden' => 1}, 'new' => {'hidden' => 1}, 'create_field' => {'hidden' => 1}, 'add_class' => {'hidden' => 1}, 'get_classes' => {'kind' => 'object'}, 'get_methods' => {'kind' => 'object'}, 'get_args' => {'kind' => 'object'}, }, ); ### Exported Subroutines ### sub import { # Export 'add_meta' call no strict 'refs'; my $caller = caller(); *{$caller.'::add_meta'} = \&add_meta; $METADATA{$caller}{'add_meta'}{'hidden'} = 1; } # Stores metadata for later use sub add_meta { my ($class, $name, $meta, $value) = @_; if (@_ == 4) { $METADATA{$class}{$name}{$meta} = $value; } else { my $data; if (@_ == 3) { $$data{$class}{$name} = $meta; } elsif (@_ == 2) { $$data{$class} = $name; } else { $data = $class; } while (my ($c, $mn) = each(%$data)) { while (my ($n, $md) = each(%$mn)) { while (my ($m, $v) = each(%$md)) { $METADATA{$c}{$n}{$m} = $v; } } } } } # This will load the OO option of our code. # It's done this way because of circular dependencies with OIO. sub AUTOLOAD { # Need 5.8.0 or later if ($] < 5.008) { OIO::Code->die('message' => q/Introspection API requires Perl 5.8.0 or later/, 'ignore_package' => 'Object::InsideOut::Metadata'); } # It's a bug if not invoked by ->new() # This should only ever happen once if (our $AUTOLOAD ne 'Object::InsideOut::Metadata::new') { OIO::Method->die('message' => "Object::InsideOut::Metadata does not support AUTOLOAD of $AUTOLOAD", 'ignore_package' => 'Object::InsideOut::Metadata'); } # Workaround to get %METADATA into our scope my $meta = \%METADATA; # Load the rest of our code my $text = do { local $/; }; close(DATA); eval $text; die if $@; # Continue on goto &Object::InsideOut::new; } } # End of package's lexical scope 1; __DATA__ ### Object Interface ### use Object::InsideOut 4.05; my @CLASSES :Field; my @FOREIGN :Field; my $GBL; my %init_args :InitArgs = ( 'GBL' => '', 'CLASS' => '', ); sub _init :Init { my ($self, $args) = @_; $GBL = $args->{'GBL'}; my $class = $args->{'CLASS'}; $CLASSES[$$self] = $$GBL{'tree'}{'td'}{$class}; my %foreign; my $herit = $$GBL{'heritage'}; foreach my $pkg (@{$$GBL{'tree'}{'bu'}{$class}}) { if (exists($$herit{$pkg})) { @foreign{keys(%{$$herit{$pkg}{'cl'}})} = undef; } } $FOREIGN[$$self] = [ keys(%foreign) ]; } # Class list sub get_classes { my $self = shift; if (! Scalar::Util::blessed($self)) { OIO::Method->die('message' => q/'get_classes' called as a class method/); } my @classes = (@{$CLASSES[$$self]}, @{$FOREIGN[$$self]}); return ((wantarray()) ? @classes : \@classes); } # Contructor argument list sub get_args { my $self = shift; if (! Scalar::Util::blessed($self)) { OIO::Method->die('message' => q/'get_args' called as a class method/); } my %args; foreach my $pkg (@{$CLASSES[$$self]}) { if (my $ia = $$GBL{'args'}{$pkg}) { foreach my $arg (keys(%$ia)) { next if ($arg eq ' '); my $hash = $$ia{$arg}; $args{$pkg}{$arg} = {}; if (ref($hash) eq 'HASH') { if ($$hash{'_F'}) { $args{$pkg}{$arg}{'field'} = 1; } if ($$hash{'_M'}) { $args{$pkg}{$arg}{'mandatory'} = 1; } if (defined(my $def = $$hash{'_D'})) { $args{$pkg}{$arg}{'default'} = Object::InsideOut::Util::clone($def); } if (my $pre = $$hash{'_P'}) { $args{$pkg}{$arg}{'preproc'} = $pre; } if (my $type = $$hash{'_T'}) { if (!ref($type)) { $type =~ s/\s//g; my $subtype; if ($type =~ /^(.*)\((.+)\)$/i) { $type = $1; $subtype = $2; if ($subtype =~ /^num(?:ber|eric)?$/i) { $subtype = 'numeric'; } } if ($type =~ /^num(?:ber|eric)?$/i) { $type = 'numeric'; } elsif ($type =~ /^(?:list|array)$/i) { $type = 'list'; } elsif ($type =~ /^(array|hash)(?:_?ref)?$/i) { $type = uc($1); } if ($subtype) { $type .= "($subtype)"; } } $args{$pkg}{$arg}{'type'} = $type; } } } } } return (wantarray() ? %args : \%args); } # Available methods sub get_methods { my $self = shift; if (! Scalar::Util::blessed($self)) { OIO::Method->die('message' => q/'get_methods' called as a class method/); } my %methods; foreach my $pkg (@{$FOREIGN[$$self]}, 'Object::InsideOut', @{$CLASSES[$$self]}) { my $foreign = grep { $_ eq $pkg } @{$FOREIGN[$$self]}; # Get all subs no strict 'refs'; foreach my $sym (keys(%{$pkg.'::'})) { next if (! *{$pkg.'::'.$sym}{'CODE'}); next if ($sym =~ /^[(_]/); # '(' overload; '_' private next if ($sym =~ /^(?:CLONE(?:_SKIP)?|DESTROY|import)$/); $methods{$sym}{'class'} = $pkg; if ($foreign) { $methods{$sym}{'kind'} = 'foreign'; } } if ($METADATA{$pkg}) { foreach my $meth (keys(%{$METADATA{$pkg}})) { # Remove hidden methods if ($METADATA{$pkg}{$meth}{'hidden'}) { delete($methods{$meth}); next; } } } if ($$GBL{'sub'}{'auto'}{$pkg}) { $methods{'AUTOLOAD'} = { 'kind' => 'automethod', 'class' => $pkg }; } } # Add metadata foreach my $meth (keys(%methods)) { next if ($meth eq 'AUTOLOAD'); my $pkg = $methods{$meth}{'class'}; if ($METADATA{$pkg}) { foreach my $key (keys(%{$METADATA{$pkg}{$meth}})) { $methods{$meth}{$key} = $METADATA{$pkg}{$meth}{$key}; } } } return (wantarray() ? %methods : \%methods); } =head1 NAME Object::InsideOut::Metadata - Introspection for Object::InsideOut classes =head1 VERSION This document describes Object::InsideOut::Metadata version 4.05 =head1 SYNOPSIS package My::Class; { use Object::InsideOut; use Object::InsideOut::Metadata; my @data :Field :Arg('data') :Get('data') :Set('put_data'); my @misc :Field; my %init_args :InitArgs = ( 'INFO' => '', ); sub _init :Init { my ($self, $args) = @_; if (exists($args->{'INFO'})) { $misc[$$self] = 'INFO: ' . $args->{'INFO'}; } } sub misc :lvalue :Method { my $self = shift; $misc[$$self]; } add_meta(__PACKAGE__, 'misc', { 'lvalue' => 1 }); } package main; # Obtain a metadata object for a class my $meta = My::Class->meta(); # ... or obtain a metadata object for an object my $obj = My::Class->new(); my $meta = $obj->meta(); # Obtain the class hierarchy from the metadata object my @classes = $meta->get_classes(); # Obtain information on the parameters for a class's construction my %args = $meta->get_args(); # Obtain information on a class's methods my %methods = $meta->get_methods(); =head1 DESCRIPTION Object::InsideOut provides an introspection API that allows you to obtain metadata on a class's hierarchy, constructor parameters, and methods. This is done through the use of metadata objects that are generated by this class. In addition, developers can specify metadata data for methods they write for their classes. =head1 METADATA OBJECT To obtain metadata on an Object::InsideOut class or object, you must first generate a metadata object for that class or object. Using that metadata object, one can then obtain information on the class hierarchy, constructor parameters, and methods. =over =item my $meta = My::Class->meta(); =item my $meta = $obj->meta(); The C<-Emeta()> method, which is exported by Object::InsideOut to each class, returns an L object which can then be I for information about the invoking class or invoking object's class. =back =head1 CLASS HIERARCHY Any Object::InsideOut class potentially has four categories of classes associated with it: =over =item 1. Object::InsideOut While the basis for all Object::InsideOut classes it is not an object class per se because you can create objects from it (i.e., you can't do Cnew()>). While Cisa('Object::InsideOut')> will return I, because Object::InsideOut is not an object class, it is not considered to be part of a class's hierarchy. =item 2. The class itself A class's hierarchy always includes itself. =item 3. Parent classes These are all the Object::InsideOut classes up the inheritance tree that a class is derived from. =item 4. Foreign classes These are non-Object::InsideOut classes that a class inherits from. (See L.) Because of implementation details, foreign classes do not appear in a class's C<@ISA> array. However, Object::InsideOut implements a version of C<-Eisa()> that handles foreign classes. =back A class's hierarchy consists of any classes in the latter three categories. =over =item $meta->get_classes(); When called in an array context, returns a list that constitutes the class hierarchy for the class or object used to generate the metadata object. When called in a scalar context, returns an array ref. =item My::Class->isa(); =item $obj->isa(); When called in an array context, calling C<-Eisa()> without any arguments on an Object::InsideOut class or object returns a list of the classes in the class hierarchy for that class or object, and is equivalent to: my @classes = $obj->meta()->get_classes(); When called in a scalar context, it returns an array ref containing the classes. =back =head1 CONSTRUCTOR PARAMETERS Constructor parameters are the arguments given to a class's C<-Enew()> call. =over =item $meta->get_args(); Returns a hash (hash ref in scalar context) containing information on the parameters that can be used to construct an object from the class associated with the metadata object. Here's an example of such a hash: { 'My::Class' => { 'data' => { 'field' => 1, 'type' => 'numeric', }, 'misc' => { 'mandatory' => 1, }, }, 'My::Parent' => { 'info' => { 'default' => '', }, }, } The keys for this hash are the Object::IsideOut classes in the class hierarchy. These I are paired with hash refs, the keys of which are the names of the parameters for that class (e.g., 'data' and 'misc' for My::Class, and 'info' for My::Parent). The hashes paired to the parameters contain information about the parameter: =over =item field The parameter corresponds directly to a class field, and is automatically processed during object creation. See L. =item mandatory The parameter is required for object creation. See L. =item default The default value assigned to the parameter if it is not found in the arguments to C<-Enew()>. See L. =item preproc The code ref for the subroutine that is used to I a parameter's value. See L =item type The form of type checking performed on the parameter. See L for more details. =over =item 'numeric' Parameter takes a numeric value as recognized by L. =item 'list' =item 'list(_subtype_)' Parameter takes a single value (which is then placed in an array ref) or an array ref. When specified, the contents of the resulting array ref must be of the specified subtype: =over =item 'numeric' Same as for the basic type above. =item A class name Same as for the basic type below. =item A reference type Any reference type as returned by L). =back =item 'ARRAY(_subtype_)' Parameter takes an array ref with contents of the specified subtype as per the above. =item A class name Parameter takes an object of a specified class, or one of its sub-classes as recognized by C<-Eisa()>. =item Other reference type Parameter takes a reference of the specified type as returned by L. =item A code ref Parameter takes a value that is type-checked by the code ref paired to the 'type' key. =back =back =back =head1 METHODS METADATA The methods returned by a metadata object are those that are currently available at the time of the C<-Eget_methods()> call. The presence of C<:Automethod> subroutines in an Object::InsideOut class, or C in a foreign class means that the methods supported by the class may not be determinable. The presence of C in the list of methods for a class should alert the programmer to the fact that more methods may be supported than are listed. Methods that are excluded are private and hidden methods (see L), methods that begin with an underscore (which, by convention, means they are private), and subroutines named C, C, and C (which are not methods). While technically a method, C is also excluded as it is generally not invoked directly (i.e., it's usually called as part of C). =over =item $meta->get_methods(); Returns a hash (hash ref in scalar context) containing information on the methods for the class associated with the metadata object. The keys in the hash are the method names. Paired to the names are hash refs containing metadata about the methods. Here's an example: { # Methods exported by Object::InsideOut 'new' => { 'class' => 'My::Class', 'kind' => 'constructor' }, 'clone' => { 'class' => 'My::Class', 'kind' => 'object' }, 'meta' => { 'class' => 'My::Class' }, 'set' => { 'class' => 'My::Class', 'kind' => 'object', 'restricted' => 1 }, # Methods provided by Object::InsideOut 'dump' => { 'class' => 'Object::InsideOut', 'kind' => 'object' }, 'pump' => { 'class' => 'Object::InsideOut', 'kind' => 'class' }, 'inherit' => { 'class' => 'Object::InsideOut', 'kind' => 'object', 'restricted' => 1 }, 'heritage' => { 'class' => 'Object::InsideOut', 'kind' => 'object', 'restricted' => 1 }, 'disinherit' => { 'class' => 'Object::InsideOut', 'kind' => 'object', 'restricted' => 1 }, # Methods generated by Object::InsideOut for My::Class 'set_data' => { 'class' => 'My::Class', 'kind' => 'set', 'type' => 'ARRAY', 'return' => 'new' }, 'get_data' => { 'class' => 'My::Class', 'kind' => 'get' } # Class method provided by My::Class 'my_method' => { 'class' => 'My::Class', 'kind' => 'class' } } Here are the method metadata that are provided: =over =item class The class in whose symbol table the method resides. The method may reside in the classes code, it may be exported by another class, or it may be generated by Object::InsideOut. Methods that are overridden in child classes are represented as being associated with the most junior class for which they appear. =item kind Designation of the I of the method: =over =item constructor The C<-Enew()> method, of course. =item get, set or accessor A I, I, or I accessor generated by Object::InsideOut. See L. =item cumulative, or cumulative (bottom up) =item chained, or chained (bottom up) A cumulative or chained method. See L, and L. The class associated with these methods is the most junior class in which they appears. =item class A method that is callable only on a class (e.g., Cmy_method()>). =item object A method that is callable only on a object (e.g. C<$obj-Eget_data()>). =item foreign A subroutine found in a foreign class's symbol table. Programmers must check the class's documentation to determine which are actually methods, and what kinds of methods they are. =item overload A subroutine used for L. These may be called as methods, but this is not normally how they are used. =item automethod Associated with an AUTOLOAD method for an Object::InsideOut class that implements an C<:Automethod> subroutine. See L. =back =item type The type checking that is done on arguments to I accessors generated by Object::InsideOut. See L =item return The value returned by a I accessor generated by Object::InsideOut. See L Accessor Return Value"> =item lvalue The method is an L<:lvalue accessor|Object::InsideOut/":lvalue Accessors">. =item restricted The method is I (i.e., callable only from within the class hierarchy; not callable from application code). See L. =back =item My::Class->can(); =item $obj->can(); When called in an array context, calling C<-Ecan()> without any arguments on an Object::InsideOut class or object returns a list of the method names for that class or object, and is equivalent to: my %meths = $obj->meta()->get_methods(); my @methods = keys(%meths); When called in a scalar context, it returns an array ref containing the method names. =back =head2 METADATA ATTRIBUTES Class authors may add the C<:Method> attribute to subroutines in their classes to specifically designate them as OO-callable methods. If a method is only a I method or only an I method, this may be added as a parameter to the attribute: sub my_method :Method(class) { ... The I or I parameter will appear in the metadata for the method when listed using C<-Eget_methods()>. B Be sure not to use C<:method> (all lowercase) except as appropriate (see L) as this is a Perl reserved attribute. The C<:Sub> attribute can be used to designate subroutines that are not OO-callable methods. These subroutines will not show up as part of the methods listed by C<-Eget_methods()>, etc.. Subroutine names beginning with an underscore are, by convention, considered private, and will not show up as part of the methods listed by C<-Eget_methods()>, etc.. =head2 ADDING METADATA Class authors may add additional metadata to their methods using the C subroutine which is exported by this package. For example, if the class implements it own C<:lvalue> method, it should add that metadata so that it is picked up the C<-Eget_methods()>: package My::Class; { use Object::InsideOut; use Object::InsideOut::Metadata; sub my_method :lvalue :Method(object) { .... } add_meta(__PACKAGE__, 'my_method', 'lvalue', 1); } The arguments to C are: =over =item Class name This can usually be designated using the special literal C__PACKAGE__>. =item Method name =item Metadata name This can be any of the metadata names under L, or can be whatever additional name the programmer chooses to implement. =item Metadata value =back When adding multiple metadata for a method, they may be enclosed in a single hash ref: add_meta(__PACKAGE__, 'my_method', { 'lvalue' => 1, 'return' => 'old' }); If adding metadata for multiple methods, another level of hash may be used: add_meta(__PACKAGE__, { 'my_method' => { 'lvalue' => 1, 'return' => 'old' }, 'get_info' => { 'my_meta' => 'true' } }); =head1 TO DO Provide filtering capabilities on the method information returned by C<-Eget_methods()>. =head1 REQUIREMENTS Perl 5.8.0 or later =head1 SEE ALSO L Perl 6 introspection: L, and L =head1 AUTHOR Jerry D. Hedden, Sjdhedden AT cpan DOT orgE> =head1 COPYRIGHT AND LICENSE Copyright 2006 - 2012 Jerry D. Hedden. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Object-InsideOut-4.05/lib/Object/InsideOut/Secure.pm0000644000175000001440000000131413377136466021717 0ustar jdheddenuserspackage Object::InsideOut::Secure; { use strict; use warnings; use Config; our $VERSION = '4.05'; $VERSION = eval $VERSION; use Object::InsideOut 4.05 ':hash_only'; # Holds used IDs my %used :Field = ( 0 => undef ); # Our PRNG BEGIN { $Math::Random::MT::Auto::shared = ($Config::Config{useithreads} && $threads::shared::threads_shared); } use Math::Random::MT::Auto 5.04 ':!auto'; my $prng = Math::Random::MT::Auto->new(); # Assigns random IDs sub _id :ID { my $id; while (exists($used{$id = $prng->irand()})) {} $used{$id} = undef; return $id; } } 1; # EOF Object-InsideOut-4.05/lib/Object/InsideOut/Exception.pm0000644000175000001440000001357313377136466022441 0ustar jdheddenuserspackage Object::InsideOut::Exception; { use strict; use warnings; our $VERSION = '4.05'; $VERSION = eval $VERSION; # Exceptions generated by this module use Exception::Class 1.29 ( 'OIO' => { 'description' => 'Generic Object::InsideOut exception', # First 3 fields must be: 'Package', 'File', 'Line' 'fields' => ['Error', 'Chain'], }, 'OIO::Code' => { 'isa' => 'OIO', 'description' => 'Object::InsideOut exception that indicates a coding error', 'fields' => ['Info', 'Code'], }, 'OIO::Internal' => { 'isa' => 'OIO::Code', 'description' => 'Object::InsideOut exception that indicates a internal problem', 'fields' => ['Code', 'Declaration'], }, 'OIO::Attribute' => { 'isa' => 'OIO::Code', 'description' => 'Object::InsideOut exception that indicates a coding error', 'fields' => ['Attribute'], }, 'OIO::Method' => { 'isa' => 'OIO', 'description' => 'Object::InsideOut exception that indicates an method calling error', }, 'OIO::Args' => { 'isa' => 'OIO::Method', 'description' => 'Object::InsideOut exception that indicates an argument error', 'fields' => ['Usage', 'Arg'], }, 'OIO::Args::Unhandled' => { 'isa' => 'OIO::Args', 'description' => 'Object::InsideOut exception that indicates an unhandled argument', 'fields' => ['Usage', 'Arg'], }, 'OIO::Runtime' => { 'isa' => 'OIO::Code', 'description' => 'Object::InsideOut exception that indicates a runtime error', 'fields' => ['Class1', 'Class2'], }, ); # Turn on stack trace by default OIO->Trace(1); # A 'throw' method that adds location information to the exception object sub OIO::die { my $class = shift; my %args = @_; # Report on ourself? my $report_self = delete($args{'self'}); # Ignore ourselves in stack trace, unless told not to if (! $report_self) { my @ignore = ('Object::InsideOut::Exception', 'Object::InsideOut'); if (exists($args{'ignore_package'})) { if (ref($args{'ignore_package'})) { push(@ignore, @{$args{'ignore_package'}}); } else { push(@ignore, $args{'ignore_package'}); } } $args{'ignore_package'} = \@ignore; } # Remove any location information my $location = delete($args{'location'}); # Create exception object my $e = $class->new(%args); # Override location information, if applicable if ($location) { $e->{'package'} = $$location[0]; $e->{'file'} = $$location[1]; $e->{'line'} = $$location[2]; } # If reporting on ourself, then correct location info elsif ($report_self) { my $frame = $e->trace->frame(1); $e->{'package'} = $frame->package(); $e->{'line'} = $frame->line(); $e->{'file'} = $frame->filename(); } # Throw error no strict 'refs'; no warnings 'once'; if (${$class.'::WARN_ONLY'}) { warn $e->OIO::full_message(); } else { $e->throw(%args); } } # Provides a fully formatted error message for the exception object sub OIO::full_message { my $self = shift; # Start with error class and message my $msg = ref($self) . ' error: ' . $self->message(); chomp($msg); # Add fields, if any my @fields = $self->Fields(); foreach my $field (@fields) { next if ($field eq 'Chain'); if (exists($self->{$field})) { $msg .= "\n$field: " . $self->{$field}; chomp($msg); } } # Add location $msg .= "\nPackage: " . $self->package() . "\nFile: " . $self->file() . "\nLine: " . $self->line(); # Chained error messages if (exists($self->{'Chain'})) { my $chain = OIO::full_message($self->{'Chain'}); chomp($chain); $chain =~ s/^/ /mg; $msg .= "\n\nSubsequent to the above, the following error also occurred:\n" . $chain; } return ($msg . "\n"); } # Catch untrapped errors # Usage: local $SIG{'__DIE__'} = 'OIO::trap'; sub OIO::trap { # Just rethrow if already an exception object if (Object::InsideOut::Util::is_it($_[0], 'Exception::Class::Base')) { die($_[0]); } # Package the error into an object OIO->die( 'location' => [ caller() ], 'message' => 'Trapped uncaught error', 'Error' => join('', @_)); } # Combine errors into a single error object sub OIO::combine { my ($err1, $err2) = @_; # Massage second error, if needed if ($err2 && ! ref($err2)) { my $e = OIO->new( 'message' => "$err2", 'ignore_package' => [ 'Object::InsideOut::Exception' ] ); my $frame = $e->trace->frame(1); $e->{'package'} = $frame->package(); $e->{'line'} = $frame->line(); $e->{'file'} = $frame->filename(); $err2 = $e; } # Massage first error, if needed if ($err1) { if (! ref($err1)) { my $e = OIO->new( 'message' => "$err1", 'ignore_package' => [ 'Object::InsideOut::Exception' ] ); my $frame = $e->trace->frame(1); $e->{'package'} = $frame->package(); $e->{'line'} = $frame->line(); $e->{'file'} = $frame->filename(); $err1 = $e; } # Combine errors, if possible if ($err2) { if (Object::InsideOut::Util::is_it($err1, 'OIO')) { $err1->{'Chain'} = $err2; } else { warn($err2); # Can't combine } } } else { $err1 = $err2; undef($err2); } return ($err1); } } # End of package's lexical scope 1; Object-InsideOut-4.05/lib/Object/InsideOut/Dynamic.pm0000644000175000001440000001232413377136466022060 0ustar jdheddenuserspackage Object::InsideOut; { use strict; use warnings; no warnings 'redefine'; sub create_field { my ($GBL, $call, @args) = @_; push(@{$$GBL{'export'}}, 'create_field'); if ($call eq 'create_field') { $$GBL{'init'} = 1; } # Dynamically create a new object field *Object::InsideOut::create_field = sub { # Handle being called as a method or subroutine if ($_[0] eq 'Object::InsideOut') { shift; } my ($class, $field, @attrs) = @_; # Verify valid class if (! $class->isa('Object::InsideOut')) { OIO::Args->die( 'message' => 'Not an Object::InsideOut class', 'Arg' => $class); } # Check for valid field if ($field !~ /^\s*[@%]\s*[a-zA-Z_]\w*\s*$/) { OIO::Args->die( 'message' => 'Not an array or hash declaration', 'Arg' => $field); } # Convert attributes to single string my $attr; if (@attrs) { s/^\s*(.*?)\s*$/$1/ foreach @attrs; $attr = join(',', @attrs); $attr =~ s/[\r\n]/ /sg; $attr =~ s/,\s*,/,/g; $attr =~ s/\s*,\s*:/ :/g; if ($attr !~ /^\s*:/) { $attr = ":Field($attr)"; } } else { $attr = ':Field'; } # Create the declaration my @errs; local $SIG{'__WARN__'} = sub { push(@errs, @_); }; my $code = "package $class; my $field $attr;"; eval $code; if (my $e = Exception::Class::Base->caught()) { die($e); } if ($@ || @errs) { my ($err) = split(/ at /, $@ || join(" | ", @errs)); OIO::Code->die( 'message' => 'Failure creating field', 'Error' => $err, 'Code' => $code); } # Invalidate object initialization activity cache delete($$GBL{'cache'}); # Process the declaration process_fields(); }; # Runtime hierarchy building *Object::InsideOut::add_class = sub { my $class = shift; if (ref($class)) { OIO::Method->die('message' => q/'add_class' called as an object method/); } if ($class eq 'Object::InsideOut') { OIO::Method->die('message' => q/'add_class' called on non-class 'Object::InsideOut'/); } if (! $class->isa('Object::InsideOut')) { OIO::Method->die('message' => "'add_class' called on non-Object::InsideOut class '$class'"); } my $pkg = shift; if (! $pkg) { OIO::Args->die( 'message' => 'Missing argument', 'Usage' => "$class\->add_class(\$class)"); } # Already in the hierarchy - ignore return if ($class->isa($pkg)); no strict 'refs'; # If no package symbols, then load it if (! grep { $_ !~ /::$/ } keys(%{$pkg.'::'})) { eval "require $pkg"; if ($@) { OIO::Code->die( 'message' => "Failure loading package '$pkg'", 'Error' => $@); } # Empty packages make no sense if (! grep { $_ !~ /::$/ } keys(%{$pkg.'::'})) { OIO::Code->die('message' => "Package '$pkg' is empty"); } } # Import the package, if needed if (@_) { eval { $pkg->import(@_); }; if ($@) { OIO::Code->die( 'message' => "Failure running 'import' on package '$pkg'", 'Error' => $@); } } my $tree_bu = $$GBL{'tree'}{'bu'}; my $tree_td = $$GBL{'tree'}{'td'}; # Foreign class added if (! exists($$tree_bu{$pkg})) { # Get inheritance 'classes' hash if (! exists($$GBL{'heritage'}{$class})) { create_heritage($class); } # Add package to inherited classes $$GBL{'heritage'}{$class}{'cl'}{$pkg} = undef; return; } # Add to class trees foreach my $cl (keys(%{$tree_bu})) { next if (! grep { $_ eq $class } @{$$tree_bu{$cl}}); # Splice in the added class's tree my @tree; foreach (@{$$tree_bu{$cl}}) { push(@tree, $_); if ($_ eq $class) { my %seen; @seen{@{$$tree_bu{$cl}}} = undef; foreach (@{$$tree_bu{$pkg}}) { push(@tree, $_) if (! exists($seen{$_})); } } } # Add to @ISA array push(@{$cl.'::ISA'}, $pkg); # Save revised trees $$tree_bu{$cl} = \@tree; @{$$tree_td{$cl}} = reverse(@tree); } $$GBL{'asi'}{$pkg}{$class} = undef; }; # Invalidate object initialization activity cache delete($$GBL{'cache'}); # Do the original call @_ = @args; goto &$call; } } # End of package's lexical scope # Ensure correct versioning ($Object::InsideOut::VERSION eq '4.05') or die("Version mismatch\n"); # EOF Object-InsideOut-4.05/lib/Object/InsideOut/lvalue.pm0000644000175000001440000001206513377136466021766 0ustar jdheddenuserspackage Object::InsideOut; { use strict; use warnings; no warnings 'redefine'; # Create an :lvalue accessor method sub create_lvalue_accessor { if ($] < 5.008) { my ($pkg, $set) = @_; OIO::Code->die( 'message' => "Can't create 'lvalue' accessor method '$set' for package '$pkg'", 'Info' => q/'lvalue' accessors require Perl 5.8.0 or later/); } eval { require Want; }; if ($@) { my ($pkg, $set) = @_; OIO::Code->die( 'message' => "Can't create 'lvalue' accessor method '$set' for package '$pkg'", 'Info' => q/Failure loading 'Want' module/, 'Error' => $@); } elsif ($Want::VERSION < 0.12) { my ($pkg, $set) = @_; OIO::Code->die( 'message' => "Can't create 'lvalue' accessor method '$set' for package '$pkg'", 'Info' => q/Requires 'Want' v0.12 or later/); } *Object::InsideOut::create_lvalue_accessor = sub { my $caller = caller(); if ($caller ne 'Object::InsideOut') { OIO::Method->die('message' => "Can't call private subroutine 'Object::InsideOut::create_lvalue_accessor' from class '$caller'"); } my ($pkg, $set, $field_ref, $get, $type, $is_ref, $subtype, $name, $return, $private, $restricted, $weak, $pre) = @_; # Field string my $fld_str = (ref($field_ref) eq 'HASH') ? "\$field->\{\${\$_[0]}}" : "\$field->\[\${\$_[0]}]"; # 'Want object' string my $obj_str = q/(Want::wantref() eq 'OBJECT')/; # Begin with subroutine declaration in the appropriate package my $code = "*${pkg}::$set = sub :lvalue {\n" . preamble_code($pkg, $set, $private, $restricted) . " my \$rv = !Want::want_lvalue(0);\n"; # Add GET portion for combination accessor if ($get && ($get eq $set)) { $code .= " Want::rreturn($fld_str) if (\$rv && (\@_ == 1));\n"; } # If set only, then must have at least one arg else { $code .= <<"_CHECK_ARGS_"; my \$wobj = $obj_str; if ((\@_ < 2) && (\$rv || \$wobj)) { OIO::Args->die( 'message' => q/Missing arg(s) to '$pkg->$set'/, 'location' => [ caller() ]); } _CHECK_ARGS_ $obj_str = '$wobj'; } # Add field locking code if sharing if (is_sharing($pkg)) { $code .= " lock(\$field);\n" } # Return value for 'OLD' if ($return eq 'OLD') { $code .= " my \$ret;\n"; } # Get args if assignment $code .= <<"_SET_"; my \$assign; if (my \@args = Want::wantassign(1)) { \@_ = (\$_[0], \@args); \$assign = 1; } if (\@_ > 1) { _SET_ # Add preprocessing code block if ($pre) { $code .= <<"_PRE_"; { my \@errs; local \$SIG{'__WARN__'} = sub { push(\@errs, \@_); }; eval { my \$self = shift; \@_ = (\$self, \$preproc->(\$self, \$field, \@_)); }; if (\$@ || \@errs) { my (\$err) = split(/ at /, \$@ || join(" | ", \@errs)); OIO::Code->die( 'message' => q/Problem with preprocessing routine for '$pkg->$set'/, 'Error' => \$err); } } _PRE_ } # Add data type checking my ($type_code, $arg_str) = type_code($pkg, $set, $weak, $type, $is_ref, $subtype); $code .= $type_code; # Grab 'OLD' value if ($return eq 'OLD') { $code .= " \$ret = $fld_str;\n"; } # Add actual 'set' code $code .= (is_sharing($pkg)) ? " $fld_str = Object::InsideOut::Util::make_shared($arg_str);\n" : " $fld_str = $arg_str;\n"; if ($weak) { $code .= " Scalar::Util::weaken($fld_str);\n"; } # Add code for return value $code .= " Want::lnoreturn if \$assign;\n"; if ($return eq 'SELF') { $code .= " Want::rreturn(\$_[0]) if \$rv;\n"; } elsif ($return eq 'OLD') { $code .= " Want::rreturn(\$ret) if \$rv;\n"; } else { $code .= " Want::rreturn($fld_str) if \$rv;\n"; } $code .= " }\n"; if ($return eq 'SELF') { $code .= " (\@_ < 2) ? $fld_str : \$_[0];\n"; } elsif ($return eq 'OLD') { $code .= " (\@_ < 2) ? $fld_str : (($obj_str && !Scalar::Util::blessed(\$ret)) ? \$_[0] : \$ret);\n"; } else { $code .= " ((\@_ > 1) && $obj_str && !Scalar::Util::blessed($fld_str)) ? \$_[0] : $fld_str;\n"; } $code .= "};\n"; # Done return ($code); }; # Do the original call goto &create_lvalue_accessor; } } # End of package's lexical scope # Ensure correct versioning ($Object::InsideOut::VERSION eq '4.05') or die("Version mismatch\n"); # EOF Object-InsideOut-4.05/lib/Object/InsideOut/Util.pm0000644000175000001440000002636513377136466021423 0ustar jdheddenuserspackage Object::InsideOut::Util; { require 5.006; use strict; use warnings; use Config; our $VERSION = '4.05'; $VERSION = eval $VERSION; use Object::InsideOut::Metadata 4.05; ### Module Initialization ### BEGIN { # 1. Install our own 'no-op' version of Internals::SvREADONLY for Perl < 5.8 if (! Internals->can('SvREADONLY')) { *Internals::SvREADONLY = sub (\$;$) { return; }; } # Import 'share' and 'bless' if threads::shared if ($Config::Config{useithreads} && $threads::shared::threads_shared) { import threads::shared; } } # 2. Export requested subroutines sub import { my $class = shift; # Not used # Exportable subroutines my %EXPORT_OK; @EXPORT_OK{qw(create_object hash_re is_it make_shared shared_copy)} = undef; # Handle entries in the import list my $caller = caller(); my %meta; while (my $sym = shift) { if (exists($EXPORT_OK{lc($sym)})) { # Export subroutine name no strict 'refs'; *{$caller.'::'.$sym} = \&{lc($sym)}; $meta{$sym}{'hidden'} = 1; } else { OIO::Code->die( 'message' => "Symbol '$sym' is not exported by Object::InsideOut::Util", 'Info' => 'Exportable symbols: ' . join(' ', keys(%EXPORT_OK)), 'ignore_package' => 'Object::InsideOut::Util'); } } if (%meta) { add_meta($caller, \%meta); } } ### Subroutines ### # Returns a blessed (optional), readonly (Perl 5.8) anonymous scalar reference # containing either: # the value returned by a user-specified subroutine; or # a user-supplied scalar sub create_object { my ($class, $id) = @_; # Create the object from an anonymous scalar reference my $obj = \do{ my $scalar; }; # Set the scalar equal to ... if (my $ref_type = ref($id)) { if ($ref_type eq 'CODE') { # ... the value returned by the user-specified subroutine local $SIG{__DIE__} = 'OIO::trap'; $$obj = $id->($class); } else { # Complain if something other than code ref OIO::Args->die( 'message' => q/2nd argument to create_object() is not a code ref or scalar/, 'Usage' => 'create_object($class, $scalar) or create_object($class, $code_ref, ...)', 'ignore_package' => 'Object::InsideOut::Util'); } } else { # ... the user-supplied scalar $$obj = $id; } # Bless the object into the specified class (optional) if ($class) { bless($obj, $class); } # Make the object 'readonly' (Perl 5.8) Internals::SvREADONLY($$obj, 1) if ($] >= 5.008003); # Done - return the object return ($obj); } # Make a thread-shared version of a complex data structure or object sub make_shared { my $in = shift; my $cloned = shift || {}; # If not sharing or already thread-shared, then just return the input if (! ref($in) || ! $Config::Config{useithreads} || ! $threads::threads || ! $threads::shared::threads_shared || threads::shared::is_shared($in)) { return ($in); } # Check for previously cloned references # (this takes care of circular refs as well) my $addr = Scalar::Util::refaddr($in); if (exists($cloned->{$addr})) { # Return the already existing clone return $cloned->{$addr}; } # Make copies of array, hash and scalar refs my $out; my $ref_type = Scalar::Util::reftype($in); # Copy an array ref if ($ref_type eq 'ARRAY') { # Make empty shared array ref $out = &threads::shared::share([]); # Add to clone checking hash $cloned->{$addr} = $out; # Recursively copy and add contents push(@$out, map { make_shared($_, $cloned) } @$in); } # Copy a hash ref elsif ($ref_type eq 'HASH') { # Make empty shared hash ref $out = &threads::shared::share({}); # Add to clone checking hash $cloned->{$addr} = $out; # Recursively copy and add contents foreach my $key (keys(%{$in})) { $out->{$key} = make_shared($in->{$key}, $cloned); } } # Copy a scalar ref elsif ($ref_type eq 'SCALAR') { $out = \do{ my $scalar = $$in; }; threads::shared::share($out); # Add to clone checking hash $cloned->{$addr} = $out; } # Copy of a ref of a ref elsif ($ref_type eq 'REF') { # Special handling for $x = \$x if ($addr == Scalar::Util::refaddr($$in)) { $out = \$out; threads::shared::share($out); $cloned->{$addr} = $out; } else { my $tmp; $out = \$tmp; threads::shared::share($out); # Add to clone checking hash $cloned->{$addr} = $out; # Recursively copy and add contents $tmp = make_shared($$in, $cloned); } } else { # Just return anything else # NOTE: This will end up generating an error return ($in); } # Return blessed copy, if applicable if (my $class = Scalar::Util::blessed($in)) { bless($out, $class); } # Clone READONLY flag if ($ref_type eq 'SCALAR') { if (Internals::SvREADONLY($$in)) { Internals::SvREADONLY($$out, 1) if ($] >= 5.008003); } } if (Internals::SvREADONLY($in)) { Internals::SvREADONLY($out, 1) if ($] >= 5.008003); } # Return clone return ($out); } # Make a copy of a complex data structure or object. # If thread-sharing, then make the copy thread-shared. sub shared_copy { return (($Config::Config{useithreads} && $threads::shared::threads_shared) ? clone_shared(@_) : clone(@_)); } # Recursively make a copy of a complex data structure or object that is # thread-shared sub clone_shared { my $in = shift; my $cloned = shift || {}; # Just return the item if not a ref or if it's an object return $in if (! ref($in) || Scalar::Util::blessed($in)); # Check for previously cloned references # (this takes care of circular refs as well) my $addr = Scalar::Util::refaddr($in); if (exists($cloned->{$addr})) { # Return the already existing clone return $cloned->{$addr}; } # Make copies of array, hash and scalar refs my $out; my $ref_type = Scalar::Util::reftype($in); # Copy an array ref if ($ref_type eq 'ARRAY') { # Make empty shared array ref $out = &threads::shared::share([]); # Add to clone checking hash $cloned->{$addr} = $out; # Recursively copy and add contents push(@$out, map { clone_shared($_, $cloned) } @$in); } # Copy a hash ref elsif ($ref_type eq 'HASH') { # Make empty shared hash ref $out = &threads::shared::share({}); # Add to clone checking hash $cloned->{$addr} = $out; # Recursively copy and add contents foreach my $key (keys(%{$in})) { $out->{$key} = clone_shared($in->{$key}, $cloned); } } # Copy a scalar ref elsif ($ref_type eq 'SCALAR') { $out = \do{ my $scalar = $$in; }; threads::shared::share($out); # Add to clone checking hash $cloned->{$addr} = $out; } # Copy of a ref of a ref elsif ($ref_type eq 'REF') { # Special handling for $x = \$x if ($addr == Scalar::Util::refaddr($$in)) { $out = \$out; threads::shared::share($out); $cloned->{$addr} = $out; } else { my $tmp; $out = \$tmp; threads::shared::share($out); # Add to clone checking hash $cloned->{$addr} = $out; # Recursively copy and add contents $tmp = clone_shared($$in, $cloned); } } else { # Just return anything else # NOTE: This will end up generating an error return ($in); } # Return blessed copy, if applicable if (my $class = Scalar::Util::blessed($in)) { bless($out, $class); } # Clone READONLY flag if ($ref_type eq 'SCALAR') { if (Internals::SvREADONLY($$in)) { Internals::SvREADONLY($$out, 1) if ($] >= 5.008003); } } if (Internals::SvREADONLY($in)) { Internals::SvREADONLY($out, 1) if ($] >= 5.008003); } # Return clone return ($out); } # Recursively make a copy of a complex data structure or object sub clone { my $in = shift; my $cloned = shift || {}; # Just return the item if not a ref or if it's an object return $in if (! ref($in) || Scalar::Util::blessed($in)); # Check for previously cloned references # (this takes care of circular refs as well) my $addr = Scalar::Util::refaddr($in); if (exists($cloned->{$addr})) { # Return the already existing clone return $cloned->{$addr}; } # Make copies of array, hash and scalar refs my $out; my $ref_type = Scalar::Util::reftype($in); # Copy an array ref if ($ref_type eq 'ARRAY') { # Make empty shared array ref $out = []; # Add to clone checking hash $cloned->{$addr} = $out; # Recursively copy and add contents push(@$out, map { clone($_, $cloned) } @$in); } # Copy a hash ref elsif ($ref_type eq 'HASH') { # Make empty shared hash ref $out = {}; # Add to clone checking hash $cloned->{$addr} = $out; # Recursively copy and add contents foreach my $key (keys(%{$in})) { $out->{$key} = clone($in->{$key}, $cloned); } } # Copy a scalar ref elsif ($ref_type eq 'SCALAR') { $out = \do{ my $scalar = $$in; }; # Add to clone checking hash $cloned->{$addr} = $out; } # Copy of a ref of a ref elsif ($ref_type eq 'REF') { # Special handling for $x = \$x if ($addr == Scalar::Util::refaddr($$in)) { $out = \$out; $cloned->{$addr} = $out; } else { my $tmp; $out = \$tmp; # Add to clone checking hash $cloned->{$addr} = $out; # Recursively copy and add contents $tmp = clone($$in, $cloned); } } else { # Just return anything else # NOTE: This will end up generating an error return ($in); } # Clone READONLY flag if ($ref_type eq 'SCALAR') { if (Internals::SvREADONLY($$in)) { Internals::SvREADONLY($$out, 1) if ($] >= 5.008003); } } if (Internals::SvREADONLY($in)) { Internals::SvREADONLY($out, 1) if ($] >= 5.008003); } # Return clone return ($out); } # Access hash value using regex sub hash_re { my $hash = $_[0]; # Hash ref to search through my $re = $_[1]; # Regex to match keys against foreach (keys(%{$hash})) { if (/$re/) { return ($hash->{$_}, $_) if wantarray(); return ($hash->{$_}); } } return; } # Checks if a scalar is a specified type sub is_it { my ($thing, $what) = @_; return ((Scalar::Util::blessed($thing)) ? $thing->isa($what) : (ref($thing) eq $what)); } } # End of package's lexical scope 1; Object-InsideOut-4.05/lib/Object/InsideOut/Dump.pm0000644000175000001440000001606313377136466021405 0ustar jdheddenuserspackage Object::InsideOut; { use strict; use warnings; no warnings 'redefine'; # Installs object dumper and loader methods sub dump { my ($GBL, $call, @args) = @_; push(@{$$GBL{'export'}}, 'dump'); $$GBL{'init'} = 1; *Object::InsideOut::dump = sub { my $self = shift; my $d_flds = $$GBL{'dump'}{'fld'}; # Extract field info from any :InitArgs hashes while (my $pkg = shift(@{$$GBL{'dump'}{'args'}})) { my $p_args = $$GBL{'args'}{$pkg}; foreach my $name (keys(%{$p_args})) { my $val = $$p_args{$name}; next if (ref($val) ne 'HASH'); if (my $field = $$val{'_F'}) { $$d_flds{$pkg} ||= {}; if (add_dump_field('InitArgs', $name, $field, $$d_flds{$pkg}) eq 'conflict') { OIO::Code->die( 'message' => 'Cannot dump object', 'Info' => "In class '$pkg', '$name' refers to two different fields set by 'InitArgs' and '$$d_flds{$pkg}{$name}{'src'}'"); } } } } # Must call ->dump() as an object method if (! Scalar::Util::blessed($self)) { OIO::Method->die('message' => q/'dump' called as a class method/); } # Gather data from the object's class tree my %dump; my $fld_refs = $$GBL{'fld'}{'ref'}; my $dumpers = $$GBL{'dump'}{'dumper'}; my $weak = $$GBL{'fld'}{'weak'}; foreach my $pkg (@{$$GBL{'tree'}{'td'}{ref($self)}}) { # Try to use a class-supplied dumper if (my $dumper = $$dumpers{$pkg}) { local $SIG{'__DIE__'} = 'OIO::trap'; $dump{$pkg} = $self->$dumper(); } elsif ($$fld_refs{$pkg}) { # Dump the data ourselves from all known class fields my @fields = @{$$fld_refs{$pkg}}; # Fields for which we have names foreach my $name (keys(%{$$d_flds{$pkg}})) { my $field = $$d_flds{$pkg}{$name}{'fld'}; if (ref($field) eq 'HASH') { if (exists($$field{$$self})) { $dump{$pkg}{$name} = $$field{$$self}; } } else { if (defined($$field[$$self])) { $dump{$pkg}{$name} = $$field[$$self]; } } if ($$weak{$field} && exists($dump{$pkg}{$name})) { Scalar::Util::weaken($dump{$pkg}{$name}); } @fields = grep { $_ != $field } @fields; } # Fields for which names are not known foreach my $field (@fields) { if (ref($field) eq 'HASH') { if (exists($$field{$$self})) { $dump{$pkg}{$field} = $$field{$$self}; } } else { if (defined($$field[$$self])) { $dump{$pkg}{$field} = $$field[$$self]; } } if ($$weak{$field} && exists($dump{$pkg}{$field})) { Scalar::Util::weaken($dump{$pkg}{$field}); } } } } # Package up the object's class and its data my $output = [ ref($self), \%dump ]; # Create a string version of dumped data if arg is true if ($_[0]) { require Data::Dumper; local $Data::Dumper::Indent = 1; $output = Data::Dumper::Dumper($output); chomp($output); $output =~ s/^\$VAR1 = //; # Remove leading '$VAR1 = ' $output =~ s/;$//s; # Remove trailing semi-colon } # Done - send back the dumped data return ($output); }; *Object::InsideOut::pump = sub { my $input = shift; # Check usage if ($input) { if ($input eq 'Object::InsideOut') { $input = shift; # Called as a class method } elsif (Scalar::Util::blessed($input)) { OIO::Method->die('message' => q/'pump' called as an object method/); } } # Must have an arg if (! $input) { OIO::Args->die('message' => 'Missing argument to pump()'); } # Convert string input to array ref, if needed if (! ref($input)) { my @errs; local $SIG{'__WARN__'} = sub { push(@errs, @_); }; my $array_ref; eval "\$array_ref = $input"; if ($@ || @errs) { my ($err) = split(/ at /, $@ || join(" | ", @errs)); OIO::Args->die( 'message' => 'Failure converting dump string back to hash ref', 'Error' => $err, 'Arg' => $input); } $input = $array_ref; } # Check input if (ref($input) ne 'ARRAY') { OIO::Args->die('message' => 'Argument to pump() is not an array ref'); } # Extract class name and object data my ($class, $dump) = @{$input}; if (! defined($class) || ref($dump) ne 'HASH') { OIO::Args->die('message' => 'Argument to pump() is invalid'); } # Create a new 'bare' object my $self = _obj($class); # Store object data foreach my $pkg (keys(%{$dump})) { if (! exists($$GBL{'tree'}{'td'}{$pkg})) { OIO::Args->die('message' => "Unknown class: $pkg"); } my $data = $$dump{$pkg}; # Try to use a class-supplied pumper if (my $pumper = $$GBL{'dump'}{'pumper'}{$pkg}) { local $SIG{'__DIE__'} = 'OIO::trap'; $self->$pumper($data); } else { # Pump in the data ourselves foreach my $fld_name (keys(%{$data})) { my $value = $$data{$fld_name}; if (my $field = $$GBL{'dump'}{'fld'}{$pkg}{$fld_name}{'fld'}) { $self->set($field, $value); } else { if ($fld_name =~ /^(?:HASH|ARRAY)/) { OIO::Args->die( 'message' => "Unnamed field encounted in class '$pkg'", 'Arg' => "$fld_name => $value"); } else { OIO::Args->die( 'message' => "Unknown field name for class '$pkg': $fld_name"); } } } } } # Done - return the object return ($self); }; # Do the original call @_ = @args; goto &$call; } } # End of package's lexical scope # Ensure correct versioning ($Object::InsideOut::VERSION eq '4.05') or die("Version mismatch\n"); # EOF Object-InsideOut-4.05/lib/Object/InsideOut/Overload.pm0000644000175000001440000000512613377136466022251 0ustar jdheddenuserspackage Object::InsideOut; { use strict; use warnings; no warnings 'redefine'; sub generate_OVERLOAD :Sub(Private) { my ($GBL) = @_; # Overload specifiers my %TYPE = ( 'STRINGIFY' => q/""/, 'NUMERIFY' => q/0+/, 'BOOLIFY' => q/bool/, 'ARRAYIFY' => q/@{}/, 'HASHIFY' => q/%{}/, 'GLOBIFY' => q/*{}/, 'CODIFY' => q/&{}/, ); my (%code, $code, %meta); # Generate overload strings while (my $info = shift(@{$$GBL{'sub'}{'ol'}})) { if ($$info{'ify'} eq 'EQUATE') { push(@{$code{$$info{'pkg'}}}, "\tq/==/ => sub { (ref(\$_[0]) eq ref(\$_[1])) && (\${\$_[0]} == \${\$_[1]}) },"); } else { $$info{'name'} ||= sub_name($$info{'code'}, ":$$info{'ify'}", $$info{'loc'}); my $pkg = $$info{'pkg'}; my $name = $$info{'name'}; push(@{$code{$pkg}}, "\tq/$TYPE{$$info{'ify'}}/ => sub { \$_[0]->$name() },"); $meta{$pkg}{$name}{'kind'} = 'overload'; } } delete($$GBL{'sub'}{'ol'}); # Generate entire code string foreach my $pkg (keys(%code)) { $code .= "package $pkg;\nuse overload (\n" . join("\n", @{$code{$pkg}}) . "\n\t'fallback' => 1);\n"; } # Eval the code string my @errs; local $SIG{'__WARN__'} = sub { push(@errs, @_); }; eval $code; if ($@ || @errs) { my ($err) = split(/ at /, $@ || join(" | ", @errs)); OIO::Internal->die( 'message' => "Failure creating overloads", 'Error' => $err, 'Code' => $code, 'self' => 1); } # Add accumulated metadata add_meta(\%meta); no strict 'refs'; foreach my $pkg (keys(%{$$GBL{'tree'}{'td'}})) { # Bless an object into every class # This works around an obscure 'overload' bug reported against # Class::Std (http://rt.cpan.org/Public/Bug/Display.html?id=14048) bless(\do{ my $scalar; }, $pkg); # Verify that scalar dereferencing is not overloaded in any class if (exists(${$pkg.'::'}{'(${}'})) { (my $file = $pkg . '.pm') =~ s/::/\//g; OIO::Code->die( 'location' => [ $pkg, $INC{$file} || '', '' ], 'message' => q/Overloading scalar dereferencing '${}' is not allowed/, 'Info' => q/The scalar of an object is its object ID, and can't be redefined/); } } } } # End of package's lexical scope # Ensure correct versioning ($Object::InsideOut::VERSION eq '4.05') or die("Version mismatch\n"); # EOF Object-InsideOut-4.05/lib/Object/InsideOut/Chained.pm0000644000175000001440000001504513377136466022032 0ustar jdheddenuserspackage Object::InsideOut; { use strict; use warnings; no warnings 'redefine'; my $GBL = {}; sub generate_CHAINED :Sub(Private) { ($GBL) = @_; my $g_ch = $$GBL{'sub'}{'chain'}; my $chain_td = $$g_ch{'new'}{'td'} || []; my $chain_bu = $$g_ch{'new'}{'bu'} || []; delete($$g_ch{'new'}); if (! exists($$g_ch{'td'})) { $$GBL{'sub'}{'chain'} = { td => {}, # 'Top down' bu => {}, # 'Bottom up' restrict => {}, # :Restricted }; $g_ch = $$GBL{'sub'}{'chain'}; } my $ch_td = $$g_ch{'td'}; my $ch_bu = $$g_ch{'bu'}; my $ch_restr = $$g_ch{'restrict'}; # Get names for :CHAINED methods my (%chain_loc); while (my $info = shift(@{$chain_td})) { $$info{'name'} ||= sub_name($$info{'code'}, ':CHAINED', $$info{'loc'}); my $package = $$info{'pkg'}; my $name = $$info{'name'}; $chain_loc{$name}{$package} = $$info{'loc'}; $$ch_td{$name}{$package} = $$info{'wrap'}; if (exists($$info{'exempt'})) { push(@{$$ch_restr{$package}{$name}}, sort grep {$_} split(/[,'\s]+/, $$info{'exempt'} || '')); } } # Get names for :CHAINED(BOTTOM UP) methods while (my $info = shift(@{$chain_bu})) { $$info{'name'} ||= sub_name($$info{'code'}, ':CHAINED(BOTTOM UP)', $$info{'loc'}); my $package = $$info{'pkg'}; my $name = $$info{'name'}; # Check for conflicting definitions of 'name' if ($$ch_td{$name}) { foreach my $other_package (keys(%{$$ch_td{$name}})) { if ($other_package->isa($package) || $package->isa($other_package)) { my ($pkg, $file, $line) = @{$chain_loc{$name}{$other_package}}; my ($pkg2, $file2, $line2) = @{$$info{'loc'}}; OIO::Attribute->die( 'location' => $$info{'loc'}, 'message' => "Conflicting definitions for chained method '$name'", 'Info' => "Declared as :CHAINED in class '$pkg' (file '$file', line $line), but declared as :CHAINED(BOTTOM UP) in class '$pkg2' (file '$file2' line $line2)"); } } } $$ch_bu{$name}{$package} = $$info{'wrap'}; if (exists($$info{'exempt'})) { push(@{$$ch_restr{$package}{$name}}, sort grep {$_} split(/[,'\s]+/, $$info{'exempt'} || '')); } } # Propagate restrictions my $reapply = 1; my $trees = $$GBL{'tree'}{'td'}; while ($reapply) { $reapply = 0; foreach my $pkg (keys(%{$ch_restr})) { foreach my $class (keys(%{$trees})) { next if (! grep { $_ eq $pkg } @{$$trees{$class}}); foreach my $p (@{$$trees{$class}}) { foreach my $n (keys(%{$$ch_restr{$pkg}})) { if (exists($$ch_restr{$p}{$n})) { next if ($$ch_restr{$p}{$n} == $$ch_restr{$pkg}{$n}); my $equal = (@{$$ch_restr{$p}{$n}} == @{$$ch_restr{$pkg}{$n}}); if ($equal) { for (1..@{$$ch_restr{$p}{$n}}) { if ($$ch_restr{$pkg}{$n}[$_-1] ne $$ch_restr{$p}{$n}[$_-1]) { $equal = 0; last; } } } if (! $equal) { my %restr = map { $_ => 1 } @{$$ch_restr{$p}{$n}}, @{$$ch_restr{$pkg}{$n}}; $$ch_restr{$pkg}{$n} = [ sort(keys(%restr)) ]; $reapply = 1; } } else { $reapply = 1; } $$ch_restr{$p}{$n} = $$ch_restr{$pkg}{$n}; } } } } } no warnings 'redefine'; no strict 'refs'; # Implement :CHAINED methods foreach my $name (keys(%{$ch_td})) { my $code = create_CHAINED($name, $trees, $$ch_td{$name}); foreach my $package (keys(%{$$ch_td{$name}})) { *{$package.'::'.$name} = $code; add_meta($package, $name, 'kind', 'chained'); if (exists($$ch_restr{$package}{$name})) { add_meta($package, $name, 'restricted', 1); } } } # Implement :CHAINED(BOTTOM UP) methods foreach my $name (keys(%{$ch_bu})) { my $code = create_CHAINED($name, $$GBL{'tree'}{'bu'}, $$ch_bu{$name}); foreach my $package (keys(%{$$ch_bu{$name}})) { *{$package.'::'.$name} = $code; add_meta($package, $name, 'kind', 'chained (bottom up)'); if (exists($$ch_restr{$package}{$name})) { add_meta($package, $name, 'restricted', 1); } } } } # Returns a closure back to initialize() that is used to setup CHAINED # and CHAINED(BOTTOM UP) methods for a particular method name. sub create_CHAINED :Sub(Private) { # $name - method name # $tree - either $GBL{'tree'}{'td'} or $GBL{'tree'}{'bu'} # $code_refs - hash ref by package of code refs for a particular method name my ($name, $tree, $code_refs) = @_; return sub { my $thing = shift; my $class = ref($thing) || $thing; if (! $class) { OIO::Method->die('message' => "Must call '$name' as a method"); } my @args = @_; # Caller must be in class hierarchy my $restr = $$GBL{'sub'}{'chain'}{'restrict'}; if ($restr && exists($$restr{$class}{$name})) { my $caller = caller(); if (! ((grep { $_ eq $caller } @{$$restr{$class}{$name}}) || $caller->isa($class) || $class->isa($caller))) { OIO::Method->die('message' => "Can't call restricted method '$class->$name' from class '$caller'"); } } # Chain results together foreach my $pkg (@{$$tree{$class}}) { if (my $code = $$code_refs{$pkg}) { local $SIG{'__DIE__'} = 'OIO::trap'; @args = $thing->$code(@args); } } # Return results return (@args); }; } } # End of package's lexical scope # Ensure correct versioning ($Object::InsideOut::VERSION eq '4.05') or die("Version mismatch\n"); # EOF Object-InsideOut-4.05/lib/Object/InsideOut/Foreign.pm0000644000175000001440000002022013377136466022057 0ustar jdheddenuserspackage Object::InsideOut; { use strict; use warnings; no warnings 'redefine'; # Installs foreign inheritance methods sub inherit { my ($GBL, $call, @args) = @_; push(@{$$GBL{'export'}}, qw(inherit heritage disinherit)); $$GBL{'init'} = 1; *Object::InsideOut::inherit = sub { my $self = shift; # Must be called as an object method my $obj_class = Scalar::Util::blessed($self); if (! $obj_class) { OIO::Method->die('message' => q/'inherit' called as a class method/); } # Inheritance takes place in caller's package my $pkg = caller(); # Restrict usage to inside class hierarchy if (! $obj_class->isa($pkg)) { OIO::Method->die('message' => "Can't call restricted method 'inherit' from class '$pkg'"); } # Flatten arg list my (@arg_objs, $_arg); while (defined($_arg = shift)) { if (ref($_arg) eq 'ARRAY') { push(@arg_objs, @{$_arg}); } else { push(@arg_objs, $_arg); } } # Must be called with at least one arg if (! @arg_objs) { OIO::Args->die('message' => q/Missing arg(s) to '->inherit()'/); } # Get 'heritage' field and 'classes' hash my $herit = $$GBL{'heritage'}; if (! exists($$herit{$pkg})) { create_heritage($pkg); } my $objects = $$herit{$pkg}{'obj'}; my $classes = $$herit{$pkg}{'cl'}; # Process args my $objs = exists($$objects{$$self}) ? $$objects{$$self} : []; while (my $obj = shift(@arg_objs)) { # Must be an object my $arg_class = Scalar::Util::blessed($obj); if (! $arg_class) { OIO::Args->die('message' => q/Arg to '->inherit()' is not an object/); } # Must not be in class hierarchy if ($obj_class->Object::InsideOut::SUPER::isa($arg_class) || $arg_class->isa($obj_class)) { OIO::Args->die('message' => q/Args to '->inherit()' cannot be within class hierarchy/); } # Add arg to object list push(@{$objs}, $obj); # Add arg class to classes hash $$classes{$arg_class} = undef; } # Add objects to heritage field $self->set($objects, $objs); }; *Object::InsideOut::heritage = sub { my $self = shift; # Must be called as an object method my $obj_class = Scalar::Util::blessed($self); if (! $obj_class) { OIO::Method->die('message' => q/'heritage' called as a class method/); } # Inheritance takes place in caller's package my $pkg = caller(); # Restrict usage to inside class hierarchy if (! $obj_class->isa($pkg)) { OIO::Method->die('message' => "Can't call restricted method 'heritage' from class '$pkg'"); } # Anything to return? if (! exists($$GBL{'heritage'}{$pkg}) || ! exists($$GBL{'heritage'}{$pkg}{'obj'}{$$self})) { return; } my @objs; if (@_) { # Filter by specified classes @objs = grep { my $obj = $_; grep { ref($obj) eq $_ } @_ } @{$$GBL{'heritage'}{$pkg}{'obj'}{$$self}}; } else { # Return entire list @objs = @{$$GBL{'heritage'}{$pkg}{'obj'}{$$self}}; } # Return results if (wantarray()) { return (@objs); } if (@objs == 1) { return ($objs[0]); } return (\@objs); }; *Object::InsideOut::disinherit = sub { my $self = shift; # Must be called as an object method my $class = Scalar::Util::blessed($self); if (! $class) { OIO::Method->die('message' => q/'disinherit' called as a class method/); } # Disinheritance takes place in caller's package my $pkg = caller(); # Restrict usage to inside class hierarchy if (! $class->isa($pkg)) { OIO::Method->die('message' => "Can't call restricted method 'disinherit' from class '$pkg'"); } # Flatten arg list my (@args, $_arg); while (defined($_arg = shift)) { if (ref($_arg) eq 'ARRAY') { push(@args, @{$_arg}); } else { push(@args, $_arg); } } # Must be called with at least one arg if (! @args) { OIO::Args->die('message' => q/Missing arg(s) to '->disinherit()'/); } # Get 'heritage' field if (! exists($$GBL{'heritage'}{$pkg})) { OIO::Code->die( 'message' => 'Nothing to ->disinherit()', 'Info' => "Class '$pkg' is currently not inheriting from any foreign classes"); } my $objects = $$GBL{'heritage'}{$pkg}{'obj'}; # Get inherited objects my @objs = exists($$objects{$$self}) ? @{$$objects{$$self}} : (); # Check that object is inheriting all args foreach my $arg (@args) { if (Scalar::Util::blessed($arg)) { # Arg is an object if (! grep { $_ == $arg } @objs) { my $arg_class = ref($arg); OIO::Args->die( 'message' => 'Cannot ->disinherit()', 'Info' => "Object is not inheriting from an object of class '$arg_class' inside class '$class'"); } } else { # Arg is a class if (! grep { ref($_) eq $arg } @objs) { OIO::Args->die( 'message' => 'Cannot ->disinherit()', 'Info' => "Object is not inheriting from an object of class '$arg' inside class '$class'"); } } } # Delete args from object my @new_list = (); OBJECT: foreach my $obj (@objs) { foreach my $arg (@args) { if (Scalar::Util::blessed($arg)) { if ($obj == $arg) { next OBJECT; } } else { if (ref($obj) eq $arg) { next OBJECT; } } } push(@new_list, $obj); } # Set new object list if (@new_list) { $self->set($objects, \@new_list); } else { # No objects left delete($$objects{$$self}); } }; *Object::InsideOut::create_heritage = sub { # Private my $caller = caller(); if ($caller ne 'Object::InsideOut') { OIO::Method->die('message' => "Can't call private subroutine 'Object::InsideOut::create_heritage' from class '$caller'"); } my $pkg = shift; # Check if 'heritage' already exists if (exists($$GBL{'dump'}{'fld'}{$pkg}{'heritage'})) { OIO::Attribute->die( 'message' => "Can't inherit into '$pkg'", 'Info' => "'heritage' already specified for another field using '$$GBL{'dump'}{'fld'}{$pkg}{'heritage'}{'src'}'"); } # Create the heritage field my $objects = {}; # Share the field, if applicable if (is_sharing($pkg)) { threads::shared::share($objects) } # Save the field's ref push(@{$$GBL{'fld'}{'ref'}{$pkg}}, $objects); # Save info for ->dump() $$GBL{'dump'}{'fld'}{$pkg}{'heritage'} = { fld => $objects, src => 'Inherit' }; # Save heritage info $$GBL{'heritage'}{$pkg} = { obj => $objects, cl => {} }; # Set up UNIVERSAL::can/isa to handle foreign inheritance install_UNIVERSAL(); }; # Do the original call @_ = @args; goto &$call; } } # End of package's lexical scope # Ensure correct versioning ($Object::InsideOut::VERSION eq '4.05') or die("Version mismatch\n"); # EOF Object-InsideOut-4.05/lib/Object/InsideOut/Autoload.pm0000644000175000001440000001644313377136466022252 0ustar jdheddenuserspackage Object::InsideOut; { use strict; use warnings; no warnings 'redefine'; # Handles :Automethods and foreign inheritance sub AUTOLOAD { my ($GBL, @args) = @_; push(@{$$GBL{'export'}}, 'AUTOLOAD'); $$GBL{'init'} = 1; *Object::InsideOut::AUTOLOAD = sub { my $thing = $_[0]; # Extract the class and method names from the fully-qualified name my ($class, $method) = our $AUTOLOAD =~ /(.*)::(.*)/; # Handle superclass calls my $super; if ($class =~ /::SUPER$/) { $class =~ s/::SUPER//; $super = 1; } my $heritage = $$GBL{'heritage'}; my $automethods = $$GBL{'sub'}{'auto'}; # Find a something to handle the method call my ($code_type, $code_dir, %code_refs); foreach my $pkg (@{$$GBL{'tree'}{'bu'}{$class}}) { # Skip self's class if SUPER if ($super && $class eq $pkg) { next; } # Check with heritage objects/classes if (exists($$heritage{$pkg})) { my $objects = $$heritage{$pkg}{'obj'}; my $classes = $$heritage{$pkg}{'cl'}; if (Scalar::Util::blessed($thing)) { if (exists($$objects{$$thing})) { # Check objects foreach my $obj (@{$$objects{$$thing}}) { if (my $code = $obj->can($method)) { shift; unshift(@_, $obj); goto $code; } } } else { # Check classes foreach my $pkg (keys(%{$classes})) { if (my $code = $pkg->can($method)) { @_ = @_; # Perl 5.8.5 bug workaround goto $code; } } } } else { # Check classes foreach my $pkg (keys(%{$classes})) { if (my $code = $pkg->can($method)) { shift; unshift(@_, $pkg); goto $code; } } } } # Check with Automethod if (my $automethod = $$automethods{$pkg}) { # Call the Automethod to get a code ref local $CALLER::_ = $_; local $_ = $method; local $SIG{'__DIE__'} = 'OIO::trap'; if (my ($code, $ctype) = $automethod->(@_)) { if (ref($code) ne 'CODE') { # Delete defective automethod delete($$automethods{$pkg}); # Not a code ref OIO::Code->die( 'message' => ':Automethod did not return a code ref', 'Info' => "NOTICE: The defective :Automethod in package '$pkg' has been DELETED!", 'Code' => ":Automethod in package '$pkg' invoked for method '$method'"); } if (defined($ctype)) { my ($type, $dir) = $ctype =~ /(\w+)(?:[(]\s*(.*)\s*[)])?/; if ($type && $type =~ /CUM/i) { if ($code_type) { $type = ':Cumulative'; $dir = ($dir && $dir =~ /BOT/i) ? 'bottom up' : 'top down'; if ($code_type ne $type || $code_dir ne $dir) { # Mixed types my ($pkg2) = keys(%code_refs); OIO::Code->die( 'message' => 'Inconsistent code types returned by :Automethods', 'Info' => "Class '$pkg' returned type $type($dir), and class '$pkg2' returned type $code_type($code_dir)"); } } else { $code_type = ':Cumulative'; $code_dir = ($dir && $dir =~ /BOT/i) ? 'bottom up' : 'top down'; } $code_refs{$pkg} = $code; next; } if ($type && $type =~ /CHA/i) { if ($code_type) { $type = ':Chained'; $dir = ($dir && $dir =~ /BOT/i) ? 'bottom up' : 'top down'; if ($code_type ne $type || $code_dir ne $dir) { # Mixed types my ($pkg2) = keys(%code_refs); OIO::Code->die( 'message' => 'Inconsistent code types returned by :Automethods', 'Info' => "Class '$pkg' returned type $type($dir), and class '$pkg2' returned type $code_type($code_dir)"); } } else { $code_type = ':Chained'; $code_dir = ($dir && $dir =~ /BOT/i) ? 'bottom up' : 'top down'; } $code_refs{$pkg} = $code; next; } # Unknown automethod code type OIO::Code->die( 'message' => "Unknown :Automethod code type: $ctype", 'Info' => ":Automethod in package '$pkg' invoked for method '$method'"); } if ($code_type) { # Mixed types my ($pkg2) = keys(%code_refs); OIO::Code->die( 'message' => 'Inconsistent code types returned by :Automethods', 'Info' => "Class '$pkg' returned an 'execute immediately' type, and class '$pkg2' returned type $code_type($code_dir)"); } # Just a one-shot - execute it @_ = @_; # Perl 5.8.5 bug workaround goto $code; } } } if ($code_type) { my $tree = ($code_dir eq 'bottom up') ? $$GBL{'tree'}{'bu'} : $$GBL{'tree'}{'td'}; my $code = ($code_type eq ':Cumulative') ? create_CUMULATIVE($method, $tree, \%code_refs) : create_CHAINED($method, $tree, \%code_refs); @_ = @_; # Perl 5.8.5 bug workaround goto $code; } # Failed to AUTOLOAD my $type = ref($thing) ? 'object' : 'class'; OIO::Method->die('message' => qq/Can't locate $type method "$method" via package "$class"/); }; # Do the original call @_ = @args; goto &Object::InsideOut::AUTOLOAD; } } # End of package's lexical scope # Ensure correct versioning ($Object::InsideOut::VERSION eq '4.05') or die("Version mismatch\n"); # EOF Object-InsideOut-4.05/lib/Object/InsideOut.pod0000644000175000001440000034365513377136466020660 0ustar jdheddenusers=head1 NAME Object::InsideOut - Comprehensive inside-out object support module =head1 VERSION This document describes Object::InsideOut version 4.05 =head1 SYNOPSIS package My::Class; { use Object::InsideOut; # Numeric field # With combined get+set accessor my @data :Field :Type(numeric) :Accessor(data); # Takes 'INPUT' (or 'input', etc.) as a mandatory parameter to ->new() my %init_args :InitArgs = ( 'INPUT' => { 'Regex' => qr/^input$/i, 'Mandatory' => 1, 'Type' => 'numeric', }, ); # Handle class-specific args as part of ->new() sub init :Init { my ($self, $args) = @_; # Put 'input' parameter into 'data' field $self->set(\@data, $args->{'INPUT'}); } } package My::Class::Sub; { use Object::InsideOut qw(My::Class); # List field # With standard 'get_X' and 'set_X' accessors # Takes 'INFO' as an optional list parameter to ->new() # Value automatically added to @info array # Defaults to [ 'empty' ] my @info :Field :Type(list) :Standard(info) :Arg('Name' => 'INFO', 'Default' => 'empty'); } package Foo; { use Object::InsideOut; # Field containing My::Class objects # With combined accessor # Plus automatic parameter processing on object creation my @foo :Field :Type(My::Class) :All(foo); } package main; my $obj = My::Class::Sub->new('Input' => 69); my $info = $obj->get_info(); # [ 'empty' ] my $data = $obj->data(); # 69 $obj->data(42); $data = $obj->data(); # 42 $obj = My::Class::Sub->new('INFO' => 'help', 'INPUT' => 86); $data = $obj->data(); # 86 $info = $obj->get_info(); # [ 'help' ] $obj->set_info(qw(foo bar baz)); $info = $obj->get_info(); # [ 'foo', 'bar', 'baz' ] my $foo_obj = Foo->new('foo' => $obj); $foo_obj->foo()->data(); # 86 =head1 DESCRIPTION This module provides comprehensive support for implementing classes using the inside-out object model. Object::InsideOut implements inside-out objects as anonymous scalar references that are blessed into a class with the scalar containing the ID for the object (usually a sequence number). For Perl 5.8.3 and later, the scalar reference is set as B to prevent I modifications to the ID. Object data (i.e., fields) are stored within the class's package in either arrays indexed by the object's ID, or hashes keyed to the object's ID. The virtues of the inside-out object model over the I object model have been extolled in detail elsewhere. See the informational links under L. Briefly, inside-out objects offer the following advantages over I objects: =over =item * Encapsulation Object data is enclosed within the class's code and is accessible only through the class-defined interface. =item * Field Name Collision Avoidance Inheritance using I classes can lead to conflicts if any classes use the same name for a field (i.e., hash key). Inside-out objects are immune to this problem because object data is stored inside each class's package, and not in the object itself. =item * Compile-time Name Checking A common error with I classes is the misspelling of field names: $obj->{'coment'} = 'Say what?'; # Should be 'comment' not 'coment' As there is no compile-time checking on hash keys, such errors do not usually manifest themselves until runtime. With inside-out objects, I hash keys are not used for accessing field data. Field names and the data index (i.e., $$self) are checked by the Perl compiler such that any typos are easily caught using S>. $coment[$$self] = $value; # Causes a compile-time error # or with hash-based fields $comment{$$self} = $value; # Also causes a compile-time error =back Object::InsideOut offers all the capabilities of other inside-out object modules with the following additional key advantages: =over =item * Speed When using arrays to store object data, Object::InsideOut objects are as much as 40% faster than I objects for fetching and setting data, and even with hashes they are still several percent faster than I objects. =item * Threads Object::InsideOut is thread safe, and thoroughly supports sharing objects between threads using L. =item * Flexibility Allows control over object ID specification, accessor naming, parameter name matching, and much more. =item * Runtime Support Supports classes that may be loaded at runtime (i.e., using S>). This makes it usable from within L, as well. Also supports additions to class hierarchies, and dynamic creation of object fields during runtime. =item * Exception Objects Object::InsideOut uses L for handling errors in an OO-compatible manner. =item * Object Serialization Object::InsideOut has built-in support for object dumping and reloading that can be accomplished in either an automated fashion or through the use of class-supplied subroutines. Serialization using L is also supported. =item * Foreign Class Inheritance Object::InsideOut allows classes to inherit from foreign (i.e., non-Object::InsideOut) classes, thus allowing you to sub-class other Perl class, and access their methods from your own objects. =item * Introspection Obtain constructor parameters and method metadata for Object::InsideOut classes. =back =head1 CLASSES To use this module, each of your classes will start with S>: package My::Class; { use Object::InsideOut; ... } Sub-classes (child classes) inherit from base classes (parent classes) by telling Object::InsideOut what the parent class is: package My::Sub; { use Object::InsideOut qw(My::Parent); ... } Multiple inheritance is also supported: package My::Project; { use Object::InsideOut qw(My::Class Another::Class); ... } Object::InsideOut acts as a replacement for the C pragma: It loads the parent module(s), calls their C<-Eimport()> methods, and sets up the sub-class's @ISA array. Therefore, you should not S> yourself, nor try to set up C<@ISA> arrays. Further, you should not use a class's C<@ISA> array to determine a class's hierarchy: See L for details on how to do this. If a parent class takes parameters (e.g., symbols to be exported via L">), enclose them in an array ref (mandatory) following the name of the parent class: package My::Project; { use Object::InsideOut 'My::Class' => [ 'param1', 'param2' ], 'Another::Class' => [ 'param' ]; ... } =head1 OBJECTS =head2 Object Creation Objects are created using the C<-Enew()> method which is exported by Object::InsideOut to each class, and is invoked in the following manner: my $obj = My::Class->new(); Object::InsideOut then handles all the messy details of initializing the object in each of the classes in the invoking class's hierarchy. As such, classes do not (normally) implement their own C<-Enew()> method. Usually, object fields are initially populated with data as part of the object creation process by passing parameters to the C<-Enew()> method. Parameters are passed in as combinations of S value>> pairs and/or hash refs: my $obj = My::Class->new('param1' => 'value1'); # or my $obj = My::Class->new({'param1' => 'value1'}); # or even my $obj = My::Class->new( 'param_X' => 'value_X', 'param_Y' => 'value_Y', { 'param_A' => 'value_A', 'param_B' => 'value_B', }, { 'param_Q' => 'value_Q', }, ); Additionally, parameters can be segregated in hash refs for specific classes: my $obj = My::Class->new( 'foo' => 'bar', 'My::Class' => { 'param' => 'value' }, 'Parent::Class' => { 'data' => 'info' }, ); The initialization methods for both classes in the above will get S 'bar'>>, C will also get S 'value'>>, and C will also get S 'info'>>. In this scheme, class-specific parameters will override general parameters specified at a higher level: my $obj = My::Class->new( 'default' => 'bar', 'Parent::Class' => { 'default' => 'baz' }, ); C will get S 'bar'>>, and C will get S 'baz'>>. Calling C<-Enew()> on an object works, too, and operates the same as calling C<-Enew()> for the class of the object (i.e., C<$obj-Enew()> is the same as Cnew()>). How the parameters passed to the C<-Enew()> method are used to initialize the object is discussed later under L. NOTE: You cannot create objects from Object::InsideOut itself: # This is an error # my $obj = Object::InsideOut->new(); In this way, Object::InsideOut is not an object class, but functions more like a pragma. =head2 Object IDs As stated earlier, this module implements inside-out objects as anonymous, read-only scalar references that are blessed into a class with the scalar containing the ID for the object. Within methods, the object is passed in as the first argument: sub my_method { my $self = shift; ... } The object's ID is then obtained by dereferencing the object: C<$$self>. Normally, this is only needed when accessing the object's field data: my @my_field :Field; sub my_method { my $self = shift; ... my $data = $my_field[$$self]; ... } At all other times, and especially in application code, the object should be treated as an I entity. =head1 ATTRIBUTES Much of the power of Object::InsideOut comes from the use of I: I on variables and subroutines that the L module sends to Object::InsideOut at compile time. Object::InsideOut then makes use of the information in these tags to handle such operations as object construction, automatic accessor generation, and so on. (Note: The use of attributes is not the same thing as L.) An attribute consists of an identifier preceded by a colon, and optionally followed by a set of parameters in parentheses. For example, the attributes on the following array declare it as an object field, and specify the generation of an accessor method for that field: my @level :Field :Accessor(level); When multiple attributes are assigned to a single entity, they may all appear on the same line (as shown above), or on separate lines: my @level :Field :Accessor(level); However, due to limitations in the Perl parser, the entirety of any one attribute must be on a single line: # This doesn't work # my @level # :Field # :Accessor('Name' => 'level', # 'Return' => 'Old'); # Each attribute must be all on one line my @level :Field :Accessor('Name' => 'level', 'Return' => 'Old'); For Object::InsideOut's purposes, the case of an attribute's name does not matter: my @data :Field; # or my @data :FIELD; However, by convention (as denoted in the L module), an attribute's name should not be all lowercase. =head1 FIELDS =head2 Field Declarations Object data fields consist of arrays within a class's package into which data are stored using the object's ID as the array index. An array is declared as being an object field by following its declaration with the C<:Field> attribute: my @info :Field; Object data fields may also be hashes: my %data :Field; However, as array access is as much as 40% faster than hash access, you should stick to using arrays. See L for more information on when hashes may be required. =head2 Getting Data In class code, data can be fetched directly from an object's field array (hash) using the object's ID: $data = $field[$$self]; # or $data = $field{$$self}; =head2 Setting Data Analogous to the above, data can be put directly into an object's field array (hash) using the object's ID: $field[$$self] = $data; # or $field{$$self} = $data; However, in threaded applications that use data sharing (i.e., use C), the above will not work when the object is shared between threads and the data being stored is either an array, hash or scalar reference (this includes other objects). This is because the C<$data> must first be converted into shared data before it can be put into the field. Therefore, Object::InsideOut automatically exports a method called C<-Eset()> to each class. This method should be used in class code to put data into object fields whenever there is the possibility that the class code may be used in an application that uses L (i.e., to make your class code B). The C<-Eset()> method handles all details of converting the data to a shared form, and storing it in the field. The C<-Eset()> method, requires two arguments: A reference to the object field array/hash, and the data (as a scalar) to be put in it: my @my_field :Field; sub store_data { my ($self, $data) = @_; ... $self->set(\@my_field, $data); } To be clear, the C<-Eset()> method is used inside class code; not application code. Use it inside any object methods that set data in object field arrays/hashes. In the event of a method naming conflict, the C<-Eset()> method can be called using its fully-qualified name: $self->Object::InsideOut::set(\@field, $data); =head1 OBJECT INITIALIZATION As stated in L, object fields are initially populated with data as part of the object creation process by passing S value>> parameters to the C<-Enew()> method. These parameters can be processed automatically into object fields, or can be passed to a class-specific object initialization subroutine. =head2 Field-Specific Parameters When an object creation parameter corresponds directly to an object field, you can specify for Object::InsideOut to automatically place the parameter into the field by adding the C<:Arg> attribute to the field declaration: my @foo :Field :Arg(foo); For the above, the following would result in C<$val> being placed in C's C<@foo> field during object creation: my $obj = My::Class->new('foo' => $val); =head2 Object Initialization Subroutines Many times, object initialization parameters do not correspond directly to object fields, or they may require special handling. For these, parameter processing is accomplished through a combination of an C<:InitArgs> labeled hash, and an C<:Init> labeled subroutine. The C<:InitArgs> labeled hash specifies the parameters to be extracted from the argument list supplied to the C<-Enew()> method. Those parameters (and only those parameters) which match the keys in the C<:InitArgs> hash are then packaged together into a single hash ref. The newly created object and this parameter hash ref are then sent to the C<:Init> subroutine for processing. Here is an example of a class with an I field and an I<:Init handled> field: package My::Class; { use Object::InsideOut; # Automatically handled field my @my_data :Field :Acc(data) :Arg(MY_DATA); # ':Init' handled field my @my_field :Field; my %init_args :InitArgs = ( 'MY_PARAM' => '', ); sub _init :Init { my ($self, $args) = @_; if (exists($args->{'MY_PARAM'})) { $self->set(\@my_field, $args->{'MY_PARAM'}); } } ... } An object for this class would be created as follows: my $obj = My::Class->new('MY_DATA' => $dat, 'MY_PARAM' => $parm); This results in, first of all, C<$dat> being placed in the object's C<@my_data> field because the C key is specified in the C<:Arg> attribute for that field. Then, C<_init> is invoked with arguments consisting of the object (i.e., C<$self>) and a hash ref consisting only of S $param }>> because the key C is specified in the C<:InitArgs> hash. C<_init> checks that the parameter C exists in the hash ref, and then (since it does exist) adds C<$parm> to the object's C<@my_field> field. =over =item Setting Data Data processed by the C<:Init> subroutine may be placed directly into the class's field arrays (hashes) using the object's ID (i.e., C<$$self>): $my_field[$$self] = $args->{'MY_PARAM'}; However, as shown in the example above, it is strongly recommended that you use the L<-Eset()|/"Setting Data"> method: $self->set(\@my_field, $args->{'MY_PARAM'}); which handles converting the data to a shared format when needed for applications using L. =item All Parameters The C<:InitArgs> hash and the C<:Arg> attribute on fields act as filters that constrain which initialization parameters are and are not sent to the C<:Init> subroutine. If, however, a class does not have an C<:InitArgs> hash B does not use the C<:Arg> attribute on any of its fields, then its C<:Init> subroutine (if it exists, of course) will get all the initialization parameters supplied to the C<-Enew()> method. =back =head2 Mandatory Parameters Field-specific parameters may be declared mandatory as follows: my @data :Field :Arg('Name' => 'data', 'Mandatory' => 1); If a mandatory parameter is missing from the argument list to C<-Enew()>, an error is generated. For C<:Init> handled parameters, use: my %init_args :InitArgs = ( 'data' => { 'Mandatory' => 1, }, ); C may be abbreviated to C, and C or C are synonymous. =head2 Default Values For optional parameters, defaults can be specified for field-specific parameters using either of these syntaxes: my @data :Field :Arg('Name' => 'data', 'Default' => 'foo'); my @info :Field :Arg(info) :Default('bar'); If an optional parameter with a specified default is missing from the argument list to C<-Enew()>, then the default is assigned to the field when the object is created (before the C<:Init> subroutine, if any, is called). The format for C<:Init> handled parameters is: my %init_args :InitArgs = ( 'data' => { 'Default' => 'foo', }, ); In this case, if the parameter is missing from the argument list to C<-Enew()>, then the parameter key is paired with the default value and added to the C<:Init> argument hash ref (e.g., S 'foo' }>>). Fields can also be assigned a default value even if not associated with an initialization parameter: my @hash :Field :Default({}); my @tuple :Field :Default([1, 'bar']); Note that when using C<:Default>, the value must be properly structured Perl code (e.g., strings must be quoted as illustrated above). C and C<:Default> may be abbreviated to C and C<:Def> respectively. =head3 Generated Default Values It is also possible to I default values on a per object basis by using code in the C<:Default> directive. my @IQ :Field :Default(50 + rand 100); my @ID :Field :Default(our $next; ++$next); The above, for example, will initialize the C attribute of each new object to a different random number, while its C attribute will be initialized with a sequential integer. The code in a C<:Default> specifier can also refer to the object being initialized, either as C<$_[0]> or as C<$self>. For example: my @unique_ID :Field :Default($self->gen_unique_ID); Any code specified as a default will I have access to the surrounding lexical scope. For example, this will not work: my $MAX = 100; my $MIN = 0; my @bar :Field :Default($MIN + rand($MAX-$MIX)); # Error For anything lexical or complex, you should factor the initializer out into a utility subroutine: sub _rand_max :Restricted { $MIN + rand($MAX-$MIX) } my @bar :Field :Default(_rand_max); When specifying a generated default using the C tag inside an C<:Arg> directive, you will need to wrap the code in a C, and C<$_[0]> (but not C<$self>) can be used to access the object being initialized: my @baz :Field :Arg(Name => 'baz', Default => sub { $_[0]->biz }); System functions need to similarly be wrapped in C: my @rand :Field :Type(numeric) :Arg(Name => 'Rand', Default => sub { rand }); Subroutines can be accessed using a code reference: my @data :Field :Arg(Name => 'Data', Default => \&gen_default); On the other hand, the above can also be simplified by using the C<:Default> directive instead: my @baz :Field :Arg(baz) :Default($self->biz); my @rand :Field :Arg(Rand) :Default(rand) :Type(numeric); my @data :Field :Arg(Data) :Default(gen_default); Using generated defaults in the C<:InitArgs> hash requires the use of the same types of syntax as with the C tag in an C<:Arg> directive: my %init_args :InitArgs = ( 'Baz' => { 'Default' => sub { $_[0]->biz }, }, 'Rand' => { 'Default' => sub { rand }, }, 'Data' => { 'Default' => \&gen_default, }, ); =head3 Sequential defaults In the previous section, one of the examples is not as safe or as convenient as it should be: my @ID :Field :Default(our $next; ++$next); The problem is the shared variable (C<$next>) that's needed to track the allocation of C values. Because it has to persist between calls, that variable has to be a package variable, except under Perl 5.10 or later where it could be a state variable instead: use feature 'state'; my @ID :Field :Default(state $next; ++$next); The version with the package variable is unsafe, because anyone could then spoof ID numbers just by reassigning that universally accessible variable: $MyClass::next = 0; # Spoof the next object my $obj = MyClass->new; # Object now has ID 1 The state-variable version avoids this problem, but even that version is more complicated (and hence more error-prone) than it needs to be. The C<:SequenceFrom> directive (which can be abbreviated to C<:SeqFrom> or C<:Seq>) makes it much easier to specify that an attribute's default value is taken from a linearly increasing sequence. For instance, the ID example above could be rewritten as: my @ID :Field :SequenceFrom(1); This directive automatically creates a hidden variable, initializes it to the initial value specified, generates a sequence starting at that initial value, and then uses successive elements of that sequence each time a default value is needed for that attribute during object creation. If the initial value is a scalar, then the default sequence is generated by by computing C<$previous_value++>. If it is an object, it is generated by calling C<< $obj->next() >> (or by calling C<$obj++> if the object doesn't have a C method). This makes it simple to create a series of objects with attributes whose values default to simple numeric, alphabetic, or alphanumeric sequences, or to the sequence specified by an iterator object of some kind: my @ID :Field :SeqFrom(1); # 1, 2, 3... my @ID :Field :SeqFrom('AAA'); # 'AAA', 'AAB', 'AAC'... my @ID :Field :SeqFrom('A01'); # 'A01', 'A02', 'A03'... my @ID :Field :SeqFrom(ID_Iterator->new); # ->next, ->next, ->next... In every other respect a C<:SequenceFrom> directive is just like a C<:Default>. For example, it can be used in conjunction with the C<:Arg> directive as follows: my @ID :Field :Arg(ID) :SeqFrom(1); However, not as a tag inside the C<:Arg> directive: my @ID :Field :Arg('Name' => 'ID', 'SeqFrom' => 1) # WRONG For the C<:InitArgs> hash, you will need to I sequential defaults if required: use feature 'state'; my %init_args :InitArgs = ( 'Counter' => { 'Default' => sub { state $next; ++$next } }, ); =head2 Parameter Name Matching Rather than having to rely on exact matches to parameter keys in the C<-Enew()> argument list, you can specify a regular expressions to be used to match them to field-specific parameters: my @param :Field :Arg('Name' => 'param', 'Regexp' => qr/^PARA?M$/i); In this case, the parameter's key could be any of the following: PARAM, PARM, Param, Parm, param, parm, and so on. And the following would result in C<$data> being placed in C's C<@param> field during object creation: my $obj = My::Class->new('Parm' => $data); For C<:Init> handled parameters, you would similarly use: my %init_args :InitArgs = ( 'Param' => { 'Regex' => qr/^PARA?M$/i, }, ); In this case, the match results in S $data }>> being sent to the C<:Init> subroutine as the argument hash. Note that the C<:InitArgs> hash key is substituted for the original argument key. This eliminates the need for any parameter key pattern matching within the C<:Init> subroutine. C may be abbreviated to C or C. =head2 Object Pre-initialization Occasionally, a child class may need to send a parameter to a parent class as part of object initialization. This can be accomplished by supplying a C<:PreInit> labeled subroutine in the child class. These subroutines, if found, are called in order from the bottom of the class hierarchy upward (i.e., child classes first). The subroutine should expect two arguments: The newly created (uninitialized) object (i.e., C<$self>), and a hash ref of all the parameters from the C<-Enew()> method call, including any additional parameters added by other C<:PreInit> subroutines. sub pre_init :PreInit { my ($self, $args) = @_; ... } The parameter hash ref will not be exactly as supplied to C<-Enew()>, but will be I into a single hash ref. For example, my $obj = My::Class->new( 'param_X' => 'value_X', { 'param_A' => 'value_A', 'param_B' => 'value_B', }, 'My::Class' => { 'param' => 'value' }, ); would produce { 'param_X' => 'value_X', 'param_A' => 'value_A', 'param_B' => 'value_B', 'My::Class' => { 'param' => 'value' } } as the hash ref to the C<:PreInit> subroutine. The C<:PreInit> subroutine may then add, modify or even remove any parameters from the hash ref as needed for its purposes. After all the C<:PreInit> subroutines have been executed, object initialization will then proceed using the resulting parameter hash. The C<:PreInit> subroutine should not try to set data in its class's fields or in other class's fields (e.g., using I methods) as such changes will be overwritten during initialization phase which follows pre-initialization. The C<:PreInit> subroutine is only intended for modifying initialization parameters prior to initialization. =head2 Initialization Sequence For the most part, object initialization can be conceptualized as proceeding from parent classes down through child classes. As such, calling child class methods from a parent class during object initialization may not work because the object will not have been fully initialized in the child classes. Knowing the order of events during object initialization may help in determining when this can be done safely: =over =item 1. The scalar reference for the object is created, populated with an L, and blessed into the appropriate class. =item 2. L<:PreInit|/"Object Pre-initialization"> subroutines are called in order from the bottom of the class hierarchy upward (i.e., child classes first). =item 3. From the top of the class hierarchy downward (i.e., parent classes first), L are assigned to fields. (These may be overwritten by subsequent steps below.) =item 4. From the top of the class hierarchy downward, parameters to the C<-Enew()> method are processed for C<:Arg> field attributes and entries in the C<:InitArgs> hash: =over =item a. L is performed. =item b. Checks for L are made. =item c. L specified in the C<:InitArgs> hash are added for subsequent processing by the C<:Init> subroutine. =item d. L is performed. =item e. L are assigned to fields. =back =item 5. From the top of the class hierarchy downward, L<:Init|/"Object Initialization Subroutines"> subroutines are called with parameters specified in the C<:InitArgs> hash. =item 6. Checks are made for any parameters to C<-Enew()> that were not handled in the above. (See next section.) =back =head2 Unhandled Parameters It is an error to include any parameters to the C<-Enew()> method that are not handled by at least one class in the hierarchy. The primary purpose of this is to catch typos in parameter names: my $obj = Person->new('nane' => 'John'); # Should be 'name' The only time that checks for unhandled parameters are not made is when at least one class in the hierarchy does not have an C<:InitArgs> hash B does not use the C<:Arg> attribute on any of its fields B uses an L<:Init|/"Object Initialization Subroutines"> subroutine for processing parameters. In such a case, it is not possible for Object::InsideOut to determine which if any of the parameters are not handled by the C<:Init> subroutine. If you add the following construct to the start of your application: BEGIN { no warnings 'once'; $OIO::Args::Unhandled::WARN_ONLY = 1; } then unhandled parameters will only generate warnings rather than causing exceptions to be thrown. =head2 Modifying C<:InitArgs> For performance purposes, Object::InsideOut I each class's C<:InitArgs> hash by creating keys in the form of C<'_X'> for the various options it handles (e.g., C<'_R'> for C<'Regexp'>). If a class has the unusual requirement to modify its C<:InitArgs> hash during runtime, then it must renormalize the hash after making such changes by invoking C on it so that Object::InsideOut will pick up the changes: Object::InsideOut::normalize(\%init_args); =head1 ACCESSOR GENERATION Accessors are object methods used to get data out of and put data into an object. You can, of course, write your own accessor code, but this can get a bit tedious, especially if your class has lots of fields. Object::InsideOut provides the capability to automatically generate accessors for you. =head2 Basic Accessors A I accessor is vary basic: It just returns the value of an object's field: my @data :Field; sub fetch_data { my $self = shift; return ($data[$$self]); } and you would use it as follows: my $data = $obj->fetch_data(); To have Object::InsideOut generate such a I accessor for you, add a C<:Get> attribute to the field declaration, specifying the name for the accessor in parentheses: my @data :Field :Get(fetch_data); Similarly, a I accessor puts data in an object's field. The I accessors generated by Object::InsideOut check that they are called with at least one argument. They are specified using the C<:Set> attribute: my @data :Field :Set(store_data); Some programmers use the convention of naming I and I accessors using I and I prefixes. Such I accessors can be generated using the C<:Standard> attribute (which may be abbreviated to C<:Std>): my @data :Field :Std(data); which is equivalent to: my @data :Field :Get(get_data) :Set(set_data); Other programmers prefer to use a single I accessors that performs both functions: When called with no arguments, it I, and when called with an argument, it I. Object::InsideOut will generate such accessors with the C<:Accessor> attribute. (This can be abbreviated to C<:Acc>, or you can use C<:Get_Set> or C<:Combined> or C<:Combo> or even C.) For example: my @data :Field :Acc(data); The generated accessor would be used in this manner: $obj->data($val); # Puts data into the object's field my $data = $obj->data(); # Fetches the object's field data =head2 I Accessor Return Value For any of the automatically generated methods that perform I operations, the default for the method's return value is the value being set (i.e., the I value). You can specify the I accessor's return value using the C attribute parameter (which may be abbreviated to C). For example, to explicitly specify the default behavior use: my @data :Field :Set('Name' => 'store_data', 'Return' => 'New'); You can specify that the accessor should return the I (previous) value (or C if unset): my @data :Field :Acc('Name' => 'data', 'Ret' => 'Old'); You may use C, C or C as synonyms for C. Finally, you can specify that the accessor should return the object itself: my @data :Field :Std('Name' => 'data', 'Ret' => 'Object'); C may be abbreviated to C, and is also synonymous with C. =head2 Method Chaining An obvious case where method chaining can be used is when a field is used to store an object: A method for the stored object can be chained to the I accessor call that retrieves that object: $obj->get_stored_object()->stored_object_method() Chaining can be done off of I accessors based on their return value (see above). In this example with a I accessor that returns the I value: $obj->set_stored_object($stored_obj)->stored_object_method() the I call stores the new object, returning it as well, and then the I call is invoked via the stored/returned object. The same would work for I accessors that return the I value, too, but in that case the chained method is invoked via the previously stored (and now returned) object. If the L module (version 0.12 or later) is available, then Object::InsideOut also tries to do I with method chaining for I accessors that don't store/return objects. In this case, the object used to invoke the I accessor will also be used to invoke the chained method (just as though the I accessor were declared with S 'Object'>>): $obj->set_data('data')->do_something(); To make use of this feature, just add C to the beginning of your application. Note, however, that this special handling does not apply to I accessors, nor to I accessors invoked without an argument (i.e., when used as a I accessor). These must return objects in order for method chaining to succeed. =head2 :lvalue Accessors As documented in L, an C<:lvalue> subroutine returns a modifiable value. This modifiable value can then, for example, be used on the left-hand side (hence C) of an assignment statement, or a substitution regular expression. For Perl 5.8.0 and later, Object::InsideOut supports the generation of C<:lvalue> accessors such that their use in an C context will set the value of the object's field. Just add C<'lvalue' =E 1> to the I accessor's attribute. (C<'lvalue'> may be abbreviated to C<'lv'>.) Additionally, C<:Lvalue> (or its abbreviation C<:lv>) may be used for a combined I I<:lvalue> accessor. In other words, the following are equivalent: :Acc('Name' => 'email', 'lvalue' => 1) :Lvalue(email) Here is a detailed example: package Contact; { use Object::InsideOut; # Create separate a get accessor and an :lvalue set accessor my @name :Field :Get(name) :Set('Name' => 'set_name', 'lvalue' => 1); # Create a standard get_/set_ pair of accessors # The set_ accessor will be an :lvalue accessor my @phone :Field :Std('Name' => 'phone', 'lvalue' => 1); # Create a combined get/set :lvalue accessor my @email :Field :Lvalue(email); } package main; my $obj = Contact->new(); # Use :lvalue accessors in assignment statements $obj->set_name() = 'Jerry D. Hedden'; $obj->set_phone() = '800-555-1212'; $obj->email() = 'jdhedden AT cpan DOT org'; # Use :lvalue accessor in substitution regexp $obj->email() =~ s/ AT (\w+) DOT /\@$1./; # Use :lvalue accessor in a 'substr' call substr($obj->set_phone(), 0, 3) = '888'; print("Contact info:\n"); print("\tName: ", $obj->name(), "\n"); print("\tPhone: ", $obj->get_phone(), "\n"); print("\tEmail: ", $obj->email(), "\n"); The use of C<:lvalue> accessors requires the installation of the L module (version 0.12 or later) from CPAN. See particularly the section L for more information. C<:lvalue> accessors also work like regular I accessors in being able to accept arguments, return values, and so on: my @pri :Field :Lvalue('Name' => 'priority', 'Return' => 'Old'); ... my $old_pri = $obj->priority(10); C<:lvalue> accessors can be used in L. B: While still classified as I, Perl's support for C<:lvalue> subroutines has been around since 5.6.0, and a good number of CPAN modules make use of them. By definition, because C<:lvalue> accessors return the I of a field, they break encapsulation. As a result, some OO advocates eschew the use of C<:lvalue> accessors. C<:lvalue> accessors are slower than corresponding I accessors. This is due to the fact that more code is needed to handle all the diverse ways in which C<:lvalue> accessors may be used. (I've done my best to optimize the generated code.) For example, here's the code that is generated for a simple combined accessor: *Foo::foo = sub { return ($$field[${$_[0]}]) if (@_ == 1); $$field[${$_[0]}] = $_[1]; }; And the corresponding code for an C<:lvalue> combined accessor: *Foo::foo = sub :lvalue { my $rv = !Want::want_lvalue(0); Want::rreturn($$field[${$_[0]}]) if ($rv && (@_ == 1)); my $assign; if (my @args = Want::wantassign(1)) { @_ = ($_[0], @args); $assign = 1; } if (@_ > 1) { $$field[${$_[0]}] = $_[1]; Want::lnoreturn if $assign; Want::rreturn($$field[${$_[0]}]) if $rv; } ((@_ > 1) && (Want::wantref() eq 'OBJECT') && !Scalar::Util::blessed($$field[${$_[0]}])) ? $_[0] : $$field[${$_[0]}]; }; =head1 ALL-IN-ONE Parameter naming and accessor generation may be combined: my @data :Field :All(data); This is I for: my @data :Field :Arg(data) :Acc(data); If you want the accessor to be C<:lvalue>, use: my @data :Field :LV_All(data); If I accessors are desired, use: my @data :Field :Std_All(data); Attribute parameters affecting the I accessor may also be used. For example, if you want I accessors with an C<:lvalue> I accessor: my @data :Field :Std_All('Name' => 'data', 'Lvalue' => 1); If you want a combined accessor that returns the I value on I operations: my @data :Field :All('Name' => 'data', 'Ret' => 'Old'); And so on. If you need to add attribute parameters that affect the C<:Arg> portion (e.g., C, C, etc.), then you cannot use C<:All>. Fall back to using the separate attributes. For example: my @data :Field :Arg('Name' => 'data', 'Mand' => 1) :Acc('Name' => 'data', 'Ret' => 'Old'); =head1 READONLY FIELDS If you want to declare a I field (i.e., one that can be initialized and retrieved, but which doesn't have a I accessor): my @data :Field :Arg(data) :Get(data); there is a I for that, too: my @data :Field :ReadOnly(data); or just: my @data :Field :RO(data); If a I I accessor is desired, use: my @data :Field :Std_RO(data); For obvious reasons, attribute parameters affecting the I accessor cannot be used with read-only fields, nor can C<:ReadOnly> be combined with C<:LValue>. As with C<:All>, if you need to add attribute parameters that affect the C<:Arg> portion then you cannot use the C<:RO> shorthand: Fall back to using the separate attributes in such cases. For example: my @data :Field :Arg('Name' => 'data', 'Mand' => 1) :Get('Name' => 'data'); =head1 DELEGATORS In addition to autogenerating accessors for a given field, you can also autogenerate I to that field. A delegator is an accessor that forwards its call to one of the object's fields. For example, if your I object has an C<@engine> field, then you might need to send all acceleration requests to the I object stored in that field. Likewise, all braking requests may need to be forwarded to I's field that stores the I object: package Car; { use Object::InsideOut; my @engine :Field :Get(engine); my @brakes :Field :Get(brakes); sub _init :Init(private) { my ($self, $args) = @_; $self->engine(Engine->new()); $self->brakes(Brakes->new()); } sub accelerate { my ($self) = @_; $self->engine->accelerate(); } sub decelerate { my ($self) = @_; $self->engine->decelerate(); } sub brake { my ($self, $foot_pressure) = @_; $self->brakes->brake($foot_pressure); } } If the I needs to forward other method calls to its I or I, this quickly becomes tedious, repetitive, and error-prone. So, instead, you can just tell Object::InsideOut that a particular method should be automatically forwarded to a particular field, by specifying a C<:Handles> attribute: package Car; { use Object::InsideOut; my @engine :Field :Get(engine) :Handles(accelerate, decelerate); my @brakes :Field :Get(brakes) :Handles(brake); sub _init :Init(private) { my ($self, $args) = @_; $self->engine(Engine->new()); $self->brakes(Brakes->new()); } } This option generates and installs a single delegator method for each of its arguments, so the second example has exactly the same effect as the first example. The delegator simply calls the corresponding method on the object stored in the field, passing it the same argument list it received. Sometimes, however, you may need to delegate a particular method to a field, but under a different name. For example, if the I class provides an C method, rather than a C method, then you'd need C to be implemented as: sub brake { my ($self, $foot_pressure) = @_; $self->brakes->engage($foot_pressure); } You can achieve that using the C<:Handles> attribute, like so: my @brakes :Field :Get(brakes) :Handles(brake-->engage); The long arrow version still creates a delegator method C, but makes that method delegate to your I object by calling its C method instead. If you are delegating a large number of methods to a particular field, the C<:Handles> declarations soon become tedious: my @onboard_computer :Field :Get(comp) :Type(Computer::Onboard) :Handles(engine_monitor engine_diagnostics) :Handles(engine_control airbag_deploy) :Handles(GPS_control GPS_diagnostics GPS_reset) :Handles(climate_control reversing_camera) :Handles(cruise_control auto_park) :Handles(iPod_control cell_phone_connect); And, of course, every time the interface of the C class changes, you have to change those C<:Handles> declarations, too. Sometimes, all you really want to say is: "This field should handle anything it I handle". To do that, you write: my @onboard_computer :Field :Get(comp) :Type(Computer::Onboard) :Handles(Computer::Onboard); That is, if a C<:Handles> directive is given a name that includes a C<::>, it treats that name as a class name, rather than a method name. Then it checks that class's metadata (see L), retrieves a list of all the method names from the class, and uses that as the list of method names to delegate. Unlike an explicit C<:Handles( method_name )>, a C<:Handles( Class::Name )> is tolerant of name collisions. If any method of C has the same name as another method or delegator that has already been installed in the current class, then C<:Handles> just silently ignores that particular method, and doesn't try to replace the existing one. In other words, a C<:Handles(Class::Name)> won't install a delegator to a method in C if that method is already being handled somewhere else by the current class. For classes that don't have a C<::> in their name (e.g., C and C), just append a C<::> to the class name: my @init_time :Field :Get(init_time) :Type( DateTime ) :Default( DateTime->now() ) :Handles( DateTime:: ); Note that, when using the class-based version of C<:Handles>, every method is delegated with its name unchanged. If some of the object's methods should be delegated under different names, you have to specify that explicitly (and beforehand): my @onboard_computer :Field :Get(comp) :Type(Computer::Onboard) # rename this method when delegating... :Handles( iPod_control-->get_iPod ) # delegate everything else with names unchanged... :Handles( Computer::Onboard ); C may be abbreviated to C or C. NOTES: Failure to add the appropriate object to the delegation field will lead to errors such as: B. Typos in C<:Handles> attribute declarations will lead to errors such as: B. Adding an object of the wrong class to the delegation field will lead to the same error, but can be avoided by adding a C<:Type> attribute for the appropriate class. =head1 PERMISSIONS =head2 Restricted and Private Accessors By default, L, can be called at any time. In other words, their access permission is I. If desired, accessors can be made I - in which case they can only be called from within the class and any child classes in the hierarchy that are derived from it - or I - such that they can only be called from within the accessors' class. Here are examples of the syntax for adding permissions: my @data :Field :Std('Name' => 'data', 'Permission' => 'private'); my @info :Field :Set('Name' => 'set_info', 'Perm' => 'restricted'); my @internal :Field :Acc('Name' => 'internal', 'Private' => 1); my @state :Field :Get('Name' => 'state', 'Restricted' => 1); When creating a I pair of I accessors, the permission setting is applied to both accessors. If different permissions are required on the two accessors, then you'll have to use separate C<:Get> and C<:Set> attributes on the field. # Create a private set method # and a restricted get method on the 'foo' field my @foo :Field :Set('Name' => 'set_foo', 'Priv' => 1) :Get('Name' => 'get_foo', 'Rest' => 1); # Create a restricted set method # and a public get method on the 'bar' field my %bar :Field :Set('Name' => 'set_bar', 'Perm' => 'restrict') :Get(get_bar); C may be abbreviated to C; C may be abbreviated to C; and C may be abbreviated to C. =head2 Restricted and Private Methods In the same vein as describe above, access to methods can be narrowed by use of C<:Restricted> and C<:Private> attributes. sub foo :Restricted { my $self = shift; ... } Without either of these attributes, most methods have I access. If desired, you may explicitly label them with the C<:Public> attribute. =head2 Exemptions It is also possible to specify classes that are exempt from the I and I access permissions (i.e., the method may be called from those classes as well): my %foo :Field :Acc('Name' => 'foo', 'Perm' => 'Restrict(Exempt::Class)') :Get(get_bar); sub bar :Private(Some::Class, Another::Class) { my $self = shift; ... } An example of when this might be needed is with delegation mechanisms. =head2 Hidden Methods For subroutines marked with the following attributes (most of which are discussed later in this document): =over =item :ID =item :PreInit =item :Init =item :Replicate =item :Destroy =item :Automethod =item :Dumper =item :Pumper =item :MOD_*_ATTRS =item :FETCH_*_ATTRS =back Object::InsideOut normally renders them uncallable (hidden) to class and application code (as they should normally only be needed by Object::InsideOut itself). If needed, this behavior can be overridden by adding the C, C or C attribute parameters: sub _init :Init(private) # Callable from within this class { my ($self, $args) = @_; ... } =head2 Restricted and Private Classes Permission for object creation on a class can be narrowed by adding a C<:Restricted> or C<:Private> flag to its S> declaration. This basically adds C<:Restricted/:Private> permissions on the C<-Enew()> method for that class. Exemptions are also supported. package Foo; { use Object::InsideOut; ... } package Bar; { use Object::InsideOut 'Foo', ':Restricted(Ping, Pong)'; ... } In the above, class C inherits from class C, and its constructor is restricted to itself, classes that inherit from C, and the classes C and C. As constructors are inherited, any class that inherits from C would also be a restricted class. To overcome this, any child class would need to add its own permission declaration: package Baz; { use Object::InsideOut qw/Bar :Private(My::Class)/; ... } Here, class C inherits from class C, and its constructor is restricted to itself (i.e., private) and class C. Inheriting from a C<:Private> class is permitted, but objects cannot be created for that class unless it has a permission declaration of its own: package Zork; { use Object::InsideOut qw/:Public Baz/; ... } Here, class C inherits from class C, and its constructor has unrestricted access. (In general, don't use the C<:Public> declaration for a class except to overcome constructor permissions inherited from parent classes.) =head1 TYPE CHECKING Object::InsideOut can be directed to add type-checking code to the I accessors it generates, and to perform type checking on object initialization parameters. =head2 Field Type Checking Type checking for a field can be specified by adding the C<:Type> attribute to the field declaration: my @count :Field :Type(numeric); my @objs :Field :Type(list(My::Class)); The C<:Type> attribute results in type checking code being added to I accessors generated by Object::InsideOut, and will perform type checking on object initialization parameters processed by the C<:Arg> attribute. Available Types are: =over =item 'scalar' Permits anything that is not a reference. =item 'numeric' Can also be specified as C or C. This uses L to test the input value. =item 'list' or 'array' =item 'list(_subtype_)' or 'array(_subtype_)' This type permits an accessor to accept multiple values (which are then placed in an array ref) or a single array ref. For object initialization parameters, it permits a single value (which is then placed in an array ref) or an array ref. When specified, the contents of the resulting array ref are checked against the specified subtype: =over =item 'scalar' Same as for the basic type above. =item 'numeric' Same as for the basic type above. =item A class name Same as for the basic type below. =item A reference type Any reference type (in all caps) as returned by L). =back =item 'ARRAY_ref' =item 'ARRAY_ref(_subtype_)' This specifies that only a single array reference is permitted. Can also be specified as C. When specified, the contents of the array ref are checked against the specified subtype as per the above. =item 'HASH' This type permits an accessor to accept multiple S value>> pairs (which are then placed in a hash ref) or a single hash ref. For object initialization parameters, only a single ref is permitted. =item 'HASH_ref' This specifies that only a single hash reference is permitted. Can also be specified as C. =item 'SCALAR_ref' This type permits an accessor to accept a single scalar reference. Can also be specified as C. =item A class name This permits only an object of the specified class, or one of its sub-classes (i.e., type checking is done using C<-Eisa()>). For example, C. The class name C permits any object. The class name C permits any object generated by an Object::InsideOut class. =item Other reference type This permits only a reference of the specified type (as returned by L). The type must be specified in all caps. For example, C. =back The C<:Type> attribute can also be supplied with a code reference to provide custom type checking. The code ref may either be in the form of an anonymous subroutine, or a fully-qualified subroutine name. The result of executing the code ref on the input argument should be a boolean value. Here's some examples: package My::Class; { use Object::InsideOut; # Type checking using an anonymous subroutine # (This checks that the argument is an object) my @data :Field :Type(sub { Scalar::Util::blessed($_[0]) }) :Acc(data); # Type checking using a fully-qualified subroutine name my @num :Field :Type(\&My::Class::positive) :Acc(num); # The type checking subroutine may be made 'Private' sub positive :Private { return (Scalar::Util::looks_like_number($_[0]) && ($_[0] > 0)); } } =head2 Type Checking on C<:Init> Parameters For object initialization parameters that are sent to the C<:Init> subroutine during object initialization, the parameter's type can be specified in the C<:InitArgs> hash for that parameter using the same types as specified in the previous section. For example: my %init_args :InitArgs = ( 'COUNT' => { 'Type' => 'numeric', }, 'OBJS' => { 'Type' => 'list(My::Class)', }, ); One exception involves custom type checking: If referenced in an C<:InitArgs> hash, the type checking subroutine cannot be made C<:Private>: package My::Class; { use Object::InsideOut; sub check_type # Cannot be :Private { ... } my %init_args :InitArgs = ( 'ARG' => { 'Type' => \&check_type, }, ); ... } Also, as shown, it also doesn't have to be a fully-qualified name. =head1 CUMULATIVE METHODS Normally, methods with the same name in a class hierarchy are masked (i.e., overridden) by inheritance - only the method in the most-derived class is called. With cumulative methods, this masking is removed, and the same-named method is called in each of the classes within the hierarchy. The return results from each call (if any) are then gathered together into the return value for the original method call. For example, package My::Class; { use Object::InsideOut; sub what_am_i :Cumulative { my $self = shift; my $ima = (ref($self) eq __PACKAGE__) ? q/I was created as a / : q/My top class is /; return ($ima . __PACKAGE__); } } package My::Foo; { use Object::InsideOut 'My::Class'; sub what_am_i :Cumulative { my $self = shift; my $ima = (ref($self) eq __PACKAGE__) ? q/I was created as a / : q/I'm also a /; return ($ima . __PACKAGE__); } } package My::Child; { use Object::InsideOut 'My::Foo'; sub what_am_i :Cumulative { my $self = shift; my $ima = (ref($self) eq __PACKAGE__) ? q/I was created as a / : q/I'm in class /; return ($ima . __PACKAGE__); } } package main; my $obj = My::Child->new(); my @desc = $obj->what_am_i(); print(join("\n", @desc), "\n"); produces: My top class is My::Class I'm also a My::Foo I was created as a My::Child When called in a list context (as in the above), the return results of cumulative methods are accumulated, and returned as a list. In a scalar context, a results object is returned that segregates the results by class for each of the cumulative method calls. Through overloading, this object can then be dereferenced as an array, hash, string, number, or boolean. For example, the above could be rewritten as: my $obj = My::Child->new(); my $desc = $obj->what_am_i(); # Results object print(join("\n", @{$desc}), "\n"); # Dereference as an array The following uses hash dereferencing: my $obj = My::Child->new(); my $desc = $obj->what_am_i(); while (my ($class, $value) = each(%{$desc})) { print("Class $class reports:\n\t$value\n"); } and produces: Class My::Class reports: My top class is My::Class Class My::Child reports: I was created as a My::Child Class My::Foo reports: I'm also a My::Foo As illustrated above, cumulative methods are tagged with the C<:Cumulative> attribute (or S>), and propagate from the I through the class hierarchy (i.e., from the parent classes down through the child classes). If tagged with S>, they will propagated from the object's class upward through the parent classes. =head1 CHAINED METHODS In addition to C<:Cumulative>, Object::InsideOut provides a way of creating methods that are chained together so that their return values are passed as input arguments to other similarly named methods in the same class hierarchy. In this way, the chained methods act as though they were I together. For example, imagine you had a method called C that formats some text for display: package Subscriber; { use Object::InsideOut; sub format_name { my ($self, $name) = @_; # Strip leading and trailing whitespace $name =~ s/^\s+//; $name =~ s/\s+$//; return ($name); } } And elsewhere you have a second class that formats the case of names: package Person; { use Lingua::EN::NameCase qw(nc); use Object::InsideOut; sub format_name { my ($self, $name) = @_; # Attempt to properly case names return (nc($name)); } } And you decide that you'd like to perform some formatting of your own, and then have all the parent methods apply their own formatting. Normally, if you have a single parent class, you'd just call the method directly with C<$self-ESUPER::format_name($name)>, but if you have more than one parent class you'd have to explicitly call each method directly: package Customer; { use Object::InsideOut qw(Person Subscriber); sub format_name { my ($self, $name) = @_; # Compress all whitespace into a single space $name =~ s/\s+/ /g; $name = $self->Subscriber::format_name($name); $name = $self->Person::format_name($name); return $name; } } With Object::InsideOut, you'd add the C<:Chained> attribute to each class's C method, and the methods will be chained together automatically: package Subscriber; { use Object::InsideOut; sub format_name :Chained { my ($self, $name) = @_; # Strip leading and trailing whitespace $name =~ s/^\s+//; $name =~ s/\s+$//; return ($name); } } package Person; { use Lingua::EN::NameCase qw(nc); use Object::InsideOut; sub format_name :Chained { my ($self, $name) = @_; # Attempt to properly case names return (nc($name)); } } package Customer; { use Object::InsideOut qw(Person Subscriber); sub format_name :Chained { my ($self, $name) = @_; # Compress all whitespace into a single space $name =~ s/\s+/ /g; return ($name); } } So passing in someone's name to C in C would cause leading and trailing whitespace to be removed, then the name to be properly cased, and finally whitespace to be compressed to a single space. The resulting C<$name> would be returned to the caller: my ($name) = $obj->format_name($name_raw); Unlike C<:Cumulative> methods, C<:Chained> methods B returns an array - even if there is only one value returned. Therefore, C<:Chained> methods should always be called in an array context, as illustrated above. The default direction is to chain methods from the parent classes at the top of the class hierarchy down through the child classes. You may use the attribute S> to make this more explicit. If you label the method with the S> attribute, then the chained methods are called starting with the object's class and working upward through the parent classes in the class hierarchy, similar to how S> works. =head1 ARGUMENT MERGING As mentioned under L<"Object Creation">, the C<-Enew()> method can take parameters that are passed in as combinations of S value>> pairs and/or hash refs: my $obj = My::Class->new( 'param_X' => 'value_X', 'param_Y' => 'value_Y', { 'param_A' => 'value_A', 'param_B' => 'value_B', }, { 'param_Q' => 'value_Q', }, ); The parameters are I into a single hash ref before they are processed. Adding the C<:MergeArgs> attribute to your methods gives them a similar capability. Your method will then get two arguments: The object and a single hash ref of the I arguments. For example: package Foo; { use Object::InsideOut; ... sub my_method :MergeArgs { my ($self, $args) = @_; my $param = $args->{'param'}; my $data = $args->{'data'}; my $flag = $args->{'flag'}; ... } } package main; my $obj = Foo->new(...); $obj->my_method( { 'data' => 42, 'flag' => 'true' }, 'param' => 'foo' ); =head1 ARGUMENT VALIDATION A number of users have asked about argument validation for methods: L. For this, I recommend using L: package Foo; { use Object::InsideOut; use Params::Validate ':all'; sub foo { my $self = shift; my %args = validate(@_, { bar => 1 }); my $bar = $args{bar}; ... } } Using L, attributes are used for argument validation specifications: package Foo; { use Object::InsideOut; use Attribute::Params::Validate; sub foo :method :Validate(bar => 1) { my $self = shift; my %args = @_; my $bar = $args{bar}; ... } } Note that in the above, Perl's C<:method> attribute (in all lowercase) is needed. There is some incompatibility between Attribute::Params::Validate and some of Object::InsideOut's attributes. Namely, you cannot use C<:Validate> with C<:Private>, C<:Restricted>, C<:Cumulative>, C<:Chained> or C<:MergeArgs>. In these cases, use the C function from L instead. =head1 AUTOMETHODS There are significant issues related to Perl's C mechanism that cause it to be ill-suited for use in a class hierarchy. Therefore, Object::InsideOut implements its own C<:Automethod> mechanism to overcome these problems. Classes requiring C-type capabilities must provided a subroutine labeled with the C<:Automethod> attribute. The C<:Automethod> subroutine will be called with the object and the arguments in the original method call (the same as for C). The C<:Automethod> subroutine should return either a subroutine reference that implements the requested method's functionality, or else just end with C to indicate that it doesn't know how to handle the request. Using its own C subroutine (which is exported to every class), Object::InsideOut walks through the class tree, calling each C<:Automethod> subroutine, as needed, to fulfill an unimplemented method call. The name of the method being called is passed as C<$_> instead of C<$AUTOLOAD>, and is I prefixed with the class name. If the C<:Automethod> subroutine also needs to access the C<$_> from the caller's scope, it is available as C<$CALLER::_>. Automethods can also be made to act as L or L. In these cases, the C<:Automethod> subroutine should return two values: The subroutine ref to handle the method call, and a string designating the type of method. The designator has the same form as the attributes used to designate C<:Cumulative> and C<:Chained> methods: ':Cumulative' or ':Cumulative(top down)' ':Cumulative(bottom up)' ':Chained' or ':Chained(top down)' ':Chained(bottom up)' The following skeletal code illustrates how an C<:Automethod> subroutine could be structured: sub _automethod :Automethod { my $self = shift; my @args = @_; my $method_name = $_; # This class can handle the method directly if (...) { my $handler = sub { my $self = shift; ... return ...; }; ### OPTIONAL ### # Install the handler so it gets called directly next time # no strict refs; # *{__PACKAGE__.'::'.$method_name} = $handler; ################ return ($handler); } # This class can handle the method as part of a chain if (...) { my $chained_handler = sub { my $self = shift; ... return ...; }; return ($chained_handler, ':Chained'); } # This class cannot handle the method request return; } Note: The I code above for installing the generated handler as a method should not be used with C<:Cumulative> or C<:Chained> automethods. =head1 OBJECT SERIALIZATION =head2 Basic Serialization =over =item my $array_ref = $obj->dump(); =item my $string = $obj->dump(1); Object::InsideOut exports a method called C<-Edump()> to each class that returns either a I or a string representation of the object that invokes the method. The I representation is returned when C<-Edump()> is called without arguments. It consists of an array ref whose first element is the name of the object's class, and whose second element is a hash ref containing the object's data. The object data hash ref contains keys for each of the classes that make up the object's hierarchy. The values for those keys are hash refs containing S value>> pairs for the object's fields. For example: [ 'My::Class::Sub', { 'My::Class' => { 'data' => 'value' }, 'My::Class::Sub' => { 'life' => 42 } } ] The name for an object field (I and I in the example above) can be specified by adding the C<:Name> attribute to the field: my @life :Field :Name(life); If the C<:Name> attribute is not used, then the name for a field will be either the name associated with an C<:All> or C<:Arg> attribute, its I method name, its I method name, or, failing all that, a string of the form C or C. When called with a I argument, C<-Edump()> returns a string version of the I representation using L. Note that using L directly on an inside-out object will not produce the desired results (it'll just output the contents of the scalar ref). Also, if inside-out objects are stored inside other structures, a dump of those structures will not contain the contents of the object's fields. In the event of a method naming conflict, the C<-Edump()> method can be called using its fully-qualified name: my $dump = $obj->Object::InsideOut::dump(); =item my $obj = Object::InsideOut->pump($data); Cpump()> takes the output from the C<-Edump()> method, and returns an object that is created using that data. If C<$data> is the array ref returned by using C<$obj-Edump()>, then the data is inserted directly into the corresponding fields for each class in the object's class hierarchy. If C<$data> is the string returned by using C<$obj-Edump(1)>, then it is Ced to turn it into an array ref, and then processed as above. B: If any of an object's fields are dumped to field name keys of the form C or C (see above), then the data will not be reloadable using Cpump()>. To overcome this problem, the class developer must either add C<:Name> attributes to the C<:Field> declarations (see above), or provide a C<:Dumper>/C<:Pumper> pair of subroutines as described below. Dynamically altering a class (e.g., using L<-Ecreate_field()|/"DYNAMIC FIELD CREATION">) after objects have been dumped will result in C fields when pumped back in regardless of whether or not the added fields have defaults. Modifying the output from C<-Edump()>, and then feeding it into Cpump()> will work, but is not specifically supported. If you know what you're doing, fine, but you're on your own. =item C<:Dumper> Subroutine Attribute If a class requires special processing to dump its data, then it can provide a subroutine labeled with the C<:Dumper> attribute. This subroutine will be sent the object that is being dumped. It may then return any type of scalar the developer deems appropriate. Usually, this would be a hash ref containing S value>> pairs for the object's fields. For example: my @data :Field; sub _dump :Dumper { my $obj = $_[0]; my %field_data; $field_data{'data'} = $data[$$obj]; return (\%field_data); } Just be sure not to call your C<:Dumper> subroutine C as that is the name of the dump method exported by Object::InsideOut as explained above. =item C<:Pumper> Subroutine Attribute If a class supplies a C<:Dumper> subroutine, it will most likely need to provide a complementary C<:Pumper> labeled subroutine that will be used as part of creating an object from dumped data using Cpump()>. The subroutine will be supplied the new object that is being created, and whatever scalar was returned by the C<:Dumper> subroutine. The corresponding C<:Pumper> for the example C<:Dumper> above would be: sub _pump :Pumper { my ($obj, $field_data) = @_; $obj->set(\@data, $field_data->{'data'}); } =back =head2 Storable Object::InsideOut also supports object serialization using the L module. There are two methods for specifying that a class can be serialized using L. The first method involves adding L to the Object::InsideOut declaration in your package: package My::Class; { use Object::InsideOut qw(Storable); ... } and adding S> in your application. Then you can use the C<-Estore()> and C<-Efreeze()> methods to serialize your objects, and the C and C subroutines to de-serialize them. package main; use Storable; use My::Class; my $obj = My::Class->new(...); $obj->store('/tmp/object.dat'); ... my $obj2 = retrieve('/tmp/object.dat'); The other method of specifying L serialization involves setting a S> variable inside a C block for the class prior to its use: package main; use Storable; BEGIN { $My::Class::storable = 1; } use My::Class; NOTE: The I discussed above for the C<-Epump()> method are also applicable when using the Storable module. =head1 OBJECT COERCION Object::InsideOut provides support for various forms of object coercion through the L mechanism. For instance, if you want an object to be usable directly in a string, you would supply a subroutine in your class labeled with the C<:Stringify> attribute: sub as_string :Stringify { my $self = $_[0]; my $string = ...; return ($string); } Then you could do things like: print("The object says, '$obj'\n"); For a boolean context, you would supply: sub as_bool :Boolify { my $self = $_[0]; my $true_or_false = ...; return ($true_or_false); } and use it in this manner: if (! defined($obj)) { # The object is undefined .... } elsif (! $obj) { # The object returned a false value ... } The following coercion attributes are supported: =over =item :Stringify =item :Numerify =item :Boolify =item :Arrayify =item :Hashify =item :Globify =item :Codify =back Coercing an object to a scalar (C<:Scalarify>) is B supported as C<$$obj> is the ID of the object and cannot be overridden. =head1 CLONING =head2 Object Cloning Copies of objects can be created using the C<-Eclone()> method which is exported by Object::InsideOut to each class: my $obj2 = $obj->clone(); When called without arguments, C<-Eclone()> creates a I copy of the object, meaning that any complex data structures (i.e., array, hash or scalar refs) stored in the object will be shared with its clone. Calling C<-Eclone()> with a I argument: my $obj2 = $obj->clone(1); creates a I copy of the object such that internally held array, hash or scalar refs are I and stored in the newly created clone. I cloning can also be controlled at the field level, and is covered in the next section. Note that cloning does not clone internally held objects. For example, if C<$foo> contains a reference to C<$bar>, a clone of C<$foo> will also contain a reference to C<$bar>; not a clone of C<$bar>. If such behavior is needed, it must be provided using a L<:Replicate|/"Object Replication"> subroutine. =head2 Field Cloning Object cloning can be controlled at the field level such that specified fields are I copied when C<-Eclone()> is called without any arguments. This is done by adding the C<:Deep> attribute to the field: my @data :Field :Deep; =head1 WEAK FIELDS Frequently, it is useful to store Led references to data or objects in a field. Such a field can be declared as C<:Weak> so that data (i.e., references) set via Object::InsideOut generated accessors, parameter processing using C<:Arg>, the C<-Eset()> method, etc., will automatically be Led after being stored in the field array/hash. my @data :Field :Weak; NOTE: If data in a I field is set directly (i.e., the C<-Eset()> method is not used), then L must be invoked on the stored reference afterwards: $self->set(\@field, $data); Scalar::Util::weaken($field[$$self]); (This is another reason why the C<-Eset()> method is recommended for setting field data within class code.) =head1 DYNAMIC FIELD CREATION Normally, object fields are declared as part of the class code. However, some classes may need the capability to create object fields I, for example, as part of an C<:Automethod>. Object::InsideOut provides a class method for this: # Dynamically create a hash field with standard accessors My::Class->create_field('%'.$fld, ":Std($fld)"); The first argument is the class into which the field will be added. The second argument is a string containing the name of the field preceded by either a C<@> or C<%> to declare an array field or hash field, respectively. The remaining string arguments should be attributes declaring accessors and the like. The C<:Field> attribute is assumed, and does not need to be added to the attribute list. For example: My::Class->create_field('@data', ":Type(numeric)", ":Acc(data)"); My::Class->create_field('@obj', ":Type(Some::Class)", ":Acc(obj)", ":Weak"); Field creation will fail if you try to create an array field within a class whose hierarchy has been declared L<:hash_only|/"HASH ONLY CLASSES">. Here's an example of an C<:Automethod> subroutine that uses dynamic field creation: package My::Class; { use Object::InsideOut; sub _automethod :Automethod { my $self = $_[0]; my $class = ref($self) || $self; my $method = $_; # Extract desired field name from get_/set_ method name my ($fld_name) = $method =~ /^[gs]et_(.*)$/; if (! $fld_name) { return; # Not a recognized method } # Create the field and its standard accessors $class->create_field('@'.$fld_name, ":Std($fld_name)"); # Return code ref for newly created accessor no strict 'refs'; return *{$class.'::'.$method}{'CODE'}; } } =head1 RUNTIME INHERITANCE The class method C<-Eadd_class()> provides the capability to dynamically add classes to a class hierarchy at runtime. For example, suppose you had a simple I class: package Trait::State; { use Object::InsideOut; my %state :Field :Set(state); } This could be added to another class at runtime using: My::Class->add_class('Trait::State'); This permits, for example, application code to dynamically modify a class without having it create an actual sub-class. =head1 PREPROCESSING =head2 Parameter Preprocessing You can specify a code ref (either in the form of an anonymous subroutine, or a subroutine name) for an object initialization parameter that will be called on that parameter prior to taking any of the other parameter actions described above. Here's an example: package My::Class; { use Object::InsideOut; # The parameter preprocessing subroutine sub preproc { my ($class, $param, $spec, $obj, $value) = @_; # Preform parameter preprocessing ... # Return result return ...; } my @data :Field :Arg('Name' => 'DATA', 'Preprocess' => \&My::Class::preproc); my %init_args :InitArgs = ( 'PARAM' => { 'Preprocess' => \&preproc, }, ); ... } When used in the C<:Arg> attribute, the subroutine name must be fully-qualified, as illustrated. Further, if not referenced in the C<:InitArgs> hash, the preprocessing subroutine can be given the C<:Private> attribute. As the above illustrates, the parameter preprocessing subroutine is sent five arguments: =over =item * The name of the class associated with the parameter This would be C in the example above. =item * The name of the parameter Either C or C in the example above. =item * A hash ref of the parameter's specifiers This is either a hash ref containing the C<:Arg> attribute parameters, or the hash ref paired to the parameter's key in the C<:InitArgs> hash. =item * The object being initialized =item * The parameter's value This is the value assigned to the parameter in the C<-Enew()> method's argument list. If the parameter was not provided to C<-Enew()>, then C will be sent. =back The return value of the preprocessing subroutine will then be assigned to the parameter. Be careful about what types of data the preprocessing subroutine tries to make use of C to the arguments supplied. For instance, because the order of parameter processing is not specified, the preprocessing subroutine cannot rely on whether or not some other parameter is set. Such processing would need to be done in the C<:Init> subroutine. It can, however, make use of object data set by classes I in the class hierarchy. (That is why the object is provided as one of the arguments.) Possible uses for parameter preprocessing include: =over =item * Overriding the supplied value (or even deleting it by returning C) =item * Providing a dynamically-determined default value =back I may be abbreviated to I or I
.

=head2 I Accessor Preprocessing

You can specify a code ref (either in the form of an anonymous subroutine, or
a fully-qualified subroutine name) for a I accessor that will be
called on the arguments supplied to the accessor prior to its taking the usual
actions of type checking and adding the data to the field.  Here's an example:

 package My::Class; {
     use Object::InsideOut;

     my @data :Field
              :Acc('Name' => 'data', 'Preprocess' => \&My::Class::preproc);

     # The set accessor preprocessing subroutine may be made 'Private'
     sub preproc :Private
     {
         my ($self, $field, @args) = @_;

         # Preform preprocessing on the accessor's arguments
         ...

         # Return result
         return ...;
     }
 }

As the above illustrates, the accessor preprocessing subroutine is sent the
following arguments:

=over

=item * The object used to invoke the accessor

=item * A reference to the field associated with the accessor

=item * The argument(s) sent to the accessor

There will always be at least one argument.

=back

Usually, the preprocessing subroutine would return just a single value.  For
fields declared as type C, multiple values may be returned.

Following preprocessing, the I accessor will operate on whatever value(s)
are returned by the preprocessing subroutine.

=head1 SPECIAL PROCESSING

=head2 Object ID

By default, the ID of an object is derived from a sequence counter for the
object's class hierarchy.  This should suffice for nearly all cases of class
development.  If there is a special need for the module code to control the
object ID (see L as an example), then a
subroutine labelled with the C<:ID> attribute can be specified:

 sub _id :ID
 {
     my $class = $_[0];

     # Generate/determine a unique object ID
     ...

     return ($id);
 }

The ID returned by your subroutine can be any kind of I scalar (e.g.,
a string or a number).  However, if the ID is something other than a
low-valued integer, then you will have to architect B your classes using
hashes for the object fields.  See L for details.

Within any class hierarchy, only one class may specify an C<:ID> subroutine.

=head2 Object Replication

Object replication occurs explicitly when the C<-Eclone()> method is
called on an object, and implicitly when threads are created in a threaded
application.  In nearly all cases, Object::InsideOut will take care of all the
details for you.

In rare cases, a class may require special handling for object replication.
It must then provide a subroutine labeled with the C<:Replicate> attribute.
This subroutine will be sent three arguments:  The parent and the cloned
objects, and a flag:

 sub _replicate :Replicate
 {
     my ($parent, $clone, $flag) = @_;

     # Special object replication processing
     if ($clone eq 'CLONE') {
        # Handling for thread cloning
        ...
     } elsif ($clone eq 'deep') {
        # Deep copy of the parent
        ...
     } else {
        # Shallow copying
        ...
     }
 }

In the case of thread cloning, C<$flag> will be set to the C<'CLONE'>, and the
C<$parent> object is just a non-blessed anonymous scalar reference that
contains the ID for the object in the parent thread.

When invoked via the C<-Eclone()> method, C<$flag> will be either an empty
string which denotes that a I copy is being produced for the clone,
or C<$flag> will be set to C<'deep'> indicating a I copy is being
produced.

The C<:Replicate> subroutine only needs to deal with the special replication
processing needed by the object:  Object::InsideOut will handle all the other
details.

=head2 Object Destruction

Object::InsideOut exports a C method to each class that deletes an
object's data from the object field arrays (hashes).  If a class requires
additional destruction processing (e.g., closing filehandles), then it must
provide a subroutine labeled with the C<:Destroy> attribute.  This subroutine
will be sent the object that is being destroyed:

 sub _destroy :Destroy
 {
     my $obj = $_[0];

     # Special object destruction processing
 }

The C<:Destroy> subroutine only needs to deal with the special destruction
processing:  The C method will handle all the other details of object
destruction.

=head1 FOREIGN CLASS INHERITANCE

Object::InsideOut supports inheritance from foreign (i.e.,
non-Object::InsideOut) classes.  This means that your classes can inherit from
other Perl class, and access their methods from your own objects.

One method of declaring foreign class inheritance is to add the class name to
the Object::InsideOut declaration inside your package:

 package My::Class; {
     use Object::InsideOut qw(Foreign::Class);
     ...
 }

This allows you to access the foreign class's static (i.e., class) methods
from your own class.  For example, suppose C has a class
method called C.  With the above, you can access that method using
Cfoo()> instead.

Multiple foreign inheritance is supported, as well:

 package My::Class; {
     use Object::InsideOut qw(Foreign::Class Other::Foreign::Class);
     ...
 }

=over

=item $self->inherit($obj, ...);

To use object methods from foreign classes, an object must I from an
object of that class.  This would normally be done inside a class's C<:Init>
subroutine:

 package My::Class; {
     use Object::InsideOut qw(Foreign::Class);

     sub init :Init
     {
         my ($self, $args) = @_;

         my $foreign_obj = Foreign::Class->new(...);
         $self->inherit($foreign_obj);
     }
 }

Thus, with the above, if C has an object method called C,
you can call that method from your own objects:

 package main;

 my $obj = My::Class->new();
 $obj->bar();

Object::InsideOut's C subroutine handles the dispatching of the
C<-Ebar()> method call using the internally held inherited object (in this
case, C<$foreign_obj>).

Multiple inheritance is supported, as well:  You can call the
C<-Einherit()> method multiple times, or make just one call with all the
objects to be inherited from.

C<-Einherit()> is a restricted method.  In other words, you cannot use it
on an object outside of code belonging to the object's class tree (e.g., you
can't call it from application code).

In the event of a method naming conflict, the C<-Einherit()> method can be
called using its fully-qualified name:

 $self->Object::InsideOut::inherit($obj);

=item my @objs = $self->heritage();

=item my $obj = $self->heritage($class);

=item my @objs = $self->heritage($class1, $class2, ...);

Your class code can retrieve any inherited objects using the
C<-Eheritage()> method. When called without any arguments, it returns a
list of any objects that were stored by the calling class using the calling
object.  In other words, if class C uses object C<$obj> to store
foreign objects C<$fobj1> and C<$fobj2>, then later on in class C,
C<$obj-Eheritage()> will return C<$fobj1> and C<$fobj2>.

C<-Eheritage()> can also be called with one or more class name arguments.
In this case, only objects of the specified class(es) are returned.

In the event of a method naming conflict, the C<-Eheritage()> method can
be called using its fully-qualified name:

 my @objs = $self->Object::InsideOut::heritage();

=item $self->disinherit($class [, ...])

=item $self->disinherit($obj [, ...])

The C<-Edisinherit()> method disassociates (i.e., deletes) the inheritance
of foreign object(s) from an object.  The foreign objects may be specified by
class, or using the actual inherited object (retrieved via C<-Eheritage()>,
for example).

The call is only effective when called inside the class code that established
the initial inheritance.  In other words, if an inheritance is set up inside a
class, then disinheritance can only be done from inside that class.

In the event of a method naming conflict, the C<-Edisinherit()> method can
be called using its fully-qualified name:

 $self->Object::InsideOut::disinherit($obj [, ...])

=back

B:  With foreign inheritance, you only have access to class and object
methods.  The encapsulation of the inherited objects is strong, meaning that
only the class where the inheritance takes place has direct access to the
inherited object.  If access to the inherited objects themselves, or their
internal hash fields (in the case of I objects), is needed
outside the class, then you'll need to write your own accessors for that.

B:  You cannot use fully-qualified method names to access foreign
methods (when encapsulated foreign objects are involved).  Thus, the following
will not work:

 my $obj = My::Class->new();
 $obj->Foreign::Class::bar();

Normally, you shouldn't ever need to do the above:  C<$obj-Ebar()> would
suffice.

The only time this may be an issue is when the I class I an
inherited foreign class's method (e.g., C has its own
C<-Ebar()> method).  Such overridden methods are not directly callable.
If such overriding is intentional, then this should not be an issue:  No one
should be writing code that tries to by-pass the override.  However, if the
overriding is accidentally, then either the I method should be renamed,
or the I class should provide a wrapper method so that the
functionality of the overridden method is made available under a different
name.

=head2 C and Fully-qualified Method Names

The foreign inheritance methodology handled by the above is predicated on
non-Object::InsideOut classes that generate their own objects and expect their
object methods to be invoked via those objects.

There are exceptions to this rule:

=over

=item 1. Foreign object methods that expect to be invoked via the inheriting
class's object, or foreign object methods that don't care how they are invoked
(i.e., they don't make reference to the invoking object).

This is the case where a class provides auxiliary methods for your objects,
but from which you don't actually create any objects (i.e., there is no
corresponding foreign object, and C<$obj-Einherit($foreign)> is not used.)

In this case, you can either:

a. Declare the foreign class using the standard method (i.e.,
S>), and invoke its methods using
their full path (e.g., C<$obj-EForeign::Class::method();>); or

b. You can use the L pragma so that you don't have to use the full path
for foreign methods.

 package My::Class; {
     use Object::InsideOut;
     use base 'Foreign::Class';
     ...
 }

The former scheme is faster.

=item 2. Foreign class methods that expect to be invoked via the inheriting
class.

As with the above, you can either invoke the class methods using their full
path (e.g., CForeign::Class::method();>), or you can
S> so that you don't have to use the full path.  Again, using the
full path is faster.

L is an example of this type of class.

=item 3. Class methods that don't care how they are invoked (i.e., they don't
make reference to the invoking class).

In this case, you can either use
S> for consistency, or use
S> if (slightly) better performance is needed.

=back

If you're not familiar with the inner workings of the foreign class such that
you don't know if or which of the above exceptions applies, then the formulaic
approach would be to first use the documented method for foreign inheritance
(i.e., S>).  If that works, then
I strongly recommend that you just use that approach unless you have a good
reason not to.  If it doesn't work, then try S>.

=head1 INTROSPECTION

For Perl 5.8.0 and later, Object::InsideOut provides an introspection API that
allow you to obtain metadata on a class's hierarchy, constructor parameters,
and methods.

=over

=item my $meta = My::Class->meta();

=item my $meta = $obj->meta();

The C<-Emeta()> method, which is exported by Object::InsideOut to each
class, returns an L object which can then be
I for information about the invoking class or invoking object's
class:

 # Get an object's class hierarchy
 my @classes = $obj->meta()->get_classes();

 # Get info on the args for a class's constructor (i.e., ->new() parameters)
 my %args = My::Class->meta()->get_args();

 # Get info on the methods that can be called by an object
 my %methods = $obj->meta()->get_methods();

=item My::Class->isa();

=item $obj->isa();

When called in an array context, calling C<-Eisa()> without any arguments
on an Object::InsideOut class or object returns a list of the classes in the
class hierarchy for that class or object, and is equivalent to:

 my @classes = $obj->meta()->get_classes();

When called in a scalar context, it returns an array ref containing the
classes.

=item My::Class->can();

=item $obj->can();

When called in an array context, calling C<-Ecan()> without any arguments
on an Object::InsideOut class or object returns a list of the method names for
that class or object, and is equivalent to:

 my %methods = $obj->meta()->get_methods();
 my @methods = keys(%methods);

When called in a scalar context, it returns an array ref containing the
method names.

=back

See L for more details.

=head1 THREAD SUPPORT

For Perl 5.8.1 and later, Object::InsideOut fully supports L (i.e.,
is thread safe), and supports the sharing of Object::InsideOut objects between
threads using L.

To use Object::InsideOut in a threaded application, you must put
S> at the beginning of the application.  (The use of
S> after the program is running is not supported.)  If
object sharing is to be utilized, then S> should
follow.

If you just S>, then objects from one thread will be copied
and made available in a child thread.

The addition of S> in and of itself does not alter the
behavior of Object::InsideOut objects.  The default behavior is to I
share objects between threads (i.e., they act the same as with
S> alone).

To enable the sharing of objects between threads, you must specify which
classes will be involved with thread object sharing.  There are two methods
for doing this.  The first involves setting a C<::shared> variable (inside
a C block) for the class prior to its use:

 use threads;
 use threads::shared;

 BEGIN {
     $My::Class::shared = 1;
 }
 use My::Class;

The other method is for a class to add a C<:SHARED> flag to its
S> declaration:

 package My::Class; {
     use Object::InsideOut ':SHARED';
     ...
 }

When either sharing flag is set for one class in an object hierarchy, then all
the classes in the hierarchy are affected.

If a class cannot support thread object sharing (e.g., one of the object
fields contains code refs [which Perl cannot share between threads]), it
should specifically declare this fact:

 package My::Class; {
     use Object::InsideOut ':NOT_SHARED';
     ...
 }

However, you cannot mix thread object sharing classes with non-sharing
classes in the same class hierarchy:

 use threads;
 use threads::shared;

 package My::Class; {
     use Object::InsideOut ':SHARED';
     ...
 }

 package Other::Class; {
     use Object::InsideOut ':NOT_SHARED';
     ...
 }

 package My::Derived; {
     use Object::InsideOut qw(My::Class Other::Class);   # ERROR!
     ...
 }

Here is a complete example with thread object sharing enabled:

 use threads;
 use threads::shared;

 package My::Class; {
     use Object::InsideOut ':SHARED';

     # One list-type field
     my @data :Field :Type(list) :Acc(data);
 }

 package main;

 # New object
 my $obj = My::Class->new();

 # Set the object's 'data' field
 $obj->data(qw(foo bar baz));

 # Print out the object's data
 print(join(', ', @{$obj->data()}), "\n");       # "foo, bar, baz"

 # Create a thread and manipulate the object's data
 my $rc = threads->create(
         sub {
             # Read the object's data
             my $data = $obj->data();
             # Print out the object's data
             print(join(', ', @{$data}), "\n");  # "foo, bar, baz"
             # Change the object's data
             $obj->data(@$data[1..2], 'zooks');
             # Print out the object's modified data
             print(join(', ', @{$obj->data()}), "\n");  # "bar, baz, zooks"
             return (1);
         }
     )->join();

 # Show that changes in the object are visible in the parent thread
 # I.e., this shows that the object was indeed shared between threads
 print(join(', ', @{$obj->data()}), "\n");       # "bar, baz, zooks"

=head1 HASH ONLY CLASSES

For performance considerations, it is recommended that arrays be used for
class fields whenever possible.  The only time when hash-bases fields are
required is when a class must provide its own L, and
those IDs are something other than low-valued integers.  In this case, hashes
must be used for fields not only in the class that defines the object ID
subroutine, but also in every class in any class hierarchy that include such a
class.

The I requirement can be enforced by adding the C<:HASH_ONLY> flag
to a class's S> declaration:

 package My::Class; {
     use Object::InsideOut ':hash_only';

     ...
 }

This will cause Object::Inside to check every class in any class hierarchy
that includes such flagged classes to make sure their fields are hashes and
not arrays.  It will also fail any L<-Ecreate_field()|/"DYNAMIC FIELD
CREATION"> call that tries to create an array-based field in any such class.

=head1 SECURITY

In the default case where Object::InsideOut provides object IDs that are
sequential integers, it is possible to hack together a I
Object::InsideOut object, and so gain access to another object's data:

 my $fake = bless(\do{my $scalar}, 'Some::Class');
 $$fake = 86;   # ID of another object
 my $stolen = $fake->get_data();

Why anyone would try to do this is unknown.  How this could be used for any
sort of malicious exploitation is also unknown.  However, if preventing this
sort of security issue is a requirement, it can be accomplished by adding the
C<:SECURE> flag to a class's S> declaration:

 package My::Class; {
     use Object::InsideOut ':SECURE';

     ...
 }

This places the module C in the class hierarchy.
Object::InsideOut::Secure provides an L<:ID subroutine|/"Object ID"> that
generates random integers for object IDs, thus preventing other code from
being able to create fake objects by I at IDs.

Using C<:SECURE> mode requires L (v5.04 or later).

Because the object IDs used with C<:SECURE> mode are large random values,
the L<:HASH_ONLY|/"HASH ONLY CLASSES"> flag is forced on all the classes in
the hierarchy.

For efficiency, it is recommended that the C<:SECURE> flag be added to the
topmost class(es) in a hierarchy.

=head1 ATTRIBUTE HANDLERS

Object::InsideOut uses I as described in
L, and provides a mechanism
for adding attribute handlers to your own classes.  Instead of naming your
attribute handler as C, name it something else and then
label it with the C<:MODIFY_*_ATTRIBUTES> attribute (or C<:MOD_*_ATTRS> for
short).  Your handler should work just as described in
L with regard to its input
arguments, and must return a list of the attributes which were not recognized
by your handler.  Here's an example:

 package My::Class; {
     use Object::InsideOut;

     sub _scalar_attrs :MOD_SCALAR_ATTRS
     {
         my ($pkg, $scalar, @attrs) = @_;
         my @unused_attrs;         # List of any unhandled attributes

         while (my $attr = shift(@attrs)) {
             if ($attr =~ /.../) {
                 # Handle attribute
                 ...
             } else {
                 # We don't handle this attribute
                 push(@unused_attrs, $attr);
             }
         }

         return (@unused_attrs);   # Pass along unhandled attributes
     }
 }

Attribute 'modify' handlers are called I through the class hierarchy
(i.e., I).  This provides child classes with the capability to
I the handling of attributes by parent classes, or to add attributes
(via the returned list of unhandled attributes) for parent classes to process.

Attribute 'modify' handlers should be located at the beginning of a package,
or at least before any use of attributes on the corresponding type of variable
or subroutine:

 package My::Class; {
     use Object::InsideOut;

     sub _array_attrs :MOD_ARRAY_ATTRS
     {
        ...
     }

     my @my_array :MyArrayAttr;
 }

For I, follow the same procedures:  Label the
subroutine with the C<:FETCH_*_ATTRIBUTES> attribute (or C<:FETCH_*_ATTRS> for
short).  Contrary to the documentation in L, I receive B arguments:
The relevant package name, and a reference to a variable or subroutine for
which package-defined attributes are desired.

Attribute handlers are normal rendered L.

=head1 SPECIAL USAGE

=head2 Usage With C

It is possible to use L to export functions from one inside-out
object class to another:

 use strict;
 use warnings;

 package Foo; {
     use Object::InsideOut 'Exporter';
     BEGIN {
         our @EXPORT_OK = qw(foo_name);
     }

     sub foo_name
     {
         return (__PACKAGE__);
     }
 }

 package Bar; {
     use Object::InsideOut 'Foo' => [ qw(foo_name) ];

     sub get_foo_name
     {
         return (foo_name());
     }
 }

 package main;

 print("Bar got Foo's name as '", Bar::get_foo_name(), "'\n");

Note that the C block is needed to ensure that the L symbol
arrays (in this case C<@EXPORT_OK>) get populated properly.

=head2 Usage With C and C

Object::InsideOut usage under L and with runtime-loaded classes is
supported automatically; no special coding is required.

B:
Runtime loading of classes should be performed before any objects are created
within any of the classes in their hierarchies.  If Object::InsideOut cannot
create a hierarchy because of previously created objects (even if all those
objects have been destroyed), a runtime error will be generated.

=head2 Singleton Classes

A singleton class is a case where you would provide your own C<-Enew()>
method that in turn calls Object::InsideOut's C<-Enew()> method:

 package My::Class; {
     use Object::InsideOut;

     my $singleton;

     sub new {
         my $thing = shift;
         if (! $singleton) {
             $singleton = $thing->Object::InsideOut::new(@_);
         }
         return ($singleton);
     }
 }

=head1 DIAGNOSTICS

Object::InsideOut uses C for reporting errors.  The base
error class for this module is C.  Here is an example of the basic manner
for trapping and handling errors:

 my $obj;
 eval { $obj = My::Class->new(); };
 if (my $e = OIO->caught()) {
     warn('Failure creating object: '.$e);
     ...
 }

A more comprehensive approach might employ elements of the following:

 eval { ... };
 if (my $e = OIO->caught()) {
     # An error generated by Object::InsideOut
     ...
 } elsif (my $e = Exception::Class::Base->caught()) {
     # An error generated by other code that uses Exception::Class
     ...
 } elsif ($@) {
     # An unhandled error (i.e., generated by code that doesn't use
     # Exception::Class)
     ...
 }

I have tried to make the messages and information returned by the error
objects as informative as possible.  Suggested improvements are welcome.
Also, please bring to my attention any conditions that you encounter where an
error occurs as a result of Object::InsideOut code that doesn't generate an
Exception::Class object.  Here is one such error:

=over

=item Invalid ARRAY/HASH attribute

This error indicates you forgot C in your class's
code.

=back

Object::InsideOut installs a C<__DIE__> handler (see L
and L) to catch any errant exceptions from
class-specific code, namely, C<:Init>, C<:Replicate>, C<:Destroy>, etc.
subroutines.  When using C blocks inside these subroutines, you should
localize C<$SIG{'__DIE__'}> to keep Object::InsideOut's C<__DIE__> handler
from interfering with exceptions generated inside the C blocks.  For
example:

 sub _init :Init {
     ...
     eval {
         local $SIG{'__DIE__'};
         ...
     };
     if $@ {
         # Handle caught exception
     }
     ...
 }

Here's another example, where the C function is used as a method of flow
control for leaving an C block:

 eval {
     local $SIG{'__DIE__'};           # Suppress any existing __DIE__ handler
     ...
     die({'found' => 1}) if $found;   # Leave the eval block
     ...
 };
 if ($@) {
     die unless (ref($@) && $@->{'found'});   # Propagate any 'real' error
     # Handle 'found' case
     ...
 }
 # Handle 'not found' case

Similarly, if calling code from other modules that use the above flow control
mechanism, but without localizing C<$SIG{'__DIE__'}>, you can workaround this
deficiency with your own C block:

 eval {
     local $SIG{'__DIE__'};     # Suppress any existing __DIE__ handler
     Some::Module::func();      # Call function that fails to localize
 };
 if ($@) {
     # Handle caught exception
 }

In addition, you should file a bug report against the offending module along
with a patch that adds the missing S> statement.

=head1 BUGS AND LIMITATIONS

If you receive an error similar to this:

 ERROR: Attempt to DESTROY object ID 1 of class Foo twice

the cause may be that some module used by your application is doing
C somewhere in the background.  L is one such module.
The workaround is to add C at the start of your application.

Another cause of the above is returning a non-shared object from a thread
either explicitly or implicitly when the result of the last statement in the
thread subroutine is an object.  For example:

 sub thr_func {
     my $obj = MyClass->new();
 }

which is equivalent to:

 sub thr_func {
     return MyClass->new();
 }

This can be avoided by ensuring your thread subroutine ends with C.

The equality operator (e.g., C) is overloaded
for C<:SHARED> classes when L is loaded.  The L
subroutine compares object classes and IDs because references to the same
thread shared object may have different refaddrs.

You cannot overload an object to a scalar context (i.e., can't C<:SCALARIFY>).

You cannot use two instances of the same class with mixed thread object
sharing in same application.

Cannot use attributes on I (i.e., forward declaration
without later definition) with C<:Automethod>:

 package My::Class; {
     sub method :Private;   # Will not work

     sub _automethod :Automethod
     {
         # Code to handle call to 'method' stub
     }
 }

Due to limitations in the Perl parser, the entirety of any one attribute must
be on a single line.  (However, multiple attributes may appear on separate
lines.)

If a I accessor accepts scalars, then you can store any inside-out
object type in it.  If its C is set to C, then it can store any
I object.

Returning objects from threads does not work:

 my $obj = threads->create(sub { return (Foo->new()); })->join();  # BAD

Instead, use thread object sharing, create the object before launching the
thread, and then manipulate the object inside the thread:

 my $obj = Foo->new();   # Class 'Foo' is set ':SHARED'
 threads->create(sub { $obj->set_data('bar'); })->join();
 my $data = $obj->get_data();

Due to a limitation in L version 1.39 and earlier, if storing
shared objects inside other shared objects, you should use C to
remove them from internal fields (e.g., C) when
necessary so that the objects' destructor gets called.  Upgrading to version
1.40 or later alleviates most of this issue except during global destruction.
See L for more.

With Perl 5.8.8 and earlier, there are bugs associated with L
that may prevent you from storing objects inside of shared objects, or using
foreign inheritance with shared objects.  With Perl 5.8.9 (and later) together
with L 1.15 (and later), you can store shared objects inside
of other shared objects, and you can use foreign inheritance with shared
objects (provided the foreign class supports shared objects as well).

Due to internal complexities, the following actions are not supported in code
that uses L while there are any threads active:

=over

=item * Runtime loading of Object::InsideOut classes

=item * Using L<-Eadd_class()|/"RUNTIME INHERITANCE">

=back

It is recommended that such activities, if needed, be performed in the main
application code before any threads are created (or at least while there are
no active threads).

For Perl 5.6.0 through 5.8.0, a Perl bug prevents package variables (e.g.,
object attribute arrays/hashes) from being referenced properly from subroutine
refs returned by an C<:Automethod> subroutine.  For Perl 5.8.0 there is no
workaround:  This bug causes Perl to core dump.  For Perl 5.6.0 through 5.6.2,
the workaround is to create a ref to the required variable inside the
C<:Automethod> subroutine, and use that inside the subroutine ref:

 package My::Class; {
     use Object::InsideOut;

     my %data;

     sub auto :Automethod
     {
         my $self = $_[0];
         my $name = $_;

         my $data = \%data;      # Workaround for 5.6.X bug

         return sub {
                     my $self = shift;
                     if (! @_) {
                         return ($$data{$name});
                     }
                     $$data{$name} = shift;
                };
     }
 }

For Perl 5.8.1 through 5.8.4, a Perl bug produces spurious warning messages
when threads are destroyed.  These messages are innocuous, and can be
suppressed by adding the following to your application code:

 $SIG{'__WARN__'} = sub {
         if ($_[0] !~ /^Attempt to free unreferenced scalar/) {
             print(STDERR @_);
         }
     };

A better solution would be to upgrade L and L from
CPAN, especially if you encounter other problems associated with threads.

For Perl 5.8.4 and 5.8.5, the L feature does not work due to a
Perl bug.  Use Object::InsideOut v1.33 if needed.

Due to bugs in the Perl interpreter, using the introspection API (i.e.
C<-Emeta()>, etc.) requires Perl 5.8.0 or later.

The version of L that is available via PPM for ActivePerl is defective,
and causes failures when using C<:lvalue> accessors.  Remove it, and then
download and install the L module using CPAN.

L (used by L) makes use of the I
namespace.  As a consequence, Object::InsideOut thinks that S>
is already loaded.  Therefore, if you create a class called I that is
sub-classed by other packages, you may need to C it as follows:

 package DB::Sub; {
     require DB;
     use Object::InsideOut qw(DB);
     ...
 }

View existing bug reports at, and submit any new bugs, problems, patches, etc.
to: L

=head1 REQUIREMENTS

=over

=item Perl 5.6.0 or later

=item L v1.22 or later

=item L v1.10 or later

It is possible to install a I version of Scalar::Util, however, it
will be missing the L function which is
needed by Object::InsideOut.  You'll need to upgrade your version of
Scalar::Util to one that supports its C code.

=item L v0.50 or later

Needed for testing during installation.

=item L v0.12 or later

Optional.  Provides support for L.

=item L v5.04 or later)

Optional.  Provides support for L<:SECURE mode|/"SECURITY">.

=back

To cover all of the above requirements and more, it is recommended that you
install L using CPAN:

 perl -MCPAN -e 'install Bundle::Object::InsideOut'

This will install the latest versions of all the required and optional modules
needed for full support of all of the features provided by Object::InsideOut.

=head1 SEE ALSO

L on MetaCPAN:
L

Code repository:
L

Inside-out Object Model:
L,
L,
L,
L,
Chapters 15 and 16 of I by Damian Conway

L

L, L, L, L,
L, L

Sample code in the I directory of this distribution on CPAN.

=head1 ACKNOWLEDGEMENTS

Abigail Sperl AT abigail DOT nlE> for inside-out objects in general.

Damian Conway Sdconway AT cpan DOT orgE> for L, and for
delegator methods.

David A. Golden Sdagolden AT cpan DOT orgE> for thread handling for
inside-out objects.

Dan Kubb Sdan.kubb-cpan AT autopilotmarketing DOT comE> for
C<:Chained> methods.

=head1 AUTHOR

Jerry D. Hedden, Sjdhedden AT cpan DOT orgE>

=head1 COPYRIGHT AND LICENSE

Copyright 2005 - 2012 Jerry D. Hedden. All rights reserved.

This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.

=head1 TRANSLATIONS

A Japanese translation of this documentation by
TSUJII, Naofumi Stsun DOT nt AT gmail DOT comE>
is available at L.

=cut
Object-InsideOut-4.05/lib/Object/InsideOut.pm0000644000175000001440000032172313377136466020502 0ustar  jdheddenuserspackage Object::InsideOut; {

require 5.006;

use strict;
use warnings;
use Config;

our $VERSION = '4.05';
$VERSION = eval $VERSION;

use Object::InsideOut::Exception 4.05;
use Object::InsideOut::Util 4.05 qw(create_object hash_re is_it make_shared);
use Object::InsideOut::Metadata 4.05;

require B;

use Scalar::Util 1.10;
if (! Scalar::Util->can('weaken')) {
    OIO->Trace(0);
    OIO::Code->die(
        'message' => q/Cannot use 'pure perl' version of Scalar::Util - 'weaken' missing/,
        'Info'    => 'Upgrade/reinstall your version of Scalar::Util');
}


### Global Data ###

my %GBL;
if (! exists($GBL{'GBL_SET'})) {
    %GBL = (
        'GBL_SET' => 1,         # Control flag for initializing this hash

        %GBL,                   # Contains 'perm', 'merge', 'attr', 'meta'
                                #   from compilation phase

        init => 1,              # Initialization flag
        # term                  # Termination flag

        export => [             # Exported subroutines (i.e., @EXPORT)
            qw(new clone meta set DESTROY)
        ],

        tree => {               # Class trees
            td => {},           #  Top down
            bu => {},           #  Bottom up
        },

        asi => {},              # Reverse 'isa'

        id => {
            obj   => {},        # Object IDs
            reuse => {},        # Reclaimed obj IDs
        },

        fld => {
            ref  => {},         # :Field
            # new
            type => {},         # :Type
            weak => {},         # :Weak
            deep => {},         # :Deep
            def  => {},         # :Default

            regen => {          # Fix field keys during CLONE
                type => [],
                weak => [],
                deep => [],
            },
        },
        hash_only => {},        # :Hash_Only

        args      => {},        # :InitArgs

        sub => {
            id   => {},         # :ID
            init => {},         # :Init
            pre  => {},         # :PreInit
            repl => {},         # :Replicate
            dest => {},         # :Destroy
            auto => {},         # :Automethod
            # cumu              # :Cumulative
            # chain             # :Chained
            # ol                # :*ify (overload)
        },

        dump => {
            dumper => {},       # :Dumper
            pumper => {},       # :Pumper
            fld    => {},       # Field info
            args   => [],       # InitArgs info
        },

        heritage => {},         # Foreign class inheritance data

        # Currently executing thread
        tid => (($threads::threads) ? threads->tid() : 0),
        # pids                  # Pseudo-forks

        obj => {},              # Object registry for thread cloning

        share => {              # Object sharing between threads
            cl  => {},
            ok  => ($Config::Config{useithreads} && $threads::shared::threads_shared),
            # obj               # Tracks TIDs for shared objects
        },

        # cache                 # Object initialization activity cache
    );

    # Add metadata
    $GBL{'meta'}{'add'}{'Object::InsideOut'} = {
        'import'                 => {'hidden' => 1},
        'MODIFY_CODE_ATTRIBUTES' => {'hidden' => 1},
        'inherit'                => {'restricted' => 1},
        'disinherit'             => {'restricted' => 1},
        'heritage'               => {'restricted' => 1},
    };

    if ($Config::Config{useithreads} &&
        $threads::shared::threads_shared &&
        ($threads::shared::VERSION lt '0.96'))
    {
        *threads::shared::is_shared = \&threads::shared::_id;
    }
}


### Import ###

# Doesn't export anything - just builds class trees and handles module flags
sub import
{
    my $self = shift;      # Ourself (i.e., 'Object::InsideOut')
    if (Scalar::Util::blessed($self)) {
        OIO::Method->die('message' => q/'import' called as an object method/);
    }

    # Invoked via inheritance - ignore
    if ($self ne 'Object::InsideOut') {
        if (Exporter->can('import')) {
            my $lvl = $Exporter::ExportLevel;
            $Exporter::ExportLevel = (caller() eq 'Object::InsideOut') ? 3 : 1;
            $self->Exporter::import(@_);
            $Exporter::ExportLevel = $lvl;
        }
        return;
    }

    my $class = caller();   # The class that is using us
    if (! $class || $class eq 'main') {
        OIO::Code->die(
            'message' => q/'import' invoked from 'main'/,
            'Info'    => "Can't use 'use Object::InsideOut;' or 'Object::InsideOut->import();' inside application code");
    }

    no strict 'refs';

    # Check for class's global sharing flag
    # (normally set in the app's main code)
    if (defined(${$class.'::shared'})) {
        set_sharing($class, ${$class.'::shared'}, (caller())[1..2]);
    }

    # Check for class's global 'storable' flag
    # (normally set in the app's main code)
    {
        no warnings 'once';
        if (${$class.'::storable'}) {
            push(@_, 'Storable');
        }
    }

    # Import packages and handle :SHARED flag
    my @packages;
    while (my $pkg = shift) {
        next if (! $pkg);    # Ignore empty strings and such

        # Handle thread object sharing flag
        if ($pkg =~ /^:(NOT?_?|!)?SHAR/i) {
            my $sharing = (defined($1)) ? 0 : 1;
            set_sharing($class, $sharing, (caller())[1..2]);
            next;
        }

        # Handle hash fields only flag
        if ($pkg =~ /^:HASH/i) {
            $GBL{'hash_only'}{$class} = [ $class, (caller())[1,2] ];
            next;
        }

        # Restricted class
        if ($pkg =~ /^:RESTRICT(?:ED)?(?:\((.*)\))?/i) {
            *{$class.'::new'}
                = wrap_RESTRICTED($class, 'new',
                                  sub { goto &Object::InsideOut::new },
                                  [ grep {$_} split(/[,'\s]+/, $1 || '') ]);
            $GBL{'meta'}{'add'}{$class}{'new'} = { 'kind' => 'constructor',
                                                   'merge_args' => 1,
                                                   'restricted' => 1 };
            next;
        }

        # Private class
        if ($pkg =~ /^:PRIV(?:ATE)?(?:\((.*)\))?/i) {
            *{$class.'::new'}
                = wrap_PRIVATE($class, 'new',
                               sub { goto &Object::InsideOut::new },
                               [ $class, grep {$_} split(/[,'\s]+/, $1 || '') ]);
            $GBL{'meta'}{'add'}{$class}{'new'} = { 'kind' => 'constructor',
                                                   'merge_args' => 1,
                                                   'private' => 1 };
            next;
        }

        # Public class
        if ($pkg =~ /^:PUB/i) {
            *{$class.'::new'} = sub { goto &Object::InsideOut::new };
            $GBL{'meta'}{'add'}{$class}{'new'} = { 'kind' => 'constructor',
                                                   'merge_args' => 1 };
            next;
        }

        # Handle secure flag
        if ($pkg =~ /^:SECUR/i) {
            $pkg = 'Object::InsideOut::Secure';
        }

        # Load the package, if needed
        if (! $class->isa($pkg)) {
            # If no package symbols, then load it
            if (! grep { $_ !~ /::$/ } keys(%{$pkg.'::'})) {
                eval "require $pkg";
                if ($@) {
                    OIO::Code->die(
                        'message' => "Failure loading package '$pkg'",
                        'Error'   => $@);
                }
                # Empty packages make no sense
                if (! grep { $_ !~ /::$/ } keys(%{$pkg.'::'})) {
                    OIO::Code->die('message' => "Package '$pkg' is empty");
                }
            }

            # Add to package list
            push(@packages, $pkg);
        }


        # Import the package, if needed
        if (ref($_[0])) {
            my $imports = shift;
            if (ref($imports) ne 'ARRAY') {
                OIO::Code->die('message' => "Arguments to '$pkg' must be contained within an array reference: $imports");
            }
            eval { $pkg->import(@{$imports}); };
            if ($@) {
                OIO::Code->die(
                    'message' => "Failure running 'import' on package '$pkg'",
                    'Error'   => $@);
            }
        }
    }

    # Create class tree
    my @tree;
    my %seen;   # Used to prevent duplicate entries in @tree
    my $need_oio = 1;
    foreach my $parent (@packages) {
        if (exists($GBL{'tree'}{'td'}{$parent})) {
            # Inherit from Object::InsideOut class
            foreach my $ancestor (@{$GBL{'tree'}{'td'}{$parent}}) {
                if (! exists($seen{$ancestor})) {
                    push(@tree, $ancestor);
                    $GBL{'asi'}{$ancestor}{$class} = undef;
                    $seen{$ancestor} = undef;
                }
            }
            push(@{$class.'::ISA'}, $parent);
            $need_oio = 0;

        } else { # Inherit from foreign class
            # Get inheritance 'classes' hash
            if (! exists($GBL{'heritage'}{$class})) {
                create_heritage($class);
            }
            # Add parent to inherited classes
            $GBL{'heritage'}{$class}{'cl'}{$parent} = undef;
        }
    }

    # Add Object::InsideOut to class's @ISA array, if needed
    if ($need_oio) {
        push(@{$class.'::ISA'}, 'Object::InsideOut');
    }

    # Add calling class to tree
    if (! exists($seen{$class})) {
        push(@tree, $class);
    }

    # Save the trees
    $GBL{'tree'}{'td'}{$class} = \@tree;
    @{$GBL{'tree'}{'bu'}{$class}} = reverse(@tree);

    $GBL{'init'} = 1;   # Need to initialize
}


### Attribute Handling ###

# Handles subroutine attributes supported by this package.
# See 'perldoc attributes' for details.
sub MODIFY_CODE_ATTRIBUTES
{
    my ($pkg, $code, @attrs) = @_;

    # Call attribute handlers in the class tree
    if (exists($GBL{'attr'}{'MOD'}{'CODE'})) {
        @attrs = CHECK_ATTRS('CODE', $pkg, $code, @attrs);
        return if (! @attrs);
    }

    # Save caller info with code ref for error reporting purposes
    my %info = (
        pkg  => $pkg,
        code => $code,
        wrap => $code,
        loc  => [ $pkg, (caller(2))[1,2] ],
    );

    # Special handling for :Restricted :Cumulative/:Chained methods
    if ((my ($restrict) = grep(/^RESTRICT(?:ED)?$/i, @attrs))  &&
        (grep { ($_ =~ /^CUM(?:ULATIVE)?$/i) ||
                ($_ =~ /^CHAIN(?:ED)?$/i) } @attrs))
    {
        @attrs = grep { $_ !~ /^RESTRICT(?:ED)?$/i } @attrs;
        ($info{'exempt'}) = $restrict =~ /^RESTRICT(?:ED)?\((.*)\)/;
    }

    my @unused_attrs;   # List of any unhandled attributes

    # Save the code refs in the appropriate hashes
    while (my $attribute = shift(@attrs)) {
        my ($attr, $arg) = $attribute =~ /(\w+)(?:[(]\s*(.*)\s*[)])?/;
        $attr = uc($attr);

        if ($attr eq 'ID') {
            $GBL{'sub'}{'id'}{$pkg} = \%info;
            push(@attrs, $arg || 'HIDDEN');
            $GBL{'init'} = 1;

        } elsif ($attr eq 'PREINIT') {
            $GBL{'sub'}{'pre'}{$pkg} = $code;
            push(@attrs, $arg || 'HIDDEN');

        } elsif ($attr eq 'INIT') {
            $GBL{'sub'}{'init'}{$pkg} = $code;
            push(@attrs, $arg || 'HIDDEN');

        } elsif ($attr =~ /^REPL(?:ICATE)?$/) {
            $GBL{'sub'}{'repl'}{$pkg} = $code;
            push(@attrs, $arg || 'HIDDEN');

        } elsif ($attr =~ /^DEST(?:ROY)?$/) {
            $GBL{'sub'}{'dest'}{$pkg} = $code;
            push(@attrs, $arg || 'HIDDEN');

        } elsif ($attr =~ /^AUTO(?:METHOD)?$/) {
            $GBL{'sub'}{'auto'}{$pkg} = $code;
            push(@attrs, $arg || 'HIDDEN');
            $GBL{'init'} = 1;

        } elsif ($attr =~ /^CUM(?:ULATIVE)?$/) {
            push(@{$GBL{'sub'}{'cumu'}{'new'}{($arg && $arg =~ /BOTTOM/i) ? 'bu' : 'td'}}, \%info);
            $GBL{'init'} = 1;

        } elsif ($attr =~ /^CHAIN(?:ED)?$/) {
            push(@{$GBL{'sub'}{'chain'}{'new'}{($arg && $arg =~ /BOTTOM/i) ? 'bu' : 'td'}}, \%info);
            $GBL{'init'} = 1;

        } elsif ($attr =~ /^DUMP(?:ER)?$/) {
            $GBL{'dump'}{'dumper'}{$pkg} = $code;
            push(@attrs, $arg || 'HIDDEN');

        } elsif ($attr =~ /^PUMP(?:ER)?$/) {
            $GBL{'dump'}{'pumper'}{$pkg} = $code;
            push(@attrs, $arg || 'HIDDEN');

        } elsif ($attr =~ /^RESTRICT(?:ED)?$/) {
            $info{'exempt'} = $arg;
            push(@{$GBL{'perm'}{'restr'}}, \%info);
            $GBL{'init'} = 1;

        } elsif ($attr =~ /^PRIV(?:ATE)?$/) {
            $info{'exempt'} = $arg;
            push(@{$GBL{'perm'}{'priv'}}, \%info);
            $GBL{'init'} = 1;

        } elsif ($attr =~ /^HIDD?EN?$/) {
            push(@{$GBL{'perm'}{'hide'}}, \%info);
            $GBL{'init'} = 1;

        } elsif ($attr =~ /^SUB/) {
            push(@{$GBL{'meta'}{'subr'}}, \%info);
            if ($arg) {
                push(@attrs, $arg);
            }
            $GBL{'init'} = 1;

        } elsif ($attr =~ /^METHOD/ && $attribute ne 'method') {
            if ($arg) {
                $info{'kind'} = lc($arg);
                push(@{$GBL{'meta'}{'method'}}, \%info);
                $GBL{'init'} = 1;
            }

        } elsif ($attr =~ /^MERGE/) {
            push(@{$GBL{'merge'}}, \%info);
            if ($arg) {
                push(@attrs, $arg);
            }
            $GBL{'init'} = 1;

        } elsif ($attr =~ /^MOD(?:IFY)?_(ARRAY|CODE|HASH|SCALAR)_ATTR/) {
            install_ATTRIBUTES(\%GBL);
            $GBL{'attr'}{'MOD'}{$1}{$pkg} = $code;
            push(@attrs, $arg || 'HIDDEN');

        } elsif ($attr =~ /^FETCH_(ARRAY|CODE|HASH|SCALAR)_ATTR/) {
            install_ATTRIBUTES(\%GBL);
            push(@{$GBL{'attr'}{'FETCH'}{$1}}, $code);
            push(@attrs, $arg || 'HIDDEN');

        } elsif ($attr eq 'SCALARIFY') {
            OIO::Attribute->die(
                'message' => q/:SCALARIFY not allowed/,
                'Info'    => q/The scalar of an object is its object ID, and can't be redefined/,
                'ignore_package' => 'attributes');

        } elsif (my ($ify) = grep { $_ eq $attr } (qw(STRINGIFY
                                                      NUMERIFY
                                                      BOOLIFY
                                                      ARRAYIFY
                                                      HASHIFY
                                                      GLOBIFY
                                                      CODIFY)))
        {
            # Overload (-ify) attributes
            $info{'ify'} = $ify;
            push(@{$GBL{'sub'}{'ol'}}, \%info);
            $GBL{'init'} = 1;

        } elsif ($attr !~ /^PUB(LIC)?$/) {   # PUBLIC is ignored
            # Not handled
            push(@unused_attrs, $attribute);
        }
    }

    # If using Attribute::Handlers, send it any unused attributes
    if (@unused_attrs &&
        Attribute::Handlers::UNIVERSAL->can('MODIFY_CODE_ATTRIBUTES'))
    {
        return (Attribute::Handlers::UNIVERSAL::MODIFY_CODE_ATTRIBUTES($pkg, $code, @unused_attrs));
    }

    # Return any unused attributes
    return (@unused_attrs);
}

my $BALANCED_PARENS; # Must declare before assigning (so var in scope for regex)
$BALANCED_PARENS = qr{(?>(?:(?>[^()]+)|[(](??{$BALANCED_PARENS})[)])*)};

# Handles hash field and :InitArgs attributes.
sub MODIFY_HASH_ATTRIBUTES :Sub
{
    my ($pkg, $hash, @attrs) = @_;

    # Call attribute handlers in the class tree
    if (exists($GBL{'attr'}{'MOD'}{'HASH'})) {
        @attrs = CHECK_ATTRS('HASH', $pkg, $hash, @attrs);
        return if (! @attrs);
    }

    my @unused_attrs;   # List of any unhandled attributes

    # Process attributes
    foreach my $attr (@attrs) {
        # Declaration for object field hash
        if ($attr =~ /^(?:Field|[GS]et|Acc|Com|Mut|St(?:an)?d|LV(alue)?|All|R(?:ead)?O(?:nly)?|Arg|Type|Hand)/i) {
            # Save hash ref and attribute
            # Accessors will be built during initialization
            if ($attr =~ /^(?:Field|Type)/i) {
                unshift(@{$GBL{'fld'}{'new'}{$pkg}}, [ $hash, $attr ]);
            } else {
                push(@{$GBL{'fld'}{'new'}{$pkg}}, [ $hash, $attr ]);
            }
            $GBL{'init'} = 1;   # Flag that initialization is required
        }

        # Weak field
        elsif ($attr =~ /^Weak$/i) {
            $GBL{'fld'}{'weak'}{$hash} = 1;
            push(@{$GBL{'fld'}{'regen'}{'weak'}}, $hash);
        }

        # Deep cloning field
        elsif ($attr =~ /^Deep$/i) {
            $GBL{'fld'}{'deep'}{$hash} = 1;
            push(@{$GBL{'fld'}{'regen'}{'deep'}}, $hash);
        }

        # Defaults
        elsif ($attr =~ /^Def(?:ault)?[(]($BALANCED_PARENS)[)]$/i) {
            my $val;
            eval "package $pkg; use $]; \$val = sub { my \$self = \$_[0]; $1 }";
            if ($@) {
                OIO::Attribute->die(
                    'location'  => [ $pkg, (caller(2))[1,2] ],
                    'message'   => "Bad ':Default' attribute in package '$pkg'",
                    'Attribute' => $attr,
                    'Error'     => $@);
            }
            push(@{$GBL{'fld'}{'def'}{$pkg}}, [ $hash, $val ]);
        }

        # Sequentials
        elsif ($attr =~ /^Seq(?:uence)?(?:From)?[(]($BALANCED_PARENS)[)]$/i) {
            my $val = $1;
            eval qq{
                package $pkg;
                my \$next = $val;
                \$val = eval{ \$next->can('next') }
                        ? sub { \$next->next() }
                        : sub { \$next++ };
            };
            if ($@) {
                OIO::Attribute->die(
                    'location'  => [ $pkg, (caller(2))[1,2] ],
                    'message'   => "Bad ':SequenceFrom' attribute in package '$pkg'",
                    'Attribute' => $attr,
                    'Error'     => $@);
            }
            push(@{$GBL{'fld'}{'def'}{$pkg}}, [ $hash, $val ]);
        }

        # Field name for dump
        elsif ($attr =~ /^Name\s*[(]\s*'?([^)'\s]+)'?\s*[)]/i) {
            $GBL{'dump'}{'fld'}{$pkg}{$1} = { fld => $hash, src => 'Name' };
        }

        # Declaration for object initializer hash
        elsif ($attr =~ /^InitArgs?$/i) {
            $GBL{'args'}{$pkg} = $hash;
            push(@{$GBL{'dump'}{'args'}}, $pkg);
        }

        # Unhandled
        # (Must filter out ':shared' attribute due to Perl bug)
        elsif ($attr ne 'shared') {
            push(@unused_attrs, $attr);
        }
    }

    # If using Attribute::Handlers, send it any unused attributes
    if (@unused_attrs &&
        Attribute::Handlers::UNIVERSAL->can('MODIFY_HASH_ATTRIBUTES'))
    {
        return (Attribute::Handlers::UNIVERSAL::MODIFY_HASH_ATTRIBUTES($pkg, $hash, @unused_attrs));
    }

    # Return any unused attributes
    return (@unused_attrs);
}


# Handles array field attributes.
sub MODIFY_ARRAY_ATTRIBUTES :Sub
{
    my ($pkg, $array, @attrs) = @_;

    # Call attribute handlers in the class tree
    if (exists($GBL{'attr'}{'MOD'}{'ARRAY'})) {
        @attrs = CHECK_ATTRS('ARRAY', $pkg, $array, @attrs);
        return if (! @attrs);
    }

    my @unused_attrs;   # List of any unhandled attributes

    # Process attributes
    foreach my $attr (@attrs) {
        # Declaration for object field array
        if ($attr =~ /^(?:Field|[GS]et|Acc|Com|Mut|St(?:an)?d|LV(alue)?|All|R(?:ead)?O(?:nly)?|Arg|Type|Hand)/i) {
            # Save array ref and attribute
            # Accessors will be built during initialization
            if ($attr =~ /^(?:Field|Type)/i) {
                unshift(@{$GBL{'fld'}{'new'}{$pkg}}, [ $array, $attr ]);
            } else {
                push(@{$GBL{'fld'}{'new'}{$pkg}}, [ $array, $attr ]);
            }
            $GBL{'init'} = 1;   # Flag that initialization is required
        }

        # Weak field
        elsif ($attr =~ /^Weak$/i) {
            $GBL{'fld'}{'weak'}{$array} = 1;
            push(@{$GBL{'fld'}{'regen'}{'weak'}}, $array);
        }

        # Deep cloning field
        elsif ($attr =~ /^Deep$/i) {
            $GBL{'fld'}{'deep'}{$array} = 1;
            push(@{$GBL{'fld'}{'regen'}{'deep'}}, $array);
        }

        # Defaults
        elsif ($attr =~ /^Def(?:ault)?[(]($BALANCED_PARENS)[)]$/i) {
            my $val;
            eval "package $pkg; use $]; \$val = sub { my \$self = \$_[0]; $1 }";
            if ($@) {
                OIO::Attribute->die(
                    'location'  => [ $pkg, (caller(2))[1,2] ],
                    'message'   => "Bad ':Default' attribute in package '$pkg'",
                    'Attribute' => $attr,
                    'Error'     => $@);
            }
            push(@{$GBL{'fld'}{'def'}{$pkg}}, [ $array, $val ]);
        }

        # Sequentials
        elsif ($attr =~ /^Seq(?:uence)?(?:From)?[(]($BALANCED_PARENS)[)]$/i) {
            my $val = $1;
            eval qq{
                package $pkg;
                my \$next = $val;
                \$val = eval{ \$next->can('next') }
                        ? sub { \$next->next() }
                        : sub { \$next++ };
            };
            if ($@) {
                OIO::Attribute->die(
                    'location'  => [ $pkg, (caller(2))[1,2] ],
                    'message'   => "Bad ':SequenceFrom' attribute in package '$pkg'",
                    'Attribute' => $attr,
                    'Error'     => $@);
            }
            push(@{$GBL{'fld'}{'def'}{$pkg}}, [ $array, $val ]);
        }

        # Field name for dump
        elsif ($attr =~ /^Name\s*[(]\s*'?([^)'\s]+)'?\s*[)]/i) {
            $GBL{'dump'}{'fld'}{$pkg}{$1} = { fld => $array, src => 'Name' };
        }

        # Unhandled
        # (Must filter out ':shared' attribute due to Perl bug)
        elsif ($attr ne 'shared') {
            push(@unused_attrs, $attr);
        }
    }

    # If using Attribute::Handlers, send it any unused attributes
    if (@unused_attrs &&
        Attribute::Handlers::UNIVERSAL->can('MODIFY_ARRAY_ATTRIBUTES'))
    {
        return (Attribute::Handlers::UNIVERSAL::MODIFY_ARRAY_ATTRIBUTES($pkg, $array, @unused_attrs));
    }

    # Return any unused attributes
    return (@unused_attrs);
}


### Array-based Object Support ###

# Supplies an ID for an object being created in a class tree
# and reclaims IDs from destroyed objects
sub _ID :Sub
{
    return if $GBL{'term'};           # Ignore during global cleanup

    my ($class, $id) = @_;            # The object's class and id
    my $tree = $GBL{'sub'}{'id'}{$class}{'pkg'};


    # If class is sharing, then all ID tracking is done as though in thread 0,
    # else tracking is done per thread
    my $sharing = is_sharing($class);
    my $thread_id = ($sharing) ? 0 : $GBL{'tid'};

    # Save deleted IDs for later reuse
    my $reuse = $GBL{'id'}{'reuse'};
    if ($id) {
        if (! exists($$reuse{$tree})) {
            $$reuse{$tree} = ($sharing) ? make_shared([]) : [];
        }
        lock($$reuse{$tree}) if $sharing;
        my $r_tree = $$reuse{$tree};
        if (! defined($$r_tree[$thread_id])) {
            $$r_tree[$thread_id] = ($sharing) ? make_shared([]) : [];
        } else {
            foreach  (@{$$r_tree[$thread_id]}) {
                if ($_ == $id) {
                    warn("ERROR: Duplicate reclaimed object ID ($id) in class tree for $tree in thread $thread_id\n");
                    return;
                }
            }
        }
        push(@{$$r_tree[$thread_id]}, $id);
        return;
    }

    # Use a reclaimed ID if available
    if (exists($$reuse{$tree})) {
        lock($$reuse{$tree}) if $sharing;
        if (defined($$reuse{$tree}[$thread_id])) {
            my $id = pop(@{$$reuse{$tree}[$thread_id]});
            if (defined($id)) {
                return $id;
            }
        }
    }

    # Return the next ID
    my $g_id = $GBL{'id'}{'obj'};
    if (exists($$g_id{$tree})) {
        lock($$g_id{$tree}) if $sharing;
        return (++$$g_id{$tree}[$thread_id]);
    }
    if ($sharing) {
        $$g_id{$tree} = make_shared([]);
        lock($$g_id{$tree});
        return (++$$g_id{$tree}[$thread_id]);
    }
    $$g_id{$tree} = [];
    return (++$$g_id{$tree}[$thread_id]);
}


### Initialization Handling ###

# Finds a subroutine's name from its code ref
sub sub_name :Sub(Private)
{
    my ($ref, $attr, $location) = @_;

    my $name;
    eval { $name = B::svref_2object($ref)->GV()->NAME(); };
    if ($@) {
        OIO::Attribute->die(
            'location' => $location,
            'message'  => "Failure finding name for subroutine with $attr attribute",
            'Error'    => $@);

    } elsif ($name eq '__ANON__') {
        OIO::Attribute->die(
            'location' => $location,
            'message'  => q/Subroutine name not found/,
            'Info'     => "Can't use anonymous subroutine for $attr attribute");
    }

    return ($name);   # Found
}


# Perform much of the 'magic' for this module
sub initialize :Sub(Private)
{
    return if (! delete($GBL{'init'}));

    my $trees = $GBL{'tree'}{'td'};
    my $id_subs = $GBL{'sub'}{'id'};
    my $obj_ids = $GBL{'id'}{'obj'};

    no warnings 'redefine';
    no strict 'refs';

    # Determine classes that need ID subs
    # Purge existing references to the default ID sub (i.e., _ID)
    #   if no objects exist in that hierarchy
    my %need_id_sub;
    foreach my $class (keys(%{$trees})) {
        if (! exists($$id_subs{$class})) {
            $need_id_sub{$class} = undef;
        } elsif (($$id_subs{$class}{'code'} == \&_ID) &&
                 ! exists($$obj_ids{$$id_subs{$class}{'pkg'}}))
        {
            delete($$id_subs{$class});
            $need_id_sub{$class} = undef;
        }
    }

    # Get ID subs to propagate
    my %to_propagate;
    foreach my $class (keys(%{$id_subs})) {
        $to_propagate{$$id_subs{$class}{'pkg'}} = undef;
    }

    # Propagate ID subs to classes
    while (%need_id_sub) {
        # Get ID sub package
        my $pkg;
        if (%to_propagate) {
            ($pkg) = keys(%to_propagate);
            delete($to_propagate{$pkg});
        } else {
            (my $class) = keys(%need_id_sub);
            $pkg = $$trees{$class}[0];
            delete($need_id_sub{$pkg});
            if (! defined($pkg)) {
                # bug
                OIO::Internal->die(
                    'message' => "Class '$class' has empty tree",
                );
            }
            if (exists($$id_subs{$pkg})) {
                # bug
                OIO::Internal->die(
                    'message' => "ID sub for '$pkg' exists but was not propagated properly",
                );
            }
            $$id_subs{$pkg} = {
                pkg  => $pkg,
                code => \&_ID,
                loc  => [ '', 'Default :ID sub', 0 ],
            };
        }

        # Add ID sub to classes using package
        next if (! exists($GBL{'asi'}{$pkg}));
        my @propagate_to = keys(%{$GBL{'asi'}{$pkg}});
        my %seen = map { $_ => undef } @propagate_to;
        while (my $class = pop(@propagate_to)) {
            if (exists($$id_subs{$class})) {
                # Verify it's the same ID sub
                if (($$id_subs{$class}{'code'} != $$id_subs{$pkg}{'code'}) ||
                    ($$id_subs{$class}{'pkg'}  ne $$id_subs{$pkg}{'pkg'}))
                {
                    # Runtime merging of hierarchies with existing objects
                    if (($$id_subs{$class}{'code'} == \&_ID) ||
                        ($$id_subs{$pkg}{'code'} == \&_ID))
                    {
                        OIO::Runtime->die(
                            'message' => "Possible extant objects prevent runtime creation of hierarchy for class '$class'",
                            'Info'    => "Runtime loading of classes needs to be performed before any objects are created within their hierarchies",
                            ((($$id_subs{$class}{'code'} == \&_ID) && ($$id_subs{$pkg}{'code'} == \&_ID))
                                ? ()
                                : ('Class1'  => "The hierarchy for '$$id_subs{$class}{'pkg'}' is using object IDs generated by " .
                                                (($$id_subs{$class}{'code'} == \&_ID) ? 'Object::InsideOut' : 'a custom :ID subroutine'),
                                   'Class2'  => "The hierarchy for '$$id_subs{$pkg}{'pkg'}' is using object IDs generated by " .
                                                (($$id_subs{$pkg}{'code'} == \&_ID) ? 'Object::InsideOut' : 'a custom :ID subroutine'))));
                    }
                    # Multiple :ID subs in hierarchy
                    my (undef, $file,  $line)  = @{$$id_subs{$class}{'loc'}};
                    my (undef, $file2, $line2) = @{$$id_subs{$pkg}{'loc'}};
                    OIO::Attribute->die(
                        'message' => "Multiple :ID subs defined within hierarchy for class '$class'",
                        'Info'    => ":ID subs in class '$$id_subs{$class}{'pkg'}' (file '$file', line $line), and class '$$id_subs{$pkg}{'pkg'}' (file '$file2', line $line2)");
                }
            } else {
                # Add ID sub to class
                $$id_subs{$class} = $$id_subs{$pkg};
                delete($need_id_sub{$class});
                # Propagate to classes in this class's tree
                foreach my $add (@{$$trees{$class}}) {
                    if (! defined($seen{$add})) {
                        push(@propagate_to, $add);
                        $seen{$add} = undef;
                    }
                }
                # Propagate to classes that use this one
                if (exists($GBL{'asi'}{$class})) {
                    foreach my $add (keys(%{$GBL{'asi'}{$class}})) {
                        if (! defined($seen{$add})) {
                            push(@propagate_to, $add);
                            $seen{$add} = undef;
                        }
                    }
                }
            }
        }
    }

    if ($GBL{'share'}{'ok'}) {
        # If needed, process any thread object sharing flags
        my $sh_cl = $GBL{'share'}{'cl'};
        foreach my $flag_class (keys(%{$sh_cl})) {
            # Find the class in any class tree
            foreach my $tree (values(%{$trees})) {
                if (grep(/^$flag_class$/, @$tree)) {
                    # Check each class in the tree
                    foreach my $class (@$tree) {
                        if (exists($$sh_cl{$class})) {
                            # Check for sharing conflicts
                            if ($$sh_cl{$class}{'share'}
                                    != $$sh_cl{$flag_class}{'share'})
                            {
                                my ($pkg1, $pkg2)
                                        = ($$sh_cl{$flag_class}{'share'})
                                                ? ($flag_class, $class)
                                                : ($class, $flag_class);
                                my @loc  = ($pkg1,
                                            $$sh_cl{$pkg1}{'file'},
                                            $$sh_cl{$pkg1}{'line'});
                                OIO::Code->die(
                                    'location' => \@loc,
                                    'message'  => "Can't combine thread-sharing classes ($pkg1) with non-sharing classes ($pkg2) in the same class tree",
                                    'Info'     => "Class '$pkg1' was declared as sharing (file '$loc[1]' line $loc[2]), but class '$pkg2' was declared as non-sharing (file '$$sh_cl{$pkg2}{'file'}' line $$sh_cl{$pkg2}{'line'})");
                            }
                        } else {
                            # Add the sharing flag to this class
                            $$sh_cl{$class} = $$sh_cl{$flag_class};
                        }
                    }
                }
            }
            # Set up for obj ID sequences, and obj ID reuse
            #   for shared classes using _ID
            if ($$sh_cl{$flag_class}{'share'}) {
                my $reuse = $GBL{'id'}{'reuse'};
                if (exists($$id_subs{$flag_class}) &&
                    ($$id_subs{$flag_class}{'code'} == \&_ID))
                {
                    my $share_tree = $$id_subs{$flag_class}{'pkg'};
                    if (! exists($$obj_ids{$share_tree})) {
                        $$obj_ids{$share_tree} = make_shared([]);
                        $$obj_ids{$share_tree}[0] = 0;
                    }
                    if (! exists($$reuse{$share_tree})) {
                        $$reuse{$share_tree} = make_shared([]);
                    }
                    my $r_tree = $$reuse{$share_tree};
                    if (! defined($$r_tree[0])) {
                        $$r_tree[0] = make_shared([]);
                    }
                }
            }
        }

        # Set up for shared object tracking
        if (! exists($GBL{'share'}{'obj'}) &&
            (($] < 5.008009) || ($threads::shared::VERSION lt '1.15')))
        {
            $GBL{'share'}{'obj'} = make_shared({});
        }
    }

    # Process field attributes
    process_fields();

    # Implement ->isa()/->can() with :AutoMethods
    if (%{$GBL{'sub'}{'auto'}}) {
        install_UNIVERSAL();
    }

    # Implement overload (-ify) operators
    if (exists($GBL{'sub'}{'ol'})) {
        generate_OVERLOAD(\%GBL);
    }

    # Add metadata for methods
    my $meta = $GBL{'meta'}{'add'};
    if (my $meta_m = delete($GBL{'meta'}{'method'})) {
        while (my $info = shift(@{$meta_m})) {
            $$info{'name'} ||= sub_name($$info{'code'}, ':METHOD', $$info{'loc'});
            $$meta{$$info{'pkg'}}{$$info{'name'}}{'kind'} = $$info{'kind'};
        }
    }

    # Add metadata for subroutines
    if (my $meta_s = delete($GBL{'meta'}{'subr'})) {
        while (my $info = shift(@{$meta_s})) {
            $$info{'name'} ||= sub_name($$info{'code'}, ':SUB', $$info{'loc'});
            $$meta{$$info{'pkg'}}{$$info{'name'}}{'hidden'} = 1;
        }
    }

    # Implement merged argument methods
    if (my $merge = delete($GBL{'merge'})) {
        while (my $info = shift(@{$merge})) {
            $$info{'name'} ||= sub_name($$info{'code'}, ':MergeArgs', $$info{'loc'});
            my $pkg = $$info{'pkg'};
            my $name = $$info{'name'};

            my $new_wrap = wrap_MERGE_ARGS($$info{'wrap'});
            *{$pkg.'::'.$name} = $new_wrap;
            $$info{'wrap'} = $new_wrap;

            $$meta{$pkg}{$name}{'merge_args'} = 1;
        }
    }

    # Implement restricted methods - only callable within hierarchy
    if (my $restr = delete($GBL{'perm'}{'restr'})) {
        while (my $info = shift(@{$restr})) {
            $$info{'name'} ||= sub_name($$info{'code'}, ':RESTRICTED', $$info{'loc'});
            my $pkg = $$info{'pkg'};
            my $name = $$info{'name'};

            my $exempt = [ grep {$_} split(/[,'\s]+/, $$info{'exempt'} || '') ];

            my $new_wrap = wrap_RESTRICTED($pkg, $name, $$info{'wrap'}, $exempt);
            *{$pkg.'::'.$name} = $new_wrap;
            $$info{'wrap'} = $new_wrap;

            $$meta{$pkg}{$name}{'restricted'} = 1;
        }
    }

    # Implement private methods - only callable from class itself
    if (my $priv = delete($GBL{'perm'}{'priv'})) {
        while (my $info = shift(@{$priv})) {
            $$info{'name'} ||= sub_name($$info{'code'}, ':PRIVATE', $$info{'loc'});
            my $pkg = $$info{'pkg'};
            my $name = $$info{'name'};

            my $exempt = [ $pkg, grep {$_} split(/[,'\s]+/, $$info{'exempt'} || '') ];

            my $new_wrap = wrap_PRIVATE($pkg, $name, $$info{'wrap'}, $exempt);
            *{$pkg.'::'.$name} = $new_wrap;
            $$info{'wrap'} = $new_wrap;

            $$meta{$pkg}{$name}{'private'} = 1;
        }
    }

    # Implement hidden methods - no longer callable by name
    if (my $hide = delete($GBL{'perm'}{'hide'})) {
        while (my $info = shift(@{$hide})) {
            $$info{'name'} ||= sub_name($$info{'code'}, ':HIDDEN', $$info{'loc'});
            my $pkg = $$info{'pkg'};
            my $name = $$info{'name'};

            *{$pkg.'::'.$name} = wrap_HIDDEN($pkg, $name);

            $$meta{$pkg}{$name}{'hidden'} = 1;
        }
    }

    # Implement cumulative methods
    if (exists($GBL{'sub'}{'cumu'}{'new'})) {
        generate_CUMULATIVE(\%GBL);
    }

    # Implement chained methods
    if (exists($GBL{'sub'}{'chain'}{'new'})) {
        generate_CHAINED(\%GBL);
    }

    # Export methods
    my @export = @{$GBL{'export'}};
    my $trees_bu = $GBL{'tree'}{'bu'};
    foreach my $pkg (keys(%{$trees})) {
        EXPORT:
        foreach my $sym (@export, ($pkg->isa('Storable'))
                                        ? (qw(STORABLE_freeze STORABLE_thaw))
                                        : ())
        {
            my $full_sym = $pkg.'::'.$sym;
            # Only export if method doesn't already exist,
            # and not overridden in a parent class
            if (! *{$full_sym}{CODE}) {
                foreach my $class (@{$$trees_bu{$pkg}}) {
                    my $class_sym = $class.'::'.$sym;
                    if (*{$class_sym}{CODE} &&
                        (*{$class_sym}{CODE} != \&{$sym}))
                    {
                        next EXPORT;
                    }
                }
                *{$full_sym} = \&{$sym};

                # Add metadata
                if ($sym eq 'new') {
                    $$meta{$pkg}{'new'} = { 'kind' => 'constructor',
                                            'merge_args' => 1 };

                } elsif ($sym eq 'clone' || $sym eq 'dump') {
                    $$meta{$pkg}{$sym}{'kind'} = 'object';

                } elsif ($sym eq 'create_field') {
                    $$meta{$pkg}{$sym}{'kind'} = 'class';

                } elsif ($sym =~ /^STORABLE_/ || ($sym eq 'AUTOLOAD')) {
                    $$meta{$pkg}{$sym}{'hidden'} = 1;

                } elsif ($sym =~ /herit/ || $sym eq 'set') {
                    $$meta{$pkg}{$sym} = { 'kind' => 'object',
                                           'restricted' => 1 };
                }
            }
        }
    }

    # Add accumulated metadata
    add_meta($meta);
    $GBL{'meta'}{'add'} = {};
}


# Process attributes for field hashes/arrays including generating accessors
sub process_fields :Sub(Private)
{
    my $new = delete($GBL{'fld'}{'new'});
    return if (! $new);

    # 'Want' module loaded?
    my $use_want = (defined($Want::VERSION) && ($Want::VERSION >= 0.12));

    my $trees    = $GBL{'tree'}{'td'};
    my $fld_refs = $GBL{'fld'}{'ref'};
    my $g_ho     = $GBL{'hash_only'};
    my $do_ho    = %{$g_ho};

    # Process field attributes
    foreach my $pkg (keys(%{$new})) {
        while (my $item = shift(@{$$new{$pkg}})) {
            my ($fld, $attr) = @{$item};

            # Verify not a 'hash field only' class
            if ((ref($fld) eq 'ARRAY') && $do_ho) {
                foreach my $ho (keys(%{$g_ho})) {
                    foreach my $class (@{$$trees{$pkg}}) {
                        if ($class eq $ho) {
                            my $loc = ((caller())[1] =~ /Dynamic/)
                                        ? [ (caller(2))[0..2] ]
                                        : $$g_ho{$ho};
                            OIO::Code->die(
                                'location' => $loc,
                                'message'  => "Can't combine 'hash only' classes ($ho) with array-based classes ($class) in the same class tree",
                                'Info'     => "Class '$ho' was declared as ':hash_only', but class '$class' has array-based fields");
                        }
                    }
                }
            }

            # Share the field, if applicable
            if (is_sharing($pkg) && !threads::shared::is_shared($fld)) {
                # Preserve any contents
                my $contents = Object::InsideOut::Util::clone_shared($fld);

                # Share the field
                threads::shared::share($fld);

                # Restore contents
                if ($contents) {
                    if (ref($fld) eq 'HASH') {
                        %{$fld} = %{$contents};
                    } else {
                        @{$fld} = @{$contents};
                    }
                }
            }

            # Process any accessor declarations
            if ($attr) {
                create_accessors($pkg, $fld, $attr, $use_want);
            }

            # Save field ref
            if (! grep { $_ == $fld } @{$$fld_refs{$pkg}}) {
                push(@{$$fld_refs{$pkg}}, $fld);
            }
        }
    }
}


# Normalize the :InitArgs hash
sub normalize :Sub
{
    my $hash = $_[$#_];
    if (ref($hash) ne 'HASH') {
        OIO::Args->die(
            'message' => 'Argument is not a hash ref',
            'Usage'   => q/Object::InsideOut::normalize($hash)/);
    }

    foreach my $arg (keys(%{$hash})) {
        my $spec = $$hash{$arg};
        next if (ref($spec) ne 'HASH');
        foreach my $opt (keys(%{$spec})) {
            if ($opt =~ qr/^DEF(?:AULTs?)?$/i) {
                $$spec{'_D'} = $$spec{$opt};
            } elsif ($opt =~ qr/^FIELD$/i) {
                $$spec{'_F'} = $$spec{$opt};
            } elsif ($opt =~ qr/^(?:MAND|REQ)/i) {
                $$spec{'_M'} = $$spec{$opt};
            } elsif ($opt =~ qr/^PRE/i) {
                $$spec{'_P'} = $$spec{$opt};
            } elsif ($opt =~ qr/^RE(?:GEXp?)?$/i) {
                # Turn into an actual 'Regexp', if needed
                $$spec{'_R'} = (ref($$spec{$opt}) eq 'Regexp')
                                    ? $$spec{$opt}
                                    : qr/^$$spec{$opt}$/;
            } elsif ($opt =~ qr/^TYPE$/i) {
                $$spec{'_T'} = $$spec{$opt};
            }
        }
    }
    $$hash{' '} = undef;

    return ($hash);
}


### Thread-Shared Object Support ###

# Set a class as thread-sharing
sub set_sharing :Sub(Private)
{
    my ($class, $sharing, $file, $line) = @_;
    $sharing = ($sharing) ? 1 : 0;

    my $sh_cl = $GBL{'share'}{'cl'};
    if (exists($$sh_cl{$class})) {
        if ($$sh_cl{$class}{'share'} != $sharing) {
            my (@loc, $nfile, $nline);
            if ($sharing) {
                @loc  = ($class, $file, $line);
                $nfile = $$sh_cl{$class}{'file'};
                $nline = $$sh_cl{$class}{'line'};
            } else {
                @loc  = ($class,
                         $$sh_cl{$class}{'file'},
                         $$sh_cl{$class}{'line'});
                ($nfile, $nline) = ($file, $line);
            }
            OIO::Code->die(
                'location' => \@loc,
                'message'  => "Can't combine thread-sharing and non-sharing instances of a class in the same application",
                'Info'     => "Class '$class' was declared as sharing in '$file' line $line, but was declared as non-sharing in '$nfile' line $nline");
        }
    } else {
        $$sh_cl{$class} = {
            share => $sharing,
            file  => $file,
            line  => $line,
        };
        # Set up equality via overload
        if ($sharing && $Config::Config{useithreads}
                     && $threads::shared::threads_shared
                     && $threads::shared::VERSION ge '0.95')
        {
            push(@{$GBL{'sub'}{'ol'}}, { 'pkg' => $class, 'ify' => 'EQUATE' });
        }
    }
}


# Determines if a class's objects are shared between threads
sub is_sharing :Sub(Private)
{
    return if ! $GBL{'share'}{'ok'};
    my $class = $_[0];
    my $sh_cl = $GBL{'share'}{'cl'};
    return (exists($$sh_cl{$class}) && $$sh_cl{$class}{'share'});
}


### Thread Cloning Support ###

sub CLONE
{
    # Don't execute when called for sub-classes
    return if ($_[0] ne 'Object::InsideOut');

    # Don't execute twice for same thread
    my $tid;
    if ($threads::threads) {
        $tid = threads->tid();
        return if ($GBL{'tid'} == $tid);
        $GBL{'tid'} = $tid;
    } else {
        # Pseudo-fork
        return if (exists($GBL{'pids'}{$$}));
        $GBL{'pids'}{$$} = undef;
        $tid = $GBL{'tid'};
    }

    # Check for delayed threads::shared usage
    if ($Config::Config{useithreads} &&
        $threads::shared::threads_shared &&
        ! $GBL{'share'}{'ok'})
    {
        OIO::Code->die(
            'message' => q/'threads::shared' imported after Object::InsideOut initialized/,
            'Info'    => q/Add 'use threads::shared;' to the start of your application code/);
    }

    # Process thread-shared objects
    if (exists($GBL{'share'}{'obj'})) {
        my $sh_obj = $GBL{'share'}{'obj'};
        lock($sh_obj);

        # Add thread ID to every object in the thread tracking registry
        foreach my $class (keys(%{$sh_obj})) {
            foreach my $oid (keys(%{$$sh_obj{$class}})) {
                push(@{$$sh_obj{$class}{$oid}}, $tid);
            }
        }
    }

    # Fix field references
    my $g_fld = $GBL{'fld'};
    my $regen = $$g_fld{'regen'};
    $$g_fld{'type'} = { map { $_->[0] => $_->[1] } @{$$regen{'type'}} };
    $$g_fld{'weak'} = { map { $_ => 1 } @{$$regen{'weak'}} };
    $$g_fld{'deep'} = { map { $_ => 1 } @{$$regen{'deep'}} };

    # Process non-thread-shared objects
    my $g_obj     = $GBL{'obj'};
    my $trees     = $GBL{'tree'}{'td'};
    my $id_subs   = $GBL{'sub'}{'id'};
    my $fld_ref   = $$g_fld{'ref'};
    my $weak      = $$g_fld{'weak'};
    my $repl_subs = $GBL{'sub'}{'repl'};
    my $do_repl   = keys(%{$repl_subs});
    foreach my $class (keys(%{$g_obj})) {
        my $obj_cl = $$g_obj{$class};

        # Get class tree
        my @tree = @{$$trees{$class}};

        # Get the ID sub for this class, if any
        my $id_sub = $$id_subs{$class}{'code'};

        # Get any replication handlers
        my @repl;
        if ($do_repl) {
            @repl = grep { $_ } map { $$repl_subs{$_} } @tree;
        }

        # Process each object in the class
        foreach my $old_id (keys(%{$obj_cl})) {
            my $obj;
            if ($id_sub == \&_ID) {
                # Objects using internal ID sub keep their same ID
                $obj = $$obj_cl{$old_id};

                # Set 'next object ID'
                my $pkg = $GBL{'sub'}{'id'}{$class}{'pkg'};
                my $g_id = $GBL{'id'}{'obj'}{$pkg};
                if (! $$g_id[$tid] || ($$g_id[$tid] < $$obj)) {
                    $$g_id[$tid] = $$obj;
                }

            } else {
                # Get cloned object associated with old ID
                $obj = delete($$obj_cl{$old_id});

                # Unlock the object
                Internals::SvREADONLY($$obj, 0) if ($] >= 5.008003);

                # Replace the old object ID with a new one
                local $SIG{'__DIE__'} = 'OIO::trap';
                $$obj = $id_sub->($class);

                # Lock the object again
                Internals::SvREADONLY($$obj, 1) if ($] >= 5.008003);

                # Update the keys of the field arrays/hashes
                # with the new object ID
                foreach my $pkg (@tree) {
                    foreach my $fld (@{$$fld_ref{$pkg}}) {
                        if (ref($fld) eq 'HASH') {
                            $$fld{$$obj} = delete($$fld{$old_id});
                            if ($$weak{'weak'}{$fld}) {
                                Scalar::Util::weaken($$fld{$$obj});
                            }
                        } else {
                            $$fld[$$obj] = $$fld[$old_id];
                            undef($$fld[$old_id]);
                            if ($$weak{$fld}) {
                                Scalar::Util::weaken($$fld[$$obj]);
                            }
                        }
                    }
                }

                # Resave weakened reference to object
                Scalar::Util::weaken($$obj_cl{$$obj} = $obj);
            }

            # Dispatch any special replication handling
            if (@repl) {
                my $pseudo_object = \do{ my $scalar = $old_id; };
                foreach my $repl (@repl) {
                    local $SIG{'__DIE__'} = 'OIO::trap';
                    $repl->($pseudo_object, $obj, 'CLONE');
                }
            }
        }
    }
}


### Object Methods ###

# Helper subroutine to create a new 'bare' object
sub _obj :Sub(Private)
{
    my $class = shift;

    # Create a new 'bare' object
    my $self = create_object($class, $GBL{'sub'}{'id'}{$class}{'code'});

    # Thread support
    if (is_sharing($class)) {
        threads::shared::share($self);

        # Add thread tracking list for this thread-shared object
        if (exists($GBL{'share'}{'obj'})) {
            my $sh_obj = $GBL{'share'}{'obj'};
            lock($sh_obj);
            if (exists($$sh_obj{$class})) {
                $$sh_obj{$class}{$$self} = make_shared([ $GBL{'tid'} ]);
            } else {
                $$sh_obj{$class} = make_shared({ $$self => [ $GBL{'tid'} ] });
            }
        }

    } elsif ($threads::threads) {
        # Add non-thread-shared object to thread cloning list
        Scalar::Util::weaken($GBL{'obj'}{$class}{$$self} = $self);
    }

    return ($self);
}


# Extracts specified args from those given
sub _args :Sub(Private)
{
    my ($class,
        $self,   # Object being initialized with args
        $spec,   # Hash ref of arg specifiers
        $args,   # Hash ref of args
        $used)   # Hash ref of used args
            = @_;

    # Ensure :InitArgs hash is normalized
    if (! exists($$spec{' '})) {
        normalize($spec);
    }

    # Extract arg-matching regexs from the specifiers
    my %regex;
    while (my ($key, $val) = each(%{$spec})) {
        next if ($key eq ' ');
        $regex{$key} = (ref($val) eq 'HASH') ? $$val{'_R'} : $val;
    }

    # Search for specified args
    my %found = ();
    my $add_used = $used;
    EXTRACT: {
        # Find arguments using regex's
        foreach my $key (keys(%regex)) {
            my $regex = $regex{$key};
            my ($value, $arg) = ($regex) ? hash_re($args, $regex) : ($$args{$key}, $key);
            if (defined($found{$key})) {
                if (defined($value)) {
                    $found{$key} = $value;
                }
            } else {
                $found{$key} = $value;
            }
            if (defined($arg)) {
                $$add_used{$arg} = undef;
            }
        }

        # Check for class-specific argument hash ref
        if (exists($$args{$class})) {
            $args = $$args{$class};
            if (ref($args) ne 'HASH') {
                OIO::Args->die(
                    'message' => "Bad class initializer for '$class'",
                    'Usage'   => q/Class initializers must be a hash ref/);
            }
            $$add_used{$class} = {};
            $add_used = $$add_used{$class};
            # Loop back to process class-specific arguments
            redo EXTRACT;
        }
    }

    # Check on what we've found
    CHECKIT:
    foreach my $key (keys(%{$spec})) {
        my $spec_item = $$spec{$key};
        # No specs to check
        if (ref($spec_item) ne 'HASH') {
            # The specifier entry was just 'key => regex'.  If 'key' is not in
            # the args, the we need to remove the 'undef' entry in the found
            # args hash.
            if (! defined($found{$key})) {
                delete($found{$key});
            }
            next CHECKIT;
        }

        # Preprocess the argument
        if (my $pre = $$spec_item{'_P'}) {
            if (ref($pre) ne 'CODE') {
                OIO::Code->die(
                    'message' => q/Can't handle argument/,
                    'Info'    => "'Preprocess' is not a code ref for initializer '$key' for class '$class'");
            }

            my (@errs);
            local $SIG{'__WARN__'} = sub { push(@errs, @_); };
            eval {
                local $SIG{'__DIE__'};
                $found{$key} = $pre->($class, $key, $spec_item, $self, $found{$key})
            };
            if ($@ || @errs) {
                my ($err) = split(/ at /, $@ || join(" | ", @errs));
                OIO::Code->die(
                    'message' => "Problem with preprocess routine for initializer '$key' for class '$class",
                    'Error'   => $err);
            }
        }

        # Handle args not found
        if (! defined($found{$key})) {
            # Complain if mandatory
            if ($$spec_item{'_M'}) {
                OIO::Args->die(
                    'message' => "Missing mandatory initializer '$key' for class '$class'");
            }

            # Assign default value
            if (exists($$spec_item{'_D'})) {
                if (ref($$spec_item{'_D'}) eq 'CODE') {
                    $found{$key} = $$spec_item{'_D'}->($self);
                } else {
                    $found{$key} = Object::InsideOut::Util::clone($$spec_item{'_D'});
                }
            }

            # If no default, then remove it from the found args hash
            if (! defined($found{$key})) {
                delete($found{$key});
                next CHECKIT;
            }
        }

        # Check for correct type
        if (my $type = $$spec_item{'_T'}) {
            my $subtype;

            # Custom type checking
            if (ref($type)) {
                if (ref($type) ne 'CODE') {
                    OIO::Code->die(
                        'message' => q/Can't validate argument/,
                        'Info'    => "'Type' is not a code ref or string for initializer '$key' for class '$class'");
                }

                my ($ok, @errs);
                local $SIG{'__WARN__'} = sub { push(@errs, @_); };
                eval {
                    local $SIG{'__DIE__'};
                    $ok = $type->($found{$key})
                };
                if ($@ || @errs) {
                    my ($err) = split(/ at /, $@ || join(" | ", @errs));
                    OIO::Code->die(
                        'message' => "Problem with type check routine for initializer '$key' for class '$class",
                        'Error'   => $err);
                }
                if (! $ok) {
                    OIO::Args->die(
                        'message' => "Initializer '$key' for class '$class' failed type check: $found{$key}");
                }
            }

            # Is it supposed to be a scalar
            elsif ($type =~ /^scalar$/i) {
                if (ref($found{$key})) {
                    OIO::Args->die(
                        'message' => "Bad value for initializer '$key': $found{$key}",
                        'Usage'   => "Initializer '$key' for class '$class' must be a scalar");
                }
            }

            # Is it supposed to be a number
            elsif ($type =~ /^num(?:ber|eric)?$/i) {
                if (! Scalar::Util::looks_like_number($found{$key})) {
                    OIO::Args->die(
                        'message' => "Bad value for initializer '$key': $found{$key}",
                        'Usage'   => "Initializer '$key' for class '$class' must be a number");
                }
            }

            # For 'LIST', turn anything not an array ref into an array ref
            elsif ($type =~ /^(?:list|array)\s*(?:\(\s*(\S+)\s*\))*$/i) {
                if (defined($1)) {
                    $subtype = $1;
                }
                if (ref($found{$key}) ne 'ARRAY') {
                    $found{$key} = [ $found{$key} ];
                }
            }

            # Otherwise, check for a specific class or ref type
            # Exact spelling and case required
            else {
                if ($type =~ /^(array|hash|scalar)(?:_?ref)?\s*(?:\(\s*(\S+)\s*\))*$/i) {
                    $type = uc($1);
                    if (defined($2)) {
                        $subtype = $2;
                    }
                }
                if (! is_it($found{$key}, $type)) {
                    OIO::Args->die(
                        'message' => "Bad value for initializer '$key': $found{$key}",
                        'Usage'   => "Initializer '$key' for class '$class' must be an object or ref of type '$type'");
                }
            }

            # Check type of each element in array
            if (defined($subtype)) {
                if ($subtype =~ /^scalar$/i) {
                    # Scalar elements
                    foreach my $elem (@{$found{$key}}) {
                        if (ref($elem)) {
                            OIO::Args->die(
                                'message' => "Bad value for initializer '$key': $elem",
                                'Usage'   => "Values making up initializer '$key' for class '$class' must be scalars");
                        }
                    }
                } elsif ($subtype =~ /^num(?:ber|eric)?$/i) {
                    # Numeric elements
                    foreach my $elem (@{$found{$key}}) {
                        if (! Scalar::Util::looks_like_number($elem)) {
                            OIO::Args->die(
                                'message' => "Bad value for initializer '$key': $elem",
                                'Usage'   => "Values making up initializer '$key' for class '$class' must be numeric");
                        }
                    }
                } else {
                    foreach my $elem (@{$found{$key}}) {
                        if (! is_it($elem, $subtype)) {
                            OIO::Args->die(
                                'message' => "Bad value for initializer '$key': $elem",
                                'Usage'   => "Values making up Initializer '$key' for class '$class' must be objects or refs of type '$subtype'");
                        }
                    }
                }
            }
        }

        # If the destination field is specified, then put it in, and remove it
        # from the found args hash.
        if (my $field = $$spec_item{'_F'}) {
            $self->set($field, delete($found{$key}));
        }
    }

    # Done - return remaining found args
    return (\%found);
}


# Object Constructor
sub new :MergeArgs
{
    my ($thing, $all_args) = @_;
    my $class = ref($thing) || $thing;

    # Can't call ->new() on this package
    if ($class eq 'Object::InsideOut') {
        OIO::Method->die('message' => q/'new' called on non-class 'Object::InsideOut'/);
    }

    # Perform package initialization, if required
    initialize();

    # Create a new 'bare' object
    my $self = _obj($class);

    # Object initialization activity caching
    my $have_cache = exists($GBL{'cache'}{$class});
    my %cache = ($have_cache) ? %{$GBL{'cache'}{$class}}
                              : ( 'pre'  => 0, 'def'  => 0 );

    # Execute pre-initialization subroutines
    if ($cache{'pre'} || ! $have_cache) {
        my $preinit_subs = $GBL{'sub'}{'pre'};
        if (%{$preinit_subs}) {
            foreach my $pkg (@{$GBL{'tree'}{'bu'}{$class}}) {
                if (my $preinit = $$preinit_subs{$pkg}) {
                    local $SIG{'__DIE__'} = 'OIO::trap';
                    $self->$preinit($all_args);
                    if ($have_cache) {
                        last if (! (--$cache{'pre'}));
                    } else {
                        $cache{'pre'}++;
                    }
                }
            }
        }
    }

    my $tree = $GBL{'tree'}{'td'}{$class};

    # Set any defaults
    if ($cache{'def'} || ! $have_cache) {
        foreach my $pkg (@{$tree}) {
            if (my $def = $GBL{'fld'}{'def'}{$pkg}) {
                $self->set($_->[0], $_->[1]->($self))
                    foreach (@{$def});
                if ($have_cache) {
                    last if (! (--$cache{'def'}));
                } else {
                    $cache{'def'}++;
                }
            }
        }
    }

    # Process :InitArgs
    my %pkg_args;
    my $used_args = {};
    my $g_args = $GBL{'args'};
    foreach my $pkg (@{$tree}) {
        if (my $spec = $$g_args{$pkg}) {
            $pkg_args{$pkg} = _args($pkg, $self, $spec, $all_args, $used_args);
        }
    }

    # Call :Init subs
    my $init_subs = $GBL{'sub'}{'init'};
    foreach my $pkg (@{$tree}) {
        if (my $init = $$init_subs{$pkg}) {
            local $SIG{'__DIE__'} = 'OIO::trap';
            if (exists($pkg_args{$pkg})) {
                $self->$init($pkg_args{$pkg});
            } else {
                $self->$init($all_args);
                undef($used_args);
            }

        } elsif (exists($pkg_args{$pkg})) {
            if (%{$pkg_args{$pkg}}) {
                # It's an error if there are unhandled args, but no :Init sub
                OIO::Args::Unhandled->die(
                    'message' => "Unhandled parameter for class '$class': " . join(', ', keys(%{$pkg_args{$pkg}})),
                    'Usage'   => q/Add appropriate 'Field =>' designators to the :InitArgs hash/);
            }

        } elsif (exists($$all_args{$pkg})) {
            # It's an error if there are unhandled class-specific args
            if (ref($$all_args{$pkg}) ne 'HASH') {
                OIO::Args->die(
                    'message' => "Bad class initializer for '$class'",
                    'Usage'   => q/Class initializers must be a hash ref/);
            }
            OIO::Args::Unhandled->die(
                'message' => "Unhandled parameter for class '$class': " . join(', ', keys(%{$$all_args{$pkg}})),
                'Usage'   => q/Add :Init subroutine or :InitArgs hash/);
        }
    }

    # Any unused args?
    if ($used_args) {
        my %pkgs;
        @pkgs{@{$tree}} = undef;
        foreach my $key (keys(%$all_args)) {
            if (exists($pkgs{$key})) {
                foreach my $subkey (keys(%{$$all_args{$key}})) {
                    if (! exists($$used_args{$key}{$subkey})) {
                        OIO::Args::Unhandled->die('message' => "Unhandled parameter for class '$key': $subkey");
                    }
                }
            } else {
                if (! exists($$used_args{$key})) {
                    OIO::Args::Unhandled->die('message' => "Unhandled parameter: $key");
                }
            }
        }
    }

    # Remember object initialization activity caching
    if (! $have_cache) {
        $GBL{'cache'}{$class} = \%cache;
    }

    # Done - return object
    return ($self);
}


# Creates a copy of an object
sub clone
{
    my ($parent, $is_deep) = @_;          # Parent object and deep cloning flag
    $is_deep = ($is_deep) ? 'deep' : '';  # Deep clone the object?

    # Must call ->clone() as an object method
    my $class = Scalar::Util::blessed($parent);
    if (! $class) {
        OIO::Method->die('message' => q/'clone' called as a class method/);
    }

    # Create a new 'bare' object
    my $clone = _obj($class);

    # Flag for shared class
    my $am_sharing = is_sharing($class);

    # Clone the object
    my $fld_ref = $GBL{'fld'}{'ref'};
    my $weak    = $GBL{'fld'}{'weak'};
    my $deep    = $GBL{'fld'}{'deep'};
    my $repl    = $GBL{'sub'}{'repl'};
    foreach my $pkg (@{$GBL{'tree'}{'td'}{$class}}) {
        # Clone field data from the parent
        foreach my $fld (@{$$fld_ref{$pkg}}) {
            my $fdeep = $is_deep || $$deep{$fld};  # Deep clone the field?
            lock($fld) if ($am_sharing);
            if (ref($fld) eq 'HASH') {
                $$fld{$$clone} = (! $fdeep) ? $$fld{$$parent}
                               : ($am_sharing)
                                    ? Object::InsideOut::Util::clone_shared($$fld{$$parent})
                                    : Object::InsideOut::Util::clone($$fld{$$parent});
                if ($$weak{$fld}) {
                    Scalar::Util::weaken($$fld{$$clone});
                }
            } else {
                $$fld[$$clone] = (! $fdeep) ? $$fld[$$parent]
                               : ($am_sharing)
                                    ? Object::InsideOut::Util::clone_shared($$fld[$$parent])
                                    : Object::InsideOut::Util::clone($$fld[$$parent]);
                if ($$weak{$fld}) {
                    Scalar::Util::weaken($$fld[$$clone]);
                }
            }
        }

        # Dispatch any special replication handling
        if (my $replicate = $$repl{$pkg}) {
            local $SIG{'__DIE__'} = 'OIO::trap';
            $parent->$replicate($clone, $is_deep);
        }
    }

    # Done - return clone
    return ($clone);
}


# Get a metadata object
sub meta
{
    my $class = ref($_[0]) || $_[0];

    # No metadata for OIO
    if ($class eq 'Object::InsideOut') {
        OIO::Method->die('message' => q/'meta' called on non-class 'Object::InsideOut'/);
    }

    initialize();   # Perform package initialization, if required

    return (Object::InsideOut::Metadata->new('GBL'   => \%GBL,
                                             'CLASS' => $class));
}


# Put data in a field, making sure that sharing is supported
sub set
{
    my ($self, $field, $data) = @_;

    # Must call ->set() as an object method
    if (! Scalar::Util::blessed($self)) {
        OIO::Method->die('message' => q/'set' called as a class method/);
    }

    # Restrict usage to inside class hierarchy
    if (! $self->isa('Object::InsideOut')) {
        my $caller = caller();
        OIO::Method->die('message' => "Can't call restricted method 'inherit' from class '$caller'");
    }

    # Check usage
    if (! defined($field)) {
        OIO::Args->die(
            'message'  => 'Missing field argument',
            'Usage'    => '$obj->set($field_ref, $data)');
    }
    my $fld_type = ref($field);
    if (! $fld_type || ($fld_type ne 'ARRAY' && $fld_type ne 'HASH')) {
        OIO::Args->die(
            'message' => 'Invalid field argument',
            'Usage'   => '$obj->set($field_ref, $data)');
    }

    # Check data
    my $weak = $GBL{'fld'}{'weak'}{$field};
    if ($weak && ! ref($data)) {
        OIO::Args->die(
            'message'  => "Bad argument: $data",
            'Usage'    => q/Argument to specified field must be a reference/);
    }

    # Handle sharing
    if ($GBL{'share'}{'ok'} && threads::shared::is_shared($field)) {
        lock($field);
        if ($fld_type eq 'HASH') {
            $$field{$$self} = make_shared($data);
        } else {
            $$field[$$self] = make_shared($data);
        }

    } else {
        # No sharing - just store the data
        if ($fld_type eq 'HASH') {
            $$field{$$self} = $data;
        } else {
            $$field[$$self] = $data;
        }
    }

    # Weaken data, if required
    if ($weak) {
        if ($fld_type eq 'HASH') {
            Scalar::Util::weaken($$field{$$self});
        } else {
            Scalar::Util::weaken($$field[$$self]);
        }
    }
}


# Object Destructor
sub DESTROY
{
    my $self  = shift;
    my $class = ref($self);

    return if (! $$self);

    # Grab any error coming into this routine
    my $err = $@;

    # Preserve other error variables
    local($!, $^E, $?);

    # Workaround for Perl's "in cleanup" bug
    if ($Config::Config{useithreads} &&
        $threads::shared::threads_shared &&
        ! $GBL{'term'})
    {
        eval {
            my $bug = keys(%{$GBL{'id'}{'obj'}})
                    + keys(%{$GBL{'id'}{'reuse'}})
                    + ((exists($GBL{'share'}{'obj'}))
                        ? keys(%{$GBL{'share'}{'obj'}})
                        : 0);
        };
        if ($@) {
            $GBL{'term'} = 1;
        }
    }

    eval {
        my $is_sharing = is_sharing($class);
        if ($is_sharing) {
            # Thread-shared object
            my $tid = $GBL{'tid'};

            if ($GBL{'term'}) {
                return if ($tid);   # Continue only if main thread

            } elsif (exists($GBL{'share'}{'obj'})) {
                my $so_cl = $GBL{'share'}{'obj'}{$class};
                if (! exists($$so_cl{$$self})) {
                    # This can happen when a non-shared object
                    #   is returned from a thread
                    warn("ERROR: Attempt to DESTROY object ID $$self of class $class in thread ID $tid twice\n");
                    return;
                }

                # Remove thread ID from this object's thread tracking list
                # NOTE:  The threads->object() test was added for the case
                # where OIO objects are passed via Thead::Queue.  I don't
                # know if this will cause problems with detached threads as
                # threads->object() returns undef for them.  Also, the main
                # thread (0) is always a valid thread.
                lock($so_cl);
                if (@{$$so_cl{$$self}} = grep { ($_ != $tid) &&
                                                (($_ == 0) || threads->object($_)) }
                                            @{$$so_cl{$$self}}) {
                    return;
                }

                # Delete the object from the thread tracking registry
                delete($$so_cl{$$self});
            }

        } elsif ($threads::threads) {
            my $obj_cl = $GBL{'obj'}{$class};
            if (! exists($$obj_cl{$$self})) {
                warn("ERROR: Attempt to DESTROY object ID $$self of class $class twice\n");
                return;
            }

            # Delete this non-thread-shared object from the thread cloning
            # registry
            delete($$obj_cl{$$self});
        }

        # Dispatch any special destruction handling
        my $dest_err;
        my $dest_subs = $GBL{'sub'}{'dest'};
        my $fld_refs  = $GBL{'fld'}{'ref'};
        foreach my $pkg (@{$GBL{'tree'}{'bu'}{$class}}) {
            if (my $destroy = $$dest_subs{$pkg}) {
                eval {
                    local $SIG{'__DIE__'} = 'OIO::trap';
                    $self->$destroy();
                };
                $dest_err = OIO::combine($dest_err, $@);
            }
        }

        # Delete object field data
        foreach my $pkg (@{$GBL{'tree'}{'bu'}{$class}}) {
            foreach my $fld (@{$$fld_refs{$pkg}}) {
                # If sharing, then must lock object field
                lock($fld) if ($is_sharing);
                if (ref($fld) eq 'HASH') {
                    if ($is_sharing) {
                        # Workaround for Perl's "in cleanup" bug
                        next if ! defined($$fld{$$self});
                    }
                    delete($$fld{$$self});
                } else {
                    if ($is_sharing) {
                        # Workaround for Perl's "in cleanup" bug
                        next if ! defined($$fld[$$self]);
                    }
                    undef($$fld[$$self]);
                }
            }
        }

        # Unlock the object
        Internals::SvREADONLY($$self, 0) if ($] >= 5.008003);

        # Reclaim the object ID if applicable
        if ($GBL{'sub'}{'id'}{$class}{'code'} == \&_ID) {
            _ID($class, $$self);
        }

        # Erase the object ID - just in case
        $$self = undef;

        # Propagate any errors
        if ($dest_err) {
            die($dest_err);
        }
    };

    # Propagate any errors
    if ($err || $@) {
        $@ = OIO::combine($err, $@);
        die("$@") if (! $err);
    }
}


# OIO specific ->can()
sub can :Method(Object)
{
    my ($thing, $method) = @_;

    return if (! defined($thing));

    # Metadata call for methods
    if (@_ == 1) {
        my $meths = Object::InsideOut::meta($thing)->get_methods();
        return (wantarray()) ? (keys(%$meths)) : [ keys(%$meths) ];
    }

    return if (! defined($method));

    # Try UNIVERSAL::can()
    eval { $thing->Object::InsideOut::SUPER::can($method) };
}


# OIO specific ->isa()
sub isa :Method(Object)
{
    my ($thing, $type) = @_;

    return ('') if (! defined($thing));

    # Metadata call for classes
    if (@_ == 1) {
        return Object::InsideOut::meta($thing)->get_classes();
    }

    # Workaround for Perl bug #47233
    return ('') if (! defined($type));

    # Try UNIVERSAL::isa()
    eval { $thing->Object::InsideOut::SUPER::isa($type); }
}


### Serialization Support Using Storable ###

sub STORABLE_freeze :Sub
{
    my ($self, $cloning) = @_;
    return ('', $self->dump());
}

sub STORABLE_thaw :Sub
{
    my ($obj, $cloning, $data);
    if (@_ == 4) {
        ($obj, $cloning, undef, $data) = @_;
    } else {
        # Backward compatibility
        ($obj, $cloning, $data) = @_;
    }

    # Recreate the object
    my $self;
    eval {
        $self = Object::InsideOut->pump($data);
    };
    if ($@) {
        die($@->as_string());   # Storable doesn't like exception objects
    }

    # Transfer the ID to Storable's object
    $$obj = $$self;
    # Make object shared, if applicable
    if (is_sharing(ref($obj))) {
        threads::shared::share($obj);
    }
    # Make object readonly
    if ($] >= 5.008003) {
        Internals::SvREADONLY($$obj, 1);
        Internals::SvREADONLY($$self, 0);
    }
    # Prevent object destruction
    undef($$self);
}


### Accessor Generator ###

# Names a field for dumping
sub add_dump_field :Sub(Private)
{
    my ($src, $name, $fld, $dump) = @_;

    # Name already in use for different field
    if (exists($$dump{$name}) && ($fld != $$dump{$name}{'fld'})) {
        return ('conflict');
    }

    # Entry already exists for field
    if (my ($old_name) = grep { $$dump{$_}{'fld'} == $fld } keys(%$dump)) {
        my $old_src = $$dump{$old_name}{'src'};
        if ($old_src eq 'Name') {
            return ('named');
        } elsif ($src eq 'Name') {
            delete($$dump{$old_name});
        } elsif ($old_src eq 'InitArgs') {
            return ('named');
        } elsif ($src eq 'InitArgs') {
            delete($$dump{$old_name});
        } elsif ($old_src eq 'Get') {
            return ('named');
        } elsif ($src eq 'Get') {
            delete($$dump{$old_name});
        } elsif ($old_src eq 'Set') {
            return ('named');
        } else {
            delete($$dump{$old_name});    # Shouldn't get here
        }
    }

    $$dump{$name} = { fld => $fld, src => $src };
    return ('okay');
}


# Utility sub to infer class API from symbol table...
# (replaces ->meta->get_methods for non-OIO classes)
sub get_symtab_methods_for :Sub(Private)
{
    my ($class_delegated_to) = @_;

    my %methods;   #...collects the methods that are found

    # Walk the class's inheritance tree...
    my @hierarchy = ($class_delegated_to);
    while (my $classname = shift @hierarchy) {
        no strict 'refs'; #...because symbols are inherently symbolic

        # Accumulate ancestors for subsequent investigation...
        push(@hierarchy, @{$classname.'::ISA'});

        # Grab and remember all subs from this class's symbol table...
        for my $symname (keys(%{$classname.'::'})) {
            # Only want symbols that define subroutines...
            next if !*{$classname.'::'.$symname}{CODE};
            # Save the necessary info...
            $methods{$symname}{'class'} = $class_delegated_to;
        }
    }

    return \%methods
}


# Utility sub to handle :Handles(Class::*) feature...
sub get_class_methods :Sub(Private)
{
    my ($class_delegated_from, $class_delegated_to) = @_;

    # Not expandable...
    return $class_delegated_to if $class_delegated_to !~ /::/;

    # Clean up any trailing ::...
    $class_delegated_to =~ s/::+$//;

    # Grab all known method names of specified class...
    my $methods = $class_delegated_to->can('meta')
                        ? $class_delegated_to->meta()->get_methods()
                        : get_symtab_methods_for($class_delegated_to);

    # Select the "real" ones...
    no strict 'refs';
    return grep {
        # Ignore "infrastructure" methods...
        !/^(?:new|clone|meta|set)$/

        # Ignore Object::InsideOut internal methods...
        && $methods->{$_}{class} eq $class_delegated_to

        # Ignore methods already installed...
        && !*{"${class_delegated_from}::$_"}{CODE}

    } keys %{$methods};
}


# Creates object data accessors for classes
sub create_accessors :Sub(Private)
{
    my ($pkg, $field_ref, $attr, $use_want) = @_;

    # Extract info from attribute
    my ($kind) = $attr =~ /^(\w+)/;
    my ($name) = $attr =~ /^\w+\s*\(\s*'?([\w:()]*)'?\s*\)$/;
    my ($decl) = $attr =~ /^\w+\s*\(\s*(.*)\s*\)/;
    my $type_code;

    if ($name) {
        $decl = "{'$kind'=>'$name'}";
        undef($name);
    } elsif (! $decl) {
        return if ($kind =~ /^Field/i);
        OIO::Attribute->die(
            'message'   => "Missing declarations for attribute in package '$pkg'",
            'Attribute' => $attr);
    } elsif (($kind =~ /^Type/i) && ($decl =~ /^(?:sub|\\&)/)) {
        $type_code = $decl;
        $decl = "{'$kind'=>$decl}";
    } elsif ($kind =~ /^Hand/i) {
        $decl =~ s/['",]/ /g;
        $decl = "{'$kind'=>'$decl'}";
    } elsif ($kind !~ /^Field/i) {
        if (! ($decl =~ s/'?name'?\s*=>/'$kind'=>/i)) {
            OIO::Attribute->die(
                'message'   => "Missing 'Name' parameter for attribute in package '$pkg'",
                'Attribute' => $attr);
        }
    }

    # Parse the accessor declaration
    my $acc_spec;
    {
        # Ensure the attribute declaration is a hash
        if ($decl !~ /^{/) {
            $decl = "{ $decl }";
        }

        my @errs;
        local $SIG{'__WARN__'} = sub { push(@errs, @_); };

        eval "package $pkg; use $]; \$acc_spec = $decl";

        if ($@ || @errs) {
            my ($err) = split(/ at /, $@ || join(" | ", @errs));
            OIO::Attribute->die(
                'message'   => "Malformed attribute in package '$pkg'",
                'Error'     => $err,
                'Attribute' => $attr);
        }
    }

    my $fld_type = $GBL{'fld'}{'type'};

    # Get info for accessors/delegators
    my ($get, $set, $return, $private, $restricted, $lvalue, $arg, $pre, $delegate);
    my $accessor_type = 'accessor';
    if ($kind !~ /^arg$/i) {
        foreach my $key (keys(%{$acc_spec})) {
            my $key_uc = uc($key);
            my $val = $$acc_spec{$key};

            # :InitArgs
            if ($key_uc =~ /ALL/) {
                $arg = $val;
                if ($key_uc eq 'ALL') {
                    $key_uc = 'ACC';
                }
            } elsif ($key_uc =~ /R(?:EAD)?O(?:NLY)?/) {
                $arg = $val;
                if ($key_uc =~ /^R(?:EAD)?O(?:NLY)?$/) {
                    $key_uc = 'GET';
                }
            } elsif ($key_uc =~ /ARG/) {
                $arg = $val;
                $key_uc = 'IGNORE';
            }

            # Standard accessors
            if ($key_uc =~ /^ST.*D.*R(?:EAD)?O(?:NLY)?/) {
                $get = 'get_' . $val;
            }
            elsif ($key_uc =~ /^ST.*D/) {
                $get = 'get_' . $val;
                $set = 'set_' . $val;
            }
            # Get and/or set accessors
            elsif ($key_uc =~ /^ACC|^COM|^MUT|[GS]ET/) {
                # Get accessor
                if ($key_uc =~ /ACC|COM|MUT|GET/) {
                    $get = $val;
                }
                # Set accessor
                if ($key_uc =~ /ACC|COM|MUT|SET/) {
                    $set = $val;
                }
            }
            # Deep clone the field
            elsif ($key_uc eq 'COPY' || $key_uc eq 'CLONE') {
                if (uc($val) eq 'DEEP') {
                    $GBL{'fld'}{'deep'}{$field_ref} = 1;
                }
                next;
            } elsif ($key_uc eq 'DEEP') {
                if ($val) {
                    $GBL{'fld'}{'deep'}{$field_ref} = 1;
                }
                next;
            }
            # Store weakened refs
            elsif ($key_uc =~ /^WEAK/) {
                if ($val) {
                    $GBL{'fld'}{'weak'}{$field_ref} = 1;
                }
                next;
            }
            # Field type checking for set accessor
            elsif ($key_uc eq 'TYPE') {
                # Check type-checking setting and set default
                if (!$val || (ref($val) && (ref($val) ne 'CODE'))) {
                    OIO::Attribute->die(
                        'message'   => "Can't create accessor method for package '$pkg'",
                        'Info'      => q/Bad 'Type' specifier: Must be a 'string' or code ref/,
                        'Attribute' => $attr);
                }
                # Normalize type declaration
                if (! ref($val)) {
                    $val =~ s/\s//g;
                    my $subtype;
                    if ($val =~ /^(.*)\((.+)\)$/i) {
                        $val = $1;
                        $subtype = $2;
                        if ($subtype =~ /^num(?:ber|eric)?$/i) {
                            $subtype = 'numeric';
                        } elsif ($subtype =~ /^scalar$/i) {
                            $subtype = 'scalar';
                        }
                    }
                    if ($val =~ /^num(?:ber|eric)?$/i) {
                        $val = 'numeric';
                    } elsif ($val =~ /^scalar$/i) {
                        $val = 'scalar';
                    } elsif ($val =~ /^(?:list|array)$/i) {
                        $val = 'list';
                    } elsif (uc($val) eq 'HASH') {
                        $val = 'HASH';
                    } elsif ($val =~ /^(hash|array|scalar)_?ref$/i) {
                        $val = uc($1) . '_ref';
                    }
                    if ($subtype) {
                        $val .= "($subtype)";
                    }
                }
                my $type = {
                    type => $val,
                    code => $type_code,
                };
                $$fld_type{$field_ref} = $type;
                push(@{$GBL{'fld'}{'regen'}{'type'}}, [ $field_ref, $type ]);
                next;
            }
            # Field name for ->dump()
            elsif ($key_uc eq 'NAME') {
                $name = $val;
            }
            # Set accessor return type
            elsif ($key_uc =~ /^RET(?:URN)?$/) {
                $return = uc($val);
            }
            # Set accessor permission
            elsif ($key_uc =~ /^PERM|^PRIV|^REST/) {
                if ($key_uc =~ /^PERM/) {
                    if ($val =~ /^PRIV/i) {
                        my @exempt = split(/[(),\s]+/, $val);
                        @exempt = grep { $_ } @exempt;
                        shift(@exempt);
                        unshift(@exempt, $pkg);
                        $private = "'" . join("','", @exempt) . "'";
                    } elsif ($val =~ /^REST/i) {
                        my @exempt = split(/[(),\s]+/, $val);
                        @exempt = grep { $_ } @exempt;
                        shift(@exempt);
                        $restricted = "'" . join("','", @exempt) . "'";
                    }
                } elsif ($key_uc =~ /^PRIV/) {
                    if ($val) {
                        $private = "'$pkg'";
                    }
                } elsif ($key_uc =~ /^REST/) {
                    if ($val) {
                        $restricted = '';
                    }
                }
            }
            # :lvalue accessor
            elsif ($key_uc =~ /^LV/) {
                if ($val && !Scalar::Util::looks_like_number($val)) {
                    $get = $val;
                    $set = $val;
                    $lvalue = 1;
                } else {
                    $lvalue = $val;
                }
            }
            # Preprocessor
            elsif ($key_uc =~ /^PRE/) {
                $pre = $val;
                if (ref($pre) ne 'CODE') {
                    OIO::Attribute->die(
                        'message'   => "Can't create accessor method for package '$pkg'",
                        'Info'      => q/Bad 'Preprocessor' specifier: Must be a code ref/,
                        'Attribute' => $attr);
                }
            }
            # Delegator
            elsif ($key_uc =~ /^HAND/) {
                $delegate = $val;
                $accessor_type = 'delegator';
            }
            # Unknown parameter
            elsif ($key_uc ne 'IGNORE') {
                OIO::Attribute->die(
                    'message' => "Can't create accessor method for package '$pkg'",
                    'Info'    => "Unknown accessor specifier: $key");
            }

            # $val must have a usable value
            if (! defined($val) || $val eq '') {
                OIO::Attribute->die(
                    'message'   => "Invalid '$key' entry in attribute",
                    'Attribute' => $attr);
            }
        }
    }

    # :InitArgs
    if ($arg || ($kind =~ /^ARG$/i)) {
        my $g_args = $GBL{'args'};
        if (! exists($$g_args{$pkg})) {
            $$g_args{$pkg} = {};
        }
        $g_args = $$g_args{$pkg};
        if (!$arg) {
            $arg = hash_re($acc_spec, qr/^ARG$/i);
            $$g_args{$arg} = normalize($acc_spec);
        }
        if (!defined($name)) {
            $name = $arg;
        }
        $$g_args{$arg}{'_F'} = $field_ref;
        # Add type to :InitArgs
        if ($$fld_type{$field_ref} && ! exists($$g_args{$arg}{'_T'})) {
            $$g_args{$arg}{'_T'} = $$fld_type{$field_ref}{'type'};
        }

        # Add default to :InitArgs
        if (my $g_def = delete($GBL{'fld'}{'def'}{$pkg})) {
            my @defs;
            foreach my $item (@{$g_def}) {
                if ($field_ref == $$item[0]) {
                    $$g_args{$arg}{'_D'} = $$item[1];
                } else {
                    push(@defs, $item);
                }
            }
            if (@defs) {
                $GBL{'fld'}{'def'}{$pkg} = \@defs;
            }
        }
    }

    # Add field info for dump()
    my $dump = $GBL{'dump'}{'fld'};
    $$dump{$pkg} ||= {};
    $dump = $$dump{$pkg};

    if ($name) {
        if (add_dump_field('Name', $name, $field_ref, $dump) eq 'conflict') {
            OIO::Attribute->die(
                'message'   => "Can't create accessor method for package '$pkg'",
                'Info'      => "'$name' already specified for another field using '$$dump{$name}{'src'}'",
                'Attribute' => $attr);
        }
        # Done if only 'Name' present
        if (! $get && ! $set && ! $return && ! $lvalue) {
            return;
        }
    } elsif ($get) {
        if (add_dump_field('Get', $get, $field_ref, $dump) eq 'conflict') {
            OIO::Attribute->die(
                'message'   => "Can't create accessor method for package '$pkg'",
                'Info'      => "'$get' already specified for another field using '$$dump{$get}{'src'}'",
                'Attribute' => $attr);
        }
    } elsif ($set) {
        if (add_dump_field('Set', $set, $field_ref, $dump) eq 'conflict') {
            OIO::Attribute->die(
                'message'   => "Can't create accessor method for package '$pkg'",
                'Info'      => "'$set' already specified for another field using '$$dump{$set}{'src'}'",
                'Attribute' => $attr);
        }
    } elsif (! $return && ! $lvalue && ! $delegate) {
        return;
    }

    # If 'RETURN' or 'LVALUE', need 'SET', too
    if (($return || $lvalue) && ! $set) {
        OIO::Attribute->die(
            'message'   => "Can't create accessor method for package '$pkg'",
            'Info'      => "No set accessor specified to go with 'RETURN'/'LVALUE'",
            'Attribute' => $attr);
    }

    # Check for name conflict
    foreach my $method ($get, $set) {
        if ($method) {
            no strict 'refs';
            # Do not overwrite existing methods
            if (*{$pkg.'::'.$method}{CODE}) {
                OIO::Attribute->die(
                    'message'   => q/Can't create accessor method/,
                    'Info'      => "Method '$method' already exists in class '$pkg'",
                    'Attribute' => $attr);
            }
        }
    }

    # Check return type and set default
    if (! defined($return) || $return eq 'NEW') {
        $return = 'NEW';
    } elsif ($return eq 'OLD' || $return =~ /^PREV(?:IOUS)?$/ || $return eq 'PRIOR') {
        $return = 'OLD';
    } elsif ($return eq 'SELF' || $return =~ /^OBJ(?:ECT)?$/) {
        $return = 'SELF';
    } else {
        OIO::Attribute->die(
            'message'   => q/Can't create accessor method/,
            'Info'      => "Invalid setting for 'RETURN': $return",
            'Attribute' => $attr);
    }

    # Get type checking (if any)
    my ($type, $subtype, $is_ref) = ('NONE', '', 0);
    if ($$fld_type{$field_ref}) {
        $type = $$fld_type{$field_ref}{'type'};
        if (! ref($type)) {
            if ($type =~ /^(.*)\((.+)\)$/i) {
                $type = $1;
                $subtype = $2;
            }
            if ($type =~ /^(HASH|ARRAY|SCALAR)_ref$/) {
                $type = $1;
                $is_ref = 1;
            }
        }
    }
    if ($subtype && ($type ne 'list' && $type ne 'ARRAY')) {
        OIO::Attribute->die(
            'message'   => "Invalid type specification for package '$pkg'",
            'Info'      => "Type '$type' cannot have subtypes",
            'Attribute' => $attr);
    }

    # Metadata
    my %meta;
    if ($set) {
        $meta{$set}{'kind'} = ($get && ($get eq $set)) ? 'accessor' : 'set';
        if ($lvalue) {
            $meta{$set}{'lvalue'} = 1;
        }
        $meta{$set}{'return'} = lc($return);
        # Type
        if (ref($type)) {
            $meta{$set}{'type'} = $$fld_type{$field_ref}{'code'};
        } elsif ($type ne 'NONE') {
            $meta{$set}{'type'} = $type;
        }
        if ($subtype) {
            $meta{$set}{'type'} .= "($subtype)";
        }
    }
    if ($get && (!$set || ($get ne $set))) {
        $meta{$get}{'kind'} = 'get';
    }
    foreach my $meth ($get, $set) {
        next if (! $meth);
        # Permissions
        if (defined($private)) {
            $meta{$meth}{'hidden'} = 1;
        } elsif (defined($restricted)) {
            $meta{$meth}{'restricted'} = 1;
        }
    }
    add_meta($pkg, \%meta);

    my $weak = $GBL{'fld'}{'weak'}{$field_ref};

    # Code to be eval'ed into subroutines
    my $code = "package $pkg;\n";

    # Create an :lvalue accessor
    if ($lvalue) {
        $code .= create_lvalue_accessor($pkg, $set, $field_ref, $get,
                                        $type, $is_ref, $subtype,
                                        $name, $return, $private,
                                        $restricted, $weak, $pre);
    }

    # Create 'set' or combination accessor
    elsif ($set) {
        # Begin with subroutine declaration in the appropriate package
        $code .= "*${pkg}::$set = sub {\n";

        $code .= preamble_code($pkg, $set, $private, $restricted);

        my $fld_str = (ref($field_ref) eq 'HASH') ? "\$field->\{\${\$_[0]}}" : "\$field->\[\${\$_[0]}]";

        # Add GET portion for combination accessor
        if ($get && ($get eq $set)) {
            $code .= "    return ($fld_str) if (\@_ == 1);\n";
        }

        # If set only, then must have at least one arg
        else {
            $code .= <<"_CHECK_ARGS_";
    if (\@_ < 2) {
        OIO::Args->die(
            'message'  => q/Missing arg(s) to '$pkg->$set'/,
            'location' => [ caller() ]);
    }
_CHECK_ARGS_
        }

        # Add preprocessing code block
        if ($pre) {
            $code .= <<"_PRE_";
    {
        my \@errs;
        local \$SIG{'__WARN__'} = sub { push(\@errs, \@_); };
        eval {
            my \$self = shift;
            \@_ = (\$self, \$preproc->(\$self, \$field, \@_));
        };
        if (\$@ || \@errs) {
            my (\$err) = split(/ at /, \$@ || join(" | ", \@errs));
            OIO::Code->die(
                'message' => q/Problem with preprocessing routine for '$pkg->$set'/,
                'Error'   => \$err);
        }
    }
_PRE_
        }

        # Add data type checking
        my ($type_code, $arg_str) = type_code($pkg, $set, $weak,
                                              $type, $is_ref, $subtype);
        $code .= $type_code;

        # Add field locking code if sharing
        if (is_sharing($pkg)) {
            $code .= "    lock(\$field);\n"
        }

        # Grab 'OLD' value
        if ($return eq 'OLD') {
            $code .= "    my \$ret = $fld_str;\n";
        }

        # Add actual 'set' code
        $code .= (is_sharing($pkg))
              ? "    $fld_str = Object::InsideOut::Util::make_shared($arg_str);\n"
              : "    $fld_str = $arg_str;\n";
        if ($weak) {
            $code .= "    Scalar::Util::weaken($fld_str);\n";
        }

        # Add code for return value
        if ($return eq 'SELF') {
            $code .= "    \$_[0];\n";
        } elsif ($return eq 'OLD') {
            if ($use_want) {
                $code .= "    ((Want::wantref() eq 'OBJECT') && !Scalar::Util::blessed(\$ret)) ? \$_[0] : ";
            }
            $code .= "\$ret;\n";
        } elsif ($use_want) {
            $code .= "    ((Want::wantref() eq 'OBJECT') && !Scalar::Util::blessed($fld_str)) ? \$_[0] : $fld_str;\n";
        } elsif ($weak) {
            $code .= "    $fld_str;\n";
        }

        # Done
        $code .= "};\n";
    }
    undef($type) if (! ref($type));

    # Create 'get' accessor
    if ($get && (!$set || ($get ne $set))) {
        $code .= "*${pkg}::$get = sub {\n"

               . preamble_code($pkg, $get, $private, $restricted, 'readonly')

               . ((ref($field_ref) eq 'HASH')
                    ? "    \$field->{\${\$_[0]}};\n};\n"
                    : "    \$field->[\${\$_[0]}];\n};\n");
    }

    # Create delegation accessor
    if ($delegate) {
        $delegate =~ s/\s*-->\s*/-->/g;
        my @methods = split(/[,\s]+/, $delegate);
        @methods = grep { $_ } @methods;
        @methods = map  { get_class_methods($pkg, $_) } @methods;
        for my $method (@methods) {
            my ($from, $to) = split(/-->/, $method);
            if (! defined($to)) {
                $to = $from;
            }
            no strict 'refs';
            if (*{$pkg.'::'.$from}{CODE}) {
                OIO::Attribute->die(
                    'message'   => q/Can't create delegator method/,
                    'Info'      => "Method '$from' already exists in class '$pkg'",
                    'Attribute' => $attr);
            }
            $code .= "*${pkg}::$from = sub {\n"

                . preamble_code($pkg, $method, $private, $restricted)

                . "    my \$self = shift;\n"

                . ((ref($field_ref) eq 'HASH')
                        ? "    \$field->{\${\$self}}->$to(\@_);\n};\n"
                        : "    \$field->[\${\$self}]->$to(\@_);\n};\n");
        }
    }

    # Compile the subroutine(s) in the smallest possible lexical scope
    my @errs;
    local $SIG{'__WARN__'} = sub { push(@errs, @_); };
    {
        my $field      = $field_ref;
        my $type_check = $type;
        my $preproc    = $pre;
        eval $code;
    }
    if ($@ || @errs) {
        my ($err) = split(/ at /, $@ || join(" | ", @errs));
        OIO::Internal->die(
            'message'     => "Failure creating accessor for class '$pkg'",
            'Error'       => $err,
            'Declaration' => $attr,
            'Code'        => $code,
            'self'        => 1);
    }
}


# Generate code for start of accessor
sub preamble_code :Sub(Private)
{
    my ($pkg, $name, $private, $restricted, $readonly) = @_;
    my $code = '';

    # Argument checking code
    if (defined($readonly)) {
        $code = <<"_READONLY_";
    if (\@_ > 1) {
        OIO::Method->die('message' => "Can't call readonly accessor method '$pkg->$name' with an argument");
    }
_READONLY_
    }

    # Permission checking code
    if (defined($private)) {
        $code = <<"_PRIVATE_";
    my \$caller = caller();
    if (! grep { \$_ eq \$caller } ($private)) {
        OIO::Method->die('message' => "Can't call private method '$pkg->$name' from class '\$caller'");
    }
_PRIVATE_
    } elsif (defined($restricted)) {
        $code = <<"_RESTRICTED_";
    my \$caller = caller();
    if (! ((grep { \$_ eq \$caller } ($restricted)) ||
           \$caller->isa('$pkg')                   ||
           $pkg->isa(\$caller)))
    {
        OIO::Method->die('message'  => "Can't call restricted method '$pkg->$name' from class '\$caller'");
    }
_RESTRICTED_
    }

    return ($code);
}


# Generate type checking code
sub type_code :Sub(Private)
{
    my ($pkg, $name, $weak, $type, $is_ref, $subtype) = @_;
    my $code = '';
    my $arg_str = '$_[1]';

    # Type checking code
    if (ref($type)) {
        $code = <<"_CODE_";
    {
        my (\$ok, \@errs);
        local \$SIG{'__WARN__'} = sub { push(\@errs, \@_); };
        eval { \$ok = \$type_check->($arg_str) };
        if (\$@ || \@errs) {
            my (\$err) = split(/ at /, \$@ || join(" | ", \@errs));
            OIO::Code->die(
                'message' => q/Problem with type check routine for '$pkg->$name'/,
                'Error'   => \$err);
        }
        if (! \$ok) {
            OIO::Args->die(
                'message'  => "Argument to '$pkg->$name' failed type check: $arg_str",
                'location' => [ caller() ]);
        }
    }
_CODE_

    } elsif ($type eq 'NONE') {
        # For 'weak' fields, the data must be a ref
        if ($weak) {
            $code = <<"_WEAK_";
    if (! ref($arg_str)) {
        OIO::Args->die(
            'message'  => "Bad argument: $arg_str",
            'Usage'    => q/Argument to '$pkg->$name' must be a reference/,
            'location' => [ caller() ]);
    }
_WEAK_
        }

    } elsif ($type eq 'scalar') {
        # One scalar argument
        $code = <<"_SCALAR_";
    if (ref($arg_str)) {
        OIO::Args->die(
            'message'  => "Bad argument: $arg_str",
            'Usage'    => q/Argument to '$pkg->$name' must be a scalar/,
            'location' => [ caller() ]);
    }
_SCALAR_

    } elsif ($type eq 'numeric') {
        # One numeric argument
        $code = <<"_NUMERIC_";
    if (! Scalar::Util::looks_like_number($arg_str)) {
        OIO::Args->die(
            'message'  => "Bad argument: $arg_str",
            'Usage'    => q/Argument to '$pkg->$name' must be a number/,
            'location' => [ caller() ]);
    }
_NUMERIC_

    } elsif ($type eq 'list') {
        # List/array - 1+ args or array ref
        $code = <<'_ARRAY_';
    my $arg;
    if (@_ == 2 && ref($_[1]) eq 'ARRAY') {
        $arg = $_[1];
    } else {
        my @args = @_;
        shift(@args);
        $arg = \@args;
    }
_ARRAY_
        $arg_str = '$arg';

    } elsif ($type eq 'HASH' && !$is_ref) {
        # Hash - pairs of args or hash ref
        $code = <<"_HASH_";
    my \$arg;
    if (\@_ == 2 && ref(\$_[1]) eq 'HASH') {
        \$arg = \$_[1];
    } elsif (\@_ % 2 == 0) {
        OIO::Args->die(
            'message'  => q/Odd number of arguments: Can't create hash ref/,
            'Usage'    => q/'$pkg->$name' requires a hash ref or an even number of args (to make a hash ref)/,
            'location' => [ caller() ]);
    } else {
        my \@args = \@_;
        shift(\@args);
        my \%args = \@args;
        \$arg = \\\%args;
    }
_HASH_
        $arg_str = '$arg';

    } else {
        # One object or ref arg - exact spelling and case required
        $code = <<"_REF_";
    if (! Object::InsideOut::Util::is_it($arg_str, '$type')) {
        OIO::Args->die(
            'message'  => q/Bad argument: Wrong type/,
            'Usage'    => q/Argument to '$pkg->$name' must be of type '$type'/,
            'location' => [ caller() ]);
    }
_REF_
    }

    # Subtype checking code
    if ($subtype) {
        if ($subtype =~ /^scalar$/i) {
            $code .= <<"_SCALAR_SUBTYPE_";
    foreach my \$elem (\@{$arg_str}) {
        if (ref(\$elem)) {
            OIO::Args->die(
                'message'  => q/Bad argument: Wrong type/,
                'Usage'    => q/Values to '$pkg->$name' must be scalars/,
                'location' => [ caller() ]);
        }
    }
_SCALAR_SUBTYPE_
        } elsif ($subtype =~ /^num(?:ber|eric)?$/i) {
            $code .= <<"_NUM_SUBTYPE_";
    foreach my \$elem (\@{$arg_str}) {
        if (! Scalar::Util::looks_like_number(\$elem)) {
            OIO::Args->die(
                'message'  => q/Bad argument: Wrong type/,
                'Usage'    => q/Values to '$pkg->$name' must be numeric/,
                'location' => [ caller() ]);
        }
    }
_NUM_SUBTYPE_
        } else {
            $code .= <<"_SUBTYPE_";
    foreach my \$elem (\@{$arg_str}) {
        if (! Object::InsideOut::Util::is_it(\$elem, '$subtype')) {
            OIO::Args->die(
                'message'  => q/Bad argument: Wrong type/,
                'Usage'    => q/Values to '$pkg->$name' must be of type '$subtype'/,
                'location' => [ caller() ]);
        }
    }
_SUBTYPE_
        }
    }

    return ($code, $arg_str);
}


### Wrappers ###

# Returns a 'wrapper' closure back to initialize() that adds merged argument
# support for a method.
sub wrap_MERGE_ARGS :Sub(Private)
{
    my $code = shift;
    return sub {
        my $self = shift;

        # Gather arguments into a single hash ref
        my $args = {};
        while (my $arg = shift) {
            if (ref($arg) eq 'HASH') {
                # Add args from a hash ref
                @{$args}{keys(%{$arg})} = values(%{$arg});
            } elsif (ref($arg)) {
                OIO::Args->die(
                    'message'  => "Bad initializer: @{[ref($arg)]} ref not allowed",
                    'Usage'    => q/Args must be 'key=>val' pair(s) and\/or hash ref(s)/);
            } elsif (! @_) {
                OIO::Args->die(
                    'message'  => "Bad initializer: Missing value for key '$arg'",
                    'Usage'    => q/Args must be 'key=>val' pair(s) and\/or hash ref(s)/);
            } else {
                # Add 'key => value' pair
                $$args{$arg} = shift;
            }
        }

        @_ = ($self, $args);
        goto $code;
    };
}


# Returns a 'wrapper' closure back to initialize() that restricts a method
# to being only callable from within its class hierarchy
sub wrap_RESTRICTED :Sub(Private)
{
    my ($pkg, $method, $code, $exempt) = @_;
    return sub {
        # Caller must be in class hierarchy, or be specified as an exemption
        my $caller = caller();
        if (! ((grep { $_ eq $caller } @$exempt) ||
               $caller->isa($pkg) ||
               $pkg->isa($caller)))
        {
            OIO::Method->die('message' => "Can't call restricted method '$pkg->$method' from class '$caller'");
        }
        goto $code;
    };
}


# Returns a 'wrapper' closure back to initialize() that makes a method
# private (i.e., only callable from within its own class).
sub wrap_PRIVATE :Sub(Private)
{
    my ($pkg, $method, $code, $exempt) = @_;
    return sub {
        # Caller must be in the package, or be specified as an exemption
        my $caller = caller();
        if (! grep { $_ eq $caller } @$exempt) {
            OIO::Method->die('message' => "Can't call private method '$pkg->$method' from class '$caller'");
        }
        goto $code;
    };
}


# Returns a 'wrapper' closure back to initialize() that makes a subroutine
# uncallable - with the original code ref stored elsewhere, of course.
sub wrap_HIDDEN :Sub(Private)
{
    my ($pkg, $method) = @_;
    return sub {
        OIO::Method->die('message' => "Can't call hidden method '$pkg->$method'");
    }
}


### Delayed Loading ###

# Loads sub-modules
sub load :Sub(Private)
{
    my $mod = shift;
    my $file = "Object/InsideOut/$mod.pm";

    if (! exists($INC{$file})) {
        # Load the file
        my $rc = do($file);

        # Check for errors
        if ($@) {
            OIO::Internal->die(
                'message'     => "Failure compiling file '$file'",
                'Error'       => $@,
                'self'        => 1);
        } elsif (! defined($rc)) {
            OIO::Internal->die(
                'message'     => "Failure reading file '$file'",
                'Error'       => $!,
                'self'        => 1);
        } elsif (! $rc) {
            OIO::Internal->die(
                'message'     => "Failure processing file '$file'",
                'Error'       => $rc,
                'self'        => 1);
        }
    }
}

sub generate_CUMULATIVE :Sub(Private)
{
    load('Cumulative');
    goto &generate_CUMULATIVE;
}

sub create_CUMULATIVE :Sub(Private)
{
    load('Cumulative');
    goto &create_CUMULATIVE;
}

sub generate_CHAINED :Sub(Private)
{
    load('Chained');
    goto &generate_CHAINED;
}

sub create_CHAINED :Sub(Private)
{
    load('Chained');
    goto &create_CHAINED;
}

sub generate_OVERLOAD :Sub(Private)
{
    load('Overload');
    goto &generate_OVERLOAD;
}

sub install_UNIVERSAL :Sub(Private)
{
    load('Universal');
    @_ = (\%GBL);
    goto &install_UNIVERSAL;
}

sub install_ATTRIBUTES :Sub
{
    load('attributes');
    goto &install_ATTRIBUTES;
}

sub dump :Method(Object)
{
    load('Dump');
    @_ = (\%GBL, 'dump', @_);
    goto &dump;
}

sub pump :Method(Class)
{
    load('Dump');
    @_ = (\%GBL, 'pump', @_);
    goto &dump;
}

sub inherit :Method(Object)
{
    load('Foreign');
    @_ = (\%GBL, 'inherit', @_);
    goto &inherit;
}

sub heritage :Method(Object)
{
    load('Foreign');
    @_ = (\%GBL, 'heritage', @_);
    goto &inherit;
}

sub disinherit :Method(Object)
{
    load('Foreign');
    @_ = (\%GBL, 'disinherit', @_);
    goto &inherit;
}

sub create_heritage :Sub(Private)
{
    load('Foreign');
    @_ = (\%GBL, 'create_heritage', @_);
    goto &inherit;
}

sub create_field :Method(Class)
{
    load('Dynamic');
    @_ = (\%GBL, 'create_field', @_);
    goto &create_field;
}

sub add_class :Method(Class)
{
    load('Dynamic');
    @_ = (\%GBL, 'add_class', @_);
    goto &create_field;
}

sub AUTOLOAD :Sub
{
    load('Autoload');
    @_ = (\%GBL, @_);
    goto &Object::InsideOut::AUTOLOAD;
}

sub create_lvalue_accessor :Sub(Private)
{
    load('lvalue');
    goto &create_lvalue_accessor;
}


### Initialization and Termination ###

# Initialize the package after loading
initialize();

{
    # Initialize as part of the CHECK phase
    no warnings 'void';
    CHECK {
        initialize();
    }
}

# Initialize just before cloning a thread
sub CLONE_SKIP
{
    if ($_[0] eq 'Object::InsideOut') {
        initialize();
    }
    return 0;
}

# Workaround for Perl's "in cleanup" bug
END {
    $GBL{'term'} = 1;
}

}  # End of package's lexical scope

1;
# EOF
Object-InsideOut-4.05/README0000644000175000001440000001041213377136466015133 0ustar  jdheddenusersObject-InsideOut version 4.05
=============================

This module provides comprehensive support for implementing classes using the
inside-out object model.

This module implements inside-out objects as anonymous scalar references that
are blessed into a class with the scalar containing the ID for the object
(usually a sequence number).  Object data (i.e., fields) are stored within the
class's package in either arrays indexed by the object's ID, or hashes keyed
to the object's ID.

The virtues of the inside-out object model over the 'blessed hash' object
model have been extolled in detail elsewhere.  Briefly, inside-out objects
offer the following advantages over 'blessed hash' objects:

* Encapsulation

Object data is enclosed within the class's code and is accessible only through
the class-defined interface.

* Field Name Collision Avoidance

Inheritance using 'blessed hash' classes can lead to conflicts if any classes
use the same name for a field (i.e., hash key).  Inside-out objects are immune
to this problem because object data is stored inside each class's package, and
not in the object itself.

* Compile-time Name Checking

A common error with 'blessed hash' classes is the misspelling of field names:

    $obj->{'coment'} = 'No comment';   # Should be 'comment' not 'coment'

As there is no compile-time checking on hash keys, such errors do not usually
manifest themselves until runtime.

With inside-out objects, data is accessed using methods, the names of which
are checked by the Perl compiler such that any typos are easily caught using
"perl -c".


This module offers all the capabilities of other inside-out object modules
with the following additional key advantages:

* Speed

When using arrays for storing object data, Object::InsideOut objects are as
much as 40% faster than 'blessed hash' objects for fetching and setting data,
and even with hashes they are still several percent faster than 'blessed hash'
objects.

* Threads

Object::InsideOut is thread safe, and thoroughly supports sharing objects
between threads using threads::shared.

* Flexibility

Allows control over object ID specification, accessor naming, parameter name
matching, and more.

* 'Runtime' Support

Supports classes that may be loaded at runtime (i.e., using "eval { require
...; };").  This makes it usable from within mod_perl, as well.  Also supports
additions to class hierarchies, and dynamic creation of object fields during
runtime.

* Perl 5.6

Tested on Perl v5.6.0 through v5.6.2, v5.8.0 through v5.8.8, and v5.9.3.

* Exception Objects

As recommended in "Perl Best Practices", Object::InsideOut uses
Exception::Class for handling errors in an OO-compatible manner.

* Object Serialization

Object::InsideOut has built-in support for object dumping and reloading that
can be accomplished in either an automated fashion or through the use of
class-supplied subroutines.  Serialization using 'Storable' is also supported.

* Foreign Class Inheritance

Object::InsideOut allows classes to inherit from foreign (i.e.,
non-Object::InsideOut) classes, thus allowing you to sub-class other Perl
class, and access their methods from your own objects.

* Introspection

Obtain constructor parameters and method metadata for Object::InsideOut
classes.

INSTALLATION

To install this module type the following:

    perl Makefile.PL
    make
    make test
    make install

or if you have Module::Build installed:

    perl Build.PL
    perl Build
    perl Build test
    perl Build install

DEPENDENCIES

Requires Perl 5.6.0 or later.

This module uses the following 'standard' modules:

  ExtUtils::MakeMaker          - For installation
  Test::More (0.50 or later)   - For installation
  Scalar::Util (1.10 or later) - Standard in 5.8 or obtain from CPAN
  Data::Dumper
  attributes
  overload
  B

This module requires the following module available from CPAN:

  Exception::Class (1.22 or later)

Using the :lvalue accessor feature of this module requires the following
module from CPAN:

  Want (0.12 or later)

For :SECURE mode, this module requires the following module from CPAN:

  Math::Random::MT::Auto (5.04 or later)

COPYRIGHT AND LICENCE

Copyright 2005 - 2012 Jerry D. Hedden 

This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.

# EOF
Object-InsideOut-4.05/META.yml0000664000175000001440000000145013377136477015532 0ustar  jdheddenusers---
abstract: 'Comprehensive inside-out object support module'
author:
  - 'Jerry D. Hedden '
build_requires:
  ExtUtils::MakeMaker: '0'
configure_requires:
  ExtUtils::MakeMaker: '0'
dynamic_config: 1
generated_by: 'ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010'
license: perl
meta-spec:
  url: http://module-build.sourceforge.net/META-spec-v1.4.html
  version: '1.4'
name: Object-InsideOut
no_index:
  directory:
    - t
    - inc
requires:
  B: '0'
  Config: '0'
  Data::Dumper: '2.131'
  Exception::Class: '1.32'
  Scalar::Util: '1.23'
  Test::More: '0.98'
  attributes: '0'
  overload: '0'
  strict: '0'
  warnings: '0'
version: '4.05'
x_serialization_backend: 'CPAN::Meta::YAML version 0.018'
recommends:
  Math::Random::MT::Auto: 6.18
  Want: 0.21
Object-InsideOut-4.05/examples/0000755000175000001440000000000013377136477016075 5ustar  jdheddenusersObject-InsideOut-4.05/examples/YAPI.pm0000644000175000001440000003635513377136466017207 0ustar  jdheddenuserspackage Term::YAPI; {
    use strict;
    use warnings;

    our $VERSION = '4.05';

    #####
    #
    # TODO:
    #   types - pulse
    #   STDERR
    #
    #####

    my $threaded_okay;   # Can we do indicators using threads?
    BEGIN {
        eval {
            require threads;
            die if ($threads::VERSION lt '1.31');
            require Thread::Queue;
        };
        $threaded_okay = !$@;
    }

    use Object::InsideOut 4.05;

    # Default progress indicator is a twirling bar
    my @yapi :Field
             :Type(List)
             :Arg('Name' => 'yapi', 'Regex' => qr/^yapi/i);

    # Boolean - indicator is asynchronous?
    my @is_async :Field
                 :Arg('Name' => 'async', 'Regex' => qr/^(?:async|thr)/i);

    # Boolean
    my @erase :Field
              :Arg('Name' => 'erase', 'Regex' => qr/^erase/i, 'Default' => 0);

    # Step counter for indicator
    my @step :Field;

    # Starting value for countdown indicators
    my @countdown :Field
                  :Arg('Name' => 'from', 'Regex' => qr/^from/i);

    # Start time of running indicator
    my @running :Field;

    # Type of indicator = twirl, dots, pulse, ...
    my @type :Field;

    my %init_args :InitArgs = (
        'type' => {
            'Regex'   => qr/^type$/i,
            'Default' => 'anim',
        },
    );


    my $current;   # Currently running indicator
    my $sig_int;   # Remembers existing $SIG{'INT'} handler
    my $queue;     # Shared queue for communicating with indicator thread


    # Terminal control code sequences
    my $HIDE = "\e[?25l";   # Hide cursor
    my $SHOW = "\e[?25h";   # Show cursor
    my $EL   = "\e[K";      # Erase line


    sub import
    {
        my $class = shift;   # Not used

        # Don't use terminal control code sequences for MSDOS console
        if (@_ && $_[0] =~ /(?:ms|win|dos)/i) {
            ($HIDE, $SHOW, $EL) = ('', '', (' 'x40)."\r");
        }
    }


    # Initialize a new indicator object
    sub init :Init
    {
        my ($self, $args) = @_;

        # Indicator type
        if ($$args{'type'} =~ /^anim/i) {
            $type[$$self] = 'anim';
            if (! defined($yapi[$$self])) {
                $yapi[$$self] = [ qw(/ - \ |) ];
            }

        } elsif ($$args{'type'} =~ /^dot/i) {
            $type[$$self] = 'dots';
            if (! defined($yapi[$$self])) {
                $yapi[$$self] = ['.'];
            }

        } elsif ($$args{'type'} =~ /^count$/i) {
            $type[$$self] = 'count';
            $yapi[$$self] = [ 0 ];

        } elsif ($$args{'type'} =~ /^countdown$/i) {
            $type[$$self] = 'countdown';
            if (! defined($countdown[$$self])) {
                OIO::Args->die(
                    'message'  => q/Missing 'From' parameter for countdown timer/,
                    'location' => [ caller(1) ]);
            }
            $yapi[$$self] = [ $countdown[$$self] ];

        } else {
            OIO::Args->die(
                'message'  => "Unknown indicator 'type': '$$args{'type'}'",
                'Usage'    => q/Supported types: 'anim', 'dots', 'count' and 'countdown'/,
                'location' => [ caller(1) ]);
        }

        # If this is the first async indicator, create the indicator thread
        if ($is_async[$$self] && ! $queue && $threaded_okay) {
            my $thr;
            eval {
                # Create communication queue for indicator thread
                if ($queue = Thread::Queue->new()) {
                    # Create indicator thread in 'void' context
                    # Give the thread the queue
                    $thr = threads->create({'void' => 1}, \&_yapi_thread, $queue);
                }
            };
            # If all is well, detach the thread
            if ($thr) {
                $thr->detach();
            } else {
                # Bummer :(  Can't do async indicators.
                undef($queue);
                $threaded_okay = 0;
            }
        }
    }


    # Start the indicator
    sub start :Method(object)
    {
        my $self = shift;
        my $msg  = shift || 'Working: ';

        # Stop currently running indicator
        if ($current) {
            $current->done();
        }

        # Set ourself as running
        $running[$$self] = time();
        $current = $self;
        $step[$$self] = 0;

        # Remember existing interrupt handler
        $sig_int = $SIG{'INT'};

        # Set interrupt handler
        $SIG{'INT'} = sub {
            $self->_done('INTERRUPTED');  # Stop the progress indicator
            kill(shift, $$);              # Propagate the signal
        };

        $| = 1;   # Autoflush

        # Print message and hide cursor
        print("\r$EL$msg$HIDE");

        # Set up progress
        if ($is_async[$$self]) {
            if ($threaded_okay) {
                $queue->enqueue('', $type[$$self], @{$yapi[$$self]});
                threads->yield();
            } else {
                print('wait...');     # Use this when 'async is broken'
            }
        } else {
            print($yapi[$$self][0]);  # First progress step
        }
    }


    # Returns a progress element
    sub _prog :Sub
    {
        my ($type, $yapi, $step, $max) = @_;

        my $prog = ($type eq 'count')     ? $step
                 : ($type eq 'countdown') ? $yapi->[0] - $step
                        : $yapi->[$step % $max];

        return $prog;
    }


    # String length ignoring ANSI color sequences
    sub _length :Sub
    {
        my $s = shift;
        $s =~ s/\e.+?m//g;
        return length($s);
    }

    # Generates a string to erase the previous progress element
    sub _undo :Sub
    {
        my ($type, $yapi, $step, $max, $last) = @_;

        my $undo = ($type eq 'anim')
                        ? ("\b \b" x _length($yapi->[$step % $max]))
                 : ($type eq 'dots')
                        ? (($last) ? ' ' : '')
                 : ($type eq 'count')
                        ? ("\b \b" x _length($step))
                 : ($type eq 'countdown')
                        ? ("\b \b" x _length($yapi->[0] - $step))
                 : '';

        return $undo;
    }


    # Prints out next progress element
    sub progress :Method(object)
    {
        my $self = shift;

        return if ($is_async[$$self]);   # N/A for 'async' indicators

        if ($running[$$self]) {
            my $type = $type[$$self];
            my $yapi = $yapi[$$self];
            my $step = $step[$$self]++;
            my $max  = scalar(@{$yapi});
            print(_undo($type, $yapi, $step,   $max, 0) .
                  _prog($type, $yapi, $step+1, $max))
        } else {
            # Not running, or some other indicator is running.
            # Therefore, start this indicator.
            $self->start();
        }
    }


    # Stop the indicator
    sub _done :Private
    {
        my ($self, $msg) = @_;

        # Ignore if not running
        return if (! $running[$$self]);
        undef($running[$$self]);

        # No longer currently running indicator
        undef($current);

        # Halt indicator thread, if applicable
        if ($is_async[$$self] && $threaded_okay) {
            eval { $queue->enqueue($msg); };
            threads->yield();
            sleep(1);

        } else {
            # Display done message
            print(_undo($type[$$self], $yapi[$$self], $step[$$self], scalar(@{$yapi[$$self]}), 1)
                  . $SHOW . $msg);
        }

        # Restore any previous interrupt handler
        $SIG{'INT'} = $sig_int || 'DEFAULT';
        undef($sig_int);
    }

    # Stop the indicator, and possibly erase the line
    sub done :Method(object)
    {
        my ($self, $msg) = @_;
        $self->_done(($erase[$$self]) ? "\r$EL"  :
                     (defined($msg))  ? "$msg\n" : "done\n");
    }

    # Stop the indicator and report elapsed time
    sub endtime :Method(object)
    {
        my $self = $_[0];
        if (my $start = $running[$$self]) {
            my $time = time() - $start;

            my $hrs = int($time/3600);
            $time -= 3600*$hrs;
            my $min = int($time/60);
            my $sec = $time - 60*$min;

            $self->_done(sprintf("time = %d:%02d:%02d\n", $hrs, $min, $sec));
        }
    }

    # Stop the indicator and erase the line
    sub erase :Method(object)
    {
        $_[0]->_done("\r$EL");
    }


    # Ensure indicator is stopped when indicator object is destroyed
    sub destroy :Destroy
    {
        my $self = shift;
        $self->done();
    }


    # Progress indicator thread entry point function
    sub _yapi_thread :Sub
    {
        my $queue = shift;

        while (1) {
            # Wait for start
            my $item;
            while (! $item) {
                $item = $queue->dequeue();
            }

            # Type of indicator
            my $type = $item;

            # Gather progress elements
            my @yapi;
            while (defined($item = $queue->dequeue_nb())) {
                push(@yapi, $item);
            }

            $| = 1;   # Autoflush

            # Show progress
            my ($step, $max) = (0, scalar(@yapi));
            print($yapi[0]);
            while (! defined($item = $queue->dequeue_nb())) {
                sleep(1);
                print(_undo($type, \@yapi, $step,   $max, 0) .
                      _prog($type, \@yapi, $step+1, $max));
                $step++;
            }

            # Display done message
            print(_undo($type, \@yapi, $step, $max, 1) . $SHOW . $item);
        }
    }
}

1;

__END__

=head1 NAME

Term::YAPI - Yet Another Progress Indicator

=head1 SYNOPSIS

 use Term::YAPI;

 # Synchronous progress indicator: .o0o.o0o.o0o.
 my $yapi = Term::YAPI->new('type' => 'dots', 'yapi' => [ qw(. o 0 o) ]);
 $yapi->start('Working: ');
 foreach (1..10) {
     sleep(1);
     $yapi->progress();
 }
 $yapi->done('done');

 # Asynchronous (threaded) incrementing counter
 my $yapi = Term::YAPI->new('type' => 'count', 'async' => 1);
 $yapi->start('Waiting 10 sec.: ');
 sleep(10);
 $yapi->erase();

=head1 DESCRIPTION

Term::YAPI provides progress indicators on the terminal to let the user know
that something is happening.  The indicator can be in incrementing counter, or
can consist of one or more elements that are displayed cyclically one after
another.

The text cursor is I while progress is being displayed, and restored
after the progress indicator finishes.  A C<$SIG{'INT'}> handler is installed
while progress is being displayed so that the text cursor is automatically
restored should the user hit C.

The progress indicator can be controlled synchronously by the application, or
can run asynchronously in a thread.

=over

=item my $yapi = Term::YAPI->new()

Creates a new synchronous progress indicator object, using the default
I indicator:  / - \ |

=item my $yapi = Term::YAPI->new('type' => 'XXX');

The C<'type'> parameter specifies the type of progress indicator to be used:

=over

=item C<'type' =E 'anim'>

An I indicator - defaults to the I indicator.  This is
the default indicator type.

=item C<'type' =E 'dots'>

A character sequence indicator - defaults to a line of periods/dots:  .....

=item C<'type' =E 'count'>

An incrementing counter that starts at 0.

=item C<'type' =E 'countdown'>

An decrementing counter.  The starting value is specified using a (mandatory)
C<'from'> parameter:

 my $yapi = Term::YAPI->new('type' => 'countdown', 'from' => 15);

=back

=item my $yapi = Term::YAPI->new('yapi' => $indicator_array_ref)

The C<'yapi'> parameter supplies an array reference containing the elements
to be used for the indicator.  Examples:

 my $yapi = Term::YAPI->new('yapi' => [ qw(^ > v <) ], 'type' => 'anim');

 my $yapi = Term::YAPI->new('yapi' => [ qw(. o O o) ]);   # Either type

 my $yapi = Term::YAPI->new('yapi' => [ qw(. : | :) ]);   # Either type

This parameter is ignored for C<'type' =E 'count'> indicators.

=item my $yapi = Term::YAPI->new('async' => 1);

Creates a new asynchronous progress indicator object.

=item my $yapi = Term::YAPI->new('erase' => 1);

Indicates that the entire line occupied by the indicator is to be erased when
the indicator is terminated.

=item $yapi->start($start_msg)

Sets up the interrupt signal handler, hides the text cursor, and prints out
the optional message followed by the first progress element.  The message
defaults to 'Working: '.

For an asynchronous progress indicator, the progress elements display at one
second intervals.

=item $yapi->progress()

Displays the next progress indicator element.

This method is not used with asynchronous progress indicators.

=item $yapi->done($done_msg)

Prints out the optional message (defaults to 'done'), restores the text
cursor, and removes the interrupt handler installed by the C<-Estart()>
method (restoring any previous interrupt handler).

=item $yapi->endtime()

Terminates the indicator as with the C<-Edone()> method, and prints out
the elapsed time for the indicator.

=item $yapi->erase()

Terminates the indicator, and erases the entire line the indicator was on.

=back

The progress indicator object is reusable.  In other words, after using it
once, you can use it again just by using C<$yapi-Estart($start_msg)>.

=head1 EXAMPLE

Term::YAPI will even support using ANSI color sequences in the progress
indicator elements:

 use Term::YAPI;
 use Term::ANSIColor ':constants';

 my $l = BOLD . BLUE . '<' . RESET;
 my $r = BOLD . BLUE . '>' . RESET;
 my $x1 = RED . '.' . RESET;
 my $x2 = RED . 'o' . RESET;
 my $x3 = RED . '0' . RESET;

 my $yapi = Term::YAPI->new('type' => 'anim',
                            'yapi' => [ "$l$x1    $r",
                                        "$l $x2   $r",
                                        "$l  $x3  $r",
                                        "$l   $x2 $r",
                                        "$l    $x1$r",
                                        "$l   $x2 $r",
                                        "$l  $x3  $r",
                                        "$l $x2   $r" ],
                            'async' => 1);

 $yapi->start(GREEN . 'Watch this ' . RESET);
 sleep(10);
 $yapi->done(YELLOW . '- cool, eh?' . RESET);

=head1 INSTALLATION

The following will install YAPI.pm under the F directory in your Perl
installation:

 cp YAPI.pm `perl -MConfig -e'print $Config{privlibexp}'`/Term/

or as part of the Object::InsideOut installation process:

 perl Makefile.PL
 make
 make yapi
 make install

=head1 LIMITATIONS

Works, as is, on C, C, and the like.  When used with MSDOS
consoles, you need to add the C<:MSDOS> flag to the module declaration line:

 use Term::YAPI ':MSDOS';

When used as such, the text cursor will not be hidden when progress is being
displayed.

Generating multiple progress indicator objects and running them at different
times in an application is supported.  This module will not allow more than
one indicator to run at the same time.

Trying to use asynchronous progress indicators on non-threaded Perls will
not cause an error, but will only display 'wait...'.

=head1 SEE ALSO

L, L, L

=head1 AUTHOR

Jerry D. Hedden, Sjdhedden AT cpan DOT orgE>

=head1 COPYRIGHT AND LICENSE

Copyright 2005 - 2012 Jerry D. Hedden. All rights reserved.

This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.

=cut
Object-InsideOut-4.05/Build.PL0000644000175000001440000000406413377136466015555 0ustar  jdheddenusers# Module makefile for Object::InsideOut (using Module::Build)

use strict;
use warnings;

use Module::Build;


# Check for Scalar::Util::weaken()
eval { require Scalar::Util; };
if ($@) {
    # Not found - require minimum version
    $Scalar::Util::VERSION = 1.10;
} elsif (! Scalar::Util->can('weaken')) {
    # Pure Perl version only
    if ($Scalar::Util::VERSION < 1.10) {
        # Require minimum version
        $Scalar::Util::VERSION = 1.10;
    } else {
        # Require next higher version
        $Scalar::Util::VERSION += 0.01;
    }
}


my %more_recommends = ();
if ($] >= 5.008) {
    %more_recommends = (
        'threads'             => 1.43,
        'threads::shared'     => 1.03,
    );
}

# Create make file
Module::Build->new(
    'module_name' => 'Object::InsideOut',
    'license'     => 'perl',
    'dist_author' => 'Jerry D. Hedden ',

    'build_requires' => {
                            'Test::More'          => 0.50,
                        },

    'requires'       => {
                            'perl'                => '5.6.0',
                            'strict'              => 0,
                            'warnings'            => 0,
                            'attributes'          => 0,
                            'overload'            => 0,
                            'Config'              => 0,
                            'B'                   => 0,
                            'Data::Dumper'        => 0,
                            'Scalar::Util'        => $Scalar::Util::VERSION,
                            'Exception::Class'    => 1.22,
                        },

    'recommends'     => {
                            'Want'                      => 0.12,
                            'Storable'                  => 2.15,
                            'Test::Pod'                 => 1.26,
                            'Test::Pod::Coverage'       => 1.08,
                            'Math::Random::MT::Auto'    => 5.04,
                            %more_recommends
                        },
)->create_build_script();

# EOF
Object-InsideOut-4.05/t/0000755000175000001440000000000013377136477014522 5ustar  jdheddenusersObject-InsideOut-4.05/t/27-exception.t0000644000175000001440000000520413377136466017132 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 19;

package Foreign::Exception; {
    use Exception::Class (
        'Foreign::Exception::Base' => {
            description => 'Generic exception base class',
        },
    );
}

package Foo; {
    use Object::InsideOut;

    my @init :Field;
    my @dest :Field;

    my %init_args :InitArgs = (
        'NEW' => {
            'DEFAULT' => 1,
        },
        'INIT' => {
            'FIELD' => \@init,
        },
        'DEST'  => {
            'FIELD' => \@dest,
        },
    );

    sub _init :Init
    {
        my $self = shift;
        if ($init[$$self]) {
            die("Die in init\n");
        }
        return;
    }

    sub _destroy :Destroy
    {
        my $self = shift;
        if ($dest[$$self]) {
            die("Die in destruct\n");
        }
        return;
    }

}

package main;

my @errs;
$SIG{__WARN__} = sub { push(@errs, @_); };

{
    my $obj = eval { Foo->new(); };
    isa_ok($obj, 'Foo', 'Object');
    ok(! @errs, 'No warnings');
    undef($@); @errs = ();
}

{
    my $obj = eval { Foo->new('INIT' => 1); };
    ok(! $obj, 'No object');
    like($@->Error(), qr/^Die in init/, 'Die in init');
    ok(! @errs, 'No warnings');
    undef($@); @errs = ();
}

{
    my $obj = Foo->new('DEST' => 1);
    ok($obj && !$@ && !@errs, 'Have object');
    undef($obj);
    if ($] <= 5.013) {
        ok($@, 'Got destroy exception');
        like($@, qr/Die in destruct/, 'Die in destroy');
    } else {
        ok(! $@, 'No destroy exception');
        pass('pass');
    }
    like($errs[0], qr/Die in destruct/, 'Die in destroy warning');
    undef($@); @errs = ();
}

{
    my $obj = eval { Foo->new('INIT' => 1, 'DEST' => 1); };
    ok(! $obj, 'No object');
    like($@->Error(), qr/Die in init/, 'Die in init');
    if ($] <= 5.013 || $] > 5.013007) {
        like($@->Chain()->Error(), qr/Die in destruct/, 'Combined errors');
        ok(! @errs, 'No warnings');
    } else {
        like($errs[0], qr/Die in destruct/, 'Die in destroy warning');
        pass('pass');
    }
    undef($@); @errs = ();
}

{
    my $obj = eval {
        my $x = Foo->new();
        Foreign::Exception::Base->throw('error' => 'Aborted');
        $x;
    };
    ok(! $obj, 'No object');
    is($@->error(), 'Aborted', 'Aborted');
    ok(! @errs, 'No warnings');
    undef($@); @errs = ();
}

{
    my $obj = eval {
        my $x = Foo->new('DEST' => 1);
        Foreign::Exception::Base->throw('error' => 'Aborted');
        $x;
    };
    ok(! $obj, 'No object');
    is($@->error(), 'Aborted', 'Aborted');
    like($errs[0], qr/Die in destruct/, 'Die in destroy warning');
    undef($@); @errs = ();
}

exit(0);

# EOF
Object-InsideOut-4.05/t/99-pod.t0000644000175000001440000001061213377136466015726 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More;
if ($ENV{RUN_MAINTAINER_TESTS}) {
    plan 'tests' => 10;
} else {
    plan 'skip_all' => 'Module maintainer tests';
}

SKIP: {
    if (! eval 'use Test::Pod 1.26; 1') {
        skip('Test::Pod 1.26 required for testing POD', 1);
    }

    pod_file_ok('lib/Object/InsideOut.pod');
    pod_file_ok('lib/Object/InsideOut/Metadata.pm');
    pod_file_ok('lib/Bundle/Object/InsideOut.pm');
    pod_file_ok('examples/YAPI.pm');
}

SKIP: {
    if (! eval 'use Test::Pod::Coverage 1.08; 1') {
        skip('Test::Pod::Coverage 1.08 required for testing POD coverage', 1);
    }

    pod_coverage_ok('Object::InsideOut',
                    {
                        'trustme' => [
                            qr/^new$/,
                            qr/^clone$/,
                            qr/^set$/,
                            qr/^meta$/,
                            qr/^create_field$/,
                            qr/^add_class$/,
                            qr/^normalize$/,
                        ],
                        'private' => [
                            qr/^STORABLE_freeze$/,
                            qr/^STORABLE_thaw$/,
                            qr/^create_CHAINED$/,
                            qr/^create_CUMULATIVE$/,
                            qr/^create_accessors$/,
                            qr/^create_heritage$/,
                            qr/^create_lvalue_accessor$/,
                            qr/^generate_CHAINED$/,
                            qr/^generate_CUMULATIVE$/,
                            qr/^generate_OVERLOAD$/,
                            qr/^wrap_HIDDEN$/,
                            qr/^wrap_MERGE_ARGS$/,
                            qr/^wrap_PRIVATE$/,
                            qr/^wrap_RESTRICTED$/,
                            qr/^initialize$/,
                            qr/^install_ATTRIBUTES$/,
                            qr/^install_UNIVERSAL$/,
                            qr/^is_sharing$/,
                            qr/^load$/,
                            qr/^preamble_code$/,
                            qr/^type_code$/,
                            qr/^process_fields$/,
                            qr/^set_sharing$/,
                            qr/^sub_name$/,
                            qr/^AUTOLOAD$/,
                            qr/^CLONE$/,
                            qr/^CLONE_SKIP$/,
                            qr/^DESTROY$/,
                            qr/^MODIFY_ARRAY_ATTRIBUTES$/,
                            qr/^MODIFY_CODE_ATTRIBUTES$/,
                            qr/^MODIFY_HASH_ATTRIBUTES$/,
                            qr/^_ID$/,
                            qr/^_args$/,
                            qr/^_obj$/,
                            qr/^import$/,
                            qr/^add_dump_field$/,
                            qr/^get_class_methods$/,
                            qr/^get_symtab_methods_for$/,
                        ]
                    }
    );

    pod_coverage_ok('Object::InsideOut::Metadata', {
                        'trustme' => [ qr/^add_meta$/ ],
                    }
    );
}

SKIP: {
    if (! eval 'use Test::Spelling; 1') {
        skip('Test::Spelling required for testing POD spelling', 4);
    }
    if (system('aspell help >/dev/null 2>&1')) {
        skip("'aspell' required for testing POD spelling", 1);
    }
    set_spell_cmd('aspell list --lang=en');
    add_stopwords();
    pod_file_spelling_ok('lib/Object/InsideOut.pod', 'OIO.pod spelling');
    pod_file_spelling_ok('lib/Object/InsideOut/Metadata.pm', 'Metadata.pm POD spelling');
    pod_file_spelling_ok('lib/Bundle/Object/InsideOut.pm', 'Bundle POD spelling');
    pod_file_spelling_ok('examples/YAPI.pm', 'Term::YAPI POD spelling');
    unlink("/home/$ENV{'USER'}/en.prepl", "/home/$ENV{'USER'}/en.pws");
}

exit(0);

__DATA__

API
Hedden
Kubb
Naofumi
OO
OO-compatible
Storable
TSUJII
abigail
accessor's
attribute's
automethods
autopilotmarketing
cpan
de-serialize
gmail
metadata
namespace
non-lvalue
nt
param
parm
Pre
preproc
preprocess
pre-initialization
refaddrs
reloadable
renormalize
uncallable
unhandled

OO-callable
automethod
se

XP

MSDOS
YAPI.pm
async
anim

PREPROCESSING
Preprocessing
preprocessing
RUNTIME
Runtime
runtime
someone's

delegator
delegators
forwards
autogenerating

designator
destructor
subtype
URI
decrementing
incrementing
syntaxes

READONLY

Arrayify
Boolify
Globify
Hashify
Numerify
PreInit
YAPI

MetaCPAN
__END__
Object-InsideOut-4.05/t/07a-dump.t0000644000175000001440000000427013377136466016242 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 12;

package MyBase; {
    use Object::InsideOut;

    my @public  :Field;
    my @private :Field;

    my %init_args :InitArgs = (
        'pub' => {
            'field' => \@public,
        },
        'priv' => {
            'field' => \@private,
            'def'   => 'base priv',
        },
    );

    # No :Init sub needed
}

package MyDer; {
    use Object::InsideOut qw(MyBase);

    my @public  :Field;
    my @private :Field;
    my @misc :Field;

    my %init_args :InitArgs = (
        'pub' => {
            'field' => \@public,
        },
        'priv' => {
            'field' => \@private,
            'def'   => 'der priv',
        },
        'misc' => '',
    );

    sub _init :Init
    {
        my ($self, $args) = @_;

        if (exists($args->{'misc'})) {
            $self->set(\@misc, $args->{'misc'});
        }
    }
}

package main;

MAIN:
{
    my $obj = MyDer->new({
                  MyBase => { pub => 'base pub' },
                  MyDer  => { pub => 'der pub'  },
                  'misc' => 'other',
              });

    my $dump = $obj->dump();

    ok($dump                                  => 'Representation is valid');
    is(ref($dump), 'ARRAY'                    => 'Representation is valid');
    my ($class, $hash) = @{$dump};

    is($class, 'MyDer'                        => 'Class');

    is($hash->{MyBase}{'pub'}, 'base pub'     => 'Public base attribute');
    is($hash->{MyBase}{'priv'}, 'base priv'   => 'Private base attribute');

    is($hash->{MyDer}{'pub'}, 'der pub'       => 'Public derived attribute');
    is($hash->{MyDer}{'priv'}, 'der priv'     => 'Private derived attribute');
    is(Object::InsideOut::Util::hash_re($hash->{MyDer}, qr/^ARRAY/), 'other'
                                              => 'Hidden derived attribute');

    my $str = $obj->dump(1);
    #print(STDERR $str, "\n");

    my $dump2 = eval $str;

    ok($str && ! ref($str)                    => 'String dump');
    ok($dump2                                 => 'eval is valid');
    is(ref($dump2), 'ARRAY'                   => 'eval is valid');
    is_deeply($dump, $dump2                   => 'Dumps are equal');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/49a-delegators-non-OIO.t0000644000175000001440000000174213377136466020651 0ustar  jdheddenusers# Test that non-OIO-based classes can be delegated to...

use strict;
use warnings;

use Test::More tests => 4;

package Base::Class; {
  sub new { bless {}, shift }

  sub foo { 'base foo' }
  sub bar { 'base bar' }
}


package Other::Base; {
  sub other { 'other base other' }
  sub baz   { 'other base baz'   }
}


package Other; {
    use base 'Other::Base';
}


package Bork; {
    use base 'Base::Class';
    use base 'Other';

    sub bar { 'der bar' }
    sub baz { 'der baz' }
}


package Test; {
    use Object::InsideOut;

    my @handler :Field Handles(Bork::) Default( Bork->new );

    sub baz { 'test baz' }
}


package main;
MAIN:
{
    my $obj = Test->new();

    is $obj->baz(),   'test baz'         => 'Direct call to baz() works';
    is $obj->bar(),   'der bar'          => 'Delegated bar() call works';
    is $obj->foo(),   'base foo'         => 'Delegated foo() call works';
    is $obj->other(), 'other base other' => 'Delegated other() call works';
}

exit(0);

# EOF
Object-InsideOut-4.05/t/24-preproc.t0000644000175000001440000000257013377136466016606 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 6;

package My::Class; {
    use Object::InsideOut;

    my @data :Field('Get' => 'data');
    my @info :Field('Get' => 'info');
    my @misc :Field('Get' => 'misc');

    my %init_args :InitArgs = (
        'DATA' => {
            'Preproc' => \&preproc,
            'Field'   => \@data,
        },
        'INFO' => {
            'Preproc' => \&preproc,
            'Field'   => \@info,
            'Default' => 'deleted',
        },
        'MISC' => {
            'Preproc' => \&preproc,
            'Field'   => \@misc,
        },
    );

    sub preproc
    {
        my ($class, $param, $spec, $obj, $value) = @_;

        Test::More::is($class, __PACKAGE__, 'Correct class');

        # Delete param and let specified default be set
        if (exists($$spec{'Default'})) {
            return;
        }

        # Override the specified value
        if (defined($value)) {
            return ('overridden');
        }

        # Provide a default
        return ('default');
    }
};

package main;

MAIN:
{
    my $obj = My::Class->new('INFO' => 'information',
                             'MISC' => 'miscellaneous');

    is($obj->data(), 'default'    => 'Preprocessing - default');
    is($obj->info(), 'deleted'    => 'Preprocessing - deleted');
    is($obj->misc(), 'overridden' => 'Preprocessing - overridden');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/23-weak.t0000644000175000001440000000245213377136466016061 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 10;

package Foo; {
    use Object::InsideOut;
    my @foo :Field('Acc' => 'foo')
            :Weak;

    my %init_args :InitArgs = (
        'foo' => {
            'Field' => \@foo,
        },
    );

    sub direct
    {
        my ($self, $data) = @_;
        $self->set(\@foo, $data);
    }
}


package Bar; {
    use Object::InsideOut;
}


package main;

my $obj = Foo->new();

my ($clone, $pump, $initargs, $set);

{
    my $dat = Bar->new();

    $obj->foo($dat);
    is($obj->foo(), $dat        => 'Stored object');

    $clone = $obj->clone();
    is($clone->foo(), $dat      => 'Object in clone');

    $pump = Object::InsideOut::pump($clone->dump());
    is($pump->foo(), $dat       => 'Object in pump');

    $initargs = Foo->new('foo' => $dat);
    is($initargs->foo(), $dat   => 'Object in initargs');

    $set = Foo->new();
    $set->direct($dat);
    is($set->foo(), $dat        => 'Object in set');

    # $dat now goes out of scope and is destroyed
}

ok(! $obj->foo()                => 'Data gone');
ok(! $clone->foo()              => 'Data gone in clone');
ok(! $pump->foo()               => 'Data gone in pump');
ok(! $initargs->foo()           => 'Data gone in initargs');
ok(! $set->foo()                => 'Data gone in set');

exit(0);

# EOF
Object-InsideOut-4.05/t/49-delegators.t0000644000175000001440000000611513377136466017273 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 11;

# The::Borg is a class we want to delegate to...
package The::Borg; {
    use Object::InsideOut;

    sub assimilate {
        return "You will be assimilated";
    }

    sub admonish {
        return "Resistance is futile";
    }

    sub advise {
        return "We will add your biological and cultural distinctiveness to our own";
    }

    sub answer {
        return "No";
    }
}

# Federation is another class we want to delegate to...
package Federation; {
    use Object::InsideOut;

    sub assimilate {
        return "Welcome to the Federation";
    }

    sub admonish {
        return "Respect the Prime Directive";
    }

    sub advise {
        my ($self, $who) = @_;
        return "We come in peace, $who (shoot to kill!)";
    }

    sub answer {
        return "Ye kenna change the laws o' physics";
    }

    sub assist {
        return "The Prime Directive forbids us to intervene";
    }
}

package Foo; {
    use Object::InsideOut;

    sub foo {
        return 'bar';
    }
}

package Delegator; {
    use Object::InsideOut;

    my @borg :Field(Std=>'borg', Handles=>'engulf-->assimilate')
             :Type(The::Borg);
    my @fed  :Field('Std'=>'fed', 'Handles'=>'admonish advise', Type=>'Federation');
    my @foo  :Field('Std'=>'foo')
             :Handle('baz' --> 'foo')
             :Handle('bar' --> 'foo');

    sub init : Init {
        my ($self, $args) = @_;

        $self->set_borg(The::Borg->new());
        $self->set_fed(Federation->new());
        $self->set_foo(Foo->new());
    }

    sub answer : Method {
        return "Aye, captain";
    }
}


package DelegatorClassy; {
    use Object::InsideOut;

    my @borg :Field(Std=>'borg', Handles=>'The::Borg')
             :Type(The::Borg);

    my @fed  :Std(fed) :Handles(Federation::) :Type(Federation);

    sub init : Init {
        my ($self, $args) = @_;

        $self->set_borg(The::Borg->new());
        $self->set_fed(Federation->new());
    }

    sub answer : Method {
        return "Aye, captain";
    }
}

package main;
MAIN:
{
    my $obj = Delegator->new();

    is($obj->engulf,        The::Borg->assimilate,     'engulf delegated to Borg->assimilate');
    is($obj->admonish,      Federation->admonish,      'admonish delegated to Federation');
    is($obj->advise('sir'), Federation->advise('sir'), 'advise delegated to Federation');
    is($obj->answer,        Delegator->answer,         'answer did not delegate');
    is($obj->baz,           Foo->foo,                  'first :Handle works');
    is($obj->bar,           Foo->foo,                  'second :Handle works');
}

{
    my $obj = DelegatorClassy->new();

    is($obj->assimilate,    The::Borg->assimilate,     'assimilate delegated to Borg');
    is($obj->admonish,      The::Borg->admonish,       'admonish delegated to Borg');
    is($obj->advise('sir'), The::Borg->advise('sir'),  'advise delegated to Borg');
    is($obj->assist(),      Federation->assist(),      'assist delegated to Federation');
    is($obj->answer,        DelegatorClassy->answer,   'answer did not delegate');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/01a-basic.t0000644000175000001440000001352113377136466016347 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 39;

package MyBase; {
    use Object::InsideOut;

    my @name :Field('Get' => 'get_name');
    my @rank :Field('Std' => 'rank');
    my @snum :Field('Get' => 'get_snum');
    my @priv :Field('get/set' => 'priv');
    my @def  :Field('Get' => 'get_default');

    my %init_args :InitArgs = (
        'name' => { 'Field' => \@name },
        'rank' => { 'Field' => \@rank },
        'SNUM' => {
            'Regexp'    => qr/^snum$/i,
            'Mandatory' => 1
        },
        'PRIV' => qr/^priv(?:ate)?$/,
        'def'  => {
            'Field'   => \@def,
            'Default' => 'MyBase::def',
        },
    );

    sub init :Init
    {
        my ($self, $args) = @_;

        Test::More::is(ref($args), 'HASH'
                            => 'Args passed to MyBase::init in hash-ref');

        $self->set(\@priv, $args->{'PRIV'});
        Test::More::is($priv[$$self], 'MyBase::priv'
                            => 'MyBase priv arg unpacked correctly');

        $self->set(\@snum, $args->{'SNUM'} . '!');
        Test::More::is($snum[$$self], 'MyBase::snum!'  => 'MyBase snum arg unpacked correctly');
    }

    sub verify :Cumulative {
        my $self = $_[0];

        Test::More::is($name[$$self], 'MyBase::name'  => 'MyBase::name initialized');
        Test::More::is($rank[$$self], 'MyBase::rank'  => 'MyBase::rank initialized');
        Test::More::is($snum[$$self], 'MyBase::snum!' => 'MyBase::snum initialized');
        Test::More::is($priv[$$self], 'MyBase::priv'  => 'MyBase::name initialized');
        Test::More::is($def[$$self],  'MyBase::def'   => 'MyBase::def initialized');
    }
}


package Der; {
    use Object::InsideOut qw(MyBase);

    my @name :Field;
    my @rank :Field;
    my @snum :Field('Get' => 'get_snum');
    my @priv :Field('Get' => 'get_priv');
    my @def  :Field('Get' => 'get_default');

    my %init_args :InitArgs = (
        'name' => { 'Field' => \@name },
        'rank' => { 'Field' => \@rank },
        'snum' => { 'Field' => \@snum },
        'priv' => { 'Field' => \@priv },
        'def'  => {
            'Field'   => \@def,
            'Default' => 'default def',
        },
    );

    sub init :Init
    {
        my ($self, $args) = @_;

        Test::More::is(ref($args), 'HASH'
                            => 'Args passed to Der::init in hash-ref');
    }

    sub verify :Cumulative {
        my $self = $_[0];

        Test::More::is($name[$$self], 'MyBase::name' => 'Der::name initialized');
        Test::More::is($rank[$$self], 'generic rank' => 'Der::rank initialized');
        Test::More::is($snum[$$self], 'Der::snum'    => 'Der::snum initialized');
        Test::More::is($priv[$$self], 'Der::priv'    => 'Der::name initialized');
        Test::More::is($def[$$self],  'Der::def'     => 'Der::def initialized');
    }
}


package main;

MAIN:
{
    my $obj = MyBase->new({
        name => 'MyBase::name',
        rank => 'generic rank',
        snum => 'MyBase::snum',
        priv => 'generic priv',
        MyBase => {
            rank => 'MyBase::rank',
            private => 'MyBase::priv',
        }
    });

    can_ok($obj, qw(new clone DESTROY CLONE get_name get_rank set_rank
                        get_snum priv get_default verify));
    $obj->verify();

    $obj->priv('Modified');
    is($obj->priv(), 'Modified' => 'MyBase combined accessor');

    my $derobj = Der->new({
        name => 'MyBase::name',
        rank => 'generic rank',
        snum => 'MyBase::snum',
        priv => 'generic priv',
        MyBase => {
            rank => 'MyBase::rank',
            priv => 'MyBase::priv',
        },
        Der => {
            snum => 'Der::snum',
            priv => 'Der::priv',
            def  => 'Der::def',
        },
    });

    can_ok($derobj, qw(new clone DESTROY CLONE get_name get_rank set_rank
                        get_snum get_priv get_default verify));
    $derobj->verify();

    is($derobj->get_name(), 'MyBase::name'  => 'Der name read accessor');
    is($derobj->get_rank(), 'MyBase::rank'  => 'Der rank read accessor');
    is($derobj->get_snum(), 'Der::snum'     => 'Der rank read accessor');
    is($derobj->get_priv(), 'Der::priv'     => 'Der priv read accessor');

    $derobj->set_rank('new rank');
    is($derobj->get_rank(), 'new rank'      => 'Der rank write accessor');

    eval { $derobj->set_name('new name') };
    ok($@->error() =~ m/^Can't locate object method "set_name" via package "Der"/
                                            => 'Read only name attribute');

    my $der2 = Der->new({
        name => undef,
        rank => 'generic rank',
        priv => '',
        MyBase => {
            rank => 'MyBase::rank',
            snum => 'MyBase::snum',
            priv => 'MyBase::priv',
        },
        Der => {
            snum => 0,
        },
    });

    my $name = $der2->get_name();
    ok(! defined($name)      => 'undef values processes as initializers');
    is($der2->get_snum(), 0  => 'False values allowable as initializers');
    is($der2->get_priv(), '' => 'False values allowable as initializers');

    eval { my $obj2 = MyBase->new(
                                    name => undef,
                                    rank => 'generic rank',
                                    priv => '',
                                    MyBase => {
                                        rank => 'MyBase::rank',
                                        priv => 'MyBase::priv',
                                    },
                                    Der => {
                                        snum => 'MyBase::snum',
                                    }
                                  );
    };
    if (my $e = OIO->caught()) {
        ok($e->error() =~ /Missing mandatory initializer/
                                => 'Missing mandatory initializer caught');
    } else {
        fail("Uncaught exception: $@");
    }
}

exit(0);

# EOF
Object-InsideOut-4.05/t/11-coercion.t0000644000175000001440000001162613377136466016733 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 35;

my  %global_hash;
my  @global_array;
sub  global_sub {}

my  %global_hash2;
my  @global_array2;
sub  global_sub2 {}

# Test basic coercions...
package BaseClass; {
    use Object::InsideOut;

    sub as_str    : STRINGIFY  { return 'hello world' }
    sub as_num    : NUMERIFY   { return 42 }
    sub as_bool   : BOOLIFY    { return }

    sub as_code   : CODIFY     { return \&::global_sub    }
    sub as_glob   : GLOBIFY    { return \*::global_glob   }
    sub as_hash   : HASHIFY    { return \%global_hash   }
    sub as_array  : ARRAYIFY   { return \@global_array  }
}

# Test inheritance without change...
package DerClass; {
    use Object::InsideOut qw(BaseClass);
}

# Test inheritance with change...
package DerClass2; {
    use Object::InsideOut qw(BaseClass);

    sub as_str    : STRINGIFY  { return 'goodbye world' }
    sub as_num    : NUMERIFY   { return 86 }
    sub as_bool   : BOOLIFY    { return 1 }

    sub as_code   : CODIFY     { return \&::global_sub2    }
    sub as_glob   : GLOBIFY    { return \*::global_glob2   }
    sub as_hash   : HASHIFY    { return \%global_hash2     }
    sub as_array  : ARRAYIFY   { return \@global_array2    }
}

# Test inheritance with change and they don't re-specify the coercions
package DerClass3; {
    use Object::InsideOut qw(BaseClass);

    sub as_str     { return 'goodbye world' }
    sub as_num     { return 86 }
    sub as_bool    { return 1 }

    sub as_code    { return \&::global_sub2    }
    sub as_glob    { return \*::global_glob2   }
    sub as_hash    { return \%global_hash2     }
    sub as_array   { return \@global_array2    }
}

# Test inheritance with changing the subs used for the coercions
package DerClass4; {
    use Object::InsideOut qw(BaseClass);

    sub as_str_changed    : STRINGIFY { return 'goodbye world' }
    sub as_num_changed    : NUMERIFY  { return 86 }
    sub as_bool_changed   : BOOLIFY   { return 1 }

    sub as_code_changed   : CODIFY    { return \&::global_sub2    }
    sub as_glob_changed   : GLOBIFY   { return \*::global_glob2   }
    sub as_hash_changed   : HASHIFY   { return \%global_hash2     }
    sub as_array_changed  : ARRAYIFY  { return \@global_array2    }
}


package main;

MAIN:
{
    my $obj;

    # Basic coercions...

    $obj = BaseClass->new();

    ok !$obj                            => 'Base Boolean coercion';
    is 0+$obj, 42                       => 'Base Numeric coercion';
    is "$obj", 'hello world'            => 'Base String coercion';

    is \&{$obj}, \&global_sub           => 'Base Code coercion';
    is \*{$obj}, \*global_glob          => 'Base Glob coercion';
    is \%{$obj}, \%global_hash          => 'Base Hash coercion';
    is \@{$obj}, \@global_array         => 'Base Array coercion';


    # Inheriting coercions...

    $obj = DerClass->new();

    ok !$obj                            => 'Der Boolean coercion';
    is 0+$obj, 42                       => 'Der Numeric coercion';
    is "$obj", 'hello world'            => 'Der String coercion';

    is \&{$obj}, \&global_sub           => 'Der Code coercion';
    is \*{$obj}, \*global_glob          => 'Der Glob coercion';
    is \%{$obj}, \%global_hash          => 'Der Hash coercion';
    is \@{$obj}, \@global_array         => 'Der Array coercion';


    # Redefining coercions on inheritance...

    $obj = DerClass2->new();

    ok $obj                             => 'Der2 Boolean coercion';
    is 0+$obj, 86                       => 'Der2 Numeric coercion';
    is "$obj", 'goodbye world'          => 'Der2 String coercion';

    is \&{$obj}, \&global_sub2          => 'Der2 Code coercion';
    is \*{$obj}, \*global_glob2         => 'Der2 Glob coercion';
    is \%{$obj}, \%global_hash2         => 'Der2 Hash coercion';
    is \@{$obj}, \@global_array2        => 'Der2 Array coercion';


    # Inheritance with change and they don't re-specify the coercions

    $obj = DerClass3->new();

    ok $obj                             => 'Der3 Boolean coercion';
    is 0+$obj, 86                       => 'Der3 Numeric coercion';
    is "$obj", 'goodbye world'          => 'Der3 String coercion';

    is \&{$obj}, \&global_sub2          => 'Der3 Code coercion';
    is \*{$obj}, \*global_glob2         => 'Der3 Glob coercion';
    is \%{$obj}, \%global_hash2         => 'Der3 Hash coercion';
    is \@{$obj}, \@global_array2        => 'Der3 Array coercion';


    # Inheritance with changing the subs used for the coercions

    $obj = DerClass4->new();

    ok $obj                             => 'Der4 Boolean coercion';
    is 0+$obj, 86                       => 'Der4 Numeric coercion';
    is "$obj", 'goodbye world'          => 'Der4 String coercion';

    is \&{$obj}, \&global_sub2          => 'Der4 Code coercion';
    is \*{$obj}, \*global_glob2         => 'Der4 Glob coercion';
    is \%{$obj}, \%global_hash2         => 'Der4 Hash coercion';
    is \@{$obj}, \@global_array2        => 'Der4 Array coercion';
}

exit(0);

# EOF
Object-InsideOut-4.05/t/22-import.t0000644000175000001440000000317713377136466016450 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 10;

use lib '.';

package t::ErrorParent::Child; {
    eval "use Object::InsideOut qw(t::ErrorParent);";
    Test::More::ok($@, 'Correctly fails on syntax error in parent');
}

package t::Child; {
    eval "use Object::InsideOut qw(t::Missing);";
    Test::More::ok($@, 'Correctly fails on missing parent');
}

package t::Missing::Child; {
    eval "use Object::InsideOut qw(t::Missing);";
    Test::More::ok($@, 'Correctly fails on missing parent');
}

package t::Child2; {
    eval 'use Object::InsideOut qw(t::EmptyParent);';
    Test::More::ok($@, 'Correctly fails on empty parent');
}

package t::EmptyParent::Child; {
    eval 'use Object::InsideOut qw(t::EmptyParent);';
    Test::More::ok($@, 'Correctly fails on empty parent');
}

package t::IntEmptyParent;
package t::IntChild; {
    eval 'use Object::InsideOut qw(t::IntEmptyParent);';
    Test::More::ok($@, 'Correctly fails on empty parent');
}

package t::IntEmptyParent::Child; {
    eval 'use Object::InsideOut qw(t::IntEmptyParent);';
    Test::More::ok($@, 'Correctly fails on empty parent');
}



# Test where parent is defined in an external file (e.g., t/Parent.pm) which
# hasn't be loaded yet, and the name of the child class starts with the the
# name of the parent class.  For example:
#       t::Parent
#           t::Parent::Child

package t::Parent::Child; {
    use Object::InsideOut qw(t::Parent);
}

package main;
MAIN:
{
    my $child = t::Parent::Child->new();
    isa_ok($child, 't::Parent::Child');
    isa_ok($child, 't::Parent');
    eval { $child->parent_func() };
    ok(!$@, 'child->parent_func()');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/46-singleton.t0000644000175000001440000000172313377136466017141 0ustar  jdheddenusersuse strict;
use warnings;

use Config;
BEGIN {
    if (! $Config{useithreads} || $] < 5.008) {
        print("1..0 # Skip Threads not supported\n");
        exit(0);
    }
}


use threads;
use threads::shared;

if ($threads::shared::VERSION lt '1.33') {
    print("1..0 # Skip Need threads::shared v1.33 or later\n");
    exit(0);
}

if ($] == 5.008) {
    require 't/test.pl';   # Test::More work-alike for Perl 5.8.0
} else {
    require Test::More;
}
Test::More->import();
plan('tests' => 1);

package Single; {
    use Object::InsideOut qw(:SHARED);

    my $singleton;
    my %field1 :Field :All(f1);
    my %field2 :Field;

    sub new
    {
        my $thing = shift;

        if (!$singleton) {
            $singleton = $thing->Object::InsideOut::new(@_);
        }

        return $singleton;
    }
}

package main;

my $obj = Single->new(f1 => 'bork');

is($obj->f1(), 'bork', 'Singleton fetch');

# The real test is that no segfault occurs when this test exits

# EOF
Object-InsideOut-4.05/t/25-access.t0000644000175000001440000000376513377136466016405 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 9;

package Foo; {
    use Object::InsideOut;
    my @data :Field('Standard' => 'data', 'Permission' => 'private');
    my @info :Field('Accessor' => 'info', 'Permission' => 'restricted');
    my @also :Field
             :Acc('Name' => 'also', 'Perm' => 'rest ( Bork , ) ');
}

package Bar; {
    use Object::InsideOut 'Foo';

    sub bar_data
    {
        my $self = shift;
        return ($self->get_data());
    }

    sub bar_info
    {
        my $self = shift;
        if (! @_) {
            return ($self->info());
        }
        $self->info(@_);
    }
}

package Bork; {
    sub exempt
    {
        my $self = shift;
        my $obj = shift;
        if (! @_) {
            return ($obj->also());
        }
        $obj->also(@_);
    }

    sub cant
    {
        my ($self, $obj) = @_;
        $obj->info();
    }
}

package main;

my $foo = Foo->new();
my $bar = Bar->new();

eval { $foo->set_data(42); };
is($@->error, q/Can't call private method 'Foo->set_data' from class 'main'/
                                    , 'Private set method');
eval { $foo->get_data(); };
is($@->error, q/Can't call private method 'Foo->get_data' from class 'main'/
                                    , 'Private get method');
eval { $foo->info(); };
is($@->error, q/Can't call restricted method 'Foo->info' from class 'main'/
                                    , 'Restricted method');

eval { $bar->bar_data(); };
is($@->error, q/Can't call private method 'Foo->get_data' from class 'Bar'/
                                    , 'Private get method');

ok($bar->bar_info(10)               => 'Restricted set');
is($bar->bar_info(), 10             => 'Restricted get');

eval { Bork->cant($bar); };
is($@->error, q/Can't call restricted method 'Foo->info' from class 'Bork'/
                                    , 'Restricted method');

ok(Bork->exempt($bar, 99)           => 'Exempt restricted set');
is(Bork->exempt($bar), 99           => 'Exempt restricted get');

exit(0);

# EOF
Object-InsideOut-4.05/t/09-chained.t0000644000175000001440000000361513377136466016533 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 2;

package Base1; {
    use Object::InsideOut;

    sub base_first :Chained            { shift; return(@_, __PACKAGE__); }
    sub der_first  :Chained(bottom up) { shift; return(@_, __PACKAGE__); }
}

package Base2; {
    use Object::InsideOut qw(Base1);

    sub base_first :Chained            { shift; return(@_, __PACKAGE__); }
    sub der_first  :Chained(bottom up) { shift; return(@_, __PACKAGE__); }
}

package Base3; {
    use Object::InsideOut qw(Base1);

    sub base_first :Chained            { shift; return(@_, __PACKAGE__); }
    sub der_first  :Chained(bottom up) { shift; return(@_, __PACKAGE__); }
}

package Base4; {
    use Object::InsideOut;

    sub base_first                     { shift; return(@_, __PACKAGE__); }
    sub der_first                      { shift; return(@_, __PACKAGE__); }
}

package Der1; {
    use Object::InsideOut qw(Base2 Base3 Base4);

    sub base_first :Chained            { shift; return(@_, __PACKAGE__); }
    sub der_first  :Chained(bottom up) { shift; return(@_, __PACKAGE__); }
}

package Der2; {
    use Object::InsideOut qw(Base2 Base3 Base4);

    sub base_first :Chained            { shift; return(@_, __PACKAGE__); }
    sub der_first  :Chained(bottom up) { shift; return(@_, __PACKAGE__); }
}

package Reder1; {
    use Object::InsideOut qw(Der1 Der2);

    sub base_first :Chained            { shift; return(@_, __PACKAGE__); }
    sub der_first  :Chained(bottom up) { shift; return(@_, __PACKAGE__); }
}

package main;

MAIN:
{
    my $obj = Reder1->new();

    my @top_down = $obj->base_first();
    my @bot_up   = $obj->der_first();

    my @my_top_down = qw(Base1 Base2 Base3 Der1 Der2 Reder1);
    my @my_bot_up   = qw(Reder1 Der2 Der1 Base3 Base2 Base1);

    is_deeply(\@top_down, \@my_top_down      => 'List chained down');
    is_deeply(\@bot_up,   \@my_bot_up        => 'List chained up');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/17-dynamic.t0000644000175000001440000000302113377136466016552 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 6;

#$Object::InsideOut::DEBUG = 1;

package My::Class; {
    use Object::InsideOut;

    sub auto : Automethod
    {
        my $self = $_[0];
        my $class = ref($self) || $self;

        my $method = $_;

        my ($fld_name) = $method =~ /^[gs]et_(.*)$/;
        if (! $fld_name) {
            return;
        }
        Object::InsideOut->create_field($class, '@'.$fld_name,
                                        "'Name'=>'$fld_name',",
                                        "'Std' =>'$fld_name'");

        no strict 'refs';
        return *{$class.'::'.$method}{'CODE'};
    }

    sub make
    {
        my ($self, $name, $type) = @_;
        My::Class->create_field('@'.$name,
                                ":Field('Std' =>'$name',",
                                "       'Type' => '$type')",
                                ":Name($name)");
    }
}


package My::Sub; {
    use Object::InsideOut qw(My::Class);

    my @data :Field('set'=>'munge');
}


package main;

MAIN:
{
    my $obj = My::Sub->new();

    $obj->set_data(5);
    can_ok($obj, qw(get_data set_data));
    is($obj->get_data(), 5              => 'Method works');
    can_ok('My::Sub', qw(get_data set_data));
    $obj->munge('hello');
    is($obj->get_data(), 5              => 'Not munged');

    $obj->make('foo', 'numeric');
    can_ok($obj, qw(get_foo set_foo));
    $obj->set_foo(99);
    is($obj->get_foo(), 99              => 'Dynamic foo');

    #print(STDERR $obj->dump(1), "\n");
}

exit(0);

# EOF
Object-InsideOut-4.05/t/14-auto_cc.t0000644000175000001440000001120513377136466016543 0ustar  jdheddenusersuse strict;
use warnings;

BEGIN {
    if ($] == 5.008) {
        print("1..0 # Skip due to Perl 5.8.0 bug\n");
        exit(0);
    }
}

use Test::More 'tests' => 6;

package My::Data; {
    use Object::InsideOut;

    my @data :Field('Accessor' => 'data');

    sub auto : Automethod
    {
        my $self = $_[0];
        my $class = ref($self) || $self;
        my $name = $_;

        # No data
        if (! exists($data[$$self])) {
            return;
        }

        my $data = \@data;      # Workaround for 5.6.X bug

        if ($$self == 1) {
            return (sub {
                        my $self = $_[0];
                        my $class = ref($self) || $self;
                        return (join(' ', $$self, $class, __PACKAGE__, $name, $$data[$$self]));
                   }, 'CUM');
        }

        return (sub {
                        my $self = shift;
                        my $class = ref($self) || $self;
                        return (@_, join(' ', $$self, $class, __PACKAGE__, $name, $$data[$$self]));
                   }, 'CHA(BOT)');
    }
}


package My::Info; {
    use Object::InsideOut qw(My::Data);

    my @info :Field('Accessor' => 'info');

    sub auto : Automethod
    {
        my $self = $_[0];
        my $class = ref($self) || $self;
        my $name = $_;

        # No info
        if (! exists($info[$$self])) {
            return;
        }

        my $info = \@info;      # Workaround for 5.6.X bug

        if ($$self == 1) {
            return (sub {
                        my $self = $_[0];
                        my $class = ref($self) || $self;
                        return (join(' ', $$self, $class, __PACKAGE__, $name, $$info[$$self]));
                   }, 'CUM');
        }
        return (sub {
                        my $self = shift;
                        my $class = ref($self) || $self;
                        return (@_, join(' ', $$self, $class, __PACKAGE__, $name, $$info[$$self]));
                   }, 'CHA(BOT)');
    }
}


package My::Comment; {
    use Object::InsideOut qw(My::Info);

    my @comment :Field('Accessor' => 'comment');

    sub AUTOMETHOD {
        if (/^foo$/) {
            return sub { return 'Bar->foo' }
        }
        return;
    }

    sub auto : Automethod
    {
        my $self = $_[0];
        my $class = ref($self) || $self;
        my $name = $_;

        # No comment
        if (! exists($comment[$$self])) {
            return;
        }

        my $comment = \@comment;      # Workaround for 5.6.X bug

        if ($$self == 1) {
            return (sub {
                        my $self = $_[0];
                        my $class = ref($self) || $self;
                        return (join(' ', $$self, $class, __PACKAGE__, $name, $$comment[$$self]));
                   }, 'CUM');
        }
        return (sub {
                        my $self = shift;
                        my $class = ref($self) || $self;
                        return (@_, join(' ', $$self, $class, __PACKAGE__, $name, $$comment[$$self]));
                   }, 'CHA(BOT)');
    }
}


package main;

MAIN:
{
    my $obj = My::Comment->new();

    my (@results, @data);

    $obj->info('test');
    @results = @{$obj->flog()};
    #print(join("\n", @results), "\n\n");

    @data = ('1 My::Comment My::Info flog test');
    is_deeply(\@results, \@data, 'Accumulation 1');

    $obj->data('tool');
    @results = @{$obj->bork()};
    #print(join("\n", @results), "\n\n");

    @data = ('1 My::Comment My::Data bork tool',
             '1 My::Comment My::Info bork test');
    is_deeply(\@results, \@data, 'Accumulation 2');

    $obj->comment('tassel');
    @results = @{$obj->funge()};
    #print(join("\n", @results), "\n\n");

    @data = ('1 My::Comment My::Data funge tool',
             '1 My::Comment My::Info funge test',
             '1 My::Comment My::Comment funge tassel');
    is_deeply(\@results, \@data, 'Accumulation 3');


    $obj = My::Comment->new();

    $obj->info('test');
    @results = $obj->flog();
    #print(join("\n", @results), "\n\n");

    @data = ('2 My::Comment My::Info flog test');
    is_deeply(\@results, \@data, 'Chained 1');

    $obj->data('tool');
    @results = $obj->bork();
    #print(join("\n", @results), "\n\n");

    @data = ('2 My::Comment My::Info bork test',
             '2 My::Comment My::Data bork tool');
    is_deeply(\@results, \@data, 'Chained 2');

    $obj->comment('tassel');
    @results = $obj->funge();
    #print(join("\n", @results), "\n\n");

    @data = ('2 My::Comment My::Comment funge tassel',
             '2 My::Comment My::Info funge test',
             '2 My::Comment My::Data funge tool');
    is_deeply(\@results, \@data, 'Chained 3');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/36-require.t0000644000175000001440000000143513377136466016612 0ustar  jdheddenusersuse strict;
use warnings;

use lib 't';

use Test::More 'tests' => 8;

{
    my $class = 'Req2';
    eval "require $class";
    ok(! $@, ($@)?$@:'eval ok');
    my $n = $class->new(field => 'ciao');
    my $m = Req2->new(field => 'a tutti');
    is($n->get_field(), 'ciao', 'field value for $n');
    is($m->get_field(), 'a tutti', 'field value for $m');
}

{
    my $class = 'Req3';
    eval "require $class";
    ok(! $@, ($@)?$@:'eval ok');
    my $n = $class->new(field => 'ciao', 'fld' => 'foo');
    my $m = Req3->new(field => 'a tutti', 'fld' => 'bar');
    is($n->get_field(), 'ciao', 'field value for $n');
    is($m->get_field(), 'a tutti', 'field value for $m');
    is($n->get_fld(), 'foo', 'field value for $n');
    is($m->get_fld(), 'bar', 'field value for $m');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/16-return.t0000644000175000001440000000232313377136466016450 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 10;

package My::Class; {
    use Object::InsideOut;

    my @oo : Field('acc'=>'oo', 'return'=>'old');
    my @nn : Field('acc'=>'nn', 'return'=>'new');
    my @ss : Field({'acc'=>'ss', 'return'=>'self'});
    my @xx : Field('acc'=>'xx');
}

package main;

MAIN:
{
    my $obj = My::Class->new();

    my $ret = $obj->oo('test');
    ok(! defined($ret)                  => 'undef on old');
    $ret = $obj->oo();
    is($ret, 'test'                     => 'Get okay');
    $ret = $obj->oo('xxx');
    is($ret, 'test'                     => 'Old return value');
    $ret = $obj->oo();
    is($ret, 'xxx'                      => 'Get okay');

    $ret = $obj->nn('zip');
    is($ret, 'zip'                      => 'New return value');
    $ret = $obj->nn();
    is($ret, 'zip'                      => 'Get okay');

    $ret = $obj->ss('jump');
    is($ret, $obj                       => 'Self return value');
    $ret = $obj->ss();
    is($ret, 'jump'                     => 'Get okay');

    $ret = $obj->xx('foo');
    is($ret, 'foo'                      => 'Default return value');
    $ret = $obj->xx();
    is($ret, 'foo'                      => 'Get okay');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/13-pump.t0000644000175000001440000000601713377136466016113 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 19;

package MyBase; {
    use Object::InsideOut;

    my %public  :Field;
    my %private :Field;

    my %init_args :InitArgs = (
        'pub' => {
            'field' => \%public,
        },
        'priv' => {
            'field' => \%private,
            'def'   => 'base priv',
        },
    );

    # No :Init sub needed
}

package MyDer; {
    use Object::InsideOut qw(MyBase);

    my @public  :Field;
    my @private :Field;
    my @misc    :Field('Name' => 'misc');

    my %init_args :InitArgs = (
        'pub' => {
            'field' => \@public,
        },
        'priv' => {
            'field' => \@private,
            'def'   => 'der priv',
        },
        'misc'   => '',
        'hidden' => '',
    );

    sub _init :Init
    {
        my ($self, $args) = @_;

        if (exists($args->{'misc'})) {
            $self->set(\@misc, $args->{'misc'});
        }
    }
}


package MyDas; {
    use Object::InsideOut qw(MyDer);

    sub _dump :Dump
    {
        my $self = shift;
        return ({ 'key' => 'value' });
    }

    sub _pump :Pump
    {
        my ($self, $data) = @_;

        Test::More::is($data->{'key'}, 'value' => 'Pumper got data');
    }

}

package main;

MAIN:
{
    my $obj = MyDas->new({
                  MyBase   => { pub => 'base pub' },
                  MyDer    => { pub => 'der pub'  },
                  'misc'   => 'other',
                  'hidden' => 'invisible',
              });

    my $dump = $obj->dump();

    ok($dump                                  => 'Representation is valid');
    is(ref($dump), 'ARRAY'                    => 'Representation is valid');
    my ($class, $hash) = @{$dump};

    is($class, 'MyDas'                        => 'Class');

    is($hash->{MyBase}{'pub'}, 'base pub'     => 'Public base attribute');
    is($hash->{MyBase}{'priv'}, 'base priv'   => 'Private base attribute');

    is($hash->{MyDer}{'pub'}, 'der pub'       => 'Public derived attribute');
    is($hash->{MyDer}{'priv'}, 'der priv'     => 'Private derived attribute');
    is($hash->{MyDer}{'misc'}, 'other'        => 'Hidden derived attribute');

    is($hash->{MyDas}{'key'}, 'value'         => 'Dumper gave value');

    my $str = $obj->dump(1);
    #print(STDERR $str, "\n");

    my $dump2 = eval $str;

    ok($str && ! ref($str)                    => 'String dump');
    ok($dump2                                 => 'eval is valid');
    is(ref($dump2), 'ARRAY'                   => 'eval is valid');
    is_deeply($dump, $dump2                   => 'Dumps are equal');

    my $obj2;
    eval { $obj2 = Object::InsideOut::pump($dump); };
    ok(! $@,                                  => 'Pump in hash');
    $dump2 = $obj2->dump();
    is_deeply($dump, $dump2                   => 'Redump equals dump');

    my $obj3;
    eval { $obj3 = Object::InsideOut::pump($str); };
    ok(! $@,                                  => 'Pump in string');
    $dump2 = $obj3->dump();
    is_deeply($dump, $dump2                   => 'Redump equals dump');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/18-inherit.t0000644000175000001440000000427413377136466016604 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 12;

# Borg is a foreign hash-based class
package Borg; {
    sub new
    {
        my $class = shift;
        my %self = @_;
        return (bless(\%self, $class));
    }

    sub get_borg
    {
        my ($self, $data) = @_;
        return ($self->{$data});
    }

    sub set_borg
    {
        my ($self, $key, $value) = @_;
        $self->{$key} = $value;
    }

    sub warn
    {
        return ('Resistance is futile');
    }
}


package Foo; {
    use Object::InsideOut qw(Borg);

    my @objs :Field('Acc'=>'obj', 'Type' => 'list');

    my %init_args :InitArgs = (
        'OBJ' => {
            'RE'    => qr/^obj$/i,
            'Field' => \@objs,
            'Type'  => 'list',
        },
        'BORG' => {
            'RE'    => qr/^borg$/i,
        }
    );

    sub init :Init
    {
        my ($self, $args) = @_;

        $self->inherit( Borg->new() );

        if (exists($args->{'BORG'})) {
            $self->set_borg('borg' => $args->{'BORG'});
        }
    }
}

package Bar; {
    use Object::InsideOut qw(Foo);
}

package Baz; {
    use Object::InsideOut qw(Bar);
}


package main;
MAIN:
{
    can_ok('Borg'                       => qw(get_borg set_borg));
    ok(Foo->isa('Borg')                 => 'Foo isa Borg');
    can_ok('Foo'                        => qw(get_borg set_borg));
    is(Foo->warn(), 'Resistance is futile' => 'Class method inheritance');

    my $obj = Baz->new('borg' => 'Picard');

    ok($obj->isa('Foo')                 => 'isa Foo');
    ok($obj->isa('Borg')                => 'isa Borg');
    can_ok($obj                         => qw(get_borg set_borg obj));
    is($obj->get_borg('borg'), 'Picard' => 'get from Borg');

    $obj->set_borg('borg' => '1 of 5');
    is($obj->get_borg('borg'), '1 of 5' => 'Changed Borg');

    my $obj2 = Baz->new('obj'=>$obj);
    ok($obj2->isa('Borg')               => 'isa Borg');

    my ($x) = @{$obj2->obj()};
    is($x, $obj                         => 'Retrieved object');

    #print($obj->dump(1), "\n");

    $obj = bless({}, 'SomeClass');
    ok(UNIVERSAL::isa($obj, '') ||
       UNIVERSAL::isa($obj, 0) ||
       UNIVERSAL::isa($obj, 'SomeClass'), 'isa works');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/03a-threads.t0000644000175000001440000000330313377136466016717 0ustar  jdheddenusersuse strict;
use warnings;

use Config;
BEGIN {
    if (! $Config{useithreads} || $] < 5.008) {
        print("1..0 # Skip Threads not supported\n");
        exit(0);
    }
}

use threads;
use threads::shared;

if ($] == 5.008) {
    require 't/test.pl';   # Test::More work-alike for Perl 5.8.0
} else {
    require Test::More;
}
Test::More->import();
plan('tests' => 12);


package My::Obj; {
    use Object::InsideOut;

    my @x : Field({'accessor'=>'x'});
}

package My::Obj::Sub; {
    use Object::InsideOut qw(My::Obj);

    my @y : Field({'accessor'=>'y'});
}


package main;

MAIN:
{
    my $obj = My::Obj->new();
    $obj->x(5);
    is($obj->x(), 5, 'Class set data');

    my $obj2 = My::Obj::Sub->new();
    $obj2->x(9);
    $obj2->y(3);
    is($obj2->x(), 9, 'Subclass set data');
    is($obj2->y(), 3, 'Subclass set data');

    my $rc = threads->create(
                        sub {
                            is($obj->x(), 5, 'Thread class data');
                            is($obj2->x(), 9, 'Thread subclass data');
                            is($obj2->y(), 3, 'Thread subclass data');

                            $obj->x([1, 2, 3]);
                            $obj2->x(99);
                            $obj2->y(3-1);

                            is_deeply($obj->x(), [1, 2, 3], 'Thread class data');
                            is($obj2->x(), 99, 'Thread subclass data');
                            is($obj2->y(), 2, 'Thread subclass data');

                            return (1);
                        }
                    )->join();

    is($obj->x(), 5, 'Class data unchanged');
    is($obj2->x(), 9, 'Subclass data unchanged');
    is($obj2->y(), 3, 'Subclass data unchanged');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/37-class_perm.t0000644000175000001440000000357013377136466017271 0ustar  jdheddenusersuse strict;
use warnings;

use lib 't';

use Test::More 'tests' => 12;

package Foo; {
    use Object::InsideOut;
}

package Bar; {
    use Object::InsideOut q/:Restricted(Zork, '')/, 'Foo';
}

package Baz; {
    use Object::InsideOut qw/:Private('Zork') Bar/;

    sub bar :Sub { return (Bar->new()); }
    sub baz :Sub { return (Baz->new()); }
}

package Ork; {
    use Object::InsideOut qw/:Public Baz/;
}

package Zork; {
    sub bar { return (Bar->new()); }
    sub baz { return (Baz->new()); }
}


package Responder; {
    use Object::InsideOut qw( :Restricted );

    my @response :Field :All( 'response' );
}

package Asker; {
    use Object::InsideOut qw( :Public Responder );

    my @question :Field
                 :Arg( 'question' )
                 ;

    sub ask {
        my ( $self ) = @_;

        Test::More::is($question[ $$self ], 'say wha?', 'Data in public class');

        Responder->new( 'response' => 'kapow!' )->response;
    }
}


package main;

MAIN:
{
    isa_ok(Foo->new(), 'Foo'            => 'Public class');

    eval { my $obj = Bar->new(); };
    like($@, qr/restricted method/      => 'Restricted class');

    eval { my $obj = Baz->new(); };
    like($@, qr/private method/         => 'Private class');
    isa_ok(Baz::bar(), 'Bar'            => 'Restricted class in hierarchy');
    isa_ok(Baz::baz(), 'Baz'            => 'Private class in class');

    isa_ok(Zork::bar(), 'Bar'           => 'Restricted class exemption');
    isa_ok(Zork::baz(), 'Baz'           => 'Private class exemption');

    isa_ok(Ork->new(), 'Ork'            => 'Public class');

    eval { my $obj = Responder->new(); };
    like($@, qr/restricted method/      => 'Restricted class');

    my $obj = Asker->new( 'question' => 'say wha?' );
    isa_ok($obj, 'Asker'                => 'Public class');
    is($obj->ask, 'kapow!'              => 'Access to restricted class');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/09a-chained.t0000644000175000001440000000435313377136466016674 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 1;

package Base1; {
    use Object::InsideOut;

    sub foo :Chained :MergedArgs
    {
        my ($self, $args) = @_;
        push(@{$args->{'list'}}, __PACKAGE__);
        return ({'list' => $args->{'list'}}, 'last' => __PACKAGE__);
    }
}

package Base2; {
    use Object::InsideOut qw(Base1);

    sub foo :Chained :MergedArgs
    {
        my ($self, $args) = @_;
        push(@{$args->{'list'}}, __PACKAGE__);
        return ('list' => $args->{'list'}, 'last' => __PACKAGE__);
    }
}

package Base3; {
    use Object::InsideOut qw(Base1);

    sub foo :Chained :MergedArgs
    {
        my ($self, $args) = @_;
        push(@{$args->{'list'}}, __PACKAGE__);
        return ({'list' => $args->{'list'}, 'last' => __PACKAGE__});
    }
}

package Base4; {
    use Object::InsideOut;

    sub foo :MergedArgs  # but not chained!
    {
        my ($self, $args) = @_;
        push(@{$args->{'list'}}, __PACKAGE__);
        $args->{'last'} = __PACKAGE__;
        return ($args);
    }
}

package Der1; {
    use Object::InsideOut qw(Base2 Base3 Base4);

    sub foo :Chained :MergedArgs
    {
        my ($self, $args) = @_;
        push(@{$args->{'list'}}, __PACKAGE__);
        return ({'list' => $args->{'list'}}, {'last' => __PACKAGE__});
    }
}

package Der2; {
    use Object::InsideOut qw(Base2 Base3 Base4);

    sub foo :Chained :MergedArgs
    {
        my ($self, $args) = @_;
        push(@{$args->{'list'}}, __PACKAGE__);
        return ('list' => $args->{'list'}, {'last' => __PACKAGE__});
    }
}

package Reder1; {
    use Object::InsideOut qw(Der1 Der2);

    sub foo :Chained :MergedArgs
    {
        my ($self, $args) = @_;
        push(@{$args->{'list'}}, __PACKAGE__);
        $args->{'last'} = __PACKAGE__;
        return ($args);
    }
}

package main;

MAIN:
{
    my $obj = Reder1->new();

    my $expected = {
          'last' => 'Reder1',
          'list' => [
                      'Base1',
                      'Base2',
                      'Base3',
                      'Der1',
                      'Der2',
                      'Reder1'
                    ]
        };

    my ($got) = $obj->foo();

    is_deeply($got, $expected => 'Chained methods with merged args');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/07-dump.t0000644000175000001440000000616113377136466016102 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 15;

package MyBase; {
    use Object::InsideOut;

    my %public  :Field;
    my %private :Field;

    my %init_args :InitArgs = (
        'pub' => {
            'field' => \%public,
        },
        'priv' => {
            'field' => \%private,
            'def'   => 'base priv',
        },
    );

    # No :Init sub needed
}

package MyDer; {
    use Object::InsideOut qw(MyBase);

    my %public  :Field;
    my %private :Field;
    my %misc    :Field
                :Name( 'misc' );
    my %hidden  :Field;

    my %init_args :InitArgs = (
        'pub' => {
            'field' => \%public,
        },
        'priv' => {
            'field' => \%private,
            'def'   => 'der priv',
        },
        'misc'   => '',
        'hidden' => '',
    );

    sub _init :Init
    {
        my ($self, $args) = @_;

        if (exists($args->{'misc'})) {
            $self->set(\%misc, $args->{'misc'});
        }
        if (exists($args->{'hidden'})) {
            $self->set(\%hidden, $args->{'hidden'});
        }
    }
}

package MyClass;
{
    use Object::InsideOut;

    my @content :Field :Acc(content);
}

package main;

MAIN:
{
    my $obj = MyDer->new({
                  MyBase   => { pub => 'base pub' },
                  MyDer    => { pub => 'der pub'  },
                  'misc'   => 'other',
                  'hidden' => 'invisible',
              });

    my $dump = $obj->dump();

    ok($dump                                  => 'Representation is valid');
    is(ref($dump), 'ARRAY'                    => 'Representation is valid');
    my ($class, $hash) = @{$dump};

    is($class, 'MyDer'                        => 'Class');

    is($hash->{MyBase}{'pub'}, 'base pub'     => 'Public base attribute');
    is($hash->{MyBase}{'priv'}, 'base priv'   => 'Private base attribute');

    is($hash->{MyDer}{'pub'}, 'der pub'       => 'Public derived attribute');
    is($hash->{MyDer}{'priv'}, 'der priv'     => 'Private derived attribute');
    is($hash->{MyDer}{'misc'}, 'other'        => 'Hidden derived attribute');
    is(Object::InsideOut::Util::hash_re($hash->{MyDer}, qr/^HASH/), 'invisible'
                                              => 'Hidden derived attribute');

    my $str = $obj->Object::InsideOut::dump(1);
    #print(STDERR $str, "\n");

    my $dump2 = eval $str;

    ok($str && ! ref($str)                    => 'String dump');
    ok($dump2                                 => 'eval is valid');
    is(ref($dump2), 'ARRAY'                   => 'eval is valid');
    is_deeply($dump, $dump2                   => 'Dumps are equal');

    eval { my $obj2 = Object::InsideOut::pump($dump); };
    is($@->error(), q/Unnamed field encounted in class 'MyDer'/
                                              => 'Unnamed field');

    my $content = < {
      'content' => 'A;B;C
1;2;3
4;5;6
7;8;9
10;11;12
'
    }
  }
]
RESULT

    $obj = MyClass->new();
    $obj->content($content);
    is($obj->dump(1)."\n", $result, 'Dump string contents verified');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/46a-singleton.t0000644000175000001440000000172313377136466017302 0ustar  jdheddenusersuse strict;
use warnings;

use Config;
BEGIN {
    if (! $Config{useithreads} || $] < 5.008) {
        print("1..0 # Skip Threads not supported\n");
        exit(0);
    }
}


use threads;
use threads::shared;

if ($threads::shared::VERSION lt '1.33') {
    print("1..0 # Skip Need threads::shared v1.33 or later\n");
    exit(0);
}

if ($] == 5.008) {
    require 't/test.pl';   # Test::More work-alike for Perl 5.8.0
} else {
    require Test::More;
}
Test::More->import();
plan('tests' => 1);

package Single; {
    use Object::InsideOut qw(:SHARED);

    my $singleton;
    my @field1 :Field :All(f1);
    my @field2 :Field;

    sub new
    {
        my $thing = shift;

        if (!$singleton) {
            $singleton = $thing->Object::InsideOut::new(@_);
        }

        return $singleton;
    }
}

package main;

my $obj = Single->new(f1 => 'bork');

is($obj->f1(), 'bork', 'Singleton fetch');

# The real test is that no segfault occurs when this test exits

# EOF
Object-InsideOut-4.05/t/15-type.t0000644000175000001440000001166113377136466016116 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 34;

package My::Class; {
    use Object::InsideOut;

    sub is_scalar :Private { return (! ref(shift)); }

    sub is_int {
        my $arg = $_[0];
        return (Scalar::Util::looks_like_number($arg) &&
                (int($arg) == $arg));
    }

    my @aa :Field('acc'=>'aa', 'type' => 'array');
    my @as :Field('acc'=>'as', 'type' => 'array(My::Class)');
    my @ar :Field('acc'=>'ar', 'type' => 'array_ref');
    my @cc :Field({'acc'=>'cc', 'type' => sub{ shift > 0 } });
    my @hh :Field('acc'=>'hh', 'type' => 'hash');
    my @hr :Field('acc'=>'hr', 'type' => 'hashref');
    my @mc :Field({'acc'=>'mc', 'type' => 'My::Class'});
    my @nn :Field({'acc'=>'nn', 'type' => 'num'});
    my @sr :Field({'acc'=>'sr', 'type' => 'scalar_ref'});
    my @ss :Field
           :Acc(ss)
           :Type(\&My::Class::is_scalar);
    my @scal :Field :Acc(scal) :Type(scalar);

    my %init_args :InitArgs = (
        'DATA' => {
            'Field' => \@nn,
            'Type'  => \&is_int,
        },
        'INFO' => {
            'Type'  => sub { $_[0] }
        },
        'BAD' => {
            'Type'  => sub { shift > 0 }
        },
        'SC' => {
            'Field' => \@scal,
            'Type'  => 'scalar',
        }
    );
}

package main;

MAIN:
{
    my $obj = My::Class->new('DATA' => 5, 'SC' => 'bork');

    $obj->aa('test');
    is_deeply($obj->aa(), ['test']              => 'Array single value');
    $obj->aa('zero', 5);
    is_deeply($obj->aa(), ['zero', 5]           => 'Array multiple values');
    $obj->aa(['x', 42, 'z']);
    is_deeply($obj->aa(), ['x', 42, 'z']        => 'Array ref value');

    {
        my $a = My::Class->new();
        my $b = My::Class->new();
        my $c = My::Class->new();

        $obj->as($a);
        is_deeply($obj->as(), [$a]              => 'Array single class');
        $obj->as($a, $b, $c);
        is_deeply($obj->as(), [$a, $b, $c]      => 'Array multiple class');
        $obj->as([$c, $a, $b]);
        is_deeply($obj->as(), [$c, $a, $b]      => 'Array ref class');
    }

    eval { $obj->ar('test'); };
    like($@->message, qr/Wrong type/            => 'Not array ref');
    $obj->ar([3, [ 'a' ]]);
    is_deeply($obj->ar(), [3, [ 'a' ]]          => 'Array ref');

    $obj->cc(12);
    is($obj->cc(), 12                           => 'Type sub');
    eval { $obj->cc(-5); };
    like($@->message, qr/failed type check/     => 'Type failure');
    eval { $obj->cc('hello'); };
    like($@->message, qr/Problem with type check routine/  => 'Type sub failure');

    $obj->hh('x' => 5);
    is_deeply($obj->hh(), {'x'=>5}              => 'Hash single pair');
    $obj->hh('a' => 'z', '0' => '9');
    is_deeply($obj->hh(), {'a'=>'z','0'=>'9'}   => 'Hash multiple pairs');
    $obj->hh({'2b'=>'not'});
    is_deeply($obj->hh(), {'2b'=>'not'}         => 'Hash ref value');

    eval { $obj->hr('test'); };
    like($@->message, qr/Wrong type/            => 'Not hash ref');
    $obj->hr({'frog'=>{'prince'=>'John'}});
    is_deeply($obj->hr(), {'frog'=>{'prince'=>'John'}} => 'Hash ref');

    my $obj2 = My::Class->new();
    $obj->mc($obj2);
    my $obj3 = $obj->mc();
    isa_ok($obj3, 'My::Class'                   => 'Object');
    is($$obj3, $$obj2                           => 'Objects equal');
    eval { $obj2->mc('test'); };
    like($@->message, qr/Wrong type/            => 'Not object');

    $obj->nn(99);
    is_deeply($obj->nn(), 99                    => 'Numeric');
    eval { $obj->nn('x'); };
    like($@->message, qr/Bad argument/          => 'Numeric failure');

    $obj->ss('hello');
    is($obj->ss(), 'hello'                      => 'Scalar');
    eval { $obj->ss([1]); };
    like($@->message, qr/failed type check/     => 'Scalar failure');

    is($obj->scal(), 'bork'                     => 'Scalar');
    $obj->scal('foo');
    is($obj->scal(), 'foo'                      => 'Scalar');
    eval { $obj->scal(bless({}, 'Foo')); };
    like($@->message, qr/Bad argument/          => 'Scalar failure');

    eval { $obj->sr('test'); };
    like($@->message, qr/Wrong type/            => 'Not scalar ref');
    my $x = 42;
    $obj->sr(\$x);
    is($obj->sr(), \$x                          => 'Scalar ref');
    my $y = $obj->sr();
    is($$y, 42                                  => 'Scalar ref value');

    eval { $obj2 = My::Class->new('DATA' => 'hello'); };
    like($@->message, qr/failed type check/     => 'Type failure');

    eval { $obj2 = My::Class->new('INFO' => ''); };
    like($@->message, qr/failed type check/     => 'Type failure');

    eval { $obj2 = My::Class->new('SC' => []); };
    like($@->message, qr/Bad value/             => 'Scalar failure');

    eval { $obj2 = My::Class->new('BAD' => ''); };
    like($@->message, qr/Problem with type check routine/  => 'Type sub failure');

    $obj = bless({}, 'SomeClass');
    ok(UNIVERSAL::isa($obj, '') ||
       UNIVERSAL::isa($obj, 0) ||
       UNIVERSAL::isa($obj, 'SomeClass'), 'isa works');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/06-id.t0000644000175000001440000000531313377136466015526 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 36;

package AA; {
    use Object::InsideOut;

    my %aa : Field({'acc'=>'aa', 'type' => 'num'});

    my $id = 1;

    sub id : ID {
        return ($id++);
    }
}


package BB; {
    use Object::InsideOut;

    my %bb : Field( { 'get' => 'bb', 'Set' => 'set_bb' } );

    my %init_args : InitArgs = (
        'BB' => {
            'Field'     => \%bb,
            'Default'   => 'def',
            'Regex'     => qr/bb/i,
        },
    );
}


package AB; {
    use Object::InsideOut qw(AA BB);

    my %data : Field({'acc'=>'data'});
    my %info : Field('gET'=>'info_get', 'SET'=>'info_set');

    my %init_args : InitArgs = (
        'data' => {
            'Field' => \%data,
        },
        'info' => {
            'FIELD' => \%info,
            'DEF'   => ''
        },
    );
}


package foo; {
    use Object::InsideOut;
}


package main;

MAIN:
{
    my $obj;
    eval { $obj = AA->new(); };
    ok(! $@, '->new() ' . $@);
    can_ok($obj, qw(new clone DESTROY CLONE aa));

    ok($$obj == 1,                  'Object ID: ' . $$obj);
    ok(! defined($obj->aa),         'No default');
    ok($obj->aa(42) == 42,          'Set ->aa()');
    ok($obj->aa == 42,              'Get ->aa() == ' . $obj->aa);

    eval { $obj = BB->new(); };
    can_ok($obj, qw(bb set_bb));
    ok(! $@, '->new() ' . $@);
    ok($$obj == 2,                  'Object ID: ' . $$obj);
    is($obj->bb, 'def',             'Default: ' . $obj->bb);
    is($obj->set_bb('foo'), 'foo',  'Set ->set_bb()');
    is($obj->bb, 'foo',             'Get ->bb() eq ' . $obj->bb);

    eval { $obj = BB->new('bB' => 'baz'); };
    ok(! $@, '->new() ' . $@);
    ok($$obj == 3,                  'Object ID: ' . $$obj);
    is($obj->bb, 'baz',             'Init: ' . $obj->bb);
    is($obj->set_bb('foo'), 'foo',  'Set ->set_bb()');
    is($obj->bb, 'foo',             'Get ->bb() eq ' . $obj->bb);

    eval { $obj = AB->new(); };
    can_ok($obj, qw(aa bb set_bb data info_get info_set));
    ok(! $@, '->new() ' . $@);
    ok($$obj == 4,                  'Object ID: ' . $$obj);
    is($obj->bb, 'def',             'Default: ' . $obj->bb);
    is($obj->set_bb('foo'), 'foo',  'Set ->set_bb()');
    is($obj->bb, 'foo',             'Get ->bb() eq ' . $obj->bb);
    is($obj->bb, 'foo',             'Get ->bb() eq ' . $obj->bb);
    is($obj->info_get(), '',        '->info_get() eq ' . $obj->info_get());
    $obj->info_set('test');
    is($obj->info_get(), 'test',    'Set: ->info_get() eq ' . $obj->info_get());

    # Test that IDs are being reclaimed
    my $id;
    {
        my $x = foo->new();
        $id = $$x;
    }
    for (1..10) {
        my $x = foo->new();
        is($$x, $id, 'ID reclaimed');
    }
}

exit(0);

# EOF
Object-InsideOut-4.05/t/35-add_class.t0000644000175000001440000000160413377136466017050 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 7;

package Trait::Selected; {
    use Object::InsideOut;

    my %is_selected :Field;

    sub is_selected
    {
        my $self = shift;
        $is_selected{$$self} ||= 0;
        return $is_selected{$$self} unless @_;
        $is_selected{$$self} = shift;
        return $self;
    }
}

package Foo; {
    use Object::InsideOut;

    my %data :Field :All(data);
}

package Bar; {
    use Object::InsideOut qw(Foo);

    my %info :Field :All(info);
}

package main;

my $obj = Bar->new('data' => 'zip', 'info' => 2);

is($obj->data(), 'zip', 'Get data');
is($obj->info(), 2,     'Get info');

Foo->add_class('Trait::Selected');
can_ok('Bar', 'is_selected');

is($obj->is_selected(1), $obj, 'Returns self');
is($obj->is_selected(), 1,     'Selected');

is($obj->data(), 'zip', 'Get data');
is($obj->info(), 2,     'Get info');

exit(0);

# EOF
Object-InsideOut-4.05/t/39-fork.t0000644000175000001440000000234413377136466016102 0ustar  jdheddenusersuse strict;
use warnings;
no warnings 'once';

BEGIN {
    use Config;
    my $pseudo_fork = (($^O eq 'MSWin32' || $^O eq 'NetWare') &&
                       $Config::Config{useithreads} &&
                       $Config::Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/);
    if (! $pseudo_fork) {
        print("1..0 # SKIP Not using pseudo-forks\n");
        exit(0);
    }
}

use Test::More 'tests' => 1;

package Foo; {
    use Object::InsideOut;

    my @foo :Field :All(foo);
}

package main;

my $main = $$;

my $obj = Foo->new();
$obj->foo(0);

open(OLDERR, ">&STDERR");
open(STDERR, ">stderr.tmp");

for (1..3) {
    if (my $pid = fork()) {
        # Parent
        $obj->foo($_);
        die if $obj->foo() != $_;

        my $x = Foo->new();
        $x->foo($$);
        die if $x->foo() != $$;

    } else {
        # Child
        $obj->foo($_);
        die if $obj->foo() != $_;

        my $x = Foo->new();
        $x->foo($$);
        die if $x->foo() != $$;
    }
}

if ($$ == $main) {
    sleep(2);
    open(STDERR, '>&OLDERR');
    ok(-z 'stderr.tmp', "MSWin32 pseudo-forks");
    if (-s 'stderr.tmp') {
        open(IN, 'stderr.tmp');
        diag($_) foreach ();
        close(IN);
    }
    unlink('stderr.tmp');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/EmptyParent.pm0000644000175000001440000000003313377136466017322 0ustar  jdheddenuserspackage t::EmptyParent;
1;
Object-InsideOut-4.05/t/45-unused.t0000644000175000001440000000476113377136466016446 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 16;

package Person; {
    use Object::InsideOut;
    my @name :Field :Arg('name');

    my %init_args :InitArgs = (
        'alias' => '',
        'person' => {
            'regex' => qr/^p/i,
            'field' => \@name,
        },
    );
}

package Foo; {
    use Object::InsideOut;
    my @foo :Field;
}

package Bar; {
    use Object::InsideOut;

    sub _init :Init
    {
        my ($self, $args) = @_;
        if (exists($$args{'bar'})) {
            Test::More::ok(1, ':Init with param');
        } elsif (exists($$args{'baz'})) {
            Test::More::ok(1, ':Init with misspelled param');
        } else {
            Test::More::ok(0, 'BUG!!!');
        }
    }
}

package Who; {
    use Object::InsideOut;
    my @name :Field;

    my %init_args :InitArgs = (
        'alias' => '',
    );

    sub _init :Init
    {
        my ($self, $args) = @_;
        if (exists($$args{'alias'})) {
            $self->set(\@name, $$args{'alias'});
        }
    }
}


package main;

MAIN:
{
    eval { my $obj = Person->new(nane => 'Joe'); };
    like($@, qr/Unhandled parameter:/, 'Misspelled param');
    eval { my $obj = Person->new(Person => { nane => 'Joe' }); };
    like($@, qr/Unhandled parameter for class/, 'Misspelled param');

    eval { my $obj = Person->new(alias => 'Joe'); };
    like($@, qr/Unhandled parameter for class/, ':InitArg with no :Init');
    eval { my $obj = Person->new(Person => { alias => 'Joe' }); };
    like($@, qr/Unhandled parameter for class/, ':InitArg with no :Init');
    my $obj = Person->new(parson => 'John');
    ok($obj, 'Regex matches');

    $obj = Foo->new();
    ok($obj, 'No params');
    eval { my $obj = Foo->new('bar' => 'baz'); };
    like($@, qr/Unhandled parameter:/, 'No :InitArg and no :Init');
    eval { my $obj = Foo->new(Foo => { 'bar' => 'baz' }); };
    like($@, qr/Unhandled parameter for class/, 'No :InitArg and no :Init');

    $obj = Bar->new('bar' => 1);
    ok($obj, ':Init with param');
    $obj = Bar->new('baz' => 1);
    ok($obj, ':Init with misspelled param');

    $obj = Who->new('alias' => 'Joe');
    ok($obj, ':Init and :InitArgs');
    $obj = Who->new(Who => {'alias' => 'Joe'});
    ok($obj, ':Init and :InitArgs');

    eval { my $obj = Who->new('aliaX' => 'Joe'); };
    like($@, qr/Unhandled parameter:/, ':InitArg and :Init with typo');
    eval { my $obj = Who->new(Who => {'aliaX' => 'Joe'}); };
    like($@, qr/Unhandled parameter for class/, ':InitArg and :Init with typo');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/15a-type.t0000644000175000001440000001167513377136466016264 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 32;

package My::Class; {
    use Object::InsideOut;

    sub is_scalar :Private { return (! ref(shift)); }

    sub is_int {
        my $arg = $_[0];
        return (Scalar::Util::looks_like_number($arg) &&
                (int($arg) == $arg));
    }

    my @aa :Field
           :Acc(aa) :Name(aa)
           :Type(array);
    my @ar :Field
           :Acc(ar)
           :Type(array_ref);
    my @cc :Field
           :Acc(cc)
           :Type(sub{ shift > 0 });
    my @hh :Field
           :Acc(hh)
           :Type(hash);
    my @hr :Field
           :Acc(hr) :Name(hr)
           :Type(hashref);
    my @mc :Field
           :Acc(mc)
           :Type(My::Class);
    my @nn :Field
           :Acc(nn)
           :Type(num);
    my @ns :Field
           :Acc(ns)
           :Type(list(num));
    my @ss :Field
           :Acc(ss)
           :Type(\&My::Class::is_scalar);
    my @sr :Field
           :Acc(sr)
           :Type(SCALARref);

    my %init_args :InitArgs = (
        'DATA' => {
            'Field' => \@nn,
            'Type'  => \&is_int,
        },
        'INFO' => {
            'Type'  => sub { $_[0] }
        },
        'BAD' => {
            'Type'  => sub { shift > 0 }
        },
    );
}

package Foo; {
    use Object::InsideOut;

    my @foo :Field :Acc(foo);
    my @array_of_num  :Field :All(array_of_num) :Type( ARRAY_ref(numeric) );

    my %init_args :InitArgs = (
        'FOO' => {
            'field' => \@foo,
            'type' => 'ARRAYref(UNIVERSAL)'
        },
    );
}

package main;

MAIN:
{
    my $obj = My::Class->new('DATA' => 5);

    $obj->aa('test');
    is_deeply($obj->aa(), ['test']              => 'Array single value');
    $obj->aa('zero', 5);
    is_deeply($obj->aa(), ['zero', 5]           => 'Array multiple values');
    $obj->aa(['x', 42, 'z']);
    is_deeply($obj->aa(), ['x', 42, 'z']        => 'Array ref value');

    eval { $obj->ar('test'); };
    like($@->message, qr/Wrong type/            => 'Not array ref');
    $obj->ar([3, [ 'a' ]]);
    is_deeply($obj->ar(), [3, [ 'a' ]]          => 'Array ref');

    $obj->cc(12);
    is($obj->cc(), 12                           => 'Type sub');
    eval { $obj->cc(-5); };
    like($@->message, qr/failed type check/     => 'Type failure');
    eval { $obj->cc('hello'); };
    like($@->message, qr/Problem with type check routine/  => 'Type sub failure');

    $obj->hh('x' => 5);
    is_deeply($obj->hh(), {'x'=>5}              => 'Hash single pair');
    $obj->hh('a' => 'z', '0' => '9');
    is_deeply($obj->hh(), {'a'=>'z','0'=>'9'}   => 'Hash multiple pairs');
    $obj->hh({'2b'=>'not'});
    is_deeply($obj->hh(), {'2b'=>'not'}         => 'Hash ref value');

    eval { $obj->hr('test'); };
    like($@->message, qr/Wrong type/            => 'Not hash ref');
    $obj->hr({'frog'=>{'prince'=>'John'}});
    is_deeply($obj->hr(), {'frog'=>{'prince'=>'John'}} => 'Hash ref');

    my $obj2 = My::Class->new();
    $obj->mc($obj2);
    my $obj3 = $obj->mc();
    isa_ok($obj3, 'My::Class'                   => 'Object');
    is($$obj3, $$obj2                           => 'Objects equal');
    eval { $obj2->mc('test'); };
    like($@->message, qr/Wrong type/            => 'Not object');

    $obj->nn(99);
    is_deeply($obj->nn(), 99                    => 'Numeric');
    eval { $obj->nn('x'); };
    like($@->message, qr/Bad argument/          => 'Numeric failure');

    $obj->ns(86);
    is_deeply($obj->ns(), [86]                  => 'Array single num');
    $obj->ns(1, 2.5, 5);
    is_deeply($obj->ns(), [1, 2.5, 5]           => 'Array multiple num');
    $obj->ns([42, 0, -1]);
    is_deeply($obj->ns(), [42, 0, -1]           => 'Array ref num');

    $obj->ss('hello');
    is($obj->ss(), 'hello'                      => 'Scalar');
    eval { $obj->ss([1]); };
    like($@->message, qr/failed type check/     => 'Scalar failure');

    eval { $obj->sr('test'); };
    like($@->message, qr/Wrong type/            => 'Not scalar ref');
    my $x = 42;
    $obj->sr(\$x);
    is($obj->sr(), \$x                          => 'Scalar ref');
    my $y = $obj->sr();
    is($$y, 42                                  => 'Scalar ref value');

    eval { $obj2 = My::Class->new('DATA' => 'hello'); };
    like($@->message, qr/failed type check/     => 'Type failure');

    eval { $obj2 = My::Class->new('INFO' => ''); };
    like($@->message, qr/failed type check/     => 'Type failure');

    eval { $obj2 = My::Class->new('BAD' => ''); };
    like($@->message, qr/Problem with type check routine/  => 'Type sub failure');

    my $foo = Foo->new();
    my $foo2 = Foo->new('FOO' => [ $foo, $obj ]);
    is_deeply($foo2->foo(), [ $foo, $obj ]      => 'InitArgs type arrayref(UNIV)');
    my $foo3 = Foo->new('array_of_num' => [ 1957, 42, 3.14 ]);
    is_deeply($foo3->array_of_num(), [ 1957, 42, 3.14 ]  => 'InitArgs type arrayref(numeric)');
    $foo3->array_of_num( [1,2,3] );
    is_deeply($foo3->array_of_num(), [ 1, 2, 3 ]  => 'Set arrayref(numeric)');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/00-load.t0000644000175000001440000000043713377136466016045 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 1;

package My::Class; {
    BEGIN {
        Test::More::use_ok('Object::InsideOut');
    }
}

package main;

if ($Object::InsideOut::VERSION) {
    diag('Testing Object::InsideOut ' . $Object::InsideOut::VERSION);
}

exit(0);

# EOF
Object-InsideOut-4.05/t/09b-chained.t0000644000175000001440000000535413377136466016677 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 3;

package Base1; {
    use Object::InsideOut;

    sub foo :Chained :MergedArgs :Restricted(Outside)
    {
        my ($self, $args) = @_;
        push(@{$args->{'list'}}, __PACKAGE__);
        return ({'list' => $args->{'list'}}, 'last' => __PACKAGE__);
    }
}

package Base2; {
    use Object::InsideOut qw(Base1);

    sub foo :Chained :MergedArgs
    {
        my ($self, $args) = @_;
        push(@{$args->{'list'}}, __PACKAGE__);
        return ('list' => $args->{'list'}, 'last' => __PACKAGE__);
    }
}

package Base3; {
    use Object::InsideOut qw(Base1);

    sub foo :Chained :MergedArgs
    {
        my ($self, $args) = @_;
        push(@{$args->{'list'}}, __PACKAGE__);
        return ({'list' => $args->{'list'}, 'last' => __PACKAGE__});
    }
}

package Base4; {
    use Object::InsideOut;

    sub foo :MergedArgs  # but not chained!
    {
        my ($self, $args) = @_;
        push(@{$args->{'list'}}, __PACKAGE__);
        $args->{'last'} = __PACKAGE__;
        return ($args);
    }
}

package Der1; {
    use Object::InsideOut qw(Base2 Base3 Base4);

    sub foo :Chained :MergedArgs :Restricted('', Prog)
    {
        my ($self, $args) = @_;
        push(@{$args->{'list'}}, __PACKAGE__);
        return ({'list' => $args->{'list'}}, {'last' => __PACKAGE__});
    }
}

package Der2; {
    use Object::InsideOut qw(Base2 Base3 Base4);

    sub foo :Chained :MergedArgs
    {
        my ($self, $args) = @_;
        push(@{$args->{'list'}}, __PACKAGE__);
        return ('list' => $args->{'list'}, {'last' => __PACKAGE__});
    }
}

package Reder1; {
    use Object::InsideOut qw(Der1 Der2);

    sub foo :Chained :MergedArgs
    {
        my ($self, $args) = @_;
        push(@{$args->{'list'}}, __PACKAGE__);
        $args->{'last'} = __PACKAGE__;
        return ($args);
    }

    sub get_foo
    {
        my $self = shift;
        return ($self->foo());
    }
}

package Outside; {
    use Object::InsideOut;

    sub bar
    {
        my $self = shift;
        my $obj  = shift;
        return ($obj->foo());
    }
}

package main;

MAIN:
{
    my $obj = Reder1->new();

    eval { $obj->foo() };
    like($@, qr/restricted method/ => ':Restricted + :Chained');

    my $expected = {
          'last' => 'Reder1',
          'list' => [
                      'Base1',
                      'Base2',
                      'Base3',
                      'Der1',
                      'Der2',
                      'Reder1'
                    ]
        };

    my ($got) = $obj->get_foo();

    is_deeply($got, $expected => 'Chained methods with merged args');

    my $out = Outside->new();
    ($got) = $out->bar($obj);

    is_deeply($got, $expected => 'Chained methods with merged args');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/34a-secure.t0000644000175000001440000000311313377136466016556 0ustar  jdheddenusersuse strict;
use warnings;

use Config;
BEGIN {
    if (! $Config{useithreads} || $] < 5.008) {
        print("1..0 # Skip Threads not supported\n");
        exit(0);
    }
}

use threads;
use threads::shared;

BEGIN {
    $Math::Random::MT::Auto::shared = 1;
    eval { require Math::Random::MT::Auto; };
    if ($@) {
        print("1..0 # Skip Math::Random::MT::Auto not available\n");
        exit(0);
    }
    if ($Math::Random::MT::Auto::VERSION < 5.04) {
        print("1..0 # Skip Needs Math::Random::MT::Auto v5.04 or later\n");
        exit(0);
    }
}

if ($] == 5.008) {
    require 't/test.pl';   # Test::More work-alike for Perl 5.8.0
} else {
    require Test::More;
}
Test::More->import();
plan('tests' => 10);


package Foo; {
    use Object::InsideOut ':SECURE :SHARED';

    my %data :Field :All(data);
}

package Bar; {
    use Object::InsideOut qw(Foo);

    my %info :Field :All(info);
    #my @foo :Field;
}

package main;

my $obj = Bar->new('data' => 1, 'info' => 2);
is($obj->data(), 1, 'Get data');
is($obj->info(), 2, 'Get info');

eval { Bar->create_field('@misc', ':Field', ':All(misc)'); };
like($@->error, qr/Can't combine 'hash only'/, 'Hash only');

ok($$obj != 1, "ID: $$obj");

threads->create(sub {
    my $id = shift;
    is($$obj, $id, 'Same ID in thread');
    is($obj->data(), 1, 'Get data in thread');
    is($obj->info(), 2, 'Get info in thread');

    my $obj2 = Bar->new('data' => 5, 'info' => 9);
    ok($$obj2 != 1, "ID: $$obj2");
    is($obj2->data(), 5, 'Get data in thread');
    is($obj2->info(), 9, 'Get info in thread');

}, $$obj)->join();

exit(0);

# EOF
Object-InsideOut-4.05/t/51-readonly.t0000644000175000001440000000465513377136466016757 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 19;

package My::Class; {
    use Object::InsideOut;

    sub is_scalar { return (! ref(shift)); }

    sub is_int {
        my $arg = $_[0];
        return (Scalar::Util::looks_like_number($arg) &&
                (int($arg) == $arg));
    }

    my @data :Field('readonly'=>'data', 'type' => 'num');
    my @info :Field({ 'std'=>'info', 'arg'=>'scalar', 'type' => \&My::Class::is_scalar });
    my @foo  :Field
             :STD_RO(foo)
             :Type(name => \&My::Class::is_int);
    my @bar  :Field('ro'=>'bar', 'type' => 'ARRAY');
    my @baz  :Field
             :ReadOnly(baz)
             :Type(hash);
    my @bork :Field
             :Def('bork')
             :Get(bork);
    my %faz  :Field
             :Arg('zzz')
             :Def('snooze');

    sub init :Init
    {
        my ($self, $args) = @_;
        Test::More::is($faz{$$self}, 'snooze' => 'default assigned before :Init');
    }
}

package main;

MAIN:
{
    my $obj = My::Class->new(
        'data'   => 5.5,
        'scalar' => 'foo',
        'foo'    => 99,
        'bar'    => 'bar',
        'baz'    => { 'hello' => 'world' },
    );

    ok($obj                             => 'Object created');
    is($obj->data(),     5.5            => 'num field');
    is($obj->get_info(), 'foo'          => 'scalar field');
    is($obj->get_foo(),  99             => 'int field');
    is_deeply($obj->bar(), [ 'bar' ]    => 'list field');
    is_deeply($obj->baz(), { 'hello' => 'world' }       => 'hash field');
    is($obj->bork(), 'bork',            => 'default');

    ok !defined eval { $obj->data(6.6); 1 } => 'no data setter';
    is($obj->data(),     5.5            => 'data value unchanged');

    ok !defined eval { $obj->set_foo(101); 1 } => 'no set_foo';
    is($obj->get_foo(),  99             => 'no change in foo');

    ok !defined eval { $obj->bar([]); 1 } => 'no bar() setter';
    is_deeply($obj->bar(), [ 'bar' ]    => 'list field unchanged');

    ok !defined eval { $obj->baz({}); 1 } => 'no baz() setter';
    is_deeply($obj->baz(), { 'hello' => 'world' }       => 'hash field unchanged');



    eval { My::Class->new('data' => 'foo'); };
    like($@, qr/must be a number/       => 'Type check');

    eval { My::Class->new('scalar' => $obj); };
    like($@, qr/failed type check/      => 'Type check');

    eval { My::Class->new('foo' => 4.5); };
    like($@, qr/failed type check/      => 'Type check');

}

exit(0);

# EOF
Object-InsideOut-4.05/t/50-active_defs.t0000644000175000001440000001373613377136466017415 0ustar  jdheddenusersuse Test::More tests => 58;
{
    package Iterator;
    use Object::InsideOut;

    my @next : Field Arg(start);

    sub next {
        my ($self) = @_;
        my $next = $next[$$self];
        $next[$$self]++;
        $next[$$self] = substr($next[$$self],-1) . substr($next[$$self],0,-1);
        return $next;
    }
}

{
    package Foo;
    use Object::InsideOut;

    sub triple { shift(@_) x 3 }

    my @ID     : Field Get(ID)     SequenceFrom(1);
    my @rating : Field Get(Rating) SeqFrom('XXX');
    my @ccv    : Field Get(CCV)    SeqFrom(Iterator->new(start=>triple('A')));

    my @seven  : Field Get(Seven)  Default(7);
    my @ID2    : Field Get(ID2)    Default($self->ID() + 1);
}

# Test sequential defaults...
is(Foo->new->ID, 1 => 'First ID in sequence');
is(Foo->new->ID, 2 => 'Second ID in sequence');
is(Foo->new->ID, 3 => 'Third ID in sequence');

is(Foo->new->Rating, 'XYA' => 'Fourth rating in sequence');
is(Foo->new->Rating, 'XYB' => 'Fifth rating in sequence');
is(Foo->new->Rating, 'XYC' => 'Sixth rating in sequence');

is(Foo->new->CCV, 'CCC' => 'Seventh CCV in sequence');
is(Foo->new->CCV, 'DCC' => 'Eighth CCV in sequence');
is(Foo->new->CCV, 'DDC' => 'Ninth CCV in sequence');

# Test constant default...
is(Foo->new->Seven, 7 => "Seven is 7");
is(Foo->new->Seven, 7 => "Seven still 7");
is(Foo->new->Seven, 7 => "Seven always 7");

# Test args to :Default...
my $obj = Foo->new;
is $obj->ID2 - 1, $obj->ID  => 'Default via $self';


package Bar; {
    use Object::InsideOut;

    my @h1 :Field :Get(H1) :Default({});
    my @h2 :Field :Get(H2) :Arg(Hash2) :Default({});
    my @h3 :Field :Get(H3) :Arg(Name => 'Hash3', Default => {});
    my @h4 :Field :Get(H4);

    my @r1 :Field :Get(R1) :Default(rand);
    my @r2 :Field :Get(R2) :Arg(Rand2) :Default(rand);
    my @r3 :Field :Get(R3) :Arg(Name => 'Rand3', Default => sub {rand});
    my @r4 :Field :Get(R4);

    my @m1 :Field :Get(M1) :Default($self->biz);
    my @m2 :Field :Get(M2) :Arg(Meth2) :Default($self->biz);
    my @m3 :Field :Get(M3) :Arg(Name => 'Meth3', Default => sub {shift->biz});
    my @m4 :Field :Get(M4);

    my @c1 :Field :Get(C1) :Default(bork);
    my @c2 :Field :Get(C2) :Arg(Code2) :Default(bork);
    my @c3 :Field :Get(C3) :Arg(Name => 'Code3', Default => \&bork);
    my @c4 :Field :Get(C4);

    my @f1 :Field :Get(F1) :Default(our $next; ++$next);
    my @f2 :Field :Get(F2) :Arg(Func2) :Default(our $nn; ++$nn, $nn*$nn);
    my @f3 :Field :Get(F3) :Arg(Name => 'Func3', Default => sub {our $foo; --$foo});
    my @f4 :Field :Get(F4);

    sub biz :Private
    {
        return ref(shift);
    }

    sub bork :Restricted
    {
        __PACKAGE__
    }

    my %init_args :InitArgs = (
        'Hash4' => {
            'Field' => \@h4,
            'Default' => {},
        },
        'Rand4' => {
            'Field' => \@r4,
            'Default' => sub {rand},
        },
        'Meth4' => {
            'Field' => \@m4,
            'Default' => sub {shift->biz},
        },
        'Code4' => {
            'Field' => \@c4,
            'Default' => \&bork,
        },
        'Func4' => {
            'Field' => \@f4,
            'Default' => sub {our $bar; chr(++$bar + 64)},
        },
    );

}

package main;

my $o1 = Bar->new('Hash3' => {'argx' => '-'},
                  'Rand2' => 'nill',
                  'Meth2' => 'foo',
                  'Func2' => 99,
                 );
my $o2 = Bar->new('Hash4' => [1,2,3],
                  'Rand3' => 1.0,
                  'Meth3' => Foo->new(),
                  'Func3' => 98,
                 );
my $o3 = Bar->new('Hash2' => 'bork',
                  'Rand4' => time,
                  'Meth4' => $],
                  'Func4' => 97,
                 );

$o1->H1->{'foo'} = 12;
$o2->H1->{'foo'} = 'bar';
is($o1->H1->{'foo'}, 12 => 'Separate hashes');
ok(!exists $o3->H1->{'foo'} => 'Separate hashes');

$o2->H2->{'foo'} = 'bip';
$o1->H2->{'foo'} = 44;
is($o2->H2->{'foo'}, 'bip' => 'Separate hashes');
is($o3->H2, 'bork' => 'Default override');

$o2->H3->{'bar'} = 'zero';
$o3->H3->{'bar'} = 44;
is($o2->H3->{'bar'}, 'zero' => 'Separate hashes');
is($o1->H3->{'argx'}, '-' => 'Default override');

$o1->H4->{'biff'} = {'foo'=>'true'};
$o3->H4->{'biff'} = 'xyz';
is($o1->H4->{'biff'}->{'foo'}, 'true' => 'Separate hashes');
is($o2->H4->[2], 3 => 'Default override');

my $r1 = $o1->R1;
my $r2 = $o2->R1;
ok(0 <= $r1 && $r1 < 1 => 'R1 for o1 is random');
ok(0 <= $r2 && $r2 < 1 => 'R1 for o2 is random');
isnt($r1, $r2 => 'Rands are different');

$r1 = $o1->R2;
$r2 = $o2->R2;
$r3 = $o3->R2;
is($r1, 'nill' => 'Default override');
ok(0 <= $r2 && $r2 < 1 => 'R2 for o2 is random');
ok(0 <= $r3 && $r3 < 1 => 'R2 for o3 is random');
isnt($r2, $r3 => 'Rands are different');

$r1 = $o1->R3;
$r2 = $o2->R3;
$r3 = $o3->R3;
ok(0 <= $r1 && $r1 < 1 => 'R3 for o1 is random');
is($r2, 1.0 => 'Default override');
ok(0 <= $r3 && $r3 < 1 => 'R3 for o3 is random');
isnt($r1, $r3 => 'Rands are different');

$r1 = $o1->R4;
$r2 = $o2->R4;
$r3 = $o3->R4;
ok(0 <= $r1 && $r1 < 1 => 'R4 for o1 is random');
ok(0 <= $r2 && $r2 < 1 => 'R4 for o2 is random');
ok($r3 > 1329336828 => 'Default override');
isnt($r1, $r2 => 'Rands are different');

is($o1->M1, 'Bar' => 'Private method access');
is($o1->M2, 'foo' => 'Default override');
is($o1->M3, 'Bar' => 'Private method access');
is($o1->M4, 'Bar' => 'Private method access');

is($o2->M3->ID2 - 1, $o2->M3->ID => 'Default override');
is($o3->M4, $] => 'Default override');

is($o1->C1, 'Bar' => 'Class method access');
is($o1->C2, 'Bar' => 'Class method access');
is($o1->C3, 'Bar' => 'Class method access');
is($o1->C4, 'Bar' => 'Class method access');

is($o1->F1, 1 => 'Default code');
is($o2->F1, 2 => 'Default code');
is($o3->F1, 3 => 'Default code');

is($o1->F2, 99 => 'Default override');
is($o2->F2, 1 => 'Default code');
is($o3->F2, 4 => 'Default code');

is($o1->F3, -1 => 'Default code');
is($o2->F3, 98 => 'Default override');
is($o3->F3, -2 => 'Default code');

is($o1->F4, 'A' => 'Default code');
is($o2->F4, 'B' => 'Default code');
is($o3->F4, 97 => 'Default override');

# EOF
Object-InsideOut-4.05/t/10a-cumulative.t0000644000175000001440000000366713377136466017456 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 1;

package Base1; {
    use Object::InsideOut;

    sub foo :Cumulative :MergedArgs
    {
        my ($self, $args) = @_;
        my $pkg = __PACKAGE__;
        return ($args->{$pkg});
    }
}

package Base2; {
    use Object::InsideOut qw(Base1);

    sub foo :Cumulative :MergedArgs
    {
        my ($self, $args) = @_;
        my $pkg = __PACKAGE__;
        return ($args->{$pkg});
    }
}

package Base3; {
    use Object::InsideOut qw(Base1);

    sub foo :Cumulative :MergedArgs
    {
        my ($self, $args) = @_;
        my $pkg = __PACKAGE__;
        return ($args->{$pkg});
    }
}

package Base4; {
    use Object::InsideOut;

    sub foo :MergedArgs  # but not Cumulative!
    {
        my ($self, $args) = @_;
        my $pkg = __PACKAGE__;
        return ($args->{$pkg});
    }
}

package Der1; {
    use Object::InsideOut qw(Base2 Base3 Base4);

    sub foo :Cumulative :MergedArgs
    {
        my ($self, $args) = @_;
        my $pkg = __PACKAGE__;
        return ($args->{$pkg});
    }
}

package Der2; {
    use Object::InsideOut qw(Base2 Base3 Base4);

    sub foo :Cumulative :MergedArgs
    {
        my ($self, $args) = @_;
        my $pkg = __PACKAGE__;
        return ($args->{$pkg});
    }
}

package Reder1; {
    use Object::InsideOut qw(Der1 Der2);

    sub foo :Cumulative :MergedArgs
    {
        my ($self, $args) = @_;
        my $pkg = __PACKAGE__;
        return ($args->{$pkg});
    }
}

package main;

MAIN:
{
    my $obj = Reder1->new();

    my @expected = ('foo', 'bar', 'baz', 'bing', 'bang', 'bong');

    my @got = $obj->foo( 'Base1'  => 'foo',
                       { 'Base2'  => 'bar', },
                       { 'Base3'  => 'baz',
                         'Der1'   => 'bing', },
                         'Der2'   => 'bang',
                       { 'Reder1' => 'bong', } );

    is_deeply(\@got, \@expected => 'Cumulative methods with merged args');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/29-non_lvalue.t0000644000175000001440000004316213377136466017305 0ustar  jdheddenusersuse strict;
use warnings;

BEGIN {
    eval { require Want; };
    if ($@ || $Want::VERSION < 0.12) {
        print("1..0 # Skip Needs Want v0.12 or later\n");
        exit(0);
    }
}


use Test::More 'tests' => 163;
use Scalar::Util;

package Baz; {
    use Object::InsideOut;
    sub me
    {
        my $self = shift;
        return ("Baz($$self)");
    }
}

package Foo; {
    use Object::InsideOut;

    # Separate get and set accessors
    my @foo1 :Field('Std' => 'foo1',                          'Return' => 'NEW');
    my @foo2 :Field('Get' => 'get_foo2', 'set' => 'set_foo2', 'Return' => 'OLD');
    my @foo3 :Field('STANDARD' => 'foo3',                     'Return' => 'SELF');

    # Combined get+set accessor
    my @bar1 :Field('Combo'  => 'bar1',  'Return' => 'new');
    my @bar2 :Field('Acc'    => 'bar2',  'Return' => 'Prev');
    my @bar3 :Field('get_set' => 'bar3', 'Return' => 'obj');

    # Type checking
    my @baz1 :Field('Acc' => 'baz1', 'Return' => 'new', 'Type' => 'Baz');
    my @baz2 :Field('Acc' => 'baz2', 'Return' => 'old', 'Type' => 'Baz');
    my @baz3 :Field('Acc' => 'baz3', 'Return' => 'obj', 'Type' => 'Baz');

    my @num1 :Field('Acc' => 'num1', 'Return' => 'new', 'Type' => 'num');
    my @num2 :Field('Acc' => 'num2', 'Return' => 'old', 'Type' => 'num');
    my @num3 :Field('Acc' => 'num3', 'Return' => 'obj', 'Type' => 'num');

    sub me
    {
        my $self = shift;
        return ("Foo($$self)");
    }
}

package main;

sub change_it
{
    $_[0] = $_[1];
}

sub check_it
{
    my ($x, $y) = @_;
    if ($x eq $y) {
        ok(1, 'Checked');
    } else {
        is($x, $y, 'Check failed');
    }
}

MAIN:
{
    my $b1 = Baz->new();
    my $b2 = Baz->new();
    my $obj = Foo->new();
    ok($b1 && $b2 && $obj, 'Objects created');

    can_ok($obj, qw(new clone DESTROY CLONE
                    get_foo1 set_foo1 get_foo2 set_foo2 get_foo3 set_foo3
                    bar1 bar2 bar3));

    # set - return new
    eval { $obj->set_foo1(); };
    like($@, qr/Missing arg/            => 'rvalue set needs arg');

    $obj->set_foo1('val');
    is($obj->get_foo1(), 'val'          => 'rvalue set void');

    eval { $obj->get_foo1(); };
    is($@, ''                           => 'rvalue get void');

    my $val = $obj->set_foo1($b1);
    is($val, $b1                        => 'rvalue set returns new');

    my $val2 = $obj->get_foo1();
    is($val2, $b1                       => 'rvalue get');

    eval { $obj->set_foo1() = $b2; };
    like($@, qr/non-lvalue subroutine/  => 'not lvalue');

    change_it($obj->set_foo1('Bert'), 'Mike');
    is($obj->get_foo1(), 'Bert'         => 'lvalue does not work');
    check_it($obj->set_foo1('Ralph'), 'Ralph');

    $obj->set_foo1($b1);
    eval { $val = $obj->set_foo1()->me(); };
    like($@, qr/Missing arg/            => 'chain set needs arg');

    $val = $obj->set_foo1('bork')->me();
    is($val, 'Foo(1)'                   => 'chain self');

    $val = $obj->set_foo1($b2)->me();
    is($val, 'Baz(2)'                   => 'chain new object');


    # set - return old
    eval { $obj->set_foo2(); };
    like($@, qr/Missing arg/            => 'rvalue set needs arg');

    $obj->set_foo2('val');
    is($obj->get_foo2(), 'val'          => 'rvalue set void');

    eval { $obj->get_foo2(); };
    is($@, ''                           => 'rvalue get void');

    $obj->set_foo2($b2);
    $val = $obj->set_foo2($b1);
    is($val, $b2                        => 'rvalue set returns old');

    $val2 = $obj->get_foo2();
    is($val2, $b1                       => 'rvalue get');

    eval { $obj->set_foo2() = $b2; };
    like($@, qr/non-lvalue subroutine/  => 'not lvalue');

    eval { $obj->set_foo2() =~ s/er/re/; };
    like($@, qr/non-lvalue subroutine/  => 'not lvalue');

    change_it($obj->set_foo2('Bert'), 'Mike');
    is($obj->get_foo2(), 'Bert'         => 'lvalue does not work');
    check_it($obj->set_foo2('Ralph'), 'Bert');

    $obj->set_foo2($b1);
    eval { $val = $obj->set_foo2()->me(); };
    like($@, qr/Missing arg/            => 'chain set needs arg');

    $obj->set_foo2('bork');
    $val = $obj->set_foo2('bar')->me();
    is($val, 'Foo(1)'                   => 'chain self');
    is($obj->get_foo2(), 'bar'          => 'chain set');

    $obj->set_foo2($b1);
    $val = $obj->set_foo2($b2)->me();
    is($val, 'Baz(1)'                   => 'chain old object');
    is($obj->get_foo2(), $b2            => 'chain set');


    # set - return self
    eval { $obj->set_foo3(); };
    like($@, qr/Missing arg/            => 'rvalue set needs arg');

    $obj->set_foo3('val');
    is($obj->get_foo3(), 'val'          => 'rvalue set void');

    eval { $obj->get_foo3(); };
    is($@, ''                           => 'rvalue get void');

    $val = $obj->set_foo3($b1);
    is($val, $obj                       => 'rvalue set returns self');

    $val2 = $obj->get_foo3();
    is($val2, $b1                       => 'rvalue get');

    eval { $obj->set_foo3() = $b2; };
    like($@, qr/non-lvalue subroutine/  => 'not lvalue');

    my $obj_old = $obj;
    change_it($obj->set_foo3('Bert'), 'Mike');
    is($obj, $obj_old                   => 'lvalue does not work');
    is($obj->get_foo3(), 'Bert'         => 'Change did set');
    check_it($obj->set_foo3('Ralph'), $obj);
    is($obj->get_foo3(), 'Ralph'        => 'Check did set');

    $obj->set_foo3($b1);
    is($obj->get_foo3()->me(), 'Baz(1)' => 'chain get');

    eval { $val = $obj->set_foo3()->me(); };
    like($@, qr/Missing arg/            => 'chain set needs arg');

    $val = $obj->set_foo3('bork')->me();
    is($val, 'Foo(1)'                   => 'chain self');
    is($obj->get_foo3(), 'bork'         => 'chain set');

    $val = $obj->set_foo3($b2)->me();
    is($val, 'Foo(1)'                   => 'chain self');
    is($obj->get_foo3(), $b2            => 'chain set');


    # get_set - return new
    $obj->bar1('val');
    is($obj->bar1(), 'val'              => 'rvalue set void');

    eval { $obj->bar1(); };
    is($@, ''                           => 'rvalue get void');

    $val = $obj->bar1($b1);
    is($val, $b1                        => 'rvalue set returns new');

    $val2 = $obj->bar1();
    is($val2, $b1                       => 'rvalue get');

    eval { $obj->bar1() = $b2; };
    like($@, qr/non-lvalue subroutine/  => 'not lvalue');

    eval { $obj->bar1() =~ s/er/re/; };
    like($@, qr/non-lvalue subroutine/  => 'not lvalue');

    change_it($obj->bar1(), 'Fred');
    is($obj->bar1(), $b1                => 'lvalue does not work');
    check_it($obj->bar1(), $b1);

    change_it($obj->bar1('Bert'), 'Mike');
    is($obj->bar1(), 'Bert'             => 'lvalue does not work');
    check_it($obj->bar1('Ralph'), 'Ralph');

    $obj->bar1($b1);
    is($obj->bar1(), $b1                => 'set');

    $val = $obj->bar1()->me();
    is($val, 'Baz(1)'                   => 'chain get');

    $val = $obj->bar1('bork')->me();
    is($val, 'Foo(1)'                   => 'chain self');
    is($obj->bar1(), 'bork'             => 'chain set');

    $val = $obj->bar1($b2)->me();
    is($val, 'Baz(2)'                   => 'chain new object');
    is($obj->bar1(), $b2                => 'chain set');


    # get_set - return old
    $obj->bar2('val');
    is($obj->bar2(), 'val'              => 'rvalue set void');

    eval { $obj->bar2(); };
    is($@, ''                           => 'rvalue get void');

    $obj->bar2($b2);
    $val = $obj->bar2($b1);
    is($val, $b2                        => 'rvalue set returns old');

    $val2 = $obj->bar2();
    is($val2, $b1                       => 'rvalue get');

    eval { $obj->bar2() = $b2; };
    like($@, qr/non-lvalue subroutine/  => 'not lvalue');

    change_it($obj->bar2(), 'Fred');
    is($obj->bar2(), $b1                => 'lvalue does not work');
    check_it($obj->bar2(), $b1);

    change_it($obj->bar2('Bert'), 'Mike');
    is($obj->bar2(), 'Bert'             => 'lvalue probably does not work');
    check_it($obj->bar2($b1), 'Bert');
    is($obj->bar2(), $b1                => 'set');

    $val = $obj->bar2()->me();
    is($val, 'Baz(1)'                   => 'chain get');

    $obj->bar2('bork');
    $val = $obj->bar2('bar')->me();
    is($val, 'Foo(1)'                   => 'chain self');
    is($obj->bar2(), 'bar'              => 'chain set');

    $obj->bar2($b1);
    $val = $obj->bar2($b2)->me();
    is($val, 'Baz(1)'                   => 'chain old object');
    is($obj->bar2(), $b2                => 'chain set');


    # get_set - return self
    $obj->bar3('val');
    is($obj->bar3(), 'val'              => 'rvalue set void');

    eval { $obj->bar3(); };
    is($@, ''                           => 'rvalue get void');

    $val = $obj->bar3($b1);
    is($val, $obj                       => 'rvalue set returns self');

    $val2 = $obj->bar3();
    is($val2, $b1                       => 'rvalue get');

    change_it($obj->bar3(), 'Fred');
    is($obj->bar3(), $b1                => 'lvalue does not work');
    check_it($obj->bar3(), $b1);

    change_it($obj->bar3('Bert'), 'Mike');
    is(ref($obj), 'Foo'                 => 'lvalue does not work');
    is($obj->bar3(), 'Bert'             => 'Change did set');
    check_it($obj->bar3('Ralph'), $obj);
    is($obj->bar3(), 'Ralph'            => 'Check did set');

    $obj->bar3($b1);
    is($obj->bar3(), $b1                => 'set');

    $val = $obj->bar3()->me();
    is($val, 'Baz(1)'                   => 'chain get');

    $val = $obj->bar3('bork')->me();
    is($val, 'Foo(1)'                   => 'chain self');
    is($obj->bar3(), 'bork'             => 'chain set');

    $val = $obj->bar3($b2)->me();
    is($val, 'Foo(1)'                   => 'chain self');
    is($obj->bar3(), $b2                => 'chain set');


    # get_set - return new - type class
    $obj->baz1($b1);
    is($obj->baz1(), $b1                => 'rvalue set void');

    eval { $obj->baz1('val'); };
    like($@, qr/must be of type 'Baz'/  => 'rvalue set void - bad');

    eval { $obj->baz1(); };
    is($@, ''                           => 'rvalue get void');

    $val = $obj->baz1($b1);
    is($val, $b1                        => 'rvalue set returns new');

    $val2 = $obj->baz1();
    is($val2, $b1                       => 'rvalue get');

    eval { $obj->baz1() = $b2; };
    like($@, qr/non-lvalue subroutine/  => 'not lvalue');

    eval { $obj->baz1($obj) = $b2; };
    like($@, qr/non-lvalue subroutine/  => 'not lvalue');
    is($obj->baz1(), $b1                => 'not changed');

    eval { $obj->baz1() =~ s/Baz/Boing/; };     # Evil
    like($@, qr/non-lvalue subroutine/  => 'not lvalue');
    is($obj->baz1(), $b1                => 'not changed');

    change_it($obj->baz1(), 'Fred');
    is($obj->baz1(), $b1                => 'lvalue does not work');
    check_it($obj->baz1(), $b1);

    change_it($obj->baz1($b1), 'Mike');
    is($obj->baz1(), $b1                => 'lvalue does not work');
    check_it($obj->baz1($b2), $b2);

    $val = $obj->baz1()->me();
    is($val, 'Baz(2)'                   => 'chain get');

    $val = $obj->baz1($b1)->me();
    is($val, 'Baz(1)'                   => 'chain new object');
    is($obj->baz1, $b1                  => 'chain set');


    # get_set - return old - type class
    $obj->baz2($b2);
    is($obj->baz2(), $b2                => 'rvalue set void');

    eval { $obj->baz2(); };
    is($@, ''                           => 'rvalue get void');

    $val = $obj->baz2($b1);
    is($val, $b2                        => 'rvalue set returns old');

    $val2 = $obj->baz2();
    is($val2, $b1                       => 'rvalue get');

    change_it($obj->baz2(), 'Fred');
    is($obj->baz2(), $b1                => 'lvalue does not work');
    check_it($obj->baz2(), $b1);

    change_it($obj->baz2($b2), 'Mike');
    is($obj->baz2(), $b2                => 'lvalue does not work');
    check_it($obj->baz2($b1), $b2);
    is($obj->baz2(), $b1                => 'set');

    $val = $obj->baz2()->me();
    is($val, 'Baz(1)'                   => 'chain get');

    $val = $obj->baz2($b2)->me();
    is($val, 'Baz(1)'                   => 'chain old object');
    is($obj->baz2(), $b2                => 'chain set');


    # get_set - return self - type class
    $obj->baz3($b1);
    is($obj->baz3(), $b1                => 'rvalue set void');

    eval { $obj->baz3(); };
    is($@, ''                           => 'rvalue get void');

    $val = $obj->baz3($b2);
    is($val, $obj                       => 'rvalue set returns self');

    $val2 = $obj->baz3();
    is($val2, $b2                       => 'rvalue get');

    change_it($obj->baz3(), 'Fred');
    is($obj->baz3(), $b2                => 'lvalue does not work');
    check_it($obj->baz3(), $b2);

    change_it($obj->baz3($b1), 'Mike');
    is($obj->baz3(), $b1                => 'lvalue does not work');
    check_it($obj->baz3($b2), $obj);
    is($obj->baz3(), $b2                => 'Check did set');

    $val = $obj->baz3()->me();
    is($val, 'Baz(2)'                   => 'chain get');

    $val = $obj->baz3($b1)->me();
    is($val, 'Foo(1)'                   => 'chain self');
    is($obj->baz3(), $b1                => 'chain set');


    # get_set - return new - type num
    $obj->num1(1);
    is($obj->num1(), 1                  => 'rvalue set void');

    eval { $obj->num1($b1); };
    like($@, qr/must be a number/       => 'rvalue set void - bad');

    eval { $obj->num1(); };
    is($@, ''                           => 'rvalue get void');

    $val = $obj->num1(2);
    is($val, 2                          => 'rvalue set returns new');

    $val2 = $obj->num1();
    is($val2, 2                         => 'rvalue get');

    eval { $obj->num1('bork') = 3; };
    like($@, qr/non-lvalue subroutine/  => 'not lvalue');

    change_it($obj->num1(), 'Fred');
    is($obj->num1(), 2                  => 'lvalue does not work');
    check_it($obj->num1(), 2);

    change_it($obj->num1(4), 'Mike');
    is($obj->num1(), 4                  => 'lvalue does not work');
    check_it($obj->num1(5), 5);

    eval { $val = $obj->num1()->me(); };
    like($@, qr/Can't (?:call|locate object) method/ => 'chain get needs object');

    $val = $obj->num1(8)->me();
    is($val, 'Foo(1)'                   => 'chain self');
    is($obj->num1(), 8                  => 'chain set');


    # get_set - return old - type num
    $obj->num2(1);
    is($obj->num2(), 1                  => 'rvalue set void');

    eval { $obj->num2(); };
    is($@, ''                           => 'rvalue get void');

    $val = $obj->num2(2);
    is($val, 1                          => 'rvalue set returns old');

    $val2 = $obj->num2();
    is($val2, 2                         => 'rvalue get');

    change_it($obj->num2(5), 'Mike');
    is($obj->num2(), 5                  => 'lvalue does not work');
    check_it($obj->num2(6), 5);

    $val = $obj->num2(7)->me();
    is($val, 'Foo(1)'                   => 'chain self');
    is($obj->num2(), 7                  => 'chain set');


    # get_set - return self - type num
    $obj->num3(1);
    is($obj->num3(), 1                  => 'rvalue set void');

    eval { $obj->num3(); };
    is($@, ''                           => 'rvalue get void');

    $val = $obj->num3(2);
    is($val, $obj                       => 'rvalue set returns self');
    is($obj->num3(), 2                  => 'rvalue set');

    $val2 = $obj->num3();
    is($val2, 2                         => 'rvalue get');

    change_it($obj->num3(5), 'Mike');
    is($obj->num3(), 5                  => 'lvalue does not work');
    check_it($obj->num3(6), $obj);
    is($obj->num3(), 6                  => 'Check did set');

    eval { $val = $obj->num3()->me(); };
    like($@, qr/Can't (?:call|locate object) method/ => 'chain get needs object');

    $val = $obj->num3(7)->me();
    is($val, 'Foo(1)'                   => 'chain self');
    is($obj->num3(), 7                  => 'chain set');
}

exit(0);

__END__

:LVALUE                             set    get_set
    $obj->foo('val');                               rvalue set void
    $obj->foo();                    ERR    get      rvalue get void

    my $x = $obj->foo('val');                       rvalue set return
        NEW
        OLD
        SELF
    my $x = $obj->foo();            ERR    get      rvalue get

    $obj->foo() = 'val';                            lvalue assign
    $obj->foo('ignored') = 'val';                   lvalue assign

    $obj->foo() =~ s/x/y/;             fld          lvalue re

    bar($obj->foo());                  fld          lvalue
        change_it
        check_it
    bar($obj->foo('val'));                          lvalue + arg
        change_it
        check_it
        NEW                            fld
        OLD                            ret
        SELF                           obj

    $obj->foo()->bar();             ERR     fld     lvalue + want(obj)
    $obj->foo('val')->bar();                        lvalue + arg + want(obj)
        NEW                            fld/obj
        OLD                            ret/obj
        SELF                           obj

Non-lvalue
    $obj->foo('val');                               rvalue set void
    $obj->foo();                    ERR     get     rvalue get void

    my $x = $obj->foo('val');                       rvalue set return
        NEW
        OLD
        SELF
    my $x = $obj->foo();            ERR     get     rvalue get

    $obj->foo() = 'val';               ERR
    $obj->foo('ignored') = 'val';      ERR
    $obj->foo() =~ s/x/y/;             ERR

    bar($obj->foo());               ERR     get
    bar($obj->foo('val'));
        NEW                            fld
        OLD                            ret
        SELF                           obj

    $obj->foo()->bar();             ERR     get
    $obj->foo('val')->bar();
        NEW                            fld/obj
        OLD                            ret/obj
        SELF                           obj

# EOF
Object-InsideOut-4.05/t/28-lvalue.t0000644000175000001440000005071613377136466016435 0ustar  jdheddenusersuse strict;
use warnings;

BEGIN {
    if ($] < 5.008) {
        print("1..0 # Skip :lvalue requires Perl 5.8.0 or later\n");
        exit(0);
    }
    eval { require Want; };
    if ($@ || $Want::VERSION < 0.12) {
        print("1..0 # Skip Needs Want v0.12 or later\n");
        exit(0);
    }
}

use Test::More 'tests' => 182;
use Scalar::Util;

package Baz; {
    use Object::InsideOut;
    sub me
    {
        my $self = shift;
        return ("Baz($$self)");
    }
}

package Foo; {
    use Object::InsideOut;

    # Separate get and set accessors
    my @foo1 :Field('Std' => 'foo1',                          'LValue' => 1, 'Return' => 'NEW');
    my @foo2 :Field('Get' => 'get_foo2', 'set' => 'set_foo2', 'lv'     => 1, 'Return' => 'OLD');
    my @foo3 :Field('STANDARD' => 'foo3',                     'LVALUE' => 1, 'Return' => 'SELF');

    # Combined get+set accessor
    my @bar1 :Field('LValue' => 'bar1',                'Return' => 'new');
    my @bar2 :Field('Acc'    => 'bar2', 'lvalue' => 1, 'Return' => 'Prev');
    my @bar3 :Field('get_set' => 'bar3', 'lv'    => 1, 'Return' => 'obj');

    # Type checking
    my @baz1 :Field('lv' => 'baz1', 'Return' => 'new', 'Type' => 'Baz');
    my @baz2 :Field('lv' => 'baz2', 'Return' => 'old', 'Type' => 'Baz');
    my @baz3 :Field('lv' => 'baz3', 'Return' => 'obj', 'Type' => 'Baz');

    my @num1 :Field('lv' => 'num1', 'Return' => 'new', 'Type' => 'num');
    my @num2 :Field('lv' => 'num2', 'Return' => 'old', 'Type' => 'num');
    my @num3 :Field('lv' => 'num3', 'Return' => 'obj', 'Type' => 'num');

    my @bork
        :Field
        :Type(Array_Ref(HASH))
        :LV(bork);

    my @zork
        :Field
        :Type(ScalarRef)
        :LV(zork);

    sub me
    {
        my $self = shift;
        return ("Foo($$self)");
    }
}

package main;

sub change_it
{
    $_[0] = $_[1];
}

sub check_it
{
    my ($x, $y) = @_;
    if ($x eq $y) {
        ok(1, 'Checked');
    } else {
        is($x, $y, 'Check failed');
    }
}

MAIN:
{
    my $b1 = Baz->new();
    my $b2 = Baz->new();
    my $obj = Foo->new();
    ok($b1 && $b2 && $obj, 'Objects created');

    can_ok($obj, qw(new clone DESTROY CLONE
                    get_foo1 set_foo1 get_foo2 set_foo2 get_foo3 set_foo3
                    bar1 bar2 bar3));

    # set - return new
    eval { $obj->set_foo1(); };
    like($@, qr/Missing arg/            => 'rvalue set needs arg');

    $obj->set_foo1('val');
    is($obj->get_foo1(), 'val'          => 'rvalue set void');

    eval { $obj->get_foo1(); };
    is($@, ''                           => 'rvalue get void');

    my $val = $obj->set_foo1($b1);
    is($val, $b1                        => 'rvalue set returns new');

    my $val2 = $obj->get_foo1();
    is($val2, $b1                       => 'rvalue get');

    $obj->set_foo1() = $b2;
    is($obj->get_foo1(), $b2            => 'lvalue assign');

    $obj->set_foo1('foo') = 'Bert';
    is($obj->get_foo1(), 'Bert'         => 'lvalue assign (arg ignored)');

    $obj->set_foo1() =~ s/er/re/;
    is($obj->get_foo1(), 'Bret'         => 'lvalue re');

    change_it($obj->set_foo1(), 'Fred');
    is($obj->get_foo1(), 'Fred'         => 'lvalue');
    check_it($obj->set_foo1(), 'Fred');

    change_it($obj->set_foo1('Bert'), 'Mike');
    is($obj->get_foo1(), 'Mike'         => 'lvalue + arg new');
    check_it($obj->set_foo1('Ralph'), 'Ralph');

    $obj->set_foo1($b1);
    eval { $val = $obj->set_foo1()->me(); };
    like($@, qr/Missing arg/            => 'chain set needs arg');

    $val = $obj->set_foo1('bork')->me();
    is($val, 'Foo(1)'                   => 'chain self');

    $val = $obj->set_foo1($b2)->me();
    is($val, 'Baz(2)'                   => 'chain new object');


    # set - return old
    eval { $obj->set_foo2(); };
    like($@, qr/Missing arg/            => 'rvalue set needs arg');

    $obj->set_foo2('val');
    is($obj->get_foo2(), 'val'          => 'rvalue set void');

    eval { $obj->get_foo2(); };
    is($@, ''                           => 'rvalue get void');

    $obj->set_foo2($b2);
    $val = $obj->set_foo2($b1);
    is($val, $b2                        => 'rvalue set returns old');

    $val2 = $obj->get_foo2();
    is($val2, $b1                       => 'rvalue get');

    $obj->set_foo2() = $b2;
    is($obj->get_foo2(), $b2            => 'lvalue assign');

    $obj->set_foo2('foo') = 'Bert';
    is($obj->get_foo2(), 'Bert'         => 'lvalue assign (arg ignored)');

    $obj->set_foo2() =~ s/er/re/;
    is($obj->get_foo2(), 'Bret'         => 'lvalue re');

    change_it($obj->set_foo2(), 'Fred');
    is($obj->get_foo2(), 'Fred'         => 'lvalue');
    check_it($obj->set_foo2(), 'Fred');

    change_it($obj->set_foo2('Bert'), 'Mike');
    is($obj->get_foo2(), 'Bert'         => 'lvalue + arg old');
    check_it($obj->set_foo2('Ralph'), 'Bert');

    $obj->set_foo2($b1);
    eval { $val = $obj->set_foo2()->me(); };
    like($@, qr/Missing arg/            => 'chain set needs arg');

    $obj->set_foo2('bork');
    $val = $obj->set_foo2('bar')->me();
    is($val, 'Foo(1)'                   => 'chain self');

    $obj->set_foo2($b1);
    $val = $obj->set_foo2($b2)->me();
    is($val, 'Baz(1)'                   => 'chain old object');


    # set - return self
    eval { $obj->set_foo3(); };
    like($@, qr/Missing arg/            => 'rvalue set needs arg');

    $obj->set_foo3('val');
    is($obj->get_foo3(), 'val'          => 'rvalue set void');

    eval { $obj->get_foo3(); };
    is($@, ''                           => 'rvalue get void');

    $val = $obj->set_foo3($b1);
    is($val, $obj                       => 'rvalue set returns self');

    $val2 = $obj->get_foo3();
    is($val2, $b1                       => 'rvalue get');

    $obj->set_foo3() = $b2;
    is($obj->get_foo3(), $b2            => 'lvalue assign');

    $obj->set_foo3('foo') = 'Bert';
    is($obj->get_foo3(), 'Bert'         => 'lvalue assign (arg ignored)');

    $obj->set_foo3() =~ s/er/re/;
    is($obj->get_foo3(), 'Bret'         => 'lvalue re');

    change_it($obj->set_foo3(), 'Fred');
    is($obj->get_foo3(), 'Fred'         => 'lvalue');
    check_it($obj->set_foo3(), 'Fred');

    my $obj_old = $obj;
    change_it($obj->set_foo3('Bert'), 'Mike');
    is($obj, 'Mike'                     => 'lvalue + arg self');
    $obj = $obj_old;
    is($obj->get_foo3(), 'Bert'         => 'Change did set');
    check_it($obj->set_foo3('Ralph'), $obj);
    is($obj->get_foo3(), 'Ralph'        => 'Check did set');

    $obj->set_foo3($b1);
    eval { $val = $obj->set_foo3()->me(); };
    like($@, qr/Missing arg/            => 'chain set needs arg');

    $val = $obj->set_foo3('bork')->me();
    is($val, 'Foo(1)'                   => 'chain self');

    $val = $obj->set_foo3($b2)->me();
    is($val, 'Foo(1)'                   => 'chain self');


    # get_set - return new
    $obj->bar1('val');
    is($obj->bar1(), 'val'              => 'rvalue set void');

    eval { $obj->bar1(); };
    is($@, ''                           => 'rvalue get void');

    $val = $obj->bar1($b1);
    is($val, $b1                        => 'rvalue set returns new');

    $val2 = $obj->bar1();
    is($val2, $b1                       => 'rvalue get');

    $obj->bar1() = $b2;
    is($obj->bar1(), $b2                => 'lvalue assign');

    $obj->bar1('foo') = 'Bert';
    is($obj->bar1(), 'Bert'             => 'lvalue assign (arg ignored)');

    $obj->bar1() =~ s/er/re/;
    is($obj->bar1(), 'Bret'             => 'lvalue re');

    change_it($obj->bar1(), 'Fred');
    is($obj->bar1(), 'Fred'             => 'lvalue');
    check_it($obj->bar1(), 'Fred');

    change_it($obj->bar1('Bert'), 'Mike');
    is($obj->bar1(), 'Mike'             => 'lvalue + arg new');
    check_it($obj->bar1('Ralph'), 'Ralph');

    $obj->bar1($b1);
    $val = $obj->bar1()->me();
    is($val, 'Baz(1)'                   => 'chain get');

    $val = $obj->bar1('bork')->me();
    is($val, 'Foo(1)'                   => 'chain self');

    $val = $obj->bar1($b2)->me();
    is($val, 'Baz(2)'                   => 'chain new object');


    # get_set - return old
    $obj->bar2('val');
    is($obj->bar2(), 'val'              => 'rvalue set void');

    eval { $obj->bar2(); };
    is($@, ''                           => 'rvalue get void');

    $obj->bar2($b2);
    $val = $obj->bar2($b1);
    is($val, $b2                        => 'rvalue set returns old');

    $val2 = $obj->bar2();
    is($val2, $b1                       => 'rvalue get');

    $obj->bar2() = $b2;
    is($obj->bar2(), $b2                => 'lvalue assign');

    $obj->bar2('foo') = 'Bert';
    is($obj->bar2(), 'Bert'             => 'lvalue assign (arg ignored)');

    $obj->bar2() =~ s/er/re/;
    is($obj->bar2(), 'Bret'             => 'lvalue re');

    change_it($obj->bar2(), 'Fred');
    is($obj->bar2(), 'Fred'             => 'lvalue');
    check_it($obj->bar2(), 'Fred');

    change_it($obj->bar2('Bert'), 'Mike');
    is($obj->bar2(), 'Bert'             => 'lvalue + arg old');
    check_it($obj->bar2('Ralph'), 'Bert');

    $obj->bar2($b1);
    $val = $obj->bar2()->me();
    is($val, 'Baz(1)'                   => 'chain get');

    $obj->bar2('bork');
    $val = $obj->bar2('bar')->me();
    is($val, 'Foo(1)'                   => 'chain self');

    $obj->bar2($b1);
    $val = $obj->bar2($b2)->me();
    is($val, 'Baz(1)'                   => 'chain old object');


    # get_set - return self
    $obj->bar3('val');
    is($obj->bar3(), 'val'              => 'rvalue set void');

    eval { $obj->bar3(); };
    is($@, ''                           => 'rvalue get void');

    $val = $obj->bar3($b1);
    is($val, $obj                       => 'rvalue set returns self');

    $val2 = $obj->bar3();
    is($val2, $b1                       => 'rvalue get');

    $obj->bar3() = $b2;
    is($obj->bar3(), $b2                => 'lvalue assign');

    $obj->bar3('foo') = 'Bert';
    is($obj->bar3(), 'Bert'             => 'lvalue assign (arg ignored)');

    $obj->bar3() =~ s/er/re/;
    is($obj->bar3(), 'Bret'             => 'lvalue re');

    change_it($obj->bar3(), 'Fred');
    is($obj->bar3(), 'Fred'              => 'lvalue');
    check_it($obj->bar3(), 'Fred');

    $obj_old = $obj;
    change_it($obj->bar3('Bert'), 'Mike');
    is($obj, 'Mike'                     => 'lvalue + arg self');
    $obj = $obj_old;
    is($obj->bar3(), 'Bert'             => 'Change did set');
    check_it($obj->bar3('Ralph'), $obj);
    is($obj->bar3(), 'Ralph'            => 'Check did set');

    $obj->bar1($b1);
    $val = $obj->bar1()->me();
    is($val, 'Baz(1)'                   => 'chain get');

    $val = $obj->bar3('bork')->me();
    is($val, 'Foo(1)'                   => 'chain self');

    $val = $obj->bar3($b2)->me();
    is($val, 'Foo(1)'                   => 'chain self');


    # get_set - return new - type class
    $obj->baz1($b1);
    is($obj->baz1(), $b1                => 'rvalue set void');

    eval { $obj->baz1('val'); };
    like($@, qr/must be of type 'Baz'/  => 'rvalue set void - bad');

    eval { $obj->baz1(); };
    is($@, ''                           => 'rvalue get void');

    $val = $obj->baz1($b1);
    is($val, $b1                        => 'rvalue set returns new');

    $val2 = $obj->baz1();
    is($val2, $b1                       => 'rvalue get');

    $obj->baz1() = $b2;
    is($obj->baz1(), $b2                => 'lvalue assign');

    eval { $obj->baz1() = 'val'; };
    like($@, qr/must be of type 'Baz'/  => 'lvalue assign - bad');

    $obj->baz1($obj) = $b2;
    is($obj->baz1(), $b2                => 'lvalue assign (arg ignored)');

    eval { $obj->baz1() =~ s/Baz/Boing/; };     # Evil
    ok(! Scalar::Util::blessed($obj->baz1()) => 'lvalue re');
    like($obj->baz1(), qr/^Boing=SCALAR\(/   => 'lvalue re');

    change_it($obj->baz1(), 'Fred');
    is($obj->baz1(), 'Fred'             => 'lvalue - no type check');
    check_it($obj->baz1(), 'Fred');

    change_it($obj->baz1($b1), 'Mike');
    is($obj->baz1(), 'Mike'             => 'lvalue + arg new - no type check');
    check_it($obj->baz1($b2), $b2);

    $val = $obj->baz1()->me();
    is($val, 'Baz(2)'                   => 'chain get');

    $val = $obj->baz1($b1)->me();
    is($val, 'Baz(1)'                   => 'chain new object');


    # get_set - return old - type class
    $obj->baz2($b2);
    is($obj->baz2(), $b2                => 'rvalue set void');

    eval { $obj->baz2(); };
    is($@, ''                           => 'rvalue get void');

    $val = $obj->baz2($b1);
    is($val, $b2                        => 'rvalue set returns old');

    $val2 = $obj->baz2();
    is($val2, $b1                       => 'rvalue get');

    $obj->baz2() = $b2;
    is($obj->baz2(), $b2                => 'lvalue assign');

    $obj->baz2($obj) = $b2;
    is($obj->baz2(), $b2                => 'lvalue assign (arg ignored)');

    change_it($obj->baz2(), 'Fred');
    is($obj->baz2(), 'Fred'             => 'lvalue - no type check');
    check_it($obj->baz2(), 'Fred');

    change_it($obj->baz2($b1), 'Mike');
    is($obj->baz2(), $b1                => 'lvalue + arg old');
    check_it($obj->baz2($b2), $b1);

    $val = $obj->baz2()->me();
    is($val, 'Baz(2)'                   => 'chain get');

    $val = $obj->baz2($b1)->me();
    is($val, 'Baz(2)'                   => 'chain old object');


    # get_set - return self - type class
    $obj->baz3($b1);
    is($obj->baz3(), $b1                => 'rvalue set void');

    eval { $obj->baz3(); };
    is($@, ''                           => 'rvalue get void');

    $val = $obj->baz3($b2);
    is($val, $obj                       => 'rvalue set returns self');

    $val2 = $obj->baz3();
    is($val2, $b2                       => 'rvalue get');

    $obj->baz3() = $b1;
    is($obj->baz3(), $b1                => 'lvalue assign');

    $obj->baz3($obj) = $b2;
    is($obj->baz3(), $b2                => 'lvalue assign (arg ignored)');

    change_it($obj->baz3(), 'Fred');
    is($obj->baz3(), 'Fred'             => 'lvalue - no type check');
    check_it($obj->baz3(), 'Fred');

    $obj_old = $obj;
    change_it($obj->baz3($b1), 'Mike');
    is($obj, 'Mike'                     => 'lvalue + arg self - no type check');
    $obj = $obj_old;
    is($obj->baz3(), $b1                => 'Change did set');
    check_it($obj->baz3($b2), $obj);
    is($obj->baz3(), $b2                => 'Check did set');

    $val = $obj->baz3()->me();
    is($val, 'Baz(2)'                   => 'chain get');

    $val = $obj->baz3($b1)->me();
    is($val, 'Foo(1)'                   => 'chain self');


    # get_set - return new - type num
    $obj->num1(1);
    is($obj->num1(), 1                  => 'rvalue set void');

    eval { $obj->num1($b1); };
    like($@, qr/must be a number/        => 'rvalue set void - bad');

    eval { $obj->num1(); };
    is($@, ''                           => 'rvalue get void');

    $val = $obj->num1(2);
    is($val, 2                          => 'rvalue set returns new');

    $val2 = $obj->num1();
    is($val2, 2                         => 'rvalue get');

    $obj->num1() = 3;
    is($obj->num1(), 3                  => 'lvalue assign');

    eval { $obj->num1() = 'val'; };
    like($@, qr/must be a number/        => 'lvalue assign - bad');

    $obj->num1('bork') = 4;
    is($obj->num1(), 4                  => 'lvalue assign (arg ignored)');

    $obj->num1(5);
    eval { $obj->num1() =~ s/5/Boing/; };     # Evil
    is($obj->num1(), 'Boing'            => 'lvalue re');

    change_it($obj->num1(), 'Fred');
    is($obj->num1(), 'Fred'             => 'lvalue - no type check');
    check_it($obj->num1(), 'Fred');

    change_it($obj->num1(6), 'Mike');
    is($obj->num1(), 'Mike'             => 'lvalue + arg new - no type check');
    check_it($obj->num1(7), 7);

    eval { $val = $obj->num1()->me(); };
    like($@, qr/Can't (?:call|locate object) method/ => 'chain get needs object');

    $val = $obj->num1(8)->me();
    is($val, 'Foo(1)'                   => 'chain self');
    is($obj->num1(), 8                  => 'chain set');


    # get_set - return old - type num
    $obj->num2(1);
    is($obj->num2(), 1                  => 'rvalue set void');

    eval { $obj->num2(); };
    is($@, ''                           => 'rvalue get void');

    $val = $obj->num2(2);
    is($val, 1                          => 'rvalue set returns old');

    $val2 = $obj->num2();
    is($val2, 2                         => 'rvalue get');

    $obj->num2() = 3;
    is($obj->num2(), 3                  => 'lvalue assign');

    $obj->num2('bork') = 4;
    is($obj->num2(), 4                  => 'lvalue assign (arg ignored)');

    change_it($obj->num2(), 'Fred');
    is($obj->num2(), 'Fred'             => 'lvalue - no type check');
    check_it($obj->num2(), 'Fred');

    change_it($obj->num2(5), 'Mike');
    is($obj->num2(), 5                  => 'lvalue + arg old');
    check_it($obj->num2(6), 5);

    $val = $obj->num2(7)->me();
    is($val, 'Foo(1)'                   => 'chain self');
    is($obj->num2(), 7                  => 'chain set');


    # get_set - return self - type num
    $obj->num3(1);
    is($obj->num3(), 1                  => 'rvalue set void');

    eval { $obj->num3(); };
    is($@, ''                           => 'rvalue get void');

    $val = $obj->num3(2);
    is($val, $obj                       => 'rvalue set returns self');
    is($obj->num3(), 2                  => 'rvalue set');

    $val2 = $obj->num3();
    is($val2, 2                         => 'rvalue get');

    $obj->num3() = 3;
    is($obj->num3(), 3                  => 'lvalue assign');

    $obj->num3($obj) = 4;
    is($obj->num3(), 4                  => 'lvalue assign (arg ignored)');

    change_it($obj->num3(), 'Fred');
    is($obj->num3(), 'Fred'             => 'lvalue - no type check');
    check_it($obj->num3(), 'Fred');

    $obj_old = $obj;
    change_it($obj->num3(5), 'Mike');
    is($obj, 'Mike'                     => 'lvalue + arg self - no type check');
    $obj = $obj_old;
    is($obj->num3(), 5                  => 'Change did set');
    check_it($obj->num3(6), $obj);
    is($obj->num3(), 6                  => 'Check did set');

    eval { $val = $obj->num3()->me(); };
    like($@, qr/Can't (?:call|locate object) method/ => 'chain get needs object');

    $val = $obj->num3(7)->me();
    is($val, 'Foo(1)'                   => 'chain self');
    is($obj->num3(), 7                  => 'chain set');

    $obj->bork() = [ {a=>5,b=>'foo'}, {}, {99=>'bork'} ];
    is_deeply($obj->bork(), [ {a=>5,b=>'foo'}, {}, {99=>'bork'} ]
                                        => 'lv array_ref subtype=hash');

    my $x = 42;
    $obj->zork() = \$x;
    is($obj->zork(), \$x                => 'lv scalar_ref');
    my $y = $obj->zork();
    is($$y, 42                          => 'lv scalar_ref value')
}

exit(0);

__END__

:LVALUE                             set    get_set
    $obj->foo('val');                               rvalue set void
    $obj->foo();                    ERR    get      rvalue get void

    my $x = $obj->foo('val');                       rvalue set return
        NEW
        OLD
        SELF
    my $x = $obj->foo();            ERR    get      rvalue get

    $obj->foo() = 'val';                            lvalue assign
    $obj->foo('ignored') = 'val';                   lvalue assign

    $obj->foo() =~ s/x/y/;             fld          lvalue re

    bar($obj->foo());                  fld          lvalue
        change_it
        check_it
    bar($obj->foo('val'));                          lvalue + arg
        change_it
        check_it
        NEW                            fld
        OLD                            ret
        SELF                           obj

    $obj->foo()->bar();             ERR     fld     lvalue + want(obj)
    $obj->foo('val')->bar();                        lvalue + arg + want(obj)
        NEW                            fld/obj
        OLD                            ret/obj
        SELF                           obj

Non-lvalue
    $obj->foo('val');                               rvalue set void
    $obj->foo();                    ERR     get     rvalue get void

    my $x = $obj->foo('val');                       rvalue set return
        NEW
        OLD
        SELF
    my $x = $obj->foo();            ERR     get     rvalue get

    $obj->foo() = 'val';               ERR
    $obj->foo('ignored') = 'val';      ERR
    $obj->foo() =~ s/x/y/;             ERR

    bar($obj->foo());               ERR     get
    bar($obj->foo('val'));
        NEW                            fld
        OLD                            ret
        SELF                           obj

    $obj->foo()->bar();             ERR     get
    $obj->foo('val')->bar();
        NEW                            fld/obj
        OLD                            ret/obj
        SELF                           obj

# EOF
Object-InsideOut-4.05/t/test.pl0000644000175000001440000001133713377136466016041 0ustar  jdheddenuserspackage Test::More;     # Test::More work-alike for Perl 5.8.0

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(plan ok is like is_deeply);

use Scalar::Util;

sub plan
{
    my $what = shift;
    if ($what eq 'skip_all') {
        my $reason = shift;
        print("1..0 # SKIP $reason\n");
        exit(0);
    }

    my $tests = shift;
    $| = 1;
    print("1..$tests\n");
}

my $TEST :shared = 1;

sub ok {
    my ($ok, $name) = @_;

    lock($TEST);
    my $id = $TEST++;

    if ($ok) {
        print("ok $id - $name\n");
    } else {
        print("not ok $id - $name\n");
        printf("# Failed test at line %d\n", (caller)[2]);
        print(STDERR "# FAIL: $name\n") if (! exists($ENV{'PERL_CORE'}));
    }

    return ($ok);
}

sub is
{
    my ($got, $expected, $name) = @_;

    lock($TEST);
    my $id = $TEST++;

    my $ok = ("$got" eq "$expected");

    if ($ok) {
        print("ok $id - $name\n");
    } else {
        print("not ok $id - $name\n");
        printf("# Failed test at line %d\n", (caller)[2]);
        print("#      got: $got\n");
        print("# expected: $expected\n");
        print(STDERR "# FAIL: $name\n") if (! exists($ENV{'PERL_CORE'}));
    }

    return ($ok);
}

sub like
{
    my ($got, $like, $name) = @_;

    lock($TEST);
    my $id = $TEST++;

    my $ok = "$got" =~ $like;

    if ($ok) {
        print("ok $id - $name\n");
    } else {
        print("not ok $id - $name\n");
        printf("# Failed test at line %d\n", (caller)[2]);
        print("#      got: $got\n");
        print("# expected: $expected\n");
        print(STDERR "# FAIL: $name\n") if (! exists($ENV{'PERL_CORE'}));
    }

    return ($ok);
}

sub is_deeply
{
    my ($got, $expected, $name) = @_;

    lock($TEST);
    my $id = $TEST++;

    my ($ok, $g_err, $e_err) = _compare($got, $expected);

    if ($ok) {
        print("ok $id - $name\n");
    } else {
        print("not ok $id - $name\n");
        printf("# Failed test at line %d\n", (caller)[2]);
        print("#      got: $g_err\n");
        print("# expected: $e_err\n");
        print(STDERR "# FAIL: $name\n") if (! exists($ENV{'PERL_CORE'}));
    }

    return ($ok);
}

sub _compare
{
    my ($got, $exp) = @_;
    my ($ok, $g_err, $e_err);

    # Undefs?
    if (! defined($got) || ! defined($exp)) {
        return 1 if (! defined($got) && ! defined($exp));
        return (undef, 'undef', "$exp") if (! defined($got));
        return (undef, "$got", 'undef');
    }

    # Not refs?
    if (! ref($got) || ! ref($exp)) {
        # Two scalars
        return ("$got" eq "$exp", "'$got'", "'$exp'")
            if (! ref($got) && ! ref($exp));

        return (undef, "'$got'", "$exp") if (! ref($got));
        return (undef, "$got", "'$exp'");
    }

    # Check classes
    return (undef, "$got", "$exp") if (ref($got) ne ref($exp));

    my $g_ref = Scalar::Util::reftype($got);
    my $e_ref = Scalar::Util::reftype($exp);

    # Check reftypes
    return (undef, "reftype=$g_ref", "reftype=$e_ref") if ($g_ref ne $e_ref);

    # Recursively compare refs or refs
    if ($g_ref eq 'REF') {
        ($ok, $g_err, $e_err) = _compare($$got, $$exp);
        return 1 if $ok;
        return (undef, "ref of '$$got'", "ref of '$$exp'");
    }

    # Compare scalar refs
    if ($g_ref eq 'SCALAR') {
        return 1 if ("$$got" eq "$$exp");
        return (undef, "ref of '$$got'", "ref of '$$exp'");
    }

    # Compare array refs
    if ($g_ref eq 'ARRAY') {
        my $g_len = scalar(@$got);
        my $e_len = scalar(@$exp);
        return (undef, "array of len $g_len", "array of len $e_len") if ($g_len != $e_len);

        # Compare elements
        for (my $ii=0; $ii<$g_len; $ii++) {
            ($ok, $g_err, $e_err) = _compare($$got[$ii], $$exp[$ii]);
            return (undef, "\$\$got[$ii]=$g_err", "\$\$exp[$ii]=$g_err")
                if ! $ok;
        }
        return 1;  # Same
    }

    # Compare array refs
    if ($g_ref eq 'HASH') {
        my %keys = map { $_ => undef } (keys(%$got), keys(%$exp));
        foreach my $key (keys(%keys)) {
            if (! exists($$got{$key})) {
                my $val = (defined($$exp{$key})) ? $$exp{$key} : 'undef';
                return (undef, "\$\$got{$key} does not exist", "\$\$exp{$key}=$val");
            }
            if (! exists($$exp{$key})) {
                my $val = (defined($$got{$key})) ? $$got{$key} : 'undef';
                return (undef, "\$\$got{$key}=$val", "\$\$exp{$key} does not exist");
            }
            ($ok, $g_err, $e_err) = _compare($$got{$key}, $$exp{$key});
            return (undef, "\$\$got{$key}=$g_err", "\$\$exp{$key}=$g_err")
                if ! $ok;

        }
        return 1;  # Same
    }

    # Other ref types - just compare as strings
    return ("$got" ne "$exp", "$got", "$exp");
};

1;
# EOF
Object-InsideOut-4.05/t/12-super.t0000644000175000001440000000525613377136466016273 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 22;

package Foo; {
    use Object::InsideOut;
    sub me { return __PACKAGE__ }
    sub down { return shift->Xyz::SUPER::me() }
}

package Bar; {
    use Object::InsideOut qw(Foo);
    sub me { return __PACKAGE__ }
    sub up { return shift->SUPER::me() }
}

package Baz; {
    use Object::InsideOut qw(Bar);
    sub me { return __PACKAGE__ }
    sub up { return shift->SUPER::me() }
}

package Xyz; {
    use Object::InsideOut qw(Baz);
    sub me { return __PACKAGE__ }
    sub up { return shift->SUPER::me() }
}


package Bing; {
    sub me { return __PACKAGE__ }
    sub down { return shift->Bong::SUPER::me() }
}

package Bang; {
    our @ISA = qw(Bing);
    sub me { return __PACKAGE__ }
    sub up { return shift->SUPER::me() }
}

package Bong; {
    our @ISA = qw(Bang);
    sub me { return __PACKAGE__ }
    sub up { return shift->SUPER::me() }
}


package main;

is(Foo->can('me')->(), Foo::me()                => q/->can('method')/);
is(Bar->can('me')->(), Bar::me()                => q/->can('method')/);
is(Baz->can('me')->(), Baz::me()                => q/->can('method')/);
is(Xyz->can('me')->(), Xyz::me()                => q/->can('method')/);

ok(! Foo->can('up'),                            => q/No can do/);

is(Bar->can('Xyz::me')->(), Xyz::me()           => q/->can('class::method')/);
is(Foo->can('Baz::me')->(), Baz::me()           => q/->can('class::method')/);

is(Xyz->can('Bar::SUPER::me')->(), Foo::me()    => q/->can('class::SUPER::method')/);
is(Bar->can('Xyz::SUPER::me')->(), Baz::me()    => q/->can('class::SUPER::method')/);

my $code = Bar->can('Xyz::SUPER::down');
is(Bar->$code(), Baz::me()                      => q/->can('class::SUPER::method')/);

is(Foo->can('Bar::SUPER::me')->(), Bar->up()    => q/->can('SUPER::method')/);
is(Baz->can('Xyz::SUPER::me')->(), Xyz->up()    => q/->can('SUPER::method')/);


is(Bing->can('me')->(), Bing::me()              => q/->can('method')/);
is(Bang->can('me')->(), Bang::me()              => q/->can('method')/);
is(Bong->can('me')->(), Bong::me()              => q/->can('method')/);

ok(! Bing->can('up'),                           => q/No can do/);

is(Bang->can('Bong::me')->(), Bong::me()        => q/->can('class::method')/);
is(Bing->can('Bong::me')->(), Bong::me()        => q/->can('class::method')/);

is(Bong->can('Bang::SUPER::me')->(), Bing::me() => q/->can('class::SUPER::method')/);

$code = Bang->can('Bong::SUPER::down');
is(Bong->$code(), Bang::me()                    => q/->can('class::SUPER::method')/);

is(Bing->can('Bang::SUPER::me')->(), Bang->up() => q/->can('SUPER::method')/);
is(Bong->can('Bong::SUPER::me')->(), Bong->up() => q/->can('SUPER::method')/);

exit(0);

# EOF
Object-InsideOut-4.05/t/18a-inherit.t0000644000175000001440000000240413377136466016736 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 1;

# Borg is a foreign hash-based class that overloads bool
package Borg;
{
    use overload 'bool' => \&bool;

    sub new {
        my $class = shift;
        my %self  = @_;
        return ( bless( \%self, $class ) );
    }

    sub get_borg {
        my ( $self, $data ) = @_;
        return ( $self->{$data} );
    }

    sub set_borg {
        my ( $self, $key, $value ) = @_;
        $self->{$key} = $value;
    }

    sub warn {
        return ('Resistance is futile');
    }
    sub bool { my $self = shift; return scalar keys %$self; }
}

package Foo;
{
    use Object::InsideOut qw(Borg);

    my @objs : Field('Acc'=>'obj', 'Type' => 'list');

    my %init_args : InitArgs = (
        'OBJ' => {
            'RE'    => qr/^obj$/i,
            'Field' => \@objs,
            'Type'  => 'list',
        },
        'BORG' => { 'RE' => qr/^borg$/i, }
    );

    sub init : Init {
        my ( $self, $args ) = @_;

        $self->inherit( Borg->new() );

        if ( exists( $args->{'BORG'} ) ) {
            $self->set_borg( 'borg' => $args->{'BORG'} );
        }
    }
}

package main;
MAIN:
{
    eval { my $obj = Foo->new(); };
    ok( $@ eq '', 'Created object with overloaded bool operation' );
}

exit(0);

# EOF
Object-InsideOut-4.05/t/08-access.t0000644000175000001440000000571313377136466016401 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 20;

package MyBase; {
    use Object::InsideOut;

    sub everyone             { return 'everyone'; }
    sub family   :RESTRICTED { return 'family';   }
    sub personal :PRIVATE    { return 'personal'; }

    sub try_all {
        my $self = $_[0];
        for my $method (qw(everyone family personal)) {
            Test::More::is($self->$method(), $method => "Called $method");
        }
    }
}

package MyDer; {
    use Object::InsideOut qw(MyBase);

    sub everyone             { my $self = shift; $self->SUPER::everyone(); }
    sub family   :RESTRICTED { my $self = shift; $self->SUPER::family();   }
    sub personal :PRIVATE    { my $self = shift; $self->SUPER::personal(); }
}


package Foo; {
    use Object::InsideOut;

    sub foo_priv :Private(Baz)
    {
        my $self = shift;
        return ('okay');
    }

    sub foo_restr :Restricted(Baz)
    {
        my $self = shift;
        return ('okay');
    }
}

package Bar; {
    use Object::InsideOut 'Foo';

    sub bar
    {
        my $self = shift;
        return ($self->foo_restr);
    }
}

package Baz; {
    use Object::InsideOut;

    sub baz
    {
        my ($self, $bar, $foo) = @_;

        Test::More::is($bar->bar,       'okay', ':Restricted');
        Test::More::is($foo->foo_restr, 'okay', ':Restricted exception');
        Test::More::is($foo->foo_priv,  'okay', ':Private exception');
    }
}


package main;

MAIN:
{
    my $base_obj = MyBase->new();
    my $der_obj  = MyDer->new();

    $base_obj->try_all();

    ok(!eval { $der_obj->try_all(); 1 }   => 'Derived call failed');
    is($@->error(), q/Can't call private method 'MyDer->personal' from class 'MyBase'/
                                          => '...with correct error message');

    is($base_obj->everyone, 'everyone' => 'External everyone succeeded');
    ok(!eval { $base_obj->family }     => 'External family failed as expected');
    is($@->error(), q/Can't call restricted method 'MyBase->family' from class 'main'/
                                          => '...with correct error message');

    ok(!eval { $base_obj->personal }   => 'External personal failed as expected');
    is($@->error(), q/Can't call private method 'MyBase->personal' from class 'main'/
                                          => '...with correct error message');

    is($der_obj->everyone, 'everyone' => 'External derived everyone succeeded');
    ok(!eval { $der_obj->family }     => 'External derived family failed as expected');
    is($@->error(), q/Can't call restricted method 'MyDer->family' from class 'main'/
                                          => '...with correct error message');

    ok(!eval { $der_obj->personal }   => 'External derived personal failed as expected');
    is($@->error(), q/Can't call private method 'MyDer->personal' from class 'main'/
                                          => '...with correct error message');

    Baz->new()->baz(Bar->new(), Foo->new());
}

exit(0);

# EOF
Object-InsideOut-4.05/t/04-shared.t0000644000175000001440000000517213377136466016401 0ustar  jdheddenusersuse strict;
use warnings;

use Config;
BEGIN {
    if (! $Config{useithreads} || $] < 5.008) {
        print("1..0 # Skip Threads not supported\n");
        exit(0);
    }
}

use threads;
use threads::shared;

if ($] == 5.008) {
    require 't/test.pl';   # Test::More work-alike for Perl 5.8.0
} else {
    require Test::More;
}
Test::More->import();
plan('tests' => 16);


package My::Obj; {
    use Object::InsideOut;

    my %x : Field({'accessor'=>'x'});
    my %data :Field
             :Type(numeric)
             :All(data);
}

package My::Obj::Sub; {
    use Object::InsideOut ':SHARED', qw(My::Obj);

    my %y : Field({'accessor'=>'y'});
}


package main;

MAIN:
{
    SKIP: {
        skip('Shared in shared not supported', 4) if (($] < 5.008009) || ($threads::shared::VERSION lt '1.15'));

        # Test that obj IDs work for shared objects
        my $ot1 :shared;
        my $ot2 :shared;

        sub th
        {
            my $tid = threads->tid();

            if ($tid == 1) {
                $ot1 = My::Obj->new('data' => $tid);
                is($ot1->data(), $tid, 'Obj data is TID in thread');
            } else {
                $ot2 = My::Obj->new('data' => $tid);
                is($ot2->data(), $tid, 'Obj data is TID in thread');
            }
        }

        my $th1 = threads->create(\&th);
        my $th2 = threads->create(\&th);

        $th2->join();
        $th1->join();

        is($ot1->data(), 1, 'Obj data is TID in main');
        is($ot2->data(), 2, 'Obj data is TID in main');
    }

    my $obj = My::Obj->new();
    $obj->x(5);
    is($obj->x(), 5, 'Class set data');

    my $obj2 = My::Obj::Sub->new();
    $obj2->x(9);
    $obj2->y(3);
    is($obj2->x(), 9, 'Subclass set data');
    is($obj2->y(), 3, 'Subclass set data');

    my $rc = threads->create(
                        sub {
                            is($obj->x(), 5, 'Thread class data');
                            is($obj2->x(), 9, 'Thread subclass data');
                            is($obj2->y(), 3, 'Thread subclass data');

                            $obj->x([ 1, 2, 3]);
                            $obj2->x(99);
                            $obj2->y(3-1);

                            is_deeply($obj->x(), [1, 2, 3], 'Thread class data');
                            is($obj2->x(), 99, 'Thread subclass data');
                            is($obj2->y(), 2, 'Thread subclass data');

                            return (1);
                        }
                    )->join();

    is_deeply($obj->x(), [1, 2, 3], 'Thread class data');
    is($obj2->x(), 99, 'Thread subclass data');
    is($obj2->y(), 2, 'Thread subclass data');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/34-secure.t0000644000175000001440000000155313377136466016423 0ustar  jdheddenusersuse strict;
use warnings;

BEGIN {
    eval { require Math::Random::MT::Auto; };
    if ($@) {
        print("1..0 # Skip Math::Random::MT::Auto not available\n");
        exit(0);
    }
    if ($Math::Random::MT::Auto::VERSION < 5.04) {
        print("1..0 # Skip Needs Math::Random::MT::Auto v5.04 or later\n");
        exit(0);
    }
}

use Test::More 'tests' => 4;

package Foo; {
    use Object::InsideOut ':SECURE';

    my %data :Field :All(data);
}

package Bar; {
    use Object::InsideOut qw(Foo);

    my %info :Field :All(info);
    #my @foo :Field;
}

package main;

my $obj = Bar->new('data' => 1, 'info' => 2);
is($obj->data(), 1, 'Get data');
is($obj->info(), 2, 'Get info');

eval { Bar->create_field('@misc', ':Field', ':All(misc)'); };
like($@->error, qr/Can't combine 'hash only'/, 'Hash only');
#print($@);

ok($$obj != 1, "ID: $$obj");

exit(0);

# EOF
Object-InsideOut-4.05/t/Imp1.pm0000644000175000001440000000054413377136466015667 0ustar  jdheddenusersuse strict;
use warnings;

package t::A; {
    use Object::InsideOut;
    # overriding import at this level will prevent users of this
    # class or users of child classes from getting their @ISA changed.
    #sub import {};
}


package t::AA; {
    use Object::InsideOut qw(t::A) ;
}

package t::AAA; {
    use Object::InsideOut qw(t::AA) ;
}

1;

# EOF
Object-InsideOut-4.05/t/30-all.t0000644000175000001440000000362213377136466015700 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 11;

package My::Class; {
    use Object::InsideOut;

    sub is_scalar { return (! ref(shift)); }

    sub is_int {
        my $arg = $_[0];
        return (Scalar::Util::looks_like_number($arg) &&
                (int($arg) == $arg));
    }

    my @data :Field('all'=>'data', 'type' => 'num');
    my @info :Field({ 'std'=>'info', 'arg'=>'scalar', 'type' => \&My::Class::is_scalar });
    my @foo  :Field
             :Acc(foo) :Name(foo)
             :Arg(FOO) :Type(name => \&My::Class::is_int);
    my @bar  :Field('all'=>'bar', 'type' => 'ARRAY');
    my @baz  :Field
             :All(baz)
             :Type(hash);
    my @bork :Field
             :Def('bork')
             :Get(bork);
    my %faz  :Field
             :Arg('zzz')
             :Def('snooze');

    sub init :Init
    {
        my ($self, $args) = @_;
        Test::More::is($faz{$$self}, 'snooze' => 'default assigned before :Init');
    }
}

package main;

MAIN:
{
    my $obj = My::Class->new(
        'data'   => 5.5,
        'scalar' => 'foo',
        'FOO'    => 99,
        'bar'    => 'bar',
        'baz'    => { 'hello' => 'world' },
    );

    ok($obj                             => 'Object created');
    is($obj->data(),     5.5            => 'num field');
    is($obj->get_info(), 'foo'          => 'scalar field');
    is($obj->foo(),      99             => 'int field');
    is_deeply($obj->bar(), [ 'bar' ]    => 'list field');
    is_deeply($obj->baz(), { 'hello' => 'world' }       => 'hash field');
    is($obj->bork(), 'bork',            => 'default');

    eval { My::Class->new('data' => 'foo'); };
    like($@, qr/must be a number/       => 'Type check');

    eval { My::Class->new('scalar' => $obj); };
    like($@, qr/failed type check/      => 'Type check');

    eval { My::Class->new('FOO' => 4.5); };
    like($@, qr/failed type check/      => 'Type check');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/ErrorParent.pm0000644000175000001440000000013113377136466017314 0ustar  jdheddenuserspackage t::ErrorParent;

---       # syntax error

sub parent_func {
    return 1;
}

1;
Object-InsideOut-4.05/t/Req3.pm0000644000175000001440000000007513377136466015672 0ustar  jdheddenuserspackage Req3; {
   use Object::InsideOut qw(Req2 Req4);
}
1;
Object-InsideOut-4.05/t/02-auto.t0000644000175000001440000001217513377136466016102 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 37;

package My::Class; {
    use Object::InsideOut;

    sub jinx : Cumulative(bottom up);

    sub auto : Automethod
    {
        my $name = $_;
        return sub {
                        my $self = $_[0];
                        my $class = ref($self) || $self;
                        return "$class->$name";
                   };
    };

    sub jinx
    {
        return 'My::Class->jinx';
    }
}

package My::Sub; {
    use Object::InsideOut qw(My::Class);

    sub jinx : Cumulative(bottom up)
    {
        return 'My::Sub->jinx';
    }

    sub foo
    {
        return 'My::Sub->foo';
    }
}

package My::Bar; {
    use Object::InsideOut qw(My::Class);

    sub auto : Automethod
    {
        if (/^foo$/) {
            return sub { return 'BOOM' }
        }
        return;
    }
}

package My::Baz; {
    use Object::InsideOut qw(My::Bar);
}

package My::MT; {
    sub new { return bless({}, __PACKAGE__); }
}


package Foo; {
    use Object::InsideOut;

    sub auto : Automethod
    {
        my $name = $_;
        return sub {
                        my $self = $_[0];
                        my $class = ref($self) || $self;
                        return __PACKAGE__ . ": $class->$name";
                   };
    };
}

package Bar; {
    use Object::InsideOut qw(Foo);
}

package Baz; {
    use Object::InsideOut qw(Bar);

    sub auto : Automethod
    {
        my $name = $_;

        if ($name eq 'bing') {
            my $self = shift;
            return ($self->can('SUPER::bing'));
        }

        return sub {
                        my $self = $_[0];
                        my $class = ref($self) || $self;
                        return __PACKAGE__ . ": $class->$name";
                   };
    }
}


package NFG; {
    use Object::InsideOut;

    sub _automethod :Automethod {
      my ($self, $val) = @_;
      my $set=exists $_[1];
      my $name=$_;
    }
}


package main;

MAIN:
{
    my (@j, @result, $method);

    $method = My::Class->can('foo');
    ok($method                                 => 'My::Class->foo()');
    is(My::Class->foo(),     'My::Class->foo'  => 'Direct My::Class->foo()');
    is(My::Class->$method(), 'My::Class->foo'  => 'Indirect My::Class->foo()');

    $method = My::Sub->can('foo');
    ok($method                             => 'My::Sub->foo()');
    is(My::Sub->foo(),     'My::Sub->foo'  => 'Direct My::Sub->foo()');
    is(My::Sub->$method(), 'My::Sub->foo'  => 'Indirect My::Sub->foo()');

    $method = My::Sub->can('bar');
    ok($method                             => 'My::Sub->bar()');
    is(My::Sub->bar(),     'My::Sub->bar'  => 'Direct My::Sub->bar()');
    is(My::Sub->$method(), 'My::Sub->bar'  => 'Indirect My::Sub->bar()');

    $method = My::Bar->can('foo');
    ok($method                     => 'My::Bar can foo()');
    is(My::Bar->foo(),     'BOOM'      => 'Direct My::Bar->foo()');
    is(My::Bar->$method(), 'BOOM'      => 'Indirect My::Bar->foo()');

    $method = My::Bar->can('bar');
    ok($method                     => 'My::Bar can bar()');
    is(My::Bar->bar(),     'My::Bar->bar'  => 'Direct My::Bar->bar()');
    is(My::Bar->$method(), 'My::Bar->bar'  => 'Indirect My::Bar->bar()');

    $method = My::Baz->can('foo');
    ok($method                     => 'My::Baz can foo()');
    is(My::Baz->foo(),     'BOOM'      => 'Direct My::Baz->foo()');
    is(My::Baz->$method(), 'BOOM'      => 'Indirect My::Baz->foo()');

    $method = My::Baz->can('bar');
    ok($method                     => 'My::Baz can bar()');
    is(My::Baz->bar(),     'My::Baz->bar'  => 'Direct My::Baz->bar()');
    is(My::Baz->$method(), 'My::Baz->bar'  => 'Indirect My::Baz->bar()');

    $method = My::MT->can('foo');
    ok(!$method              => 'My::MT no can foo()');
    eval { My::MT->foo() };
    ok($@                    => 'No My::MT foo()');

    my $x = My::Class->new();
    @j = $x->jinx();
    @result = qw(My::Class->jinx);
    is_deeply(\@j, \@result, 'Class cumulative');

    my $z = My::Sub->new();
    @j = $z->jinx();
    @result = qw(My::Sub->jinx My::Class->jinx);
    is_deeply(\@j, \@result, 'Subclass cumulative');

    is($x->dummy(), 'My::Class->dummy', 'Class automethod');
    is($z->zebra(), 'My::Sub->zebra', 'Sublass automethod');

    my $y = $x->can('turtle');
    is($x->$y, 'My::Class->turtle', 'Class can+automethod');

    $y = $z->can('snort');
    is($z->$y, 'My::Sub->snort', 'Sublass can+automethod');

    my $obj = My::Bar->new();
    @j = $obj->jinx();
    @result = qw(My::Class->jinx);
    is_deeply(\@j, \@result, 'Inherited cumulative');

    $obj = My::Bar->new();
    is($obj->foom(), 'My::Bar->foom', 'Object automethod');

    $obj = My::Baz->new();
    is($obj->foom(), 'My::Baz->foom', 'Object automethod');

    is(Foo->Baz::SUPER::foo(), 'Foo: Foo->foo'  => 'class::SUPER::method');
    is(Bar->Baz::SUPER::foo(), 'Foo: Bar->foo'  => 'class::SUPER::method');
    is(Baz->bing(),            'Foo: Baz->bing' => 'SUPER::method');
    is(Bar->Baz::foo(),        'Baz: Bar->foo'  => 'class::method');

    $obj = NFG->new();
    eval { $obj->nfg(); };
    like($@->error, qr/did not return a code ref/, 'Defective :Automethod');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/05a-require.pm0000644000175000001440000000137713377136466017125 0ustar  jdheddenusersuse strict;
use warnings;

package t::AA; {
    use Object::InsideOut;

    my @aa : Field({'acc'=>'aa', 'type' => 'num'});
}


package t::BB; {
    use Object::InsideOut;

    my @bb : Field( { 'get' => 'bb', 'Set' => 'set_bb' } );

    my %init_args : InitArgs = (
        'BB' => {
            'Field'     => \@bb,
            'Default'   => 'def',
            'Regex'     => qr/bb/i,
        },
    );
}


package t::AB; {
    use Object::InsideOut qw(t::AA t::BB);

    my @data : Field({'acc'=>'data'});
    my @info : Field('gET'=>'info_get', 'SET'=>'info_set');

    my %init_args : InitArgs = (
        'data' => {
            'Field' => \@data,
        },
        'info' => {
            'FIELD' => \@info,
            'DEF'   => ''
        },
    );
}

1;
Object-InsideOut-4.05/t/04a-shared.t0000644000175000001440000000517213377136466016542 0ustar  jdheddenusersuse strict;
use warnings;

use Config;
BEGIN {
    if (! $Config{useithreads} || $] < 5.008) {
        print("1..0 # Skip Threads not supported\n");
        exit(0);
    }
}

use threads;
use threads::shared;

if ($] == 5.008) {
    require 't/test.pl';   # Test::More work-alike for Perl 5.8.0
} else {
    require Test::More;
}
Test::More->import();
plan('tests' => 16);


package My::Obj; {
    use Object::InsideOut;

    my @x : Field({'accessor'=>'x'});
    my @data :Field
             :Type(numeric)
             :All(data);
}

package My::Obj::Sub; {
    use Object::InsideOut ':SHARED', qw(My::Obj);

    my @y : Field({'accessor'=>'y'});
}


package main;

MAIN:
{
    SKIP: {
        skip('Shared in shared not supported', 4) if (($] < 5.008009) || ($threads::shared::VERSION lt '1.15'));

        # Test that obj IDs work for shared objects
        my $ot1 :shared;
        my $ot2 :shared;

        sub th
        {
            my $tid = threads->tid();

            if ($tid == 1) {
                $ot1 = My::Obj->new('data' => $tid);
                is($ot1->data(), $tid, 'Obj data is TID in thread');
            } else {
                $ot2 = My::Obj->new('data' => $tid);
                is($ot2->data(), $tid, 'Obj data is TID in thread');
            }
        }

        my $th1 = threads->create(\&th);
        my $th2 = threads->create(\&th);

        $th2->join();
        $th1->join();

        is($ot1->data(), 1, 'Obj data is TID in main');
        is($ot2->data(), 2, 'Obj data is TID in main');
    }

    my $obj = My::Obj->new();
    $obj->x(5);
    is($obj->x(), 5, 'Class set data');

    my $obj2 = My::Obj::Sub->new();
    $obj2->x(9);
    $obj2->y(3);
    is($obj2->x(), 9, 'Subclass set data');
    is($obj2->y(), 3, 'Subclass set data');

    my $rc = threads->create(
                        sub {
                            is($obj->x(), 5, 'Thread class data');
                            is($obj2->x(), 9, 'Thread subclass data');
                            is($obj2->y(), 3, 'Thread subclass data');

                            $obj->x([ 1, 2, 3]);
                            $obj2->x(99);
                            $obj2->y(3-1);

                            is_deeply($obj->x(), [1, 2, 3], 'Thread class data');
                            is($obj2->x(), 99, 'Thread subclass data');
                            is($obj2->y(), 2, 'Thread subclass data');

                            return (1);
                        }
                    )->join();

    is_deeply($obj->x(), [1, 2, 3], 'Thread class data');
    is($obj2->x(), 99, 'Thread subclass data');
    is($obj2->y(), 2, 'Thread subclass data');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/10-cumulative.t0000644000175000001440000000615613377136466017311 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 62;

package Base1; {
    use Object::InsideOut;

    sub base_first :Cumulative(top down)  { shift; return(@_, __PACKAGE__); }
    sub der_first  :Cumulative(bottom up) { shift; return(@_, __PACKAGE__); }
    sub shift_obj  :Cumulative            { return shift; }
}

package Base2; {
    use Object::InsideOut qw(Base1);

    sub base_first :Cumulative            { shift; return(@_, __PACKAGE__); }
    sub der_first  :Cumulative(bottom up) { shift; return(@_, __PACKAGE__); }
    sub shift_obj  :Cumulative            { return shift; }
}

package Base3; {
    use Object::InsideOut qw(Base1);

    sub base_first :Cumulative            { shift; return(@_, __PACKAGE__); }
    sub der_first  :Cumulative(bottom up) { shift; return(@_, __PACKAGE__); }
    sub shift_obj  :Cumulative            { return shift; }
}

package Base4; {
    use Object::InsideOut;

    sub base_first                     { shift; return(@_, __PACKAGE__); }
    sub der_first                      { shift; return(@_, __PACKAGE__); }
}

package Der1; {
    use Object::InsideOut qw(Base2 Base3 Base4);

    sub base_first :Cumulative            { shift; return(@_, __PACKAGE__); }
    sub der_first  :Cumulative(bottom up) { shift; return(@_, __PACKAGE__); }
    sub shift_obj  :Cumulative            { return shift; }
}

package Der2; {
    use Object::InsideOut qw(Base2 Base3 Base4);

    sub base_first :Cumulative            { shift; return(@_, __PACKAGE__); }
    sub der_first  :Cumulative(bottom up) { shift; return(@_, __PACKAGE__); }
    sub shift_obj  :Cumulative            { return shift; }
}

package Reder1; {
    use Object::InsideOut qw(Der1 Der2);

    sub base_first :Cum            { shift; return(@_, __PACKAGE__); }
    sub der_first  :Cum(bottom up) { shift; return(@_, __PACKAGE__); }
    sub shift_obj  :Cum(top down)  { return shift; }
}

package main;

MAIN:
{
    my $obj = Reder1->new();

    for (1..2) {
        my $top_down = $obj->base_first();
        my $bot_up   = $obj->der_first();
        my $objs     = $obj->shift_obj();

        my @top_down = qw(Base1 Base2 Base3 Der1 Der2 Reder1);
        my @bot_up   = qw(Reder1 Der2 Der1 Base3 Base2 Base1);
        my @objs     = ($obj) x 6;

        is_deeply(\@$top_down, \@top_down      => 'List chained down');
        is_deeply(\@$bot_up,   \@bot_up        => 'List chained up');

        is(int $bot_up,   int @bot_up          => 'Numeric chained up');
        is(int $top_down, int @top_down        => 'Numeric chained down');

        is("$bot_up",   join(q{}, @bot_up)     => 'String chained up');
        is("$top_down", join(q{}, @top_down)   => 'String chained down');

        for my $pkg (keys(%{$bot_up})) {
            ok(grep($pkg, @bot_up)   => "Valid up hash key ($pkg)");
            is($pkg, $bot_up->{$pkg} => "Valid up hash value ($pkg)");
        }

        while(my $pkg = each(%{$top_down})) {
            ok(grep($pkg, @top_down) => "Valid down hash key ($pkg)");
            is($pkg, $bot_up->{$pkg} => "Valid down hash value ($pkg)");
        }

        is_deeply(\@$objs, \@objs    => 'shift(@_) used in method');
    }
}

exit(0);

# EOF
Object-InsideOut-4.05/t/05a-require.t0000644000175000001440000000302613377136466016745 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 24;

eval {
    use lib 't';
    require '05a-require.pm';
};
ok(! $@, 'require ' . $@);


package main;

MAIN:
{
    my $obj;
    eval { $obj = t::AA->new(); };
    ok(! $@, '->new() ' . $@);
    can_ok($obj, qw(new clone DESTROY CLONE aa));

    is($$obj, 1,                    'Object ID: ' . $$obj);
    ok(! defined($obj->aa),         'No default');
    is($obj->aa(42), 42,            'Set ->aa()');
    is($obj->aa, 42,                'Get ->aa()');

    eval { $obj = t::BB->new(); };
    can_ok($obj, qw(bb set_bb));
    ok(! $@, '->new() ' . $@);
    is($$obj, 2,                    'Object ID: ' . $$obj);
    is($obj->bb, 'def',             'Default: ' . $obj->bb);
    is($obj->set_bb('foo'), 'foo',  'Set ->set_bb()');
    is($obj->bb, 'foo',             'Get ->bb() eq ' . $obj->bb);

    eval { $obj = t::BB->new('bB' => 'baz'); };
    ok(! $@, '->new() ' . $@);
    is($$obj, 1,                    'Object ID: ' . $$obj);
    is($obj->bb, 'baz',             'Init: ' . $obj->bb);
    is($obj->set_bb('foo'), 'foo',  'Set ->set_bb()');
    is($obj->bb, 'foo',             'Get ->bb() eq ' . $obj->bb);

    eval { $obj = t::AB->new(); };
    can_ok($obj, qw(aa bb set_bb data info_get info_set));
    ok(! $@, '->new() ' . $@);
    is($$obj, 2,                    'Object ID: ' . $$obj);
    is($obj->bb, 'def',             'Default: ' . $obj->bb);
    is($obj->set_bb('foo'), 'foo',  'Set ->set_bb()');
    is($obj->bb, 'foo',             'Get ->bb() eq ' . $obj->bb);
}

exit(0);

# EOF
Object-InsideOut-4.05/t/41-def.t0000644000175000001440000000107013377136466015663 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 4;

package foo; {
    use Object::InsideOut;
    my @foo :Field :Acc(foo) :Default({});
}

package bar; {
    use Object::InsideOut;
    my @bar :Field :Acc(bar) :Arg(foo) :Default({});
}

package main;

my $foo1 = foo->new();
my $foo2 = foo->new();

$foo1->foo()->{a} = 1;
$foo2->foo()->{a} = 2;

is($foo1->foo()->{a}, 1);
is($foo2->foo()->{a}, 2);

my $bar1 = bar->new();
my $bar2 = bar->new();

$bar1->bar()->{a} = 1;
$bar2->bar()->{a} = 2;

is($bar1->bar()->{a}, 1);
is($bar2->bar()->{a}, 2);

exit(0);

# EOF
Object-InsideOut-4.05/t/47-sh_reuse.t0000644000175000001440000000333013377136466016751 0ustar  jdheddenusersuse strict;
use warnings;

use Config;
BEGIN {
    if ($] < 5.008009) {
        print("1..0 # Skip Needs Perl 5.8.9 or later\n");
        exit(0);
    }
    if (! $Config{useithreads}) {
        print("1..0 # Skip Threads not supported\n");
        exit(0);
    }
}

use threads;
use threads::shared;

BEGIN {
    if ($threads::shared::VERSION lt '1.15') {
        print("1..0 # Skip Needs threads::shared 1.15 or later\n");
        exit(0);
    }
}

use Thread::Queue;
BEGIN {
    if ($Thread::Queue::VERSION lt '2.08') {
        print("1..0 # Skip Needs Thread::Queue 2.08 or later\n");
        exit(0);
    }
}

use Test::More 'tests' => 25;

package MyClass; {
    use Object::InsideOut qw/:SHARED/;

    sub _init :Init {
        my ($self, $arg) = @_;
        Test::More::is($$self, 1, '_init');
    }

    sub _destroy :Destroy {
        my ($self) = @_;
        Test::More::is($$self, 1, '_destroy');
    }
}

package main;

sub consumer
{
    my $fm_main = $_[0];
    my $to_main = $_[1];

    while (1) {
        my $obj = $fm_main->dequeue();
        last if (! ref($obj));
        my $id = $$obj;
        undef($obj);
        Test::More::is($id, 1, 'thread');
        $to_main->enqueue($id);
    }
    $to_main->enqueue('bye');
}

MAIN:
{
    my $to_thr = Thread::Queue->new();
    my $fm_thr = Thread::Queue->new();

    # Consumer
    my $thr = threads->create(\&consumer, $to_thr, $fm_thr);

    # Producer
    foreach (1..5) {
        my $obj = MyClass->new();
        my $id = $$obj;
        $to_thr->enqueue($obj);
        undef($obj);
        Test::More::is($id, 1, 'main');
        Test::More::is($fm_thr->dequeue(), 1, 'returned');
    }

    $to_thr->enqueue('done');
    $fm_thr->dequeue();

    $thr->join();
}

exit(0);

# EOF
Object-InsideOut-4.05/t/42-sh_obj.t0000644000175000001440000001113213377136466016372 0ustar  jdheddenusersuse strict;
use warnings;

use Config;
BEGIN {
    if ($] < 5.008009) {
        print("1..0 # Skip Needs Perl 5.8.9 or later\n");
        exit(0);
    }
    if (! $Config{useithreads}) {
        print("1..0 # Skip Threads not supported\n");
        exit(0);
    }
}

use threads;
use threads::shared;

BEGIN {
    if ($threads::shared::VERSION lt '1.15') {
        print("1..0 # Skip Needs threads::shared 1.15 or later\n");
        exit(0);
    }
}

use Test::More 'tests' => 29;

package Container; {
    use Object::InsideOut qw(:SHARED);

    my @contents :Field;

    sub store
    {
        my ($self, $item) = @_;
        if (exists($contents[$$self])) {
            push(@{$contents[$$self]}, $item);
        } else {
            $self->set(\@contents, [ $item ]);
        }
        return $contents[$$self][-1];
    }

    sub peek
    {
        my $self = shift;
        return $contents[$$self][-1];
    }

    sub fetch
    {
        my $self = shift;
        pop(@{$contents[$$self]});
    }
}

package Jar; {
    use Object::InsideOut qw(Container :SHARED);
}

package Baggie; {
    use Object::InsideOut qw(Container :SHARED);
}

# Foreign hash-based class
package Foo; {
    sub new
    {
        my $class = shift;
        threads::shared::share(my %self);
        return (bless(\%self, $class));
    }

    sub set_foo
    {
        my ($self, $key, $value) = @_;
        $self->{$key} = $value;
    }

    sub get_foo
    {
        my ($self, $data) = @_;
        return ($self->{$data});
    }
}

package Cookie; {
    use Object::InsideOut qw(Foo :SHARED);

    my @kind :Field :All(kind);

    sub init :Init
    {
        my ($self, $args) = @_;

        $self->inherit(Foo->new());
    }
}


package main;

MAIN:
{
    my $C1 = 'chocolate chip';
    my $C2 = 'oatmeal raisin';
    my $C3 = 'vanilla wafer';

    my $cookie = Cookie->new('kind' => $C1);
    ok($cookie->kind() eq $C1, 'Have cookie');

    my $jar = Jar->new();
    $jar->store($cookie);

    ok($cookie->kind()      eq $C1, 'Still have cookie');
    ok($jar->peek()->kind() eq $C1, 'Still have cookie');
    ok($cookie->kind()      eq $C1, 'Still have cookie');

    threads->create(sub {
        ok($cookie->kind()      eq $C1, 'Have cookie in thread');
        ok($jar->peek()->kind() eq $C1, 'Still have cookie in thread');
        ok($cookie->kind()      eq $C1, 'Still have cookie in thread');

        $jar->store(Cookie->new('kind' => $C2));
        ok($jar->peek()->kind() eq $C2, 'Added cookie in thread');
    })->join();

    ok($cookie->kind()      eq $C1, 'Still have original cookie after thread');
    ok($jar->peek()->kind() eq $C2, 'Still have added cookie after thread');

    $cookie = $jar->fetch();
    ok($cookie->kind()      eq $C2, 'Fetched cookie from jar');
    ok($jar->peek()->kind() eq $C1, 'Cookie still in jar');

    $cookie = $jar->fetch();
    ok($cookie->kind()      eq $C1, 'Fetched cookie from jar');
    undef($cookie);

    share($cookie);
    $cookie = $jar->store(Cookie->new('kind' => $C3));
    ok($jar->peek()->kind() eq $C3, 'New cookie in jar');
    ok($cookie->kind()      eq $C3, 'Have cookie');

    threads->create(sub {
        ok($cookie->kind()      eq $C3, 'Have cookie in thread');
        $cookie = Cookie->new('kind' => $C1);
        ok($cookie->kind()      eq $C1, 'Change cookie in thread');
        ok($jar->peek()->kind() eq $C3, 'Still have cookie in jar');
    })->join();

    ok($cookie->kind()      eq $C1, 'Have changed cookie after thread');
    ok($jar->peek()->kind() eq $C3, 'Still have cookie in jar');
    undef($cookie);
    ok($jar->peek()->kind() eq $C3, 'Still have cookie in jar');
    $cookie = $jar->fetch();
    ok($cookie->kind()      eq $C3, 'Fetched cookie from jar');

    # Multiple levels of shared objects
    my $baggie = Baggie->new();
    $baggie->store($cookie);
    $jar->store($baggie);
    ok($jar->peek()->peek()->kind() eq $C3, 'Cookie in baggie in jar');

    # Inheritance with shared objects
    $cookie->set_foo('bar' => 99);
    threads->create(sub {
        ok($jar->peek()->peek()->get_foo('bar') == 99, 'Cookie foo in thread');
        $cookie->set_foo('insider' => Cookie->new('kind' => $C2));
        # New cookie
        $cookie = Cookie->new('kind' => $C1);
        # Old cookie in jar
        ok($jar->peek()->peek()->kind() eq $C3, 'Cookie in baggie in jar');
        ok($jar->peek()->peek()->get_foo('bar') == 99, 'Cookie foo in thread');
    })->join();

    ok($jar->peek()->peek()->get_foo('bar') == 99, 'Cookie foo in thread');
    ok($cookie->kind()      eq $C1, 'Have changed cookie after thread');
    ok($jar->peek()->peek()->get_foo('insider')->kind() eq $C2, 'Wow');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/32-meta.t0000644000175000001440000003226713377136466016067 0ustar  jdheddenusersuse strict;
use warnings;

my $HAVE_STORABLE;
BEGIN {
    if ($] < 5.008) {
        print("1..0 # Skip Introspection requires Perl 5.8.0 or later\n");
        exit(0);
    }

    eval { require Storable; };
    $HAVE_STORABLE = !$@;
}

use Test::More 'tests' => 43;

package Foo; {
    use Object::InsideOut;

    my @data :Field :Type(num) :All(data);
    my @get  :Field
             :Type(\&Foo::my_sub)
             :Set(setget)
             :Get('name' => 'fooget', 'perm' => 'restricted');

    my $id = 1;
    sub id :ID(restricted) {
        return ($id++);
    }

    sub my_sub :Sub {}
    sub my_foo :Method(Class) {}
    sub my_fink :Restricted :Method(Object) {}

    sub cu :Cumulative   { return ('Foo cumulative'); }
    sub ch :Chain(Bottom up)
    {
        my ($self, $val) = @_;
        return ($val . ' ' . __PACKAGE__);
    }

    sub am :Automethod
    {
        return (sub {});
    }
}

package Bar; {
    BEGIN {
        no warnings 'once';
        $Bar::storable = $HAVE_STORABLE;
    }
    use Object::InsideOut qw(Foo);
    use Object::InsideOut::Metadata;

    my @info :Field :Type(list(num)) :All(info);
    my @more :Field :Type(ARRAY(Foo)) :Arg(more);
    my @set
        :Field
        :Type(sub { $_[0]->isa('UNIVERSAL') })
        :Set('name' => 'barset', 'ret' => 'old');

    sub cu :Cumulative   { return ('Bar cumulative'); }
    sub ch :Chain(Bottom up)
    {
        my ($self, $val) = @_;
        return ('Chain: ', __PACKAGE__);
    }

    sub _internal { return; }
    sub bar :Method { return; }
    add_meta(__PACKAGE__, 'bar', 'bork', 1);

    sub bork :Method :MergeArgs(restricted) { return; }
}


package main;

sub check_bar
{
    my $thing = shift;
    my $meta = $thing->meta();

    my @classes_are = (qw/Foo Bar Storable/);
    if (! $HAVE_STORABLE) {
        pop(@classes_are);
    }

    my @classes = $meta->get_classes();
    is_deeply(\@classes, \@classes_are, 'Meta classes');
    my $classes = $meta->get_classes();
    is_deeply($classes, \@classes_are, 'Meta classes (ref)');

    @classes = $thing->isa();
    is_deeply(\@classes, \@classes_are, '->isa() classes');
    $classes = $thing->isa();
    is_deeply($classes, \@classes_are, '->isa() classes (ref)');


    my %args_are = (
        'Foo' => {
            'data' => {
                'type' => 'numeric',
                'field' => 1,
            },
        },
        'Bar' => {
            'info' => {
                'type' => 'list(numeric)',
                'field' => 1,
            },
            'more' => {
                'type' => 'list(Foo)',
                'field' => 1,
            }
        },
    );

    my %args = $meta->get_args();
    is_deeply(\%args, \%args_are, 'Bar args');
    my $args = $meta->get_args();
    is_deeply($args, \%args_are, 'Bar args (ref)');

    my %meths_are = (
          'new'   => { 'class' => 'Bar',
                       'kind'  => 'constructor',
                       'merge_args' => 1 },
          'clone' => { 'class' => 'Bar',
                       'kind'  => 'object', },
          'meta'  => { 'class' => 'Bar' },
          'set'   => { 'class' => 'Bar',
                       'kind'  => 'object',
                       'restricted' => 1 },

          'can' => { 'class' => 'Object::InsideOut',
                     'kind'  => 'object', },
          'isa' => { 'class' => 'Object::InsideOut',
                     'kind'  => 'object', },

          'id' => { 'class' => 'Foo',
                    'restricted' => 1 },

          'dump' => { 'class' => 'Object::InsideOut',
                      'kind'  => 'object', },
          'pump' => { 'class' => 'Object::InsideOut',
                      'kind'  => 'class', },

          'create_field' => { 'class' => 'Object::InsideOut',
                              'kind'  => 'class', },
          'add_class'    => { 'class' => 'Object::InsideOut',
                              'kind'  => 'class', },

          'inherit'    => { 'class' => 'Bar',
                            'kind'  => 'object',
                            'restricted' => 1 },
          'heritage'   => { 'class' => 'Bar',
                            'kind'  => 'object',
                            'restricted' => 1 },
          'disinherit' => { 'class' => 'Bar',
                            'kind'  => 'object',
                            'restricted' => 1 },

          'freeze' => { 'class' => 'Storable',
                        'kind'  => 'foreign', },
          'thaw'   => { 'class' => 'Storable',
                        'kind'  => 'foreign', },

          'data' => { 'class'  => 'Foo',
                      'kind'   => 'accessor',
                      'type'   => 'numeric',
                      'return' => 'new' },

          'setget' => { 'class'  => 'Foo',
                        'kind'   => 'set',
                        'type'   => '\&Foo::my_sub',
                        'return' => 'new' },
          'fooget' => { 'class'  => 'Foo',
                        'kind'   => 'get',
                        'restricted' => 1 },

          'my_foo' => { 'class' => 'Foo',
                        'kind'  => 'class', },

          'my_fink' => { 'class' => 'Foo',
                         'kind'  => 'object',
                         'restricted' => 1 },

          'AUTOLOAD' => { 'class' => 'Foo',
                          'kind'  => 'automethod', },

          'info' => { 'class'  => 'Bar',
                      'kind'   => 'accessor',
                      'type'   => 'list(numeric)',
                      'return' => 'new' },

          'barset' => { 'class'  => 'Bar',
                        'kind'   => 'set',
                        'type'   => q/sub { $_[0]->isa('UNIVERSAL') }/,
                        'return' => 'old' },

          'cu' => { 'class'  => 'Bar',
                    'kind'   => 'cumulative' },

          'ch' => { 'class'  => 'Bar',
                    'kind'   => 'chained (bottom up)' },

          'bar' => { 'class' => 'Bar',
                     'bork'  => 1 },

          'bork' => { 'class' => 'Bar',
                      'merge_args' => 1,
                      'restricted' => 1 },
    );
    if (! $HAVE_STORABLE) {
        delete($meths_are{'freeze'});
        delete($meths_are{'thaw'});
        $meths_are{'inherit'}{'class'}    = 'Object::InsideOut';
        $meths_are{'heritage'}{'class'}   = 'Object::InsideOut';
        $meths_are{'disinherit'}{'class'} = 'Object::InsideOut';
    }

    my %meths = $meta->get_methods();

    # Remove most Storable methods
    foreach my $meth (keys(%meths)) {
        next if ($meth eq 'freeze' || $meth eq 'thaw');
        if ($meths{$meth}{'class'} eq 'Storable') {
            delete($meths{$meth});
        }
    }

    is_deeply(\%meths, \%meths_are, 'Bar methods');
}


sub check_meta_meta
{
    my $thing = shift;
    my $meta = $thing->meta();

    isa_ok($meta, 'Object::InsideOut::Metadata');

    my @meta_classes = ( 'Object::InsideOut::Metadata' );

    my @classes = $meta->get_classes();
    is_deeply(\@classes, \@meta_classes, 'no subclasses');
    my $classes = $meta->get_classes();
    is_deeply($classes, \@meta_classes, 'no subclasses (ref)');


    my %meta_args = (
        'Object::InsideOut::Metadata' => {
            'GBL'   => {},
            'CLASS' => {},
        },
    );

    my %args = $meta->get_args();
    is_deeply(\%args, \%meta_args, 'Meta args');
    my $args = $meta->get_args();
    is_deeply($args, \%meta_args, 'Meta args (ref)');

    my %meta_meths = (
          'clone' => { 'class' => 'Object::InsideOut::Metadata',
                       'kind'  => 'object' },
          'meta'  => { 'class' => 'Object::InsideOut::Metadata' },
          'set'   => { 'class' => 'Object::InsideOut::Metadata',
                       'kind'  => 'object',
                       'restricted' => 1 },

          'can' => { 'class' => 'Object::InsideOut',
                     'kind'  => 'object', },
          'isa' => { 'class' => 'Object::InsideOut',
                     'kind'  => 'object', },

          'dump' => { 'class' => 'Object::InsideOut',
                      'kind'  => 'object' },
          'pump' => { 'class' => 'Object::InsideOut',
                      'kind'  => 'class' },

          'get_classes' => { 'class' => 'Object::InsideOut::Metadata',
                             'kind'  => 'object' },
          'get_args'    => { 'class' => 'Object::InsideOut::Metadata',
                             'kind'  => 'object' },
          'get_methods' => { 'class' => 'Object::InsideOut::Metadata',
                             'kind'  => 'object' },

          'inherit'    => { 'class' => 'Object::InsideOut::Metadata',
                            'kind'  => 'object',
                            'restricted' => 1 },
          'heritage'   => { 'class' => 'Object::InsideOut::Metadata',
                            'kind'  => 'object',
                            'restricted' => 1 },
          'disinherit' => { 'class' => 'Object::InsideOut::Metadata',
                            'kind'  => 'object',
                            'restricted' => 1 },
    );
    if (! $HAVE_STORABLE) {
        $meta_meths{'inherit'}{'class'}    = 'Object::InsideOut';
        $meta_meths{'heritage'}{'class'}   = 'Object::InsideOut';
        $meta_meths{'disinherit'}{'class'} = 'Object::InsideOut';
    }

    my %meths = $meta->get_methods();
    is_deeply(\%meths, \%meta_meths, 'Meta methods');
    my $meths = $meta->get_methods();
    is_deeply($meths, \%meta_meths, 'Meta methods (ref)');

    my @meths = sort($thing->can());
    my @meths2 = sort(keys(%meta_meths));
    is_deeply(\@meths, \@meths2, '->can() methods');
    $meths = $thing->can();
    @meths = sort(@$meths);
    is_deeply(\@meths, \@meths2, '->can() methods (ref)');

    my $meta_meta = $meta->meta()->get_methods();
    is_deeply($meta_meta, \%meta_meths, 'meta meta');
}


sub check_res
{
    my $thing = shift;
    my $meta = $thing->meta();

    my @meta_classes = ( 'Object::InsideOut::Results' );

    my @classes = $meta->get_classes();
    is_deeply(\@classes, \@meta_classes, 'no subclasses');
    my $classes = $meta->get_classes();
    is_deeply($classes, \@meta_classes, 'no subclasses (ref)');


    my %meta_args = (
        'Object::InsideOut::Results' => {
            'VALUES'      => { 'field' => 1 },
            'CLASSES'     => { 'field' => 1 },
        },
    );

    my %args = $meta->get_args();
    is_deeply(\%args, \%meta_args, 'Meta args');
    my $args = $meta->get_args();
    is_deeply($args, \%meta_args, 'Meta args (ref)');


    my %meta_meths = (
          'clone' => { 'class' => 'Object::InsideOut::Results',
                       'kind'  => 'object' },
          'meta'  => { 'class' => 'Object::InsideOut::Results' },
          'set'   => { 'class' => 'Object::InsideOut::Results',
                       'kind'  => 'object',
                       'restricted' => 1 },

          'can' => { 'class' => 'Object::InsideOut',
                     'kind'  => 'object', },
          'isa' => { 'class' => 'Object::InsideOut',
                     'kind'  => 'object', },

          'dump' => { 'class' => 'Object::InsideOut',
                      'kind'  => 'object' },
          'pump' => { 'class' => 'Object::InsideOut',
                      'kind'  => 'class' },

          'as_string' => { 'class' => 'Object::InsideOut::Results',
                           'kind'  => 'overload', },
          'count'     => { 'class' => 'Object::InsideOut::Results',
                           'kind'  => 'overload', },
          'as_hash'   => { 'class' => 'Object::InsideOut::Results',
                           'kind'  => 'overload', },
          'values'    => { 'class' => 'Object::InsideOut::Results',
                           'kind'  => 'overload', },
          'have_any'  => { 'class' => 'Object::InsideOut::Results',
                           'kind'  => 'overload', },

          'inherit'    => { 'class' => 'Object::InsideOut::Results',
                            'kind'  => 'object',
                            'restricted' => 1 },
          'heritage'   => { 'class' => 'Object::InsideOut::Results',
                            'kind'  => 'object',
                            'restricted' => 1 },
          'disinherit' => { 'class' => 'Object::InsideOut::Results',
                            'kind'  => 'object',
                            'restricted' => 1 },
    );
    if (! $HAVE_STORABLE) {
        $meta_meths{'inherit'}{'class'}    = 'Object::InsideOut';
        $meta_meths{'heritage'}{'class'}   = 'Object::InsideOut';
        $meta_meths{'disinherit'}{'class'} = 'Object::InsideOut';
    }

    my %meths = $meta->get_methods();
    is_deeply(\%meths, \%meta_meths, 'Meta methods');
    my $meths = $meta->get_methods();
    is_deeply($meths, \%meta_meths, 'Meta methods (ref)');
}


MAIN:
{
    can_ok('Bar', 'meta');

    ### Bar class meta
    check_bar('Bar');

    ### Bar object meta
    my $obj = Bar->new();
    check_bar($obj);

    ### Meta class meta
    check_meta_meta('Object::InsideOut::Metadata');

    ### Meta object meta
    check_meta_meta($obj->meta());

    ### Cumulative meta
    my $res = $obj->cu();
    my @cum = @{$res};
    is_deeply(\@cum, [ 'Foo cumulative', 'Bar cumulative' ], 'cumulative results');
    check_res($res);

    eval { Object::InsideOut->meta(); };
    is($@->{'message'}, "'meta' called on non-class 'Object::InsideOut'", 'No OIO meta');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/Imp2.pm0000644000175000001440000000012313377136466015661 0ustar  jdheddenusersuse strict;
use warnings;

package t::B; {
    use Object::InsideOut;
}

1;

# EOF
Object-InsideOut-4.05/t/33-hash_only.t0000644000175000001440000000102713377136466017114 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 3;

package Foo; {
    use Object::InsideOut ':hash_only';

    my %data :Field :All(data);
}

package Bar; {
    use Object::InsideOut qw(Foo);

    my %info :Field :All(info);
    #my @foo :Field;
}

package main;

my $obj = Bar->new('data' => 1, 'info' => 2);
is($obj->data(), 1, 'Get data');
is($obj->info(), 2, 'Get info');

eval { Bar->create_field('@misc', ':Field', ':All(misc)'); };
like($@->error, qr/Can't combine 'hash only'/, 'Hash only');
#print($@);

exit(0);

# EOF
Object-InsideOut-4.05/t/Req1.pm0000644000175000001440000000044413377136466015670 0ustar  jdheddenuserspackage Req1; {
   use Object::InsideOut;

   my @field :Field
             :Arg('Name' => 'field', Mand => 1)
             :Standard('field');
}

package Req4; {
   use Object::InsideOut;

   my @field :Field
             :Arg('Name' => 'fld', Mand => 1)
             :Standard('fld');
}
1;
Object-InsideOut-4.05/t/19-storable.t0000644000175000001440000000567013377136466016757 0ustar  jdheddenusersuse strict;
use warnings;

BEGIN {
    if ($] == 5.008004 || $] == 5.008005) {
        my $z = ($] == 5.008004) ? 4 : 5;
        print("1..0 # Skip due to Perl 5.8.$z bug\n");
        exit(0);
    }
    eval {
        require Storable;
        Storable->import('thaw');
    };
    if ($@) {
        print("1..0 # Skip Storable not available\n");
        exit(0);
    }
}

use Test::More 'tests' => 8;

# Borg is a foreign hash-based class
package Borg; {
    sub new
    {
        my $class = shift;
        my %self = @_;
        return (bless(\%self, $class));
    }

    sub get_borg
    {
        my ($self, $data) = @_;
        return ($self->{$data});
    }

    sub set_borg
    {
        my ($self, $key, $value) = @_;
        $self->{$key} = $value;
    }

    sub warn
    {
        return ('Resistance is futile');
    }

    sub DESTROY {}
}


package Foo; {
    use Object::InsideOut qw(Borg);

    my @objs :Field('Acc'=>'obj', 'Type' => 'list');

    my %init_args :InitArgs = (
        'OBJ' => {
            'RE'    => qr/^obj$/i,
            'Field' => \@objs,
            'Type'  => 'list',
        },
        'BORG' => {
            'RE'    => qr/^borg$/i,
        }
    );

    sub init :Init
    {
        my ($self, $args) = @_;

        my $borg = Borg->new();
        $self->inherit($borg);

        if (exists($args->{'BORG'})) {
            $borg->set_borg('borg' => $args->{'BORG'});
        }
    }

    sub unborg
    {
        my $self = $_[0];
        #if (my $borg = $self->heritage('Borg')) {
        #    $self->disinherit($borg);
        #}
        $self->disinherit('Borg');
    }
}

package Bar; {
    use Object::InsideOut qw(Foo);
}

package Baz; {
    use Object::InsideOut qw(Bar Storable);
}


package Mat; {
    use Object::InsideOut qw(Storable);
    my @bom :Field( Standard => 'bom', Name => 'bom' );
}

package Bork; {
    use Object::InsideOut 'Storable';

    my @fld :Field;

    sub set_fld
    {
        my ($self, $data) = @_;
        $self->set(\@fld, $data);
    }
}


package main;
MAIN:
{
    my $obj = Baz->new('borg' => 'Picard');
    isa_ok($obj, 'Baz', 'Baz->new()');

    my $tmp = $obj->freeze();
    my $obj2 = thaw($tmp);
    is($obj->dump(1), $obj2->dump(1) => 'Storable works');

    # Test stored objects
    my $f1 = Mat->new();
    $f1->set_bom($obj);
    is($f1->get_bom(), $obj     => 'Stored object');

    my $f2 = thaw($f1->freeze());
    $obj2 = $f2->get_bom();
    is($obj->dump(1), $obj2->dump(1) => 'Storable works');

    # Test circular references
    $f1->set_bom($f1);
    is($f1->get_bom(), $f1      => 'Circular reference');

    $f2 = thaw($f1->freeze());
    is($f2->get_bom(), $f2      => 'Storable works');

    # Test that unnamed fields generate proper errors
    $obj = Bork->new();
    $obj->set_fld('foo');
    $tmp = $obj->freeze();
    undef($obj2);
    eval { $obj2 = thaw($tmp); };
    like($@, qr(Unnamed field encounted) => 'Unnamed field');
    is($obj2, undef,  'thaw failed');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/48-not_shared.t0000644000175000001440000000166713377136466017276 0ustar  jdheddenusersuse strict;
use warnings;

use Config;
BEGIN {
    if ($] < 5.008009) {
        print("1..0 # Skip Needs Perl 5.8.9 or later\n");
        exit(0);
    }
    if (! $Config{useithreads}) {
        print("1..0 # Skip Threads not supported\n");
        exit(0);
    }
}

use threads;
use threads::shared;

BEGIN {
    if ($threads::shared::VERSION lt '1.15') {
        print("1..0 # Skip Needs threads::shared 1.15 or later\n");
        exit(0);
    }
}

use Test::More 'tests' => 4;

package Foo; {
    use Object::InsideOut qw/:NOT_SHARED/;
}

package Bar; {
    use Object::InsideOut qw/:SHARED/;
}

package main;

sub thr_func {
    eval {
        my $obj = Foo->new();
    };
    ok(! $@);

    eval {
        my $obj = Bar->new();
    };
    ok(! $@);
}

MAIN:
{
    eval {
        my $obj = Foo->new();
    };
    ok(! $@);

    eval {
        my $obj = Bar->new();
    };
    ok(! $@);

    threads->create(\&thr_func)->join();
}

exit(0);

# EOF
Object-InsideOut-4.05/t/Req2.pm0000644000175000001440000000006613377136466015671 0ustar  jdheddenuserspackage Req2; {
   use Object::InsideOut 'Req1';
}
1;
Object-InsideOut-4.05/t/05-require.pm0000644000175000001440000000150113377136466016751 0ustar  jdheddenusersuse strict;
use warnings;

package t::AA; {
    use Object::InsideOut;

    my %aa : Field({'acc'=>'aa', 'type' => 'num'});

    my $id = 1;

    sub id : ID {
        return ($id++);
    }
}


package t::BB; {
    use Object::InsideOut;

    my %bb : Field( { 'get' => 'bb', 'Set' => 'set_bb' } );

    my %init_args : InitArgs = (
        'BB' => {
            'Field'     => \%bb,
            'Default'   => 'def',
            'Regex'     => qr/bb/i,
        },
    );
}


package t::AB; {
    use Object::InsideOut qw(t::AA t::BB);

    my %data : Field({'acc'=>'data'});
    my %info : Field('gET'=>'info_get', 'SET'=>'info_set');

    my %init_args : InitArgs = (
        'data' => {
            'Field' => \%data,
        },
        'info' => {
            'FIELD' => \%info,
            'DEF'   => ''
        },
    );
}

1;
Object-InsideOut-4.05/t/Parent.pm0000644000175000001440000000017313377136466016310 0ustar  jdheddenusersuse strict;
use warnings;

package t::Parent; {
    use Object::InsideOut;
}

sub parent_func {
    return 1;
}

1;

# EOF
Object-InsideOut-4.05/t/20-clone.t0000644000175000001440000000305013377136466016222 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 9;

package Foo; {
    use Object::InsideOut;
    my @foo :Field('Acc' => 'foo')
            :Deep;
}

package Bar; {
    use Object::InsideOut 'Foo';
    my @bar :Field('Acc' => 'bar');
}

package Baz; {
    use Object::InsideOut;
    my @baz :Field :All(baz);
}

package main;

my $adat = [ 'foo', 'bar', 'baz' ];
my $hdat = { 'bing' => 'bang', 'bop' => 'BOOM' };

my $obj = Bar->new();
$obj->foo($adat);
$obj->bar($hdat);

my $obj2 = $obj->clone();
is_deeply($obj->dump(), $obj2->dump()   => 'Clone equal');

$adat->[1] = 'trap';

my $data = $obj2->foo();
is($data->[1], 'bar'                    => 'Deep field copy');

$hdat->{'test'} = 'here';
$data = $obj->bar();
is($data->{'test'}, 'here'              => 'Shared data');

$data = $obj2->bar();
is($data->{'test'}, 'here'              => 'Shared data');

my $obj3 = $obj2->clone(1);
is_deeply($obj2->dump(), $obj3->dump()  => 'Clone equal');

$obj2->foo({ 'junk' => 0 });
$obj2->bar('data');

$data = $obj3->bar();
is($data->{'bop'}, 'BOOM'               => 'Deep object clone');
$data = $obj3->foo();
is($data->[2], 'baz'                    => 'Deep object clone');

my $baz = Baz->new();
$baz->baz($obj);
my $baz2 = $baz->clone(1);
my $objx = $baz->baz();
$data = $objx->bar();
is($data->{'test'}, 'here'              => 'Internal object');

$baz = Baz->new();
$baz->baz({'baz' => $obj});
$baz2 = $baz->clone(1);
$data = $baz->baz();
$objx = $$data{'baz'};
$data = $objx->bar();
is($data->{'test'}, 'here'              => 'Deep internal object');

exit(0);

# EOF
Object-InsideOut-4.05/t/40-normalize.t0000644000175000001440000000167013377136466017132 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 6;

package Foo; {
    use Object::InsideOut;

use Data::Dumper;
    my @foo :Field :Acc(foo);
    my @bar :Field :Acc(bar);

    my %init_args :InitArgs = (
        foo => {
            field => \@foo,
            def   => 1,
        },
    );

    sub add_to_init_args
    {
        $init_args{bar} = {
            field => \@bar,
            def   => 'bar',
        };
    }

    sub renormalize
    {
        Object::InsideOut::normalize(\%init_args);
    }
}


package main;

my $obj = Foo->new();
is($obj->foo(), 1       => q/Default for 'foo'/);
ok(! $obj->bar()        => q/'bar' not set/);

Foo::add_to_init_args();

$obj = Foo->new();
is($obj->foo(), 1       => q/Default for 'foo'/);
ok(! $obj->bar()        => q/'bar' not set/);

Foo::renormalize();

$obj = Foo->new();
is($obj->foo(), 1       => q/Default for 'foo'/);
is($obj->bar(), 'bar'   => q/Default for 'bar'/);

exit(0);

# EOF
Object-InsideOut-4.05/t/31-attr.t0000644000175000001440000000407413377136466016105 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 5;

#MODIFY_CODE_ATTRIBUTES
#MODIFY_HASH_ATTRIBUTES
#MODIFY_ARRAY_ATTRIBUTES
#MODIFY_SCALAR_ATTRIBUTES

package Foo; {
    use Object::InsideOut;

    sub _add_defaults :MOD_SCALAR_ATTRS
    {
        my ($pkg, $scalar, @attrs) = @_;
        my @unused_attrs;   # List of any unhandled attributes

        while (my $attr = shift(@attrs)) {
            if ($attr =~ /^D\('?([^)']+)'?\)/i) {
                $$scalar = $1;
                Test::More::ok(1, "Foo: $attr");
            } else {
                push(@unused_attrs, $attr);
            }
        }

        return (@unused_attrs);
    }

    sub _make_fields :MOD_ARRAY_ATTRS
    {
        my ($pkg, $array, @attrs) = @_;
        my @unused_attrs;   # List of any unhandled attributes

        while (my $attr = shift(@attrs)) {
            if ($attr =~ /^F\('?([^)']+)'?\)/i) {
                push(@unused_attrs, "Field('all' => '$1')");
            } else {
                push(@unused_attrs, $attr);
            }
        }

        return (@unused_attrs);
    }

    my @foo :F(foo);    # :Field('all'=>'foo')
}

package Bork; {
    use Object::InsideOut;

    sub _check_attr :MOD_ARRAY_ATTRS
    {
        my ($pkg, $array, @attrs) = @_;
        my @unused_attrs;   # List of any unhandled attributes

        while (my $attr = shift(@attrs)) {
            if ($attr eq 'Test') {
                Test::More::ok(1, "Bork: $attr");
            } else {
                push(@unused_attrs, $attr);
            }
        }

        return (@unused_attrs);
    }
}

package Bar; {
    use Object::InsideOut qw(Foo Bork);

    my $iam :D(ima_foo);

    sub iam { return ($iam); }

    my @bar :F('bar') Test;

    sub _fetch_attrs :FETCH_CODE_ATTRS
    {
        my ($pkg, $ref) = @_;
        if ($ref == \&iam) {
            return ('Method');
        }
    }
}

package main;

MAIN:
{
    is(Bar::iam, 'ima_foo'      => 'Scalar default');

    my $obj = Bar->new();
    can_ok($obj => qw(foo bar));
    is((attributes::get(Bar->can('iam')))[0], 'Method', 'Fetch attr');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/03-threads.t0000644000175000001440000000330313377136466016556 0ustar  jdheddenusersuse strict;
use warnings;

use Config;
BEGIN {
    if (! $Config{useithreads} || $] < 5.008) {
        print("1..0 # Skip Threads not supported\n");
        exit(0);
    }
}

use threads;
use threads::shared;

if ($] == 5.008) {
    require 't/test.pl';   # Test::More work-alike for Perl 5.8.0
} else {
    require Test::More;
}
Test::More->import();
plan('tests' => 12);


package My::Obj; {
    use Object::InsideOut;

    my %x : Field({'accessor'=>'x'});
}

package My::Obj::Sub; {
    use Object::InsideOut qw(My::Obj);

    my %y : Field({'accessor'=>'y'});
}


package main;

MAIN:
{
    my $obj = My::Obj->new();
    $obj->x(5);
    is($obj->x(), 5, 'Class set data');

    my $obj2 = My::Obj::Sub->new();
    $obj2->x(9);
    $obj2->y(3);
    is($obj2->x(), 9, 'Subclass set data');
    is($obj2->y(), 3, 'Subclass set data');

    my $rc = threads->create(
                        sub {
                            is($obj->x(), 5, 'Thread class data');
                            is($obj2->x(), 9, 'Thread subclass data');
                            is($obj2->y(), 3, 'Thread subclass data');

                            $obj->x([1, 2, 3]);
                            $obj2->x(99);
                            $obj2->y(3-1);

                            is_deeply($obj->x(), [1, 2, 3], 'Thread class data');
                            is($obj2->x(), 99, 'Thread subclass data');
                            is($obj2->y(), 2, 'Thread subclass data');

                            return (1);
                        }
                    )->join();

    is($obj->x(), 5, 'Class data unchanged');
    is($obj2->x(), 9, 'Subclass data unchanged');
    is($obj2->y(), 3, 'Subclass data unchanged');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/10b-cumulative.t0000644000175000001440000000532713377136466017452 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 3;

package Base1; {
    use Object::InsideOut;

    sub foo :Cumulative :MergedArgs
    {
        my ($self, $args) = @_;
        my $pkg = __PACKAGE__;
        return ($args->{$pkg});
    }
}

package Base2; {
    use Object::InsideOut qw(Base1);

    sub foo :Cumulative :MergedArgs
    {
        my ($self, $args) = @_;
        my $pkg = __PACKAGE__;
        return ($args->{$pkg});
    }
}

package Base3; {
    use Object::InsideOut qw(Base1);

    sub foo :Cumulative :MergedArgs :Restricted( 'Outside', '')
    {
        my ($self, $args) = @_;
        my $pkg = __PACKAGE__;
        return ($args->{$pkg});
    }
}

package Base4; {
    use Object::InsideOut;

    sub foo :MergedArgs  # but not Cumulative!
    {
        my ($self, $args) = @_;
        my $pkg = __PACKAGE__;
        return ($args->{$pkg});
    }
}

package Der1; {
    use Object::InsideOut qw(Base2 Base3 Base4);

    sub foo :Cumulative :MergedArgs
    {
        my ($self, $args) = @_;
        my $pkg = __PACKAGE__;
        return ($args->{$pkg});
    }
}

package Der2; {
    use Object::InsideOut qw(Base2 Base3 Base4);

    sub foo :Cumulative :MergedArgs
    {
        my ($self, $args) = @_;
        my $pkg = __PACKAGE__;
        return ($args->{$pkg});
    }
}

package Reder1; {
    use Object::InsideOut qw(Der1 Der2);

    sub foo :Cumulative :MergedArgs
    {
        my ($self, $args) = @_;
        my $pkg = __PACKAGE__;
        return ($args->{$pkg});
    }

    sub get_foo
    {
        my $self = shift;
        return ($self->foo(@_));
    }
}

package Outside; {
    use Object::InsideOut;

    sub bar
    {
        my $self = shift;
        my $obj  = shift;
        return ($obj->foo(@_));
    }
}

package main;

MAIN:
{
    my $obj = Reder1->new();

    eval { $obj->foo() };
    like($@, qr/restricted method/ => ':Restricted + :Cumulative');

    my @expected = ('foo', 'bar', 'baz', 'bing', 'bang', 'bong');

    my @got = $obj->get_foo( 'Base1'  => 'foo',
                           { 'Base2'  => 'bar', },
                           { 'Base3'  => 'baz',
                             'Der1'   => 'bing', },
                             'Der2'   => 'bang',
                           { 'Reder1' => 'bong', } );

    is_deeply(\@got, \@expected => 'Cumulative methods with merged args');

    my $out = Outside->new();
    @got = $out->bar($obj, 'Base1'  => 'foo',
                           { 'Base2'  => 'bar', },
                           { 'Base3'  => 'baz',
                             'Der1'   => 'bing', },
                             'Der2'   => 'bang',
                           { 'Reder1' => 'bong', } );

    is_deeply(\@got, \@expected => 'Cumulative methods with merged args');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/44-data.t0000644000175000001440000000225113377136466016043 0ustar  jdheddenusersuse strict;
use warnings;

use Config;
BEGIN {
    if (! $Config{useithreads} || $] < 5.008) {
        print("1..0 # Skip Threads not supported\n");
        exit(0);
    }
}


use threads;
use threads::shared;

if ($] == 5.008) {
    require 't/test.pl';   # Test::More work-alike for Perl 5.8.0
} else {
    require Test::More;
}
Test::More->import();
plan('tests' => 4);


package My::Obj; {
    use Object::InsideOut ':SHARED';

    my @s :Field :All(s);
    my @a :Field :All(a);
    my @h :Field :All(h);
    my @r :Field :All(r);
}

package main;

MAIN:
{
    my $s = \do{ my $anon = 321; };
    my $a = [ 1..3, [ qw(foo bar) ], { 'qux' => 99 } ];
    my $h = { 'foo' => [ 99..101 ], 'bar' => { 'bork' => 5 } };
    my $x = [ $s, $h, $a ];
    my $y = \$x;
    my $z = \$y;
    my $r = \$z;

    my $obj = My::Obj->new(
        's' => $s,
        'a' => $a,
        'h' => $h,
        'r' => $r,
    );

    threads->create(sub {
            is_deeply($obj->s(), $s, 'scalar');
            is_deeply($obj->a(), $a, 'array');
            is_deeply($obj->h(), $h, 'hash');
            my $ii = $obj->r();
            is_deeply($$$$ii, $$$$r, 'ref');
        })->join();
}

exit(0);

# EOF
Object-InsideOut-4.05/t/38-combined.t0000644000175000001440000001032313377136466016714 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 4;

package Foo; {
    use Object::InsideOut;

    sub we_are :Cumulative :Restricted
    {
        return __PACKAGE__;
    }

    sub whoami :Chained(bottom up) :Restricted
    {
        my ($self, $whoami) = @_;
        my $class = __PACKAGE__;
        return ($whoami) ? "$whoami son of $class" : $class;
    }

    sub auto : Automethod
    {
        my $self = $_[0];
        my $class = ref($self) || $self;
        my $name = $_;

        if ($name eq 'izza') {
            return (sub {
                        my $self = $_[0];
                        my $class = ref($self) || $self;
                        return ($class . ' isa ' . __PACKAGE__);
                   }, 'CUM(BOT)');
        }

        if ($name eq 'bork') {
            return (sub {
                        my $self = $_[0];
                        my $class = __PACKAGE__;
                        my ($whoami) = $class->whoami();
                        return ("$class says 'I am $whoami.'");
                   }, 'CUM');
        }

        return;
    }

    sub as_string :Stringify
    {
        my ($whoami) = $_[0]->whoami('');
        return ("I am $whoami");
    }

    sub as_hash :Hashify
    {
        return ($_[0]->we_are());
    }

    sub as_array :Arrayify
    {
        return ($_[0]->izza());
    }

    sub as_code :Codify
    {
        my $self = $_[0];
        return (sub { $self->can('bork')->($self) });
    }
}

package Bar; {
    use Object::InsideOut 'Foo';

    sub we_are :Cumulative :Restricted
    {
        return __PACKAGE__;
    }

    sub whoami :Chained(bottom up) :Restricted
    {
        my ($self, $whoami) = @_;
        my $class = __PACKAGE__;
        return ($whoami) ? "$whoami son of $class" : $class;
    }

    sub auto : Automethod
    {
        my $self = $_[0];
        my $class = ref($self) || $self;
        my $name = $_;

        if ($name eq 'izza') {
            return (sub {
                        my $self = $_[0];
                        my $class = ref($self) || $self;
                        return ($class . ' isa ' . __PACKAGE__);
                   }, 'CUM(BOT)');
        }

        if ($name eq 'bork') {
            return (sub {
                        my $self = $_[0];
                        my $class = __PACKAGE__;
                        my ($whoami) = $class->whoami();
                        return ("$class says 'I am $whoami.'");
                   }, 'CUM');
        }

        return;
    }
}

package Baz; {
    use Object::InsideOut 'Bar';

    sub we_are :Cumulative :Restricted
    {
        return __PACKAGE__;
    }

    sub whoami :Chained(bottom up) :Restricted
    {
        my ($self, $whoami) = @_;
        my $class = __PACKAGE__;
        return ($whoami) ? "$whoami son of $class" : $class;
    }

    sub auto : Automethod
    {
        my $self = $_[0];
        my $class = ref($self) || $self;
        my $name = $_;

        if ($name eq 'izza') {
            return (sub {
                        my $self = $_[0];
                        my $class = ref($self) || $self;
                        return ($class . ' isa ' . __PACKAGE__);
                   }, 'CUM(BOT)');
        }

        if ($name eq 'bork') {
            return (sub {
                        my $self = $_[0];
                        my $class = __PACKAGE__;
                        my ($whoami) = $class->whoami();
                        return ("$class says 'I am $whoami.'");
                   }, 'CUM');
        }

        return;
    }
}

package main;

MAIN:
{
    my $baz = Baz->new();
    is("$baz", 'I am Baz son of Bar son of Foo' => 'whoami');

    my %we_are = %{$baz};
    is_deeply(\%we_are, { 'Foo' => 'Foo',
                          'Bar' => 'Bar',
                          'Baz' => 'Baz' }      => 'we_are');

SKIP: {
    skip('due to Perl 5.8.0 bug', 2) if ($] == 5.008);

    my @izza = @{$baz};
    is_deeply(\@izza, [ 'Baz isa Baz',
                        'Baz isa Bar',
                        'Baz isa Foo' ]         => 'izza');

    my @says = @{$baz->()};
    is_deeply(\@says, [ "Foo says 'I am Foo.'",
                        "Bar says 'I am Bar son of Foo.'",
                        "Baz says 'I am Baz son of Bar son of Foo.'" ] => 'bork');
}

}

exit(0);

# EOF
Object-InsideOut-4.05/t/21-import.t0000644000175000001440000000224713377136466016444 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 7;

package main;
MAIN:
{
    use lib 't';
    use Imp1;
    use Imp2;

    is_deeply( \@main::ISA, [], 
            '@main::ISA result=' . join(', ', @main::ISA));

    is_deeply( \@t::A::ISA, [ 'Object::InsideOut' ], 
            '@t::A::ISA result=' . join(', ', @t::A::ISA));

    is_deeply( \@t::AA::ISA, [ 't::A' ], 
            '@t::AA::ISA result=' . join(', ', @t::AA::ISA));

    is_deeply( \@t::AAA::ISA, [ 't::AA' ], 
            '@t::AAA::ISA result=' . join(', ', @t::AAA::ISA));

    is_deeply( \@t::AA::ISA, [ 't::A' ], 
            '@t::AA::ISA result=' . join(', ', @t::AA::ISA));

    is_deeply( \@t::A_also::ISA, [ 't::A' ], 
            '@t::A_also::ISA result=' . join(', ', @t::A_also::ISA));

    is_deeply( \@t::AB::ISA, [ 't::A', 't::B' ], 
            '@t::AB::ISA result=' . join(', ', @t::AB::ISA));
}

exit(0);


# Multiple inheritance
package t::AB; {
    use Object::InsideOut qw( t::A t::B ) ;
}

# Embedded class inheritance test
package t::A_also; {
    use Object::InsideOut qw( t::A ) ;

    my @foo :Field();

    my %init_args :InitArgs = ( foo => {FIELD => \@foo});

    sub init :Init {}
}

# EOF
Object-InsideOut-4.05/t/05-require.t0000644000175000001440000000304413377136466016604 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 24;

eval {
    use lib 't';
    require '05-require.pm';
};
ok(! $@, 'require ' . $@);


package main;

MAIN:
{
    my $obj;
    eval { $obj = t::AA->new(); };
    ok(! $@, '->new() ' . $@);
    can_ok($obj, qw(new clone DESTROY CLONE aa));

    ok($$obj == 1,                  'Object ID: ' . $$obj);
    ok(! defined($obj->aa),         'No default');
    ok($obj->aa(42) == 42,          'Set ->aa()');
    ok($obj->aa == 42,              'Get ->aa() == ' . $obj->aa);

    eval { $obj = t::BB->new(); };
    can_ok($obj, qw(bb set_bb));
    ok(! $@, '->new() ' . $@);
    ok($$obj == 2,                  'Object ID: ' . $$obj);
    is($obj->bb, 'def',             'Default: ' . $obj->bb);
    is($obj->set_bb('foo'), 'foo',  'Set ->set_bb()');
    is($obj->bb, 'foo',             'Get ->bb() eq ' . $obj->bb);

    eval { $obj = t::BB->new('bB' => 'baz'); };
    ok(! $@, '->new() ' . $@);
    ok($$obj == 3,                  'Object ID: ' . $$obj);
    is($obj->bb, 'baz',             'Init: ' . $obj->bb);
    is($obj->set_bb('foo'), 'foo',  'Set ->set_bb()');
    is($obj->bb, 'foo',             'Get ->bb() eq ' . $obj->bb);

    eval { $obj = t::AB->new(); };
    can_ok($obj, qw(aa bb set_bb data info_get info_set));
    ok(! $@, '->new() ' . $@);
    ok($$obj == 4,                  'Object ID: ' . $$obj);
    is($obj->bb, 'def',             'Default: ' . $obj->bb);
    is($obj->set_bb('foo'), 'foo',  'Set ->set_bb()');
    is($obj->bb, 'foo',             'Get ->bb() eq ' . $obj->bb);
}

exit(0);

# EOF
Object-InsideOut-4.05/t/43-overload.t0000644000175000001440000000333013377136466016743 0ustar  jdheddenusersuse strict;
use warnings;

use Config;
BEGIN {
    if (! $Config{useithreads} || $] < 5.008) {
        print("1..0 # Skip Threads not supported\n");
        exit(0);
    }
}

use threads;
use threads::shared;

BEGIN {
    if ($threads::shared::VERSION lt '0.95') {
        print("1..0 # Skip Needs threads::shared 0.95 or later\n");
        exit(0);
    }
}

use Test::More 'tests' => 8;

package Foo; {
    use Object::InsideOut ':SHARED';
    my @objs :Field :All(obj);
}

package Bar; {
    use Object::InsideOut;
    my @objs :Field :All(obj);
    my @value :Field :All(value) :Type(numeric);

    sub num :Numerify { $value[${$_[0]}]; }

    use overload (
        '='  => 'clone',
        '++' => sub { $value[${$_[0]}]++; shift },
    );
}

package main;
MAIN:
{
    my $foo = Foo->new();
    my $foo2 = Foo->new('obj'=>$foo);
    my $oof = $foo2->obj();
    isnt($oof, $foo             => 'Shared objects are not the same');
    if (! ok($oof == $foo       => 'However, they equate')) {
        diag("Original object:  ref(\$foo)=" . ref($foo) . '  ID=' . $$foo);
        diag("Shared   object:  ref(\$oof)=" . ref($oof) . '  ID=' . $$oof);
        no strict 'refs';
        diag('Equality: ' . &{'Foo::(=='}($foo, $oof));
    }

    my $bar = Bar->new('value' => 42);
    ok($oof != $bar             => "Different objects don't equate");
    ok($$oof == $$bar           => "Even if they have the same ID");

    my $bar2 = Bar->new('obj'=>$bar);
    my $rab = $bar2->obj();
    is($rab, $bar               => 'Non-shared objects are the same');
    ok($rab == $bar             => 'And they equate');

    ++$rab;
    is($rab->value(), 43        => '++ worked');
    is($bar->value(), 42        => 'Copy constuctor worked');
}

exit(0);

# EOF
Object-InsideOut-4.05/t/01-basic.t0000644000175000001440000001356513377136466016216 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 39;

package MyBase; {
    use Object::InsideOut;

    my %name :Field('Get' => 'get_name');
    my %rank :Field('Std' => 'rank');
    my %snum :Field('Get' => 'get_snum');
    my %priv :Field('get/set' => 'priv');
    my %def  :Field('Get' => 'get_default');

    my %init_args :InitArgs = (
        'name' => { 'Field' => \%name },
        'rank' => { 'Field' => \%rank },
        'SNUM' => {
            'Regexp'    => qr/^snum$/i,
            'Mandatory' => 1
        },
        'PRIV' => qr/^priv(?:ate)?$/,
        'def'  => {
            'Field'   => \%def,
            'Default' => 'MyBase::def',
        },
    );

    sub init :Init(private)
    {
        my ($self, $args) = @_;

        Test::More::is(ref($args), 'HASH'
                            => 'Args passed to MyBase::init in hash-ref');

        $self->set(\%priv, $args->{'PRIV'});
        Test::More::is($priv{$$self}, 'MyBase::priv'
                            => 'MyBase priv arg unpacked correctly');

        $self->Object::InsideOut::set(\%snum, $args->{'SNUM'} . '!');
        Test::More::is($snum{$$self}, 'MyBase::snum!'  => 'MyBase snum arg unpacked correctly');
    }

    sub verify :Cumulative {
        my $self = $_[0];

        Test::More::is($name{$$self}, 'MyBase::name'  => 'MyBase::name initialized');
        Test::More::is($rank{$$self}, 'MyBase::rank'  => 'MyBase::rank initialized');
        Test::More::is($snum{$$self}, 'MyBase::snum!' => 'MyBase::snum initialized');
        Test::More::is($priv{$$self}, 'MyBase::priv'  => 'MyBase::name initialized');
        Test::More::is($def{$$self},  'MyBase::def'   => 'MyBase::def initialized');
    }
}


package Der; {
    use Object::InsideOut qw(MyBase);

    my %name :Field;
    my %rank :Field;
    my %snum :Field('Get' => 'get_snum');
    my %priv :Field('Get' => 'get_priv');
    my %def  :Field('Get' => 'get_default');

    my %init_args :InitArgs = (
        'name' => { 'Field' => \%name },
        'rank' => { 'Field' => \%rank },
        'snum' => { 'Field' => \%snum },
        'priv' => { 'Field' => \%priv },
        'def'  => {
            'Field'   => \%def,
            'Default' => 'default def',
        },
    );

    sub init :Init(public)
    {
        my ($self, $args) = @_;

        Test::More::is(ref($args), 'HASH'
                            => 'Args passed to Der::init in hash-ref');
    }

    sub verify :Cumulative {
        my $self = $_[0];

        Test::More::is($name{$$self}, 'MyBase::name' => 'Der::name initialized');
        Test::More::is($rank{$$self}, 'generic rank' => 'Der::rank initialized');
        Test::More::is($snum{$$self}, 'Der::snum'    => 'Der::snum initialized');
        Test::More::is($priv{$$self}, 'Der::priv'    => 'Der::name initialized');
        Test::More::is($def{$$self},  'Der::def'     => 'Der::def initialized');
    }
}


package main;

MAIN:
{
    my $obj = MyBase->new({
        name => 'MyBase::name',
        rank => 'generic rank',
        snum => 'MyBase::snum',
        priv => 'generic priv',
        MyBase => {
            rank => 'MyBase::rank',
            private => 'MyBase::priv',
        }
    });

    can_ok($obj, qw(new clone DESTROY CLONE get_name get_rank set_rank
                        get_snum priv get_default verify));
    $obj->verify();

    $obj->priv('Modified');
    is($obj->priv(), 'Modified' => 'MyBase combined accessor');

    my $derobj = Der->new({
        name => 'MyBase::name',
        rank => 'generic rank',
        snum => 'MyBase::snum',
        priv => 'generic priv',
        MyBase => {
            rank => 'MyBase::rank',
            priv => 'MyBase::priv',
        },
        Der => {
            snum => 'Der::snum',
            priv => 'Der::priv',
            def  => 'Der::def',
        },
    });

    can_ok($derobj, qw(new clone DESTROY CLONE get_name get_rank set_rank
                        get_snum get_priv get_default verify));
    $derobj->verify();

    is($derobj->get_name(), 'MyBase::name'  => 'Der name read accessor');
    is($derobj->get_rank(), 'MyBase::rank'  => 'Der rank read accessor');
    is($derobj->get_snum(), 'Der::snum'     => 'Der rank read accessor');
    is($derobj->get_priv(), 'Der::priv'     => 'Der priv read accessor');

    $derobj->set_rank('new rank');
    is($derobj->get_rank(), 'new rank'      => 'Der rank write accessor');

    eval { $derobj->set_name('new name') };
    ok($@->error() =~ m/^Can't locate object method "set_name" via package "Der"/
                                            => 'Read only name attribute');

    my $der2 = Der->new({
        name => undef,
        rank => 'generic rank',
        priv => '',
        MyBase => {
            rank => 'MyBase::rank',
            snum => 'MyBase::snum',
            priv => 'MyBase::priv',
        },
        Der => {
            snum => 0,
        },
    });

    my $name = $der2->get_name();
    ok(! defined($name)      => 'undef values processes as initializers');
    is($der2->get_snum(), 0  => 'False values allowable as initializers');
    is($der2->get_priv(), '' => 'False values allowable as initializers');

    eval { my $obj2 = MyBase->new(
                                    name => undef,
                                    rank => 'generic rank',
                                    priv => '',
                                    MyBase => {
                                        rank => 'MyBase::rank',
                                        priv => 'MyBase::priv',
                                    },
                                    Der => {
                                        snum => 'MyBase::snum',
                                    }
                                  );
    };
    if (my $e = OIO->caught()) {
        ok($e->error() =~ /Missing mandatory initializer/
                                => 'Missing mandatory initializer caught');
    } else {
        fail("Uncaught exception: $@");
    }
}

exit(0);

# EOF
Object-InsideOut-4.05/t/26-preinit.t0000644000175000001440000000214613377136466016607 0ustar  jdheddenusersuse strict;
use warnings;

use Test::More 'tests' => 8;

package Foo; {
    use Object::InsideOut;

    my @data :Field('Acc'=>'data');

    my %init_args :InitArgs = (
        'DATA' => {
            'Field' => \@data,
        },
    );
}

package Bar; {
    use Object::InsideOut qw(Foo);

    sub _preinit :PreInit
    {
        my ($self, $args) = @_;

        if (! exists($args->{'DATA'})) {
            $args->{'DATA'} = 'bar';
        }
    }
}


package Baz; {
    use Object::InsideOut qw(Bar);
}


package main;
MAIN:
{
    my $obj = Bar->new('DATA' => 'main');
    ok($obj                     => 'Object okay');
    is($obj->data(), 'main'     => 'Object data from main');

    $obj = Bar->new();
    ok($obj                     => 'Object okay');
    is($obj->data(), 'bar'      => 'Object data from bar');

    $obj = Baz->new('DATA' => 'main');
    ok($obj                     => 'Object okay');
    is($obj->data(), 'main'     => 'Object data from main');

    $obj = Baz->new();
    ok($obj                     => 'Object okay');
    is($obj->data(), 'bar'      => 'Object data from bar');
}

exit(0);

# EOF
Object-InsideOut-4.05/Makefile.PL0000644000175000001440000000702413377136466016232 0ustar  jdheddenusers# Module makefile for Object::InsideOut (using ExtUtils::MakeMaker)

require 5.006;

use strict;
use warnings;

use ExtUtils::MakeMaker;


# Check for Scalar::Util::weaken()
eval { require Scalar::Util; };
if (! $@ &&
    ! Scalar::Util->can('weaken') &&
    $Scalar::Util::VERSION ge '1.20')
{
    die <<_NO_WEAKEN_;
You must reinstall Scalar::Util in order to install Object::InsideOut
because the currently installed Scalar::Util is a 'pure perl' version
that is missing the 'weaken()' function.
_NO_WEAKEN_
}


# Check for Want module
eval { require Want; };
if ($@) {
    print(<<_WANT_);

Checking prerequisites...
 * Optional prerequisite Want is not installed

ERRORS/WARNINGS FOUND IN PREREQUISITES.  You may wish to install the versions
of the modules indicated above before proceeding with this installation

_WANT_
} elsif ($Want::VERSION < 0.21) {
    print(<<_WANT_);

Checking prerequisites...
 * Want ($Want::VERSION) is installed, but we prefer to have 0.21 or later

ERRORS/WARNINGS FOUND IN PREREQUISITES.  You may wish to install the versions
of the modules indicated above before proceeding with this installation

_WANT_
}


# Check for MRMA
eval { require Math::Random::MT::Auto; };
if ($@) {
    print(<<_MRMA_);

Checking prerequisites...
 * Optional prerequisite Math::Random::MT::Auto is not installed

ERRORS/WARNINGS FOUND IN PREREQUISITES.  You may wish to install the versions
of the modules indicated above before proceeding with this installation

_MRMA_
} elsif ($Math::Random::MT::Auto::VERSION < 6.18) {
    print(<<_MRMA_);

Checking prerequisites...
 * Math::Random::MT::Auto ($Math::Random::MT::Auto::VERSION) is installed, but we prefer to have 6.18 or later

ERRORS/WARNINGS FOUND IN PREREQUISITES.  You may wish to install the versions
of the modules indicated above before proceeding with this installation

_MRMA_
}


# Construct make file
WriteMakefile(
    'NAME'          => 'Object::InsideOut',
    'AUTHOR'        => 'Jerry D. Hedden ',
    'VERSION_FROM'  => 'lib/Object/InsideOut.pm',
    'ABSTRACT_FROM' => 'lib/Object/InsideOut.pod',
    'PREREQ_PM'     => { 'strict'           => 0,
                         'warnings'         => 0,
                         'attributes'       => 0,
                         'overload'         => 0,
                         'Config'           => 0,
                         'B'                => 0,
                         'Data::Dumper'     => 2.131,
                         'Scalar::Util'     => 1.23,
                         'Exception::Class' => 1.32,
                         'Test::More'       => 0.98,
                       },
    ((ExtUtils::MakeMaker->VERSION() lt '6.25')
                              ? ('PL_FILES' => { })    : ()),
    ((ExtUtils::MakeMaker->VERSION() gt '6.30')
                              ? ('LICENSE'  => 'perl') : ()),
);


package MY;

# Add to metafile target
sub metafile
{
    my $inherited = shift->SUPER::metafile_target(@_);
    $inherited .= <<'_MOREMETA_';
	$(NOECHO) $(ECHO) 'recommends:' >>$(DISTVNAME)/META.yml
	$(NOECHO) $(ECHO) '  Math::Random::MT::Auto: 6.18' >>$(DISTVNAME)/META.yml
	$(NOECHO) $(ECHO) '  Want: 0.21' >>$(DISTVNAME)/META.yml
_MOREMETA_

    return $inherited;
}

# Additional 'make' targets
sub postamble
{
    return <<'_EXTRAS_';
fixfiles:
	@dos2unix `cat MANIFEST`
	@$(CHMOD) 644 `cat MANIFEST`

yapi:
	$(NOECHO) $(ABSPERLRUN) -MExtUtils::Install -e 'pm_to_blib({@ARGV}, '\''$(INST_LIB)/auto'\'', '\''$(PM_FILTER)'\'')' -- \
	  examples/YAPI.pm blib/lib/Term/YAPI.pm
	$(NOECHO) $(TOUCH) pm_to_blib
_EXTRAS_
}

# EOF