Class-Accessor-Grouped-0.10014/000755 000765 000024 00000000000 13316225501 016346 5ustar00gknopstaff000000 000000 Class-Accessor-Grouped-0.10014/inc/000755 000765 000024 00000000000 13316225500 017116 5ustar00gknopstaff000000 000000 Class-Accessor-Grouped-0.10014/Changes000644 000765 000024 00000014576 13316225262 017662 0ustar00gknopstaff000000 000000 Revision history for Class::Accessor::Grouped. 0.10014 2018-07-01 19:25 (UTC) - releasing 0.10013_01 as stable 0.10013_01 2018-05-28 13:37 (UTC) - convert packaging from Module::Install to plain ExtUtils::MakeMaker - fix running Makefile.PL when @INC does not contain '.' (perl 5.26). - don't run author tests at all for user installs 0.10012 2014-10-05 21:22 (UTC) - Fix tests tickling deficient threads on perl 5.10.0 0.10011 2014-09-26 11:24 (UTC) - Soft-depend on newer (bugfixed and *simpler*) Class::XSAccessor 1.19 - More robust threading tests 0.10010 2013-04-24 02:58 (UTC) - Fix bug with identically-named 'simple' accessors in different classes set to access *differently named fields* getting their field access mixed up - Fix subtle pessimization when having identically-named accessors in different classes leads to 'simple' implementations not being replaced by Class::XSAccessor where appropriate 0.10009 2012-11-15 18:51 (UTC) - Stop leaking extra methods into the inheritance chain - there are plenty already 0.10008 2012-11-15 09:48 (UTC) - Allow disabling of accessor name checking introduced in 0.10007 - Pass tests if Class::XSAccessor is available but Sub::Name isn't 0.10007 2012-11-08 11:54 (UTC) - Disable tests on perls where Class::XSAccessor emits broken error messages (RT#74883, RT#80519) - Drop minimum perl to 5.6 (from 5.6.2) - Switch all module loading to Module::Runtime and lose dependency on Class::Inspector - Fix stupid mistake causing double-require of Sub::Name when Class::XSAccessor is not available (RT#80657) - Simplify superclass traversal done by the 'inherited' group type - Fix incorrect quoting of unusual hash keys (fieldnames) - Depend on newer bugfixed Class::XSAccessor 1.15 - Improve text of ro/wo violation exceptions - Sanity-check accessor names for well-formedness (qr/[A-Z_a-z][0-9A-Z_a-z]*/) 0.10006 2011-12-30 03:52 (UTC) - Silence warnings resulting from incomplete can() overrides hiding get/set_simple methods 0.10005 2011-12-26 12:43 (UTC) - Depend on newer bugfixed Class::XSAccessor - Repack with correct metadata (RT#73100) 0.10004 2011-11-28 21:20 (UTC) - No longer leak internal __CAG* methods into the inheritable namespace 0.10003 2011-05-03 00:15 (UTC) - Only require MRO::Compat for older perls - Add SYNOPSIS - Add examples for methods that get used most often 0.10002 Sun Dec 19 05:23:44 2010 - Fix grave bug of XS-enabled simple accessors clobbering an existing 'around' overlay installed in the same method slot - Require bugfixed XSAccessor, remove Win32 caveat 0.10001 Sun Dec 12 03:17:05 2010 - Fix an ActiveState Win32 incompatibility - Fix spurious method re-invocation warnings after Class::Unload 0.10000 Sat Nov 27 17:51:04 2010 - Fix perl 5.6 failures - Add test-time deferred coderef reinvocation checks - Another minor (8%) speedup 0.09009 Fri Nov 26 01:31:56 2010 - Major cleanup and optimization of code (evaled coderef sharing) - Module can now operate in PurePerl environments with 100% compatibility (including proper naming of generated coderefs) 0.09008 Sun Oct 11 07:41:56 2010 - Put back a private undocumented method that the DBIC-CDBI compat layer relies on :( - Fix corner case segfaults with C::XSA and old 5.8 perls 0.09007 Sat Oct 9 10:22:56 2010 (DELETED) - Fix corner case when get/set_simple overrides are circumvented iff Class::XSAccessor is present 0.09006 Fri Sep 10 23:55:00 2010 - Fix bugs in ro/wo accessor generation when XSAccessor is being used - Better Class::XSAccessor usage control - introducing $ENV{CAG_USE_XS} and $Class::Accessor::Grouped::USE_XS 0.09005 Wed Sep 1 04:00:00 2010 - Again, remove Class::XSAccessor for Win32 sine it still breaks 0.09004 Wed Aug 11 04:23:15 2010 - Changed the way Class::XSAccessor is invoked if available (recommended by C::XSA author) - Modified internal cache names to avoid real accessor clashes - Some micro-optimizations for get_inherited - Fixed field names with a single quote in them (patch from Jason Plum) 0.09003 Fri Apr 23 23:00:19 2010 - use Class::XSAccessor if available for 'simple' accessors, except on MSWin32, with documentation 0.09002 Tue Oct 20 23:16:28 2009 - removing Class::XSAccessor usage for now 0.09001 Thu Oct 1 21:48:06 2009 - remove optional dep from Makefile.PL 0.09000 Sun Aug 23 20:08:09 2009 - release 0.08999_01 Tue July 7 22:06:21 2009 - Make _mk_group_accessors name the closures installed for Moose compat - Use Class::XSAccessor if available RT#45577 (Andy Grundman) 0.08003 Sat Mar 21 9:27:24 2009 - Fixed set_inherited under C3::Componentised: RT#43702, RIBASUSHI 0.08002 Mon Nov 17 20:27:22 2008 - Removed unnecessary code in get_simple: RT#40992, BUCHMULLER Norbert 0.08001 Wed Jan 09 19:35:34 2008 - Fixed Makefile.PL tests setting that was killing older installs 0.08000 Tue Jan 08 18:22:47 2008 - Bumped version for release. No changes oherwise. 0.07009_01 Fri Dec 28 18:08::00 2007 - Tweak code for pure speed while fixing performance issue when assigning @_ under Perl 5.10.0 0.07000 - Altered get_inherited to return undef rather than () when no value set for Class::Data::(Inheritable|Accessor) compatiblity - Fixed spelling test error - Added WriteAll/DIST/PREOP for README 0.06000 Fri May 11 22:00:26 2007 - get_super_paths now uses mro::get_linear_isa to DTRT under C3 0.05002 Fri May 11 20:46:16 2007 - killed Class::Inspector->installed warnings 0.05001 Thur May 10 20:55:11 2007 - set_component_class now only dies if the specified class is a installed/installable class and fails to load it. 0.05000 Tue May 08 19:42:33 2007 - Added get/set_component_class 0 04000 Sat May 05 21:17:23 2007 - Converted to Module::Install - Added culterific tests/TEST_AUTHOR - Converted to distro friendly version number 0.03 2006-11-07 21:33::35 - big speedup for get_inherited - get_inherited now checks the current class first before calculating super_path - get_inherited now caches super_path results 0.02 2006-06-26 19:23:13 - Added return statement to end of get_inherited - Fixed pod NAME 0.01 2006-06-26 17:38:23 - initial release Class-Accessor-Grouped-0.10014/MANIFEST000644 000765 000024 00000001644 13316225501 017504 0ustar00gknopstaff000000 000000 Changes inc/ExtUtils/HasCompiler.pm lib/Class/Accessor/Grouped.pm Makefile.PL MANIFEST This list of files t/accessors.t t/accessors_pp.t t/accessors_ro.t t/accessors_wo.t t/accessors_xs.t t/accessors_xs_cachedwarn.t t/basic.t t/clean_namespace.t t/component.t t/illegal_name.t t/inherited.t t/lib/AccessorGroups.pm t/lib/AccessorGroupsComp.pm t/lib/AccessorGroupsParent.pm t/lib/AccessorGroupsRO.pm t/lib/AccessorGroupsSubclass.pm t/lib/AccessorGroupsWO.pm t/lib/BaseInheritedGroups.pm t/lib/ExtraInheritedGroups.pm t/lib/NotHashBased.pm t/lib/NotReallyAClass.pm t/lib/SuperInheritedGroups.pm xt/manifest.t xt/pod_coverage.t xt/pod_spelling.t xt/pod_syntax.t xt/strict.t xt/style_no_tabs.t xt/warnings.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) README Generated README Class-Accessor-Grouped-0.10014/t/000755 000765 000024 00000000000 13316225500 016610 5ustar00gknopstaff000000 000000 Class-Accessor-Grouped-0.10014/xt/000755 000765 000024 00000000000 13316225500 017000 5ustar00gknopstaff000000 000000 Class-Accessor-Grouped-0.10014/README000644 000765 000024 00000031222 13316225501 017226 0ustar00gknopstaff000000 000000 NAME Class::Accessor::Grouped - Lets you build groups of accessors SYNOPSIS use base 'Class::Accessor::Grouped'; # make basic accessors for objects __PACKAGE__->mk_group_accessors(simple => qw(id name email)); # make accessor that works for objects and classes __PACKAGE__->mk_group_accessors(inherited => 'awesome_level'); # make an accessor which calls a custom pair of getters/setters sub get_column { ... this will be called when you do $obj->name() ... } sub set_column { ... this will be called when you do $obj->name('foo') ... } __PACKAGE__->mk_group_accessors(column => 'name'); DESCRIPTION This class lets you build groups of accessors that will call different getters and setters. The documentation of this module still requires a lot of work (volunteers welcome >.>), but in the meantime you can refer to this post for more information. Notes on accessor names In general method names in Perl are considered identifiers, and as such need to conform to the identifier specification of "qr/\A[A-Z_a-z][0-9A-Z_a-z]*\z/". While it is rather easy to invoke methods with non-standard names ("$obj->${\"anything goes"}"), it is not possible to properly declare such methods without the use of Sub::Name. Since this module must be able to function identically with and without its optional dependencies, starting with version 0.10008 attempting to declare an accessor with a non-standard name is a fatal error (such operations would silently succeed since version 0.08004, as long as Sub::Name is present, or otherwise would result in a syntax error during a string eval). Unfortunately in the years since 0.08004 a rather large body of code accumulated in the wild that does attempt to declare accessors with funny names. One notable perpetrator is DBIx::Class::Schema::Loader, which under certain conditions could create accessors of the "column" group which start with numbers and/or some other punctuation (the proper way would be to declare columns with the "accessor" attribute set to "undef"). Therefore an escape mechanism is provided via the environment variable "CAG_ILLEGAL_ACCESSOR_NAME_OK". When set to a true value, one warning is issued per class on attempts to declare an accessor with a non-conforming name, and as long as Sub::Name is available all accessors will be properly created. Regardless of this setting, accessor names containing nulls "\0" are disallowed, due to various deficiencies in perl itself. If your code base has too many instances of illegal accessor declarations, and a fix is not feasible due to time constraints, it is possible to disable the warnings altogether by setting $ENV{CAG_ILLEGAL_ACCESSOR_NAME_OK} to "DO_NOT_WARN" (observe capitalization). METHODS mk_group_accessors __PACKAGE__->mk_group_accessors(simple => 'hair_length', [ hair_color => 'hc' ]); Arguments: $group, @fieldspec Returns: none Creates a set of accessors in a given group. $group is the name of the accessor group for the generated accessors; they will call get_$group($field) on get and set_$group($field, $value) on set. If you want to mimic Class::Accessor's mk_accessors $group has to be 'simple' to tell Class::Accessor::Grouped to use its own get_simple and set_simple methods. @fieldspec is a list of field/accessor names; if a fieldspec is a scalar this is used as both field and accessor name, if a listref it is expected to be of the form [ $accessor, $field ]. mk_group_ro_accessors __PACKAGE__->mk_group_ro_accessors(simple => 'birthdate', [ social_security_number => 'ssn' ]); Arguments: $group, @fieldspec Returns: none Creates a set of read only accessors in a given group. Identical to "mk_group_accessors" but accessors will throw an error if passed a value rather than setting the value. mk_group_wo_accessors __PACKAGE__->mk_group_wo_accessors(simple => 'lie', [ subject => 'subj' ]); Arguments: $group, @fieldspec Returns: none Creates a set of write only accessors in a given group. Identical to "mk_group_accessors" but accessors will throw an error if not passed a value rather than getting the value. get_simple Arguments: $field Returns: $value Simple getter for hash-based objects which returns the value for the field name passed as an argument. set_simple Arguments: $field, $new_value Returns: $new_value Simple setter for hash-based objects which sets and then returns the value for the field name passed as an argument. get_inherited Arguments: $field Returns: $value Simple getter for Classes and hash-based objects which returns the value for the field name passed as an argument. This behaves much like Class::Data::Accessor where the field can be set in a base class, inherited and changed in subclasses, and inherited and changed for object instances. set_inherited Arguments: $field, $new_value Returns: $new_value Simple setter for Classes and hash-based objects which sets and then returns the value for the field name passed as an argument. When called on a hash-based object it will set the appropriate hash key value. When called on a class, it will set a class level variable. Note:: This method will die if you try to set an object variable on a non hash-based object. get_component_class Arguments: $field Returns: $value Gets the value of the specified component class. __PACKAGE__->mk_group_accessors('component_class' => 'result_class'); $self->result_class->method(); ## same as $self->get_component_class('result_class')->method(); set_component_class Arguments: $field, $class Returns: $new_value Inherited accessor that automatically loads the specified class before setting it. This method will die if the specified class could not be loaded. __PACKAGE__->mk_group_accessors('component_class' => 'result_class'); __PACKAGE__->result_class('MyClass'); $self->result_class->method(); INTERNAL METHODS These methods are documented for clarity, but are never meant to be called directly, and are not really meant for overriding either. get_super_paths Returns a list of 'parent' or 'super' class names that the current class inherited from. This is what drives the traversal done by "get_inherited". make_group_accessor __PACKAGE__->make_group_accessor('simple', 'hair_length', 'hair_length'); __PACKAGE__->make_group_accessor('simple', 'hc', 'hair_color'); Arguments: $group, $field, $accessor Returns: \&accessor_coderef ? Called by mk_group_accessors for each entry in @fieldspec. Either returns a coderef which will be installed at "&__PACKAGE__::$accessor", or returns "undef" if it elects to install the coderef on its own. make_group_ro_accessor __PACKAGE__->make_group_ro_accessor('simple', 'birthdate', 'birthdate'); __PACKAGE__->make_group_ro_accessor('simple', 'ssn', 'social_security_number'); Arguments: $group, $field, $accessor Returns: \&accessor_coderef ? Called by mk_group_ro_accessors for each entry in @fieldspec. Either returns a coderef which will be installed at "&__PACKAGE__::$accessor", or returns "undef" if it elects to install the coderef on its own. make_group_wo_accessor __PACKAGE__->make_group_wo_accessor('simple', 'lie', 'lie'); __PACKAGE__->make_group_wo_accessor('simple', 'subj', 'subject'); Arguments: $group, $field, $accessor Returns: \&accessor_coderef ? Called by mk_group_wo_accessors for each entry in @fieldspec. Either returns a coderef which will be installed at "&__PACKAGE__::$accessor", or returns "undef" if it elects to install the coderef on its own. PERFORMANCE To provide total flexibility Class::Accessor::Grouped calls methods internally while performing get/set actions, which makes it noticeably slower than similar modules. To compensate, this module will automatically use the insanely fast Class::XSAccessor to generate the "simple"-group accessors if this module is available on your system. Benchmark This is the benchmark of 200 get/get/set/get/set cycles on perl 5.16.2 with thread support, showcasing how this modules simple (CAG_S), inherited (CAG_INH) and inherited with parent-class data (CAG_INHP) accessors stack up against most popular accessor builders: Moose, Moo, Mo, Mouse (both pure-perl and XS variant), Object::Tiny::RW (OTRW), Class::Accessor (CA), Class::Accessor::Lite (CAL), Class::Accessor::Fast (CAF), Class::Accessor::Fast::XS (CAF_XS) and Class::XSAccessor (XSA) Rate CAG_INHP CAG_INH CA CAG_S CAF moOse OTRW CAL mo moUse HANDMADE moo CAF_XS moUse_XS XSA CAG_INHP 287.021+-0.02/s -- -0.3% -10.0% -37.1% -53.1% -53.6% -53.7% -54.1% -56.9% -59.0% -59.6% -59.8% -78.7% -81.9% -83.5% CAG_INH 288.025+-0.031/s 0.3% -- -9.7% -36.9% -52.9% -53.5% -53.5% -53.9% -56.7% -58.8% -59.5% -59.7% -78.6% -81.9% -83.5% CA 318.967+-0.047/s 11.1% 10.7% -- -30.1% -47.9% -48.5% -48.5% -49.0% -52.1% -54.4% -55.1% -55.3% -76.3% -79.9% -81.7% CAG_S 456.107+-0.054/s 58.9% 58.4% 43.0% -- -25.4% -26.3% -26.4% -27.0% -31.5% -34.8% -35.8% -36.1% -66.1% -71.3% -73.9% CAF 611.745+-0.099/s 113.1% 112.4% 91.8% 34.1% -- -1.2% -1.2% -2.1% -8.1% -12.6% -14.0% -14.3% -54.5% -61.5% -64.9% moOse 619.051+-0.059/s 115.7% 114.9% 94.1% 35.7% 1.2% -- -0.1% -1.0% -7.0% -11.6% -12.9% -13.3% -54.0% -61.0% -64.5% OTRW 619.475+-0.1/s 115.8% 115.1% 94.2% 35.8% 1.3% 0.1% -- -0.9% -6.9% -11.5% -12.9% -13.2% -54.0% -61.0% -64.5% CAL 625.106+-0.085/s 117.8% 117.0% 96.0% 37.1% 2.2% 1.0% 0.9% -- -6.1% -10.7% -12.1% -12.5% -53.5% -60.6% -64.2% mo 665.44+-0.12/s 131.8% 131.0% 108.6% 45.9% 8.8% 7.5% 7.4% 6.5% -- -4.9% -6.4% -6.8% -50.5% -58.1% -61.9% moUse 699.9+-0.15/s 143.9% 143.0% 119.4% 53.5% 14.4% 13.1% 13.0% 12.0% 5.2% -- -1.6% -2.0% -48.0% -55.9% -59.9% HANDMADE 710.98+-0.16/s 147.7% 146.8% 122.9% 55.9% 16.2% 14.9% 14.8% 13.7% 6.8% 1.6% -- -0.4% -47.2% -55.2% -59.2% moo 714.04+-0.13/s 148.8% 147.9% 123.9% 56.6% 16.7% 15.3% 15.3% 14.2% 7.3% 2.0% 0.4% -- -46.9% -55.0% -59.1% CAF_XS 1345.55+-0.051/s 368.8% 367.2% 321.8% 195.0% 120.0% 117.4% 117.2% 115.3% 102.2% 92.2% 89.3% 88.4% -- -15.3% -22.9% moUse_XS 1588+-0.036/s 453.3% 451.3% 397.9% 248.2% 159.6% 156.5% 156.3% 154.0% 138.6% 126.9% 123.4% 122.4% 18.0% -- -9.0% XSA 1744.67+-0.052/s 507.9% 505.7% 447.0% 282.5% 185.2% 181.8% 181.6% 179.1% 162.2% 149.3% 145.4% 144.3% 29.7% 9.9% -- Benchmarking program is available in the root of the repository : Notes on Class::XSAccessor You can force (or disable) the use of Class::XSAccessor before creating a particular "simple" accessor by either manipulating the global variable $Class::Accessor::Grouped::USE_XS to true or false (preferably with localization, or you can do so before runtime via the "CAG_USE_XS" environment variable. Since Class::XSAccessor has no knowledge of "get_simple" and "set_simple" this module does its best to detect if you are overriding one of these methods and will fall back to using the perl version of the accessor in order to maintain consistency. However be aware that if you enable use of "Class::XSAccessor" (automatically or explicitly), create an object, invoke a simple accessor on that object, and then manipulate the symbol table to install a "get/set_simple" override - you get to keep all the pieces. AUTHORS Matt S. Trout Christopher H. Laco CONTRIBUTORS Caelum: Rafael Kitover frew: Arthur Axel "fREW" Schmidt groditi: Guillermo Roditi Jason Plum ribasushi: Peter Rabbitson COPYRIGHT & LICENSE Copyright (c) 2006-2010 Matt S. Trout This program is free software; you can redistribute it and/or modify it under the same terms as perl itself. Class-Accessor-Grouped-0.10014/META.yml000644 000765 000024 00000001747 13316225500 017627 0ustar00gknopstaff000000 000000 --- abstract: 'Lets you build groups of accessors' author: - 'Matt S. Trout ' build_requires: Test::Exception: '0.31' Test::More: '0.88' 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: Class-Accessor-Grouped no_index: directory: - t - xt recommends: Class::XSAccessor: '1.19' Sub::Name: '0.05' requires: Carp: '0' Module::Runtime: '0.012' Scalar::Util: '0' perl: '5.006' resources: bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Class-Accessor-Grouped homepage: https://metacpan.org/release/Class-Accessor-Grouped license: http://dev.perl.org/licenses/ repository: git://git.shadowcat.co.uk/p5sagit/Class-Accessor-Grouped.git version: '0.10014' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Class-Accessor-Grouped-0.10014/lib/000755 000765 000024 00000000000 13316225500 017113 5ustar00gknopstaff000000 000000 Class-Accessor-Grouped-0.10014/Makefile.PL000644 000765 000024 00000011176 13316224511 020326 0ustar00gknopstaff000000 000000 use strict; use warnings; use 5.006; use lib 'inc'; use ExtUtils::HasCompiler qw(can_compile_loadable_object); use ExtUtils::MakeMaker; my %META = ( name => 'Class-Accessor-Grouped', license => 'perl_5', author => [ 'Matt S. Trout ' ], prereqs => { configure => { requires => { 'ExtUtils::MakeMaker' => 0, } }, runtime => { requires => { 'perl' => '5.006', 'Carp' => 0, 'Module::Runtime' => '0.012', 'Scalar::Util' => 0, }, recommends => { 'Sub::Name' => '0.05', # when changing CXSA version don't forget to adjust lib/Class/Accessor/Grouped.pm as well 'Class::XSAccessor' => '1.19', }, }, test => { requires => { 'Test::More' => '0.88', 'Test::Exception' => '0.31', }, }, develop => { requires => { 'Sub::Name' => '0.05', 'Class::XSAccessor' => '1.19', 'Pod::Coverage' => '0.14', 'Test::CheckManifest' => '0.09', 'Test::NoTabs' => '0.03', 'Test::Pod' => '1.00', 'Test::Pod::Coverage' => '1.04', 'Test::Spelling' => '0.11', 'Test::Strict' => '0.05', }, }, }, resources => { homepage => 'https://metacpan.org/release/Class-Accessor-Grouped', repository => { url => 'git://git.shadowcat.co.uk/p5sagit/Class-Accessor-Grouped.git', web => 'https://github.com/p5sagit/Class-Accessor-Grouped', type => 'git', }, bugtracker => { web => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Class-Accessor-Grouped', mailto => 'bug-Class-Accessor-Grouped@rt.cpan.org', }, license => [ 'http://dev.perl.org/licenses/' ], }, no_index => { directory => [ 't', 'xt' ] }, ); my %MM_ARGS = ( PREREQ_PM => { ( ( parse_args()->{PUREPERL_ONLY} or !can_compile_loadable_object(quiet => 1) ) ? () : ( 'Sub::Name' => $META{prereqs}{runtime}{recommends}{'Sub::Name'}, # CXSA does not work on 5.6 ( "$]" > 5.008 ? ( 'Class::XSAccessor' => $META{prereqs}{runtime}{recommends}{'Class::XSAccessor'} ) : ()), ) ), ("$]" < 5.009_005 ? ( 'MRO::Compat' => 0 ) : ()), }, realclean => { FILES => 'README' }, (-e 'META.yml' ? () : ( test => { TESTS => 't/*.t xt/*.t xt/*/*.t' } ) ), ); { package MY; sub distdir { my ($self, @arg) = @_; my $frag = $self->SUPER::distdir(@arg); $frag =~ s/^(distdir\s*:.*)/$1 create_readme/m; $frag .= <<'END_MAKE'; create_readme: create_distdir pod2text lib/Class/Accessor/Grouped.pm > $(DISTVNAME)/README cd $(DISTVNAME) && $(PERLRUN) "-MExtUtils::Manifest=maniadd" -e "maniadd({ README => 'Generated README' })" END_MAKE $frag; } } use Text::ParseWords; sub parse_args { # copied from EUMM ExtUtils::MakeMaker::parse_args( my $tmp = {}, Text::ParseWords::shellwords($ENV{PERL_MM_OPT} || ''), @ARGV, ); return $tmp->{ARGS} || {}; } ## BOILERPLATE ############################################################### require ExtUtils::MakeMaker; # have to do this since old EUMM dev releases miss the eval $VERSION line my $eumm_version = eval $ExtUtils::MakeMaker::VERSION; my $mymeta = $eumm_version >= 6.57_02; my $mymeta_broken = $mymeta && $eumm_version < 6.57_07; ($MM_ARGS{NAME} = $META{name}) =~ s/-/::/g; ($MM_ARGS{VERSION_FROM} = "lib/$MM_ARGS{NAME}.pm") =~ s{::}{/}g; $MM_ARGS{ABSTRACT_FROM} = $MM_ARGS{VERSION_FROM}; $META{license} = [ $META{license} ] if $META{license} && !ref $META{license}; $MM_ARGS{LICENSE} = $META{license}[0] if $META{license} && $eumm_version >= 6.30; $MM_ARGS{NO_MYMETA} = 1 if $mymeta_broken; $MM_ARGS{META_ADD} = { 'meta-spec' => { version => 2 }, %META } unless -f 'META.yml'; for (qw(configure build test runtime)) { my $key = $_ eq 'runtime' ? 'PREREQ_PM' : uc $_.'_REQUIRES'; my $r = $MM_ARGS{$key} = { %{$META{prereqs}{$_}{requires} || {}}, %{delete $MM_ARGS{$key} || {}}, }; defined $r->{$_} or delete $r->{$_} for keys %$r; } $MM_ARGS{MIN_PERL_VERSION} = delete $MM_ARGS{PREREQ_PM}{perl} || 0; delete $MM_ARGS{MIN_PERL_VERSION} if $eumm_version < 6.47_01; $MM_ARGS{BUILD_REQUIRES} = {%{$MM_ARGS{BUILD_REQUIRES}}, %{delete $MM_ARGS{TEST_REQUIRES}}} if $eumm_version < 6.63_03; $MM_ARGS{PREREQ_PM} = {%{$MM_ARGS{PREREQ_PM}}, %{delete $MM_ARGS{BUILD_REQUIRES}}} if $eumm_version < 6.55_01; delete $MM_ARGS{CONFIGURE_REQUIRES} if $eumm_version < 6.51_03; ExtUtils::MakeMaker::WriteMakefile(%MM_ARGS); ## END BOILERPLATE ########################################################### Class-Accessor-Grouped-0.10014/META.json000644 000765 000024 00000004227 13316225501 017774 0ustar00gknopstaff000000 000000 { "abstract" : "Lets you build groups of accessors", "author" : [ "Matt S. Trout " ], "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" : "Class-Accessor-Grouped", "no_index" : { "directory" : [ "t", "xt" ] }, "prereqs" : { "build" : {}, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "develop" : { "requires" : { "Class::XSAccessor" : "1.19", "Pod::Coverage" : "0.14", "Sub::Name" : "0.05", "Test::CheckManifest" : "0.09", "Test::NoTabs" : "0.03", "Test::Pod" : "1.00", "Test::Pod::Coverage" : "1.04", "Test::Spelling" : "0.11", "Test::Strict" : "0.05" } }, "runtime" : { "recommends" : { "Class::XSAccessor" : "1.19", "Sub::Name" : "0.05" }, "requires" : { "Carp" : "0", "Module::Runtime" : "0.012", "Scalar::Util" : "0", "perl" : "5.006" } }, "test" : { "requires" : { "Test::Exception" : "0.31", "Test::More" : "0.88" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-Class-Accessor-Grouped@rt.cpan.org", "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Class-Accessor-Grouped" }, "homepage" : "https://metacpan.org/release/Class-Accessor-Grouped", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "type" : "git", "url" : "git://git.shadowcat.co.uk/p5sagit/Class-Accessor-Grouped.git", "web" : "https://github.com/p5sagit/Class-Accessor-Grouped" } }, "version" : "0.10014", "x_serialization_backend" : "JSON::PP version 2.97001" } Class-Accessor-Grouped-0.10014/lib/Class/000755 000765 000024 00000000000 13316225500 020160 5ustar00gknopstaff000000 000000 Class-Accessor-Grouped-0.10014/lib/Class/Accessor/000755 000765 000024 00000000000 13316225500 021722 5ustar00gknopstaff000000 000000 Class-Accessor-Grouped-0.10014/lib/Class/Accessor/Grouped.pm000644 000765 000024 00000071235 13316224653 023705 0ustar00gknopstaff000000 000000 package Class::Accessor::Grouped; use strict; use warnings; use Carp (); use Scalar::Util (); use Module::Runtime (); BEGIN { # use M::R to work around the 5.8 require bugs if ($] < 5.009_005) { Module::Runtime::require_module('MRO::Compat'); } else { require mro; } } our $VERSION = '0.10014'; $VERSION =~ tr/_//d; # numify for warning-free dev releases # when changing minimum version don't forget to adjust Makefile.PL as well our $__minimum_xsa_version; BEGIN { $__minimum_xsa_version = '1.19' } our $USE_XS; # the unless defined is here so that we can override the value # before require/use, *regardless* of the state of $ENV{CAG_USE_XS} $USE_XS = $ENV{CAG_USE_XS} unless defined $USE_XS; BEGIN { package # hide from PAUSE __CAG_ENV__; die "Huh?! No minimum C::XSA version?!\n" unless $__minimum_xsa_version; local $@; require constant; # individual (one const at a time) imports so we are 5.6.2 compatible # if we can - why not ;) constant->import( NO_SUBNAME => eval { Module::Runtime::require_module('Sub::Name') } ? 0 : "$@" ); my $found_cxsa; constant->import( NO_CXSA => ( NO_SUBNAME() || ( eval { Module::Runtime::require_module('Class::XSAccessor'); $found_cxsa = Class::XSAccessor->VERSION; Class::XSAccessor->VERSION($__minimum_xsa_version); } ? 0 : "$@" ) ) ); if (NO_CXSA() and $found_cxsa and !$ENV{CAG_OLD_XS_NOWARN}) { warn( 'The installed version of Class::XSAccessor is too old ' . "(v$found_cxsa < v$__minimum_xsa_version). Please upgrade " . "to instantly quadruple the performance of 'simple' accessors. " . 'Set $ENV{CAG_OLD_XS_NOWARN} if you wish to disable this ' . "warning.\n" ); } constant->import( BROKEN_GOTO => ($] < '5.008009') ? 1 : 0 ); constant->import( UNSTABLE_DOLLARAT => ($] < '5.013002') ? 1 : 0 ); constant->import( TRACK_UNDEFER_FAIL => ( $INC{'Test/Builder.pm'} || $INC{'Test/Builder2.pm'} and $0 =~ m{ ^ (?: \. \/ )? x?t / .+ \.t $}x ) ? 1 : 0 ); sub perlstring ($) { q{"}. quotemeta( shift ). q{"} }; } # Yes this method is undocumented # Yes it should be a private coderef like all the rest at the end of this file # No we can't do that (yet) because the DBIC-CDBI compat layer overrides it # %$*@!?&!&#*$!!! my $illegal_accessors_warned; sub _mk_group_accessors { my($self, $maker, $group, @fields) = @_; my $class = length (ref ($self) ) ? ref ($self) : $self; no strict 'refs'; no warnings 'redefine'; # So we don't have to do lots of lookups inside the loop. $maker = $self->can($maker) unless ref $maker; for (@fields) { my ($name, $field) = (ref $_) ? (@$_) : ($_, $_); if ($name !~ /\A[A-Z_a-z][0-9A-Z_a-z]*\z/) { if ($name =~ /\0/) { Carp::croak(sprintf "Illegal accessor name %s - nulls should never appear in stash keys", __CAG_ENV__::perlstring($name), ); } elsif (! $ENV{CAG_ILLEGAL_ACCESSOR_NAME_OK} ) { Carp::croak( "Illegal accessor name '$name'. If you want CAG to attempt creating " . 'it anyway (possible if Sub::Name is available) set ' . '$ENV{CAG_ILLEGAL_ACCESSOR_NAME_OK}' ); } elsif (__CAG_ENV__::NO_SUBNAME) { Carp::croak( "Unable to install accessor with illegal name '$name': " . 'Sub::Name not available' ); } elsif ( # Because one of the former maintainers of DBIC::SL is a raging # idiot, there is now a ton of DBIC code out there that attempts # to create column accessors with illegal names. In the interest # of not cluttering the logs of unsuspecting victims (unsuspecting # because these accessors are unusable anyway) we provide an # explicit "do not warn at all" escape, until all such code is # fixed (this will be a loooooong time >:( $ENV{CAG_ILLEGAL_ACCESSOR_NAME_OK} ne 'DO_NOT_WARN' and ! $illegal_accessors_warned->{$class}++ ) { Carp::carp( "Installing illegal accessor '$name' into $class, see " . 'documentation for more details' ); } } Carp::carp("Having a data accessor named '$name' in '$class' is unwise.") if $name =~ /\A(?: DESTROY | AUTOLOAD | CLONE )\z/x; my $alias = "_${name}_accessor"; for ($name, $alias) { # the maker may elect to not return anything, meaning it already # installed the coderef for us (e.g. lack of Sub::Name) my $cref = $self->$maker($group, $field, $_) or next; my $fq_meth = "${class}::$_"; *$fq_meth = Sub::Name::subname($fq_meth, $cref); #unless defined &{$class."\:\:$field"} } } }; # $gen_accessor coderef is setup at the end for clarity my $gen_accessor; =head1 NAME Class::Accessor::Grouped - Lets you build groups of accessors =head1 SYNOPSIS use base 'Class::Accessor::Grouped'; # make basic accessors for objects __PACKAGE__->mk_group_accessors(simple => qw(id name email)); # make accessor that works for objects and classes __PACKAGE__->mk_group_accessors(inherited => 'awesome_level'); # make an accessor which calls a custom pair of getters/setters sub get_column { ... this will be called when you do $obj->name() ... } sub set_column { ... this will be called when you do $obj->name('foo') ... } __PACKAGE__->mk_group_accessors(column => 'name'); =head1 DESCRIPTION This class lets you build groups of accessors that will call different getters and setters. The documentation of this module still requires a lot of work (B<< volunteers welcome >.> >>), but in the meantime you can refer to L for more information. =head2 Notes on accessor names In general method names in Perl are considered identifiers, and as such need to conform to the identifier specification of C. While it is rather easy to invoke methods with non-standard names (C<< $obj->${\"anything goes"} >>), it is not possible to properly declare such methods without the use of L. Since this module must be able to function identically with and without its optional dependencies, starting with version C<0.10008> attempting to declare an accessor with a non-standard name is a fatal error (such operations would silently succeed since version C<0.08004>, as long as L is present, or otherwise would result in a syntax error during a string eval). Unfortunately in the years since C<0.08004> a rather large body of code accumulated in the wild that does attempt to declare accessors with funny names. One notable perpetrator is L, which under certain conditions could create accessors of the C group which start with numbers and/or some other punctuation (the proper way would be to declare columns with the C attribute set to C). Therefore an escape mechanism is provided via the environment variable C. When set to a true value, one warning is issued B on attempts to declare an accessor with a non-conforming name, and as long as L is available all accessors will be properly created. Regardless of this setting, accessor names containing nulls C<"\0"> are disallowed, due to various deficiencies in perl itself. If your code base has too many instances of illegal accessor declarations, and a fix is not feasible due to time constraints, it is possible to disable the warnings altogether by setting C<$ENV{CAG_ILLEGAL_ACCESSOR_NAME_OK}> to C (observe capitalization). =head1 METHODS =head2 mk_group_accessors __PACKAGE__->mk_group_accessors(simple => 'hair_length', [ hair_color => 'hc' ]); =over 4 =item Arguments: $group, @fieldspec Returns: none =back Creates a set of accessors in a given group. $group is the name of the accessor group for the generated accessors; they will call get_$group($field) on get and set_$group($field, $value) on set. If you want to mimic Class::Accessor's mk_accessors $group has to be 'simple' to tell Class::Accessor::Grouped to use its own get_simple and set_simple methods. @fieldspec is a list of field/accessor names; if a fieldspec is a scalar this is used as both field and accessor name, if a listref it is expected to be of the form [ $accessor, $field ]. =cut sub mk_group_accessors { my ($self, $group, @fields) = @_; $self->_mk_group_accessors('make_group_accessor', $group, @fields); return; } =head2 mk_group_ro_accessors __PACKAGE__->mk_group_ro_accessors(simple => 'birthdate', [ social_security_number => 'ssn' ]); =over 4 =item Arguments: $group, @fieldspec Returns: none =back Creates a set of read only accessors in a given group. Identical to L but accessors will throw an error if passed a value rather than setting the value. =cut sub mk_group_ro_accessors { my($self, $group, @fields) = @_; $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields); return; } =head2 mk_group_wo_accessors __PACKAGE__->mk_group_wo_accessors(simple => 'lie', [ subject => 'subj' ]); =over 4 =item Arguments: $group, @fieldspec Returns: none =back Creates a set of write only accessors in a given group. Identical to L but accessors will throw an error if not passed a value rather than getting the value. =cut sub mk_group_wo_accessors { my($self, $group, @fields) = @_; $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields); return; } =head2 get_simple =over 4 =item Arguments: $field Returns: $value =back Simple getter for hash-based objects which returns the value for the field name passed as an argument. =cut sub get_simple { $_[0]->{$_[1]}; } =head2 set_simple =over 4 =item Arguments: $field, $new_value Returns: $new_value =back Simple setter for hash-based objects which sets and then returns the value for the field name passed as an argument. =cut sub set_simple { $_[0]->{$_[1]} = $_[2]; } =head2 get_inherited =over 4 =item Arguments: $field Returns: $value =back Simple getter for Classes and hash-based objects which returns the value for the field name passed as an argument. This behaves much like L where the field can be set in a base class, inherited and changed in subclasses, and inherited and changed for object instances. =cut sub get_inherited { if ( length (ref ($_[0]) ) ) { if (Scalar::Util::reftype $_[0] eq 'HASH') { return $_[0]->{$_[1]} if exists $_[0]->{$_[1]}; # everything in @_ is aliased, an assignment won't work splice @_, 0, 1, ref($_[0]); } else { Carp::croak('Cannot get inherited value on an object instance that is not hash-based'); } } # if we got this far there is nothing in the instance # OR this is a class call # in any case $_[0] contains the class name (see splice above) no strict 'refs'; no warnings 'uninitialized'; my $cag_slot = '::__cag_'. $_[1]; return ${$_[0].$cag_slot} if defined(${$_[0].$cag_slot}); do { return ${$_.$cag_slot} if defined(${$_.$cag_slot}) } for $_[0]->get_super_paths; return undef; } =head2 set_inherited =over 4 =item Arguments: $field, $new_value Returns: $new_value =back Simple setter for Classes and hash-based objects which sets and then returns the value for the field name passed as an argument. When called on a hash-based object it will set the appropriate hash key value. When called on a class, it will set a class level variable. B: This method will die if you try to set an object variable on a non hash-based object. =cut sub set_inherited { if (length (ref ($_[0]) ) ) { if (Scalar::Util::reftype $_[0] eq 'HASH') { return $_[0]->{$_[1]} = $_[2]; } else { Carp::croak('Cannot set inherited value on an object instance that is not hash-based'); }; } no strict 'refs'; ${$_[0].'::__cag_'.$_[1]} = $_[2]; } =head2 get_component_class =over 4 =item Arguments: $field Returns: $value =back Gets the value of the specified component class. __PACKAGE__->mk_group_accessors('component_class' => 'result_class'); $self->result_class->method(); ## same as $self->get_component_class('result_class')->method(); =cut sub get_component_class { $_[0]->get_inherited($_[1]); }; =head2 set_component_class =over 4 =item Arguments: $field, $class Returns: $new_value =back Inherited accessor that automatically loads the specified class before setting it. This method will die if the specified class could not be loaded. __PACKAGE__->mk_group_accessors('component_class' => 'result_class'); __PACKAGE__->result_class('MyClass'); $self->result_class->method(); =cut sub set_component_class { if (defined $_[2] and length $_[2]) { # disable warnings, and prevent $_ being eaten away by a behind-the-scenes # module loading local ($^W, $_); if (__CAG_ENV__::UNSTABLE_DOLLARAT) { my $err; { local $@; eval { Module::Runtime::use_package_optimistically($_[2]) } or $err = $@; } Carp::croak("Could not load $_[1] '$_[2]': $err") if defined $err; } else { eval { Module::Runtime::use_package_optimistically($_[2]) } or Carp::croak("Could not load $_[1] '$_[2]': $@"); } }; $_[0]->set_inherited($_[1], $_[2]); }; =head1 INTERNAL METHODS These methods are documented for clarity, but are never meant to be called directly, and are not really meant for overriding either. =head2 get_super_paths Returns a list of 'parent' or 'super' class names that the current class inherited from. This is what drives the traversal done by L. =cut sub get_super_paths { # get_linear_isa returns the class itself as the 1st element # use @_ as a pre-allocated scratch array (undef, @_) = @{mro::get_linear_isa( length( ref($_[0]) ) ? ref($_[0]) : $_[0] )}; @_; }; =head2 make_group_accessor __PACKAGE__->make_group_accessor('simple', 'hair_length', 'hair_length'); __PACKAGE__->make_group_accessor('simple', 'hc', 'hair_color'); =over 4 =item Arguments: $group, $field, $accessor Returns: \&accessor_coderef ? =back Called by mk_group_accessors for each entry in @fieldspec. Either returns a coderef which will be installed at C<&__PACKAGE__::$accessor>, or returns C if it elects to install the coderef on its own. =cut sub make_group_accessor { $gen_accessor->('rw', @_) } =head2 make_group_ro_accessor __PACKAGE__->make_group_ro_accessor('simple', 'birthdate', 'birthdate'); __PACKAGE__->make_group_ro_accessor('simple', 'ssn', 'social_security_number'); =over 4 =item Arguments: $group, $field, $accessor Returns: \&accessor_coderef ? =back Called by mk_group_ro_accessors for each entry in @fieldspec. Either returns a coderef which will be installed at C<&__PACKAGE__::$accessor>, or returns C if it elects to install the coderef on its own. =cut sub make_group_ro_accessor { $gen_accessor->('ro', @_) } =head2 make_group_wo_accessor __PACKAGE__->make_group_wo_accessor('simple', 'lie', 'lie'); __PACKAGE__->make_group_wo_accessor('simple', 'subj', 'subject'); =over 4 =item Arguments: $group, $field, $accessor Returns: \&accessor_coderef ? =back Called by mk_group_wo_accessors for each entry in @fieldspec. Either returns a coderef which will be installed at C<&__PACKAGE__::$accessor>, or returns C if it elects to install the coderef on its own. =cut sub make_group_wo_accessor { $gen_accessor->('wo', @_) } =head1 PERFORMANCE To provide total flexibility L calls methods internally while performing get/set actions, which makes it noticeably slower than similar modules. To compensate, this module will automatically use the insanely fast L to generate the C-group accessors if this module is available on your system. =head2 Benchmark This is the benchmark of 200 get/get/set/get/set cycles on perl 5.16.2 with thread support, showcasing how this modules L, L and L accessors stack up against most popular accessor builders: L, L, L, L (both pure-perl and XS variant), L, L, L, L, L and L Rate CAG_INHP CAG_INH CA CAG_S CAF moOse OTRW CAL mo moUse HANDMADE moo CAF_XS moUse_XS XSA CAG_INHP 287.021+-0.02/s -- -0.3% -10.0% -37.1% -53.1% -53.6% -53.7% -54.1% -56.9% -59.0% -59.6% -59.8% -78.7% -81.9% -83.5% CAG_INH 288.025+-0.031/s 0.3% -- -9.7% -36.9% -52.9% -53.5% -53.5% -53.9% -56.7% -58.8% -59.5% -59.7% -78.6% -81.9% -83.5% CA 318.967+-0.047/s 11.1% 10.7% -- -30.1% -47.9% -48.5% -48.5% -49.0% -52.1% -54.4% -55.1% -55.3% -76.3% -79.9% -81.7% CAG_S 456.107+-0.054/s 58.9% 58.4% 43.0% -- -25.4% -26.3% -26.4% -27.0% -31.5% -34.8% -35.8% -36.1% -66.1% -71.3% -73.9% CAF 611.745+-0.099/s 113.1% 112.4% 91.8% 34.1% -- -1.2% -1.2% -2.1% -8.1% -12.6% -14.0% -14.3% -54.5% -61.5% -64.9% moOse 619.051+-0.059/s 115.7% 114.9% 94.1% 35.7% 1.2% -- -0.1% -1.0% -7.0% -11.6% -12.9% -13.3% -54.0% -61.0% -64.5% OTRW 619.475+-0.1/s 115.8% 115.1% 94.2% 35.8% 1.3% 0.1% -- -0.9% -6.9% -11.5% -12.9% -13.2% -54.0% -61.0% -64.5% CAL 625.106+-0.085/s 117.8% 117.0% 96.0% 37.1% 2.2% 1.0% 0.9% -- -6.1% -10.7% -12.1% -12.5% -53.5% -60.6% -64.2% mo 665.44+-0.12/s 131.8% 131.0% 108.6% 45.9% 8.8% 7.5% 7.4% 6.5% -- -4.9% -6.4% -6.8% -50.5% -58.1% -61.9% moUse 699.9+-0.15/s 143.9% 143.0% 119.4% 53.5% 14.4% 13.1% 13.0% 12.0% 5.2% -- -1.6% -2.0% -48.0% -55.9% -59.9% HANDMADE 710.98+-0.16/s 147.7% 146.8% 122.9% 55.9% 16.2% 14.9% 14.8% 13.7% 6.8% 1.6% -- -0.4% -47.2% -55.2% -59.2% moo 714.04+-0.13/s 148.8% 147.9% 123.9% 56.6% 16.7% 15.3% 15.3% 14.2% 7.3% 2.0% 0.4% -- -46.9% -55.0% -59.1% CAF_XS 1345.55+-0.051/s 368.8% 367.2% 321.8% 195.0% 120.0% 117.4% 117.2% 115.3% 102.2% 92.2% 89.3% 88.4% -- -15.3% -22.9% moUse_XS 1588+-0.036/s 453.3% 451.3% 397.9% 248.2% 159.6% 156.5% 156.3% 154.0% 138.6% 126.9% 123.4% 122.4% 18.0% -- -9.0% XSA 1744.67+-0.052/s 507.9% 505.7% 447.0% 282.5% 185.2% 181.8% 181.6% 179.1% 162.2% 149.3% 145.4% 144.3% 29.7% 9.9% -- Benchmarking program is available in the root of the L: =head2 Notes on Class::XSAccessor You can force (or disable) the use of L before creating a particular C accessor by either manipulating the global variable C<$Class::Accessor::Grouped::USE_XS> to true or false (preferably with L, or you can do so before runtime via the C environment variable. Since L has no knowledge of L and L this module does its best to detect if you are overriding one of these methods and will fall back to using the perl version of the accessor in order to maintain consistency. However be aware that if you enable use of C (automatically or explicitly), create an object, invoke a simple accessor on that object, and B manipulate the symbol table to install a C override - you get to keep all the pieces. =head1 AUTHORS Matt S. Trout Christopher H. Laco =head1 CONTRIBUTORS Caelum: Rafael Kitover frew: Arthur Axel "fREW" Schmidt groditi: Guillermo Roditi Jason Plum ribasushi: Peter Rabbitson =head1 COPYRIGHT & LICENSE Copyright (c) 2006-2010 Matt S. Trout This program is free software; you can redistribute it and/or modify it under the same terms as perl itself. =cut ######################################################################## ######################################################################## ######################################################################## # # Here be many angry dragons # (all code is in private coderefs since everything inherits CAG) # ######################################################################## ######################################################################## # Autodetect unless flag supplied my $xsa_autodetected; if (! defined $USE_XS) { $USE_XS = __CAG_ENV__::NO_CXSA ? 0 : 1; $xsa_autodetected++; } my $maker_templates = { rw => { cxsa_call => 'accessors', pp_generator => sub { # my ($group, $fieldname) = @_; my $quoted_fieldname = __CAG_ENV__::perlstring($_[1]); sprintf <<'EOS', ($_[0], $quoted_fieldname) x 2; @_ > 1 ? shift->set_%s(%s, @_) : shift->get_%s(%s) EOS }, }, ro => { cxsa_call => 'getters', pp_generator => sub { # my ($group, $fieldname) = @_; my $quoted_fieldname = __CAG_ENV__::perlstring($_[1]); sprintf <<'EOS', $_[0], $quoted_fieldname; @_ > 1 ? do { my ($meth) = (caller(0))[3] =~ /([^\:]+)$/; my $class = length( ref($_[0]) ) ? ref($_[0]) : $_[0]; Carp::croak( "'$meth' cannot alter its value (read-only attribute of class $class)" ); } : shift->get_%s(%s) EOS }, }, wo => { cxsa_call => 'setters', pp_generator => sub { # my ($group, $fieldname) = @_; my $quoted_fieldname = __CAG_ENV__::perlstring($_[1]); sprintf <<'EOS', $_[0], $quoted_fieldname; @_ > 1 ? shift->set_%s(%s, @_) : do { my ($meth) = (caller(0))[3] =~ /([^\:]+)$/; my $class = length( ref($_[0]) ) ? ref($_[0]) : $_[0]; Carp::croak( "'$meth' cannot access its value (write-only attribute of class $class)" ); } EOS }, }, }; my $cag_eval = sub { #my ($src, $no_warnings, $err_msg) = @_; my $src = sprintf "{ %s warnings; use strict; no strict 'refs'; %s }", $_[1] ? 'no' : 'use', $_[0], ; my (@rv, $err); { local $@ if __CAG_ENV__::UNSTABLE_DOLLARAT; wantarray ? @rv = eval $src : $rv[0] = eval $src ; $err = $@ if $@ ne ''; } Carp::croak(join ': ', ($_[2] || 'String-eval failed'), "$err\n$src\n" ) if defined $err; wantarray ? @rv : $rv[0]; }; my ($accessor_maker_cache, $no_xsa_warned_classes); # can't use pkg_gen to track this stuff, as it doesn't # detect superclass mucking my $original_simple_getter = __PACKAGE__->can ('get_simple'); my $original_simple_setter = __PACKAGE__->can ('set_simple'); my ($resolved_methods, $cag_produced_crefs); sub CLONE { my @crefs = grep { defined $_ } values %{$cag_produced_crefs||{}}; $cag_produced_crefs = @crefs ? { map { $_ => $_ } @crefs } : undef ; } # Note!!! Unusual signature $gen_accessor = sub { my ($type, $class, $group, $field, $methname) = @_; $class = ref $class if length ref $class; # When installing an XSA simple accessor, we need to make sure we are not # short-circuiting a (compile or runtime) get_simple/set_simple override. # What we do here is install a lazy first-access check, which will decide # the ultimate coderef being placed in the accessor slot # # Also note that the *original* class will always retain this shim, as # different branches inheriting from it may have different overrides. # Thus the final method (properly labeled and all) is installed in the # calling-package's namespace if ($USE_XS and $group eq 'simple') { die sprintf( "Class::XSAccessor requested but not available:\n%s\n", __CAG_ENV__::NO_CXSA ) if __CAG_ENV__::NO_CXSA; my $ret = sub { my $current_class = length (ref ($_[0] ) ) ? ref ($_[0]) : $_[0]; my $resolved_implementation = $resolved_methods->{$current_class}{$methname} ||= do { if ( ($current_class->can('get_simple')||0) == $original_simple_getter && ($current_class->can('set_simple')||0) == $original_simple_setter ) { # nothing has changed, might as well use the XS crefs # # note that by the time this code executes, we already have # *objects* (since XSA works on 'simple' only by definition). # If someone is mucking with the symbol table *after* there # are some objects already - look! many, shiny pieces! :) # # The weird breeder thingy is because XSA does not have an # interface returning *just* a coderef, without installing it # anywhere :( Class::XSAccessor->import( replace => 1, class => '__CAG__XSA__BREEDER__', $maker_templates->{$type}{cxsa_call} => { $methname => $field, }, ); __CAG__XSA__BREEDER__->can($methname); } else { if (! $xsa_autodetected and ! $no_xsa_warned_classes->{$current_class}++) { # not using Carp since the line where this happens doesn't mean much warn 'Explicitly requested use of Class::XSAccessor disabled for objects of class ' . "'$current_class' inheriting from '$class' due to an overriden get_simple and/or " . "set_simple\n"; } do { # that's faster than local $USE_XS = 0; my $c = $gen_accessor->($type, $class, 'simple', $field, $methname); $USE_XS = 1; $c; }; } }; # if after this shim was created someone wrapped it with an 'around', # we can not blindly reinstall the method slot - we will destroy the # wrapper. Silently chain execution further... if ( ! $cag_produced_crefs->{ $current_class->can($methname) || 0 } ) { # older perls segfault if the cref behind the goto throws # http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878 return $resolved_implementation->(@_) if __CAG_ENV__::BROKEN_GOTO; goto $resolved_implementation; } if (__CAG_ENV__::TRACK_UNDEFER_FAIL) { my $deferred_calls_seen = do { no strict 'refs'; \%{"${current_class}::__cag_deferred_xs_shim_invocations"} }; my @cframe = caller(0); if (my $already_seen = $deferred_calls_seen->{$cframe[3]}) { Carp::carp ( "Deferred version of method $cframe[3] invoked more than once (originally " . "invoked at $already_seen). This is a strong indication your code has " . 'cached the original ->can derived method coderef, and is using it instead ' . 'of the proper method re-lookup, causing minor performance regressions' ); } else { $deferred_calls_seen->{$cframe[3]} = "$cframe[1] line $cframe[2]"; } } # install the resolved implementation into the code slot so we do not # come here anymore (hopefully) # since XSAccessor was available - so is Sub::Name { no strict 'refs'; no warnings 'redefine'; my $fq_name = "${current_class}::${methname}"; *$fq_name = Sub::Name::subname($fq_name, $resolved_implementation); } # now things are installed - one ref less to carry delete $resolved_methods->{$current_class}{$methname}; # but need to record it in the expectation registry *in case* it # was cached via ->can for some moronic reason Scalar::Util::weaken( $cag_produced_crefs->{$resolved_implementation} = $resolved_implementation ); # older perls segfault if the cref behind the goto throws # http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878 return $resolved_implementation->(@_) if __CAG_ENV__::BROKEN_GOTO; goto $resolved_implementation; }; Scalar::Util::weaken($cag_produced_crefs->{$ret} = $ret); $ret; # returning shim } # no Sub::Name - just install the coderefs directly (compiling every time) elsif (__CAG_ENV__::NO_SUBNAME) { my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||= $maker_templates->{$type}{pp_generator}->($group, $field); $cag_eval->( "no warnings 'redefine'; sub ${class}::${methname} { $src }; 1", ); undef; # so that no further attempt will be made to install anything } # a coderef generator with a variable pad (returns a fresh cref on every invocation) else { ($accessor_maker_cache->{pp}{$type}{$group}{$field} ||= do { my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||= $maker_templates->{$type}{pp_generator}->($group, $field); $cag_eval->( "sub { my \$dummy; sub { \$dummy if 0; $src } }" ); })->() } }; 1; Class-Accessor-Grouped-0.10014/xt/pod_syntax.t000644 000765 000024 00000000240 13316224511 021352 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More; BEGIN { eval 'use Test::Pod 1.00; 1' or plan skip_all => 'Test::Pod 1.00 not installed'; } all_pod_files_ok(); Class-Accessor-Grouped-0.10014/xt/warnings.t000644 000765 000024 00000001714 13316224511 021021 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More; BEGIN { plan skip_all => 'Need untaint in newer File::Find' if $] <= 5.006; } BEGIN { eval 'use Test::Strict 0.05; 1' or plan skip_all => 'Test::Strict 0.05 not installed'; } use File::Find; use File::Basename; ## I hope this can go away if Test::Strict or File::Find::Rule ## finally run under -T. Until then, I'm on my own here. ;-) my @files; my %trusted = ( 'NotReallyAClass.pm' => 1 ); find({ wanted => \&wanted, untaint => 1, untaint_pattern => qr|^([-+@\w./]+)$|, untaint_skip => 1, no_chdir => 1 }, qw(lib t)); sub wanted { my $name = $File::Find::name; my $file = fileparse($name); return if $name =~ /TestApp/; if ($name =~ /\.(pm|pl|t)$/i && !exists($trusted{$file})) { push @files, $name; }; }; if (scalar @files) { plan tests => scalar @files; } else { plan tests => 1; fail 'No perl files found for Test::Strict checks!'; }; foreach (@files) { warnings_ok($_); } Class-Accessor-Grouped-0.10014/xt/manifest.t000644 000765 000024 00000000510 13316224511 020770 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More; BEGIN { eval 'use Test::CheckManifest 0.09; 1' or plan skip_all => 'Test::CheckManifest 0.09 not installed'; } ok_manifest({ exclude => ['/t/var', '/cover_db'], filter => [qr/\.(svn|git)/, qr/cover/, qr/Build(.(PL|bat))?/, qr/_build/, qr/\.DS_Store/], bool => 'or' }); Class-Accessor-Grouped-0.10014/xt/style_no_tabs.t000644 000765 000024 00000000254 13316224511 022034 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More; BEGIN { eval 'use Test::NoTabs 0.03; 1' or plan skip_all => 'Test::NoTabs 0.03 not installed'; } all_perl_files_ok('lib'); Class-Accessor-Grouped-0.10014/xt/pod_spelling.t000644 000765 000024 00000000726 13316224511 021652 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More; BEGIN { eval 'use Test::Spelling 0.11; 1' or plan skip_all => 'Test::Spelling 0.11 not installed'; } set_spell_cmd('aspell list'); add_stopwords(); all_pod_files_spelling_ok(); __DATA__ Bowden Raygun Roditi isa mst behaviour further overridable Laco Pauley claco stylings fieldspec listref getters ribasushi Rabbitson groditi Caelum Kitover CAF Sep XSA OTRW runtime Axel fREW frew getter subclasses Benchmarking Class-Accessor-Grouped-0.10014/xt/strict.t000644 000765 000024 00000001677 13316224511 020511 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More; BEGIN { plan skip_all => 'Need untaint in newer File::Find' if $] <= 5.006; } BEGIN { eval 'use Test::Strict; 1' or plan skip_all => 'Test::Strict not installed'; } use File::Find; use File::Basename; ## I hope this can go away if Test::Strict or File::Find::Rule ## finally run under -T. Until then, I'm on my own here. ;-) my @files; my %trusted = ( 'NotReallyAClass.pm' => 1 ); find({ wanted => \&wanted, untaint => 1, untaint_pattern => qr|^([-+@\w./]+)$|, untaint_skip => 1, no_chdir => 1 }, qw(lib t)); sub wanted { my $name = $File::Find::name; my $file = fileparse($name); return if $name =~ /TestApp/; if ($name =~ /\.(pm|pl|t)$/i && !exists($trusted{$file})) { push @files, $name; }; }; if (scalar @files) { plan tests => scalar @files; } else { plan tests => 1; fail 'No perl files found for Test::Strict checks!'; }; foreach (@files) { strict_ok($_); } Class-Accessor-Grouped-0.10014/xt/pod_coverage.t000644 000765 000024 00000000540 13316224511 021622 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More; BEGIN { eval 'use Test::Pod::Coverage 1.04; 1' or plan skip_all => 'Test::Pod::Coverage 1.04 not installed'; eval 'use Pod::Coverage 0.14; 1' or plan skip_all => 'Pod::Coverage 0.14 not installed'; } my $trustme = { trustme => [qr/^(g|s)et_component_class$/] }; all_pod_coverage_ok($trustme); Class-Accessor-Grouped-0.10014/t/clean_namespace.t000644 000765 000024 00000002076 13316224511 022101 0ustar00gknopstaff000000 000000 use Test::More; use strict; use warnings; BEGIN { plan skip_all => "Package::Stash required for this test" unless eval { require Package::Stash }; require MRO::Compat if $] < 5.009_005; } { package AccessorGroups::Clean; use strict; use warnings; use base 'Class::Accessor::Grouped'; my $obj = bless {}; for (qw/simple inherited component_class/) { __PACKAGE__->mk_group_accessors($_ => "${_}_a"); $obj->${\ "${_}_a"} ('blah'); } } is_deeply [ sort keys %{ { map { %{Package::Stash->new($_)->get_all_symbols('CODE')} } (reverse @{mro::get_linear_isa('AccessorGroups::Clean')}) } } ], [ sort +( (map { ( "$_", "_${_}_accessor" ) } qw/simple_a inherited_a component_class_a/ ), (map { ( "get_$_", "set_$_" ) } qw/simple inherited component_class/ ), qw/ _mk_group_accessors get_super_paths make_group_accessor make_group_ro_accessor make_group_wo_accessor mk_group_accessors mk_group_ro_accessors mk_group_wo_accessors CLONE /, )], 'Expected list of methods in a freshly inheriting class'; done_testing; Class-Accessor-Grouped-0.10014/t/illegal_name.t000644 000765 000024 00000002100 13316224511 021400 0ustar00gknopstaff000000 000000 use Test::More; use Test::Exception; use strict; use warnings; use lib 't/lib'; use AccessorGroupsSubclass; { my $warned = 0; local $SIG{__WARN__} = sub { $_[0] =~ /unwise/ ? $warned++ : warn(@_) }; for (qw/DESTROY AUTOLOAD CLONE/) { AccessorGroupsSubclass->mk_group_accessors(warnings => $_); } is($warned, 3, 'Correct amount of unise warnings'); } if (eval { require Sub::Name } ) { my $warned = 0; local $SIG{__WARN__} = sub { $_[0] =~ /Installing illegal accessor/ ? $warned++ : warn(@_) }; for (qw/666_one 666_two/) { no warnings qw/once/; no strict 'refs'; local $ENV{CAG_ILLEGAL_ACCESSOR_NAME_OK} = 1; AccessorGroupsSubclass->mk_group_accessors(warnings => $_); } is($warned, 1, 'Correct amount of illegal installation warnings'); }; throws_ok { AccessorGroupsSubclass->mk_group_accessors(simple => '2wrvwrv;') } qr/Illegal accessor name/; throws_ok { local $ENV{CAG_ILLEGAL_ACCESSOR_NAME_OK} = 1; AccessorGroupsSubclass->mk_group_accessors(simple => "2wr\0vwrv;") } qr/nulls should never appear/; done_testing; Class-Accessor-Grouped-0.10014/t/accessors.t000644 000765 000024 00000010161 13316224511 020762 0ustar00gknopstaff000000 000000 use Test::More; use strict; use warnings; no warnings 'once'; use lib 't/lib'; use B qw/svref_2object/; # we test the pure-perl versions only, but allow overrides # from the accessor_xs test-umbrella # Also make sure a rogue envvar will not interfere with # things my $use_xs; BEGIN { $Class::Accessor::Grouped::USE_XS = 0 unless defined $Class::Accessor::Grouped::USE_XS; $ENV{CAG_USE_XS} = 1; $use_xs = $Class::Accessor::Grouped::USE_XS; }; require AccessorGroupsSubclass; my $test_accessors = { singlefield => { is_simple => 1, has_extra => 1, }, runtime_around => { # even though this accessor is declared as simple it will *not* be # reinstalled due to the runtime 'around' forced_class => 'AccessorGroups', is_simple => 1, has_extra => 1, }, multiple1 => { }, multiple2 => { }, lr1name => { custom_field => 'lr1;field', }, lr2name => { custom_field => "lr2'field", }, fieldname_torture => { is_simple => 1, custom_field => join ('', map { chr($_) } (0..255) ), }, }; for my $class (qw( AccessorGroupsSubclass AccessorGroups AccessorGroupsParent )) { my $obj = $class->new; for my $name (sort keys %$test_accessors) { my $alias = "_${name}_accessor"; my $field = $test_accessors->{$name}{custom_field} || $name; my $extra = $test_accessors->{$name}{has_extra}; my $origin_class = 'AccessorGroupsParent'; if ( $class eq 'AccessorGroupsParent' ) { next if $name eq 'runtime_around'; # implemented in the AG subclass $extra = 0; } elsif ($name eq 'fieldname_torture') { $field = reverse $field; $origin_class = 'AccessorGroups'; } can_ok($obj, $name, $alias); ok(!$obj->can($field), "field for $name is not a method on $class") if $field ne $name; my $init_shims; # initial method name for my $meth ($name, $alias) { my $cv = svref_2object( $init_shims->{$meth} = $obj->can($meth) ); is($cv->GV->NAME, $meth, "initial ${class}::$meth accessor is named"); is( $cv->GV->STASH->NAME, $test_accessors->{$name}{forced_class} || $origin_class, "initial ${class}::$meth origin class correct", ); } is($obj->$name, undef, "${class}::$name begins undef"); is($obj->$alias, undef, "${class}::$alias begins undef"); # get/set via name is($obj->$name('a'), 'a', "${class}::$name setter RV correct"); is($obj->$name, 'a', "${class}::$name getter correct"); is($obj->{$field}, $extra ? 'a Extra tackled on' : 'a', "${class}::$name corresponding field correct"); # alias gets same as name is($obj->$alias, 'a', "${class}::$alias getter correct after ${class}::$name setter"); # get/set via alias is($obj->$alias('b'), 'b', "${class}::$alias setter RV correct"); is($obj->$alias, 'b', "${class}::$alias getter correct"); is($obj->{$field}, $extra ? 'b Extra tackled on' : 'b', "${class}::$alias corresponding field still correct"); # alias gets same as name is($obj->$name, 'b', "${class}::$name getter correct after ${class}::$alias setter"); for my $meth ($name, $alias) { my $resolved = $obj->can($meth); my $cv = svref_2object($resolved); is($cv->GV->NAME, $meth, "$meth accessor is named after operations"); is( $cv->GV->STASH->NAME, # XS deferred subs install into each caller, not into the original parent $test_accessors->{$name}{forced_class} || ( ($use_xs and $test_accessors->{$name}{is_simple}) ? (ref $obj) : $origin_class ), "${class}::$meth origin class correct after operations", ); # just simple for now if ($use_xs and $test_accessors->{$name}{is_simple} and ! $test_accessors->{$name}{forced_class}) { ok ($resolved != $init_shims->{$meth}, "$meth was replaced with a resolved version"); if ($class eq 'AccessorGroupsParent') { ok ($cv->XSUB, "${class}::$meth is an XSUB"); } else { ok (!$cv->XSUB, "${class}::$meth is *not* an XSUB (due to get_simple overrides)"); } } } } } done_testing unless $::SUBTESTING; Class-Accessor-Grouped-0.10014/t/accessors_pp.t000644 000765 000024 00000004141 13316224511 021462 0ustar00gknopstaff000000 000000 my $has_threads; BEGIN { eval ' use 5.008001; use threads; use threads::shared; $has_threads = 1; ' } use strict; use warnings; no warnings 'once'; use FindBin qw($Bin); use File::Spec::Functions; use File::Spec::Unix (); # need this for %INC munging use Test::More; use lib 't/lib'; BEGIN { local $ENV{DEVEL_HIDE_VERBOSE} = 0; eval { require Devel::Hide }; if ($@) { eval { require Sub::Name }; plan skip_all => "Devel::Hide required for this test in presence of Sub::Name" if ! $@; } else { Devel::Hide->import('Sub/Name.pm'); } require Class::Accessor::Grouped; } # rerun the regular 3 tests under the assumption of no Sub::Name our $SUBTESTING = 1; for my $tname (qw/accessors.t accessors_ro.t accessors_wo.t/) { my $pass = 1; share($pass) if $has_threads; my $todo = sub { note "\nTesting $tname without Sub::Name (pass @{[ $pass ++ ]})\n\n"; my ($tfn) = catfile($Bin, $tname) =~ /(.+)/; for ( qw|AccessorGroups.pm AccessorGroups/BeenThereDoneThat.pm AccessorGroupsRO.pm AccessorGroupsSubclass.pm AccessorGroupsParent.pm AccessorGroupsWO.pm|, File::Spec::Unix->catfile ($tfn), ) { delete $INC{$_}; no strict 'refs'; if (my ($mod) = $_ =~ /(.+)\.pm$/ ) { %{"${mod}::"} = (); } } local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /subroutine .+ redefined/i }; do($tfn); 666; }; if ($has_threads) { for (1,2) { is ( threads->create(sub { # nested threading of this sort badly blows up on 5.10.0 (fixed with 5.10.1) unless ($] > 5.009 and $] < 5.010001) { is ( threads->create(sub { $todo->(); })->join, 666, 'Innner thread joined ok', ); is ($todo->(), 666, "Intermediate result ok"); } return 777; })->join, 777, 'Outer thread joined ok', ); is ($todo->(), 666, "Unthreaded run ok") for (1,2); } } else { is ($todo->(), 666, "Unthreaded run ok") for (1,2); } } done_testing; Class-Accessor-Grouped-0.10014/t/inherited.t000644 000765 000024 00000006141 13316224511 020753 0ustar00gknopstaff000000 000000 use Test::More tests => 36; use Test::Exception; use strict; use warnings; use lib 't/lib'; use SuperInheritedGroups; use NotHashBased; my $super = SuperInheritedGroups->new; my $base = BaseInheritedGroups->new; my @ret = SuperInheritedGroups->basefield; ok(@ret == 1, 'Return value before set'); ok(!defined(SuperInheritedGroups->basefield), 'Undef return before set'); # set base. base, super, object = base is(BaseInheritedGroups->basefield('All Your Base'), 'All Your Base'); is(SuperInheritedGroups->basefield, 'All Your Base'); is($super->basefield, 'All Your Base'); is($base->basefield, 'All Your Base'); # set super. super = super, base = base, object = super is(SuperInheritedGroups->basefield('Now Its Our Base'), 'Now Its Our Base'); is(SuperInheritedGroups->basefield, 'Now Its Our Base'); is(BaseInheritedGroups->basefield, 'All Your Base'); is($super->basefield, 'Now Its Our Base'); is($base->basefield, 'All Your Base'); #set base is($base->basefield('First Base'), 'First Base'); is($base->basefield, 'First Base'); is($super->basefield, 'Now Its Our Base'); is(BaseInheritedGroups->basefield, 'All Your Base'); is(SuperInheritedGroups->basefield, 'Now Its Our Base'); # set object, object = object, super = super, base = base is($super->basefield('Third Base'), 'Third Base'); is($super->basefield, 'Third Base'); is(SuperInheritedGroups->basefield, 'Now Its Our Base'); is(BaseInheritedGroups->basefield, 'All Your Base'); # create new super. new = base, object = object, super = super, base = base my $newsuper = SuperInheritedGroups->new; is($newsuper->basefield, 'Now Its Our Base'); is($super->basefield, 'Third Base'); is(SuperInheritedGroups->basefield, 'Now Its Our Base'); is(BaseInheritedGroups->basefield, 'All Your Base'); # create new base. new = base, super = super, base = base my $newbase = BaseInheritedGroups->new; is($newbase->basefield, 'All Your Base'); is($newsuper->basefield, 'Now Its Our Base'); is($super->basefield, 'Third Base'); is(SuperInheritedGroups->basefield, 'Now Its Our Base'); is(BaseInheritedGroups->basefield, 'All Your Base'); # croak on get/set on non hash-based object my $dying = NotHashBased->new; throws_ok { $dying->killme; } qr/Cannot get.*is not hash-based/; throws_ok { $dying->killme('foo'); } qr/Cannot set.*is not hash-based/; # make sure we're get defined items, even 0, '' BaseInheritedGroups->basefield('base'); SuperInheritedGroups->basefield(0); is(SuperInheritedGroups->basefield, 0); BaseInheritedGroups->basefield('base'); SuperInheritedGroups->basefield(''); is(SuperInheritedGroups->basefield, ''); BaseInheritedGroups->basefield('base'); SuperInheritedGroups->basefield(undef); is(SuperInheritedGroups->basefield, 'base'); is(BaseInheritedGroups->undefined, undef); # make sure run-time @ISA changes trigger an inheritance chain recalculation SuperInheritedGroups->basefield(undef); BaseInheritedGroups->basefield('your base'); # dirty hack, emulate Class::C3::Componentised require ExtraInheritedGroups; unshift @SuperInheritedGroups::ISA, qw/ExtraInheritedGroups/; # this comes from ExtraInheritedGroups is(SuperInheritedGroups->basefield, 'your extra base!'); Class-Accessor-Grouped-0.10014/t/accessors_xs_cachedwarn.t000644 000765 000024 00000003163 13316224511 023657 0ustar00gknopstaff000000 000000 my $has_threads; BEGIN { eval ' use 5.008005; # older perls get confused by $SIG fiddling under CXSA use threads; use threads::shared; $has_threads = 1; ' } use strict; use warnings; use Test::More; use lib 't/lib'; BEGIN { plan skip_all => "Sub::Name not available" unless eval { require Sub::Name }; require Class::Accessor::Grouped; my $xsa_ver = $Class::Accessor::Grouped::__minimum_xsa_version; eval { require Class::XSAccessor; Class::XSAccessor->VERSION ($xsa_ver); }; plan skip_all => "Class::XSAccessor >= $xsa_ver not available" if $@; } use AccessorGroupsSubclass; my @w; share(@w) if $has_threads; { my $obj = AccessorGroupsSubclass->new; my $deferred_stub = AccessorGroupsSubclass->can('singlefield'); my $obj2 = AccessorGroups->new; my $todo = sub { local $SIG{__WARN__} = sub { push @w, @_ }; is ($obj->$deferred_stub(1), 1, 'Set'); is ($obj->$deferred_stub, 1, 'Get'); is ($obj->$deferred_stub(2), 2, 'ReSet'); is ($obj->$deferred_stub, 2, 'ReGet'); is ($obj->singlefield, 2, 'Normal get'); is ($obj2->singlefield, undef, 'Normal get on unrelated object'); 42; }; is ( ($has_threads ? threads->create( $todo )->join : $todo->()), 42, "Correct result after do-er", ) } is (@w, 3, '3 warnings total'); is ( scalar (grep { $_ =~ /^\QDeferred version of method AccessorGroupsParent::singlefield invoked more than once/ } @w), 3, '3 warnings produced as expected on cached invocation during testing', ) or do { require Data::Dumper; diag "\n \$0 is: " . Data::Dumper->new([$0])->Useqq(1)->Terse(1)->Dump; }; done_testing; Class-Accessor-Grouped-0.10014/t/accessors_xs.t000644 000765 000024 00000004313 13316224511 021476 0ustar00gknopstaff000000 000000 my $has_threads; BEGIN { eval ' use 5.008005; # older perls segfault on threading under CXSA use threads; use threads::shared; $has_threads = 1; ' } use strict; use warnings; no warnings 'once'; use FindBin qw($Bin); use File::Spec::Functions; use File::Spec::Unix (); # need this for %INC munging use Test::More; use lib 't/lib'; BEGIN { plan skip_all => "Sub::Name not available" unless eval { require Sub::Name }; require Class::Accessor::Grouped; my $xsa_ver = $Class::Accessor::Grouped::__minimum_xsa_version; eval { require Class::XSAccessor; Class::XSAccessor->VERSION ($xsa_ver); }; plan skip_all => "Class::XSAccessor >= $xsa_ver not available" if $@; } # rerun the regular 3 tests under XSAccessor our $SUBTESTING = 1; $Class::Accessor::Grouped::USE_XS = 1; for my $tname (qw/accessors.t accessors_ro.t accessors_wo.t/) { my $pass = 1; share($pass) if $has_threads; my $todo = sub { note "\nTesting $tname with USE_XS (pass @{[ $pass++ ]})\n\n"; my ($tfn) = catfile($Bin, $tname) =~ /(.+)/; for ( qw|AccessorGroups.pm AccessorGroups/BeenThereDoneThat.pm AccessorGroupsRO.pm AccessorGroupsSubclass.pm AccessorGroupsParent.pm AccessorGroupsWO.pm|, File::Spec::Unix->catfile ($tfn), ) { delete $INC{$_}; no strict 'refs'; if (my ($mod) = $_ =~ /(.+)\.pm$/ ) { %{"${mod}::"} = (); } } local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /subroutine .+ redefined/i }; do($tfn); 666; }; if ($has_threads) { for (1,2) { is ( threads->create(sub { # nested threading of this sort badly blows up on 5.10.0 (fixed with 5.10.1) unless ($] > 5.009 and $] < 5.010001) { is ( threads->create(sub { $todo->(); })->join, 666, 'Innner thread joined ok', ); is ($todo->(), 666, "Intermediate result ok"); } return 777; })->join, 777, 'Outer thread joined ok', ); is ($todo->(), 666, "Unthreaded run ok") for (1,2); } } else { is ($todo->(), 666, "Unthreaded run ok") for (1,2); } } done_testing; Class-Accessor-Grouped-0.10014/t/basic.t000644 000765 000024 00000000722 13316224511 020060 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More; use B qw/svref_2object/; use_ok('Class::Accessor::Grouped'); # ensure core accessor types are properly named # for (qw/simple inherited component_class/) { for my $meth ("get_$_", "set_$_") { my $cv = svref_2object( Class::Accessor::Grouped->can($meth) ); is($cv->GV->NAME, $meth, "$meth accessor is named"); is($cv->GV->STASH->NAME, 'Class::Accessor::Grouped', "$meth class correct"); } } done_testing; Class-Accessor-Grouped-0.10014/t/lib/000755 000765 000024 00000000000 13316225500 017356 5ustar00gknopstaff000000 000000 Class-Accessor-Grouped-0.10014/t/component.t000644 000765 000024 00000001622 13316224511 021001 0ustar00gknopstaff000000 000000 use Test::More tests => 8; use Test::Exception; use strict; use warnings; use lib 't/lib'; use AccessorGroupsComp; is(AccessorGroupsComp->result_class, undef); ## croak on set where class can't be loaded and it's a physical class my $dying = AccessorGroupsComp->new; throws_ok { $dying->result_class('NotReallyAClass'); } qr/Could not load result_class 'NotReallyAClass'/; is($dying->result_class, undef); ## don't croak when the class isn't available but not loaded for people ## who create class/packages on the fly $dying->result_class('JunkiesNeverInstalled'); is($dying->result_class, 'JunkiesNeverInstalled'); ok(! $INC{'BaseInheritedGroups.pm'}); AccessorGroupsComp->result_class('BaseInheritedGroups'); ok($INC{'BaseInheritedGroups.pm'}); is(AccessorGroupsComp->result_class, 'BaseInheritedGroups'); ## unset it AccessorGroupsComp->result_class(undef); is(AccessorGroupsComp->result_class, undef); Class-Accessor-Grouped-0.10014/t/accessors_wo.t000644 000765 000024 00000003770 13316224511 021477 0ustar00gknopstaff000000 000000 use Test::More; use Test::Exception; use strict; use warnings; no warnings 'once'; use lib 't/lib'; # we test the pure-perl versions only, but allow overrides # from the accessor_xs test-umbrella # Also make sure a rogue envvar will not interfere with # things my $use_xs; BEGIN { $Class::Accessor::Grouped::USE_XS = 0 unless defined $Class::Accessor::Grouped::USE_XS; $ENV{CAG_USE_XS} = 1; $use_xs = $Class::Accessor::Grouped::USE_XS; }; use AccessorGroupsWO; my $obj = AccessorGroupsWO->new; { my $warned = 0; local $SIG{__WARN__} = sub { if (shift =~ /DESTROY/i) { $warned++; }; }; no warnings qw/once/; local *AccessorGroupsWO::DESTROY = sub {}; $obj->mk_group_wo_accessors('warnings', 'DESTROY'); ok($warned); }; my $test_accessors = { singlefield => { is_xs => $use_xs, }, multiple1 => { }, multiple2 => { }, lr1name => { custom_field => 'lr1;field', }, lr2name => { custom_field => "lr2'field", }, fieldname_torture => { custom_field => join ('', map { chr($_) } (0..255) ), is_xs => $use_xs, }, }; for my $name (sort keys %$test_accessors) { my $alias = "_${name}_accessor"; my $field = $test_accessors->{$name}{custom_field} || $name; can_ok($obj, $name, $alias); ok(!$obj->can($field)) if $field ne $name; # set via name is($obj->$name('a'), 'a'); is($obj->{$field}, 'a'); # alias sets same as name is($obj->$alias('b'), 'b'); is($obj->{$field}, 'b'); my $wo_regex = $test_accessors->{$name}{is_xs} ? qr/Usage\:.+$name.*\(self, newvalue\)/ : qr/$name(:?_accessor)?\Q' cannot access its value (write-only attribute of class AccessorGroupsWO)/ ; # die on get via name/alias SKIP: { skip "Class::XSAccessor emits broken error messages on 5.10 and earlier", 1 if ( $test_accessors->{$name}{is_xs} and $] < '5.011' ); throws_ok { $obj->$name; } $wo_regex; throws_ok { $obj->$alias; } $wo_regex; } }; done_testing unless $::SUBTESTING; Class-Accessor-Grouped-0.10014/t/accessors_ro.t000644 000765 000024 00000004127 13316224511 021467 0ustar00gknopstaff000000 000000 use Test::More; use Test::Exception; use strict; use warnings; no warnings 'once'; use lib 't/lib'; # we test the pure-perl versions only, but allow overrides # from the accessor_xs test-umbrella # Also make sure a rogue envvar will not interfere with # things my $use_xs; BEGIN { $Class::Accessor::Grouped::USE_XS = 0 unless defined $Class::Accessor::Grouped::USE_XS; $ENV{CAG_USE_XS} = 1; $use_xs = $Class::Accessor::Grouped::USE_XS; }; use AccessorGroupsRO; my $obj = AccessorGroupsRO->new; { my $warned = 0; local $SIG{__WARN__} = sub { if (shift =~ /DESTROY/i) { $warned++; }; }; no warnings qw/once/; local *AccessorGroupsRO::DESTROY = sub {}; $obj->mk_group_ro_accessors('warnings', 'DESTROY'); ok($warned); }; my $test_accessors = { singlefield => { is_xs => $use_xs, }, multiple1 => { }, multiple2 => { }, lr1name => { custom_field => 'lr1;field', }, lr2name => { custom_field => "lr2'field", }, fieldname_torture => { custom_field => join ('', map { chr($_) } (0..255) ), is_xs => $use_xs, }, }; for my $name (sort keys %$test_accessors) { my $alias = "_${name}_accessor"; my $field = $test_accessors->{$name}{custom_field} || $name; can_ok($obj, $name, $alias); ok(!$obj->can($field)) if $field ne $name; is($obj->$name, undef); is($obj->$alias, undef); # get via name $obj->{$field} = 'a'; is($obj->$name, 'a'); # alias gets same as name is($obj->$alias, 'a'); my $ro_regex = $test_accessors->{$name}{is_xs} ? qr/Usage\:.+$name.*\(self\)/ : qr/$name(:?_accessor)?\Q' cannot alter its value (read-only attribute of class AccessorGroupsRO)/ ; SKIP: { skip "Class::XSAccessor emits broken error messages on 5.10 and earlier", 1 if ( $test_accessors->{$name}{is_xs} and $] < '5.011' ); # die on set via name/alias throws_ok { $obj->$name('b'); } $ro_regex; throws_ok { $obj->$alias('b'); } $ro_regex; } # value should be unchanged is($obj->$name, 'a'); is($obj->$alias, 'a'); }; done_testing unless $::SUBTESTING; Class-Accessor-Grouped-0.10014/t/lib/BaseInheritedGroups.pm000644 000765 000024 00000000321 13316224511 023617 0ustar00gknopstaff000000 000000 package BaseInheritedGroups; use strict; use warnings; use base 'Class::Accessor::Grouped'; __PACKAGE__->mk_group_accessors('inherited', 'basefield', 'undefined'); sub new { return bless {}, shift; }; 1; Class-Accessor-Grouped-0.10014/t/lib/ExtraInheritedGroups.pm000644 000765 000024 00000000333 13316224511 024033 0ustar00gknopstaff000000 000000 package ExtraInheritedGroups; use strict; use warnings; use base 'Class::Accessor::Grouped'; __PACKAGE__->mk_group_accessors('inherited', 'basefield'); __PACKAGE__->set_inherited (basefield => 'your extra base!'); 1; Class-Accessor-Grouped-0.10014/t/lib/AccessorGroupsComp.pm000644 000765 000024 00000000314 13316224511 023474 0ustar00gknopstaff000000 000000 package AccessorGroupsComp; use strict; use warnings; use base 'Class::Accessor::Grouped'; __PACKAGE__->mk_group_accessors('component_class', 'result_class'); sub new { return bless {}, shift; }; 1; Class-Accessor-Grouped-0.10014/t/lib/AccessorGroups.pm000644 000765 000024 00000002040 13316224511 022653 0ustar00gknopstaff000000 000000 package AccessorGroups; use strict; use warnings; use base 'AccessorGroupsParent'; __PACKAGE__->mk_group_accessors('simple', [ fieldname_torture => join ('', reverse map { chr($_) } (0..255) ) ]); sub get_simple { my $v = shift->SUPER::get_simple (@_); $v =~ s/ Extra tackled on$// if $v; $v; } sub set_simple { my ($self, $f, $v) = @_; $v .= ' Extra tackled on' if $f eq 'singlefield'; $self->SUPER::set_simple ($f, $v); $_[2]; } # a runtime Class::Method::Modifiers style around # the eval/our combo is so that we do not need to rely on Sub::Name being available my $orig_ra_cref = __PACKAGE__->can('runtime_around'); our $around_cref = sub { my $self = shift; if (@_) { my $val = shift; $self->$orig_ra_cref($val . ' Extra tackled on'); $val; } else { my $val = $self->$orig_ra_cref; $val =~ s/ Extra tackled on$// if defined $val; $val; } }; { no warnings qw/redefine/; eval <<'EOE'; sub runtime_around { goto $around_cref }; sub _runtime_around_accessor { goto $around_cref }; EOE } 1; Class-Accessor-Grouped-0.10014/t/lib/NotHashBased.pm000644 000765 000024 00000000272 13316224511 022221 0ustar00gknopstaff000000 000000 package NotHashBased; use strict; use warnings; use base 'Class::Accessor::Grouped'; sub new { return bless [], shift; }; __PACKAGE__->mk_group_accessors('inherited', 'killme'); 1; Class-Accessor-Grouped-0.10014/t/lib/NotReallyAClass.pm000644 000765 000024 00000000000 13316224511 022703 0ustar00gknopstaff000000 000000 Class-Accessor-Grouped-0.10014/t/lib/SuperInheritedGroups.pm000644 000765 000024 00000000134 13316224511 024045 0ustar00gknopstaff000000 000000 package SuperInheritedGroups; use strict; use warnings; use base 'BaseInheritedGroups'; 1; Class-Accessor-Grouped-0.10014/t/lib/AccessorGroupsSubclass.pm000644 000765 000024 00000000131 13316224511 024352 0ustar00gknopstaff000000 000000 package AccessorGroupsSubclass; use strict; use warnings; use base 'AccessorGroups'; 1; Class-Accessor-Grouped-0.10014/t/lib/AccessorGroupsParent.pm000644 000765 000024 00000002001 13316224511 024022 0ustar00gknopstaff000000 000000 BEGIN { package AccessorGroups::BeenThereDoneThat; use strict; use warnings; use base 'Class::Accessor::Grouped'; __PACKAGE__->mk_group_accessors('simple', 'singlefield'); __PACKAGE__->mk_group_accessors('multiple', qw/multiple1 multiple2/); my $dummy = bless {}; # tickle stuff at BEGIN time $dummy->singlefield('foo'); } package AccessorGroupsParent; use strict; use warnings; use base 'Class::Accessor::Grouped'; __PACKAGE__->mk_group_accessors('simple', 'singlefield'); __PACKAGE__->mk_group_accessors('multiple', qw/multiple1 multiple2/); __PACKAGE__->mk_group_accessors('listref', [qw/lr1name lr1;field/], [qw/lr2name lr2'field/]); __PACKAGE__->mk_group_accessors('simple', 'runtime_around'); __PACKAGE__->mk_group_accessors('simple', [ fieldname_torture => join ('', map { chr($_) } (0..255) ) ]); sub new { return bless {}, shift; }; foreach (qw/multiple listref/) { no strict 'refs'; *{"get_$_"} = __PACKAGE__->can('get_simple'); *{"set_$_"} = __PACKAGE__->can('set_simple'); }; 1; Class-Accessor-Grouped-0.10014/t/lib/AccessorGroupsRO.pm000644 000765 000024 00000001104 13316224511 023114 0ustar00gknopstaff000000 000000 package AccessorGroupsRO; use strict; use warnings; use base 'Class::Accessor::Grouped'; __PACKAGE__->mk_group_ro_accessors('simple', 'singlefield'); __PACKAGE__->mk_group_ro_accessors('multiple', qw/multiple1 multiple2/); __PACKAGE__->mk_group_ro_accessors('listref', [qw/lr1name lr1;field/], [qw/lr2name lr2'field/]); __PACKAGE__->mk_group_ro_accessors('simple', [ fieldname_torture => join ('', map { chr($_) } (0..255) ) ]); sub new { return bless {}, shift; }; foreach (qw/multiple listref/) { no strict 'refs'; *{"get_$_"} = __PACKAGE__->can ('get_simple'); }; 1; Class-Accessor-Grouped-0.10014/t/lib/AccessorGroupsWO.pm000644 000765 000024 00000001103 13316224511 023120 0ustar00gknopstaff000000 000000 package AccessorGroupsWO; use strict; use warnings; use base 'Class::Accessor::Grouped'; __PACKAGE__->mk_group_wo_accessors('simple', 'singlefield'); __PACKAGE__->mk_group_wo_accessors('multiple', qw/multiple1 multiple2/); __PACKAGE__->mk_group_wo_accessors('listref', [qw/lr1name lr1;field/], [qw/lr2name lr2'field/]); __PACKAGE__->mk_group_wo_accessors('simple', [ fieldname_torture => join ('', map { chr($_) } (0..255) ) ]); sub new { return bless {}, shift; }; foreach (qw/multiple listref/) { no strict 'refs'; *{"set_$_"} = __PACKAGE__->can('set_simple'); }; 1; Class-Accessor-Grouped-0.10014/inc/ExtUtils/000755 000765 000024 00000000000 13316225500 020677 5ustar00gknopstaff000000 000000 Class-Accessor-Grouped-0.10014/inc/ExtUtils/HasCompiler.pm000644 000765 000024 00000022031 13316224511 023442 0ustar00gknopstaff000000 000000 package ExtUtils::HasCompiler; $ExtUtils::HasCompiler::VERSION = '0.021'; use strict; use warnings; use base 'Exporter'; our @EXPORT_OK = qw/can_compile_loadable_object can_compile_static_library can_compile_extension/; our %EXPORT_TAGS = (all => \@EXPORT_OK); use Config; use Carp 'carp'; use File::Basename 'basename'; use File::Spec::Functions qw/catfile catdir rel2abs/; use File::Temp qw/tempdir tempfile/; my $tempdir = tempdir('HASCOMPILERXXXX', CLEANUP => 1, DIR => '.'); my $loadable_object_format = <<'END'; #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifndef PERL_UNUSED_VAR #define PERL_UNUSED_VAR(var) #endif XS(exported) { #ifdef dVAR dVAR; #endif dXSARGS; PERL_UNUSED_VAR(cv); /* -W */ PERL_UNUSED_VAR(items); /* -W */ XSRETURN_IV(42); } #ifndef XS_EXTERNAL #define XS_EXTERNAL(foo) XS(foo) #endif /* we don't want to mess with .def files on mingw */ #if defined(WIN32) && defined(__GNUC__) # define EXPORT __declspec(dllexport) #else # define EXPORT #endif EXPORT XS_EXTERNAL(boot_%s) { #ifdef dVAR dVAR; #endif dXSARGS; PERL_UNUSED_VAR(cv); /* -W */ PERL_UNUSED_VAR(items); /* -W */ newXS("%s::exported", exported, __FILE__); } END my $counter = 1; my %prelinking = map { $_ => 1 } qw/MSWin32 VMS aix/; sub can_compile_loadable_object { my %args = @_; my $output = $args{output} || \*STDOUT; my $config = $args{config} || 'ExtUtils::HasCompiler::Config'; return if not $config->get('usedl'); my ($source_handle, $source_name) = tempfile('TESTXXXX', DIR => $tempdir, SUFFIX => '.c', UNLINK => 1); my $basename = basename($source_name, '.c'); my $abs_basename = catfile($tempdir, $basename); my ($cc, $ccflags, $optimize, $cccdlflags, $ld, $ldflags, $lddlflags, $libperl, $perllibs, $archlibexp, $_o, $dlext) = map { $config->get($_) } qw/cc ccflags optimize cccdlflags ld ldflags lddlflags libperl perllibs archlibexp _o dlext/; my $incdir = catdir($archlibexp, 'CORE'); my $object_file = $abs_basename.$_o; my $loadable_object = "$abs_basename.$dlext"; my @commands; if ($^O eq 'MSWin32' && $cc =~ /^cl/) { push @commands, qq{$cc $ccflags $cccdlflags $optimize /I "$incdir" /c $source_name /Fo$object_file}; push @commands, qq{$ld $object_file $lddlflags $libperl $perllibs /out:$loadable_object /def:$abs_basename.def /pdb:$abs_basename.pdb}; } elsif ($^O eq 'VMS') { # Mksymlists is only the beginning of the story. open my $opt_fh, '>>', "$abs_basename.opt" or do { carp "Couldn't append to '$abs_basename.opt'"; return }; print $opt_fh "PerlShr/Share\n"; close $opt_fh; my $incdirs = $ccflags =~ s{ /inc[^=]+ (?:=)+ (?:\()? ( [^\/\)]* ) }{}xi ? "$1,$incdir" : $incdir; push @commands, qq{$cc $ccflags $optimize /include=($incdirs) $cccdlflags $source_name /obj=$object_file}; push @commands, qq{$ld $ldflags $lddlflags=$loadable_object $object_file,$abs_basename.opt/OPTIONS,${incdir}perlshr_attr.opt/OPTIONS' $perllibs}; } else { my @extra; if ($^O eq 'MSWin32') { my $lib = '-l' . ($libperl =~ /lib([^.]+)\./)[0]; push @extra, "$abs_basename.def", $lib, $perllibs; } elsif ($^O eq 'cygwin') { push @extra, catfile($incdir, $config->get('useshrplib') ? 'libperl.dll.a' : 'libperl.a'); } elsif ($^O eq 'aix') { $lddlflags =~ s/\Q$(BASEEXT)\E/$abs_basename/; $lddlflags =~ s/\Q$(PERL_INC)\E/$incdir/; } elsif ($^O eq 'android') { push @extra, qq{"-L$incdir"}, '-lperl', $perllibs; } push @commands, qq{$cc $ccflags $optimize "-I$incdir" $cccdlflags -c $source_name -o $object_file}; push @commands, qq{$ld $object_file -o $loadable_object $lddlflags @extra}; } if ($prelinking{$^O}) { require ExtUtils::Mksymlists; ExtUtils::Mksymlists::Mksymlists(NAME => $basename, FILE => $abs_basename, IMPORTS => {}); } my $shortname = '_Loadable' . $counter++; my $package = "ExtUtils::HasCompiler::$shortname"; printf $source_handle $loadable_object_format, $basename, $package or do { carp "Couldn't write to $source_name: $!"; return }; close $source_handle or do { carp "Couldn't close $source_name: $!"; return }; for my $command (@commands) { print $output "$command\n" if not $args{quiet}; system $command and do { carp "Couldn't execute $command: $!"; return }; } # Skip loading when cross-compiling return 1 if exists $args{skip_load} ? $args{skip_load} : $config->get('usecrosscompile'); require DynaLoader; local @DynaLoader::dl_require_symbols = "boot_$basename"; my $handle = DynaLoader::dl_load_file(rel2abs($loadable_object), 0); if ($handle) { my $symbol = DynaLoader::dl_find_symbol($handle, "boot_$basename") or do { carp "Couldn't find boot symbol for $basename"; return }; my $compilet = DynaLoader::dl_install_xsub('__ANON__::__ANON__', $symbol, $source_name); my $ret = eval { $compilet->(); $package->exported } or carp $@; delete $ExtUtils::HasCompiler::{"$shortname\::"}; eval { DynaLoader::dl_unload_file($handle) } or carp $@; return defined $ret && $ret == 42; } else { carp "Couldn't load $loadable_object: " . DynaLoader::dl_error(); return; } } my %static_unsupported_on = map { $_ => 1 } qw/VMS aix MSWin32 cygwin/; sub can_compile_static_library { my %args = @_; my $output = $args{output} || \*STDOUT; my $config = $args{config} || 'ExtUtils::HasCompiler::Config'; return if $config->get('useshrplib') eq 'true'; my ($source_handle, $source_name) = tempfile('TESTXXXX', DIR => $tempdir, SUFFIX => '.c', UNLINK => 1); my $basename = basename($source_name, '.c'); my $abs_basename = catfile($tempdir, $basename); my ($cc, $ccflags, $optimize, $ar, $full_ar, $ranlib, $archlibexp, $_o, $lib_ext) = map { $config->get($_) } qw/cc ccflags optimize ar full_ar ranlib archlibexp _o lib_ext/; my $incdir = catdir($archlibexp, 'CORE'); my $object_file = "$abs_basename$_o"; my $static_library = $abs_basename.$lib_ext; my @commands; if ($static_unsupported_on{$^O}) { return; } else { my $my_ar = length $full_ar ? $full_ar : $ar; push @commands, qq{$cc $ccflags $optimize "-I$incdir" -c $source_name -o $object_file}; push @commands, qq{$my_ar cr $static_library $object_file}; push @commands, qq{$ranlib $static_library} if $ranlib ne ':'; } my $shortname = '_Loadable' . $counter++; my $package = "ExtUtils::HasCompiler::$shortname"; printf $source_handle $loadable_object_format, $basename, $package or do { carp "Couldn't write to $source_name: $!"; return }; close $source_handle or do { carp "Couldn't close $source_name: $!"; return }; for my $command (@commands) { print $output "$command\n" if not $args{quiet}; system $command and do { carp "Couldn't execute $command: $!"; return }; } return 1; } sub can_compile_extension { my %args = @_; $args{config} ||= 'ExtUtils::HasCompiler::Config'; my $linktype = $args{linktype} || ($args{config}->get('usedl') ? 'dynamic' : 'static'); return $linktype eq 'static' ? can_compile_static_library(%args) : can_compile_loadable_object(%args); } sub ExtUtils::HasCompiler::Config::get { my (undef, $key) = @_; return $ENV{uc $key} || $Config{$key}; } 1; # ABSTRACT: Check for the presence of a compiler __END__ =pod =encoding UTF-8 =head1 NAME ExtUtils::HasCompiler - Check for the presence of a compiler =head1 VERSION version 0.021 =head1 SYNOPSIS use ExtUtils::HasCompiler 'can_compile_extension'; if (can_compile_extension()) { ... } else { ... } =head1 DESCRIPTION This module tries to check if the current system is capable of compiling, linking and loading an XS module. B: this is an early release, interface stability isn't guaranteed yet. =head1 FUNCTIONS =head2 can_compile_loadable_object(%opts) This checks if the system can compile, link and load a perl loadable object. It may take the following options: =over 4 =item * quiet Do not output the executed compilation commands. =item * config An L (compatible) object for configuration. =item * skip_load This causes can_compile_loadable_object to not try to load the generated object. This defaults to true on a cross-compiling perl. =back =head2 can_compile_static_library(%opts) This checks if the system can compile and link a perl static library. It does not check it it can compile a new perl with it. It may take the following options: =over 4 =item * quiet Do not output the executed compilation commands. =item * config An L (compatible) object for configuration. =back =head2 can_compile_extension(%opts) This will call either C, or C, depending on which is the default on your configuration. In addition to the arguments listed above, it can take one more optional argument: =over 4 =item * linktype This will force the linktype to be either static or dynamic. Dynamic compilation on a static perl won't work, but static libraries can be viable on a dynamic perl. =back =head1 AUTHOR Leon Timmermans =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2014 by Leon Timmermans. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut