├── .gitignore ├── .travis.yml ├── Changes ├── README.md ├── dist.ini ├── lib ├── Moxie.pm └── Moxie │ ├── Enum.pm │ ├── Object.pm │ ├── Object │ └── Immutable.pm │ └── Traits │ ├── Provider.pm │ └── Provider │ ├── Accessor.pm │ ├── Constructor.pm │ └── Experimental.pm ├── t ├── 000-samples │ ├── 000-synopsis.t │ ├── 001-point.t │ ├── 002-bank-account.t │ ├── 003-binary-tree.t │ ├── 004-linked-list.t │ ├── 007-currency.t │ ├── 008-cache.t │ ├── 009-counter.t │ └── 010-web-framework.t ├── 001-basic │ ├── 001-basic.t │ ├── 001-new.t │ ├── 002-new-w-attributes.t │ ├── 003-BUILD.t │ ├── 004-DEMOLISH.t │ ├── 005-attribute-override.t │ ├── 006-next-method.t │ ├── 007-class-methods.t │ ├── 014-loading-from-disk.t │ ├── 015-inheritance-loading-from-disk.t │ ├── 017-method-closures.t │ ├── 020-simple-attributes.t │ ├── 021-attributes-w-defaults.t │ ├── 022-attributes-w-lazy-defaults.t │ ├── 023-attributes-w-lazy-accessor.t │ ├── 024-attributes-w-complex-defaults.t │ ├── 025-attributes-w-lazy-complex-default.t │ ├── 026-complex-attributes.t │ ├── 027-multi-complex-attributes.t │ ├── 028-attributes-in-class-methods.t │ ├── 040-handles.t │ └── 041-required.t ├── 030-roles │ ├── 002-compose-into-role.t │ ├── 003-multiple-role-compose.t │ ├── 004-DOES.t │ ├── 007-next-method.t │ ├── 008-multilevel-does.t │ ├── 020-attribute-conflict.t │ ├── 021-deep-attribute-conflict.t │ ├── 022-deep-method-conflict.t │ ├── 025-method-conflict.t │ ├── 026-multiple-method-conflict.t │ ├── 030-required-methods.t │ └── 060-inherited-methods-fulfill-requirements.t ├── 040-method │ └── 001-basic.t ├── 050-non-mop-integration │ ├── 001-inherit-from-non-mop.t │ ├── 002-more-non-mop.t │ └── 003-attributes-in-non-mop-inherited-class.t ├── 080-enum │ └── 001-basic.t ├── 100-annotations │ ├── 001-basic.t │ ├── 010-init_args.t │ └── 100-lexical-accessors.t └── lib │ ├── Foo │ └── Bar.pm │ ├── Level1.pm │ ├── Level2.pm │ ├── Level3.pm │ └── Root.pm └── weaver.ini /.gitignore: -------------------------------------------------------------------------------- 1 | MYMETA.* 2 | blib 3 | pm_to_blib 4 | nytprof* 5 | .DS_Store 6 | Makefile 7 | Makefile.old 8 | cover_db 9 | .build 10 | *.gz 11 | .build/ 12 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: false 2 | language: perl 3 | perl: 4 | - 'blead' 5 | - '5.26' 6 | - '5.24' 7 | - '5.22' 8 | matrix: 9 | allow_failures: 10 | - perl: 'blead' 11 | fast_finish: true 12 | before_install: 13 | - git config --global user.name "TravisCI" 14 | - git config --global user.email $HOSTNAME":not-for-mail@travis-ci.org" 15 | install: 16 | - cpanm --quiet --notest --skip-satisfied Dist::Zilla 17 | - "dzil authordeps --missing | grep -vP '[^\\w:]' | xargs -n 5 -P 10 cpanm --quiet --notest" 18 | - "dzil listdeps --author --missing | grep -vP '[^\\w:]' | cpanm --verbose" 19 | script: 20 | - dzil smoke --release --author 21 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for Perl extension Moxie 2 | 3 | 0.08 4 | - some small types fixed by Aaron Crane 5 | - fixed the `use lib` in a few tests so that they can 6 | be run from any location 7 | - thanks to Tom Legrady for this fix 8 | 9 | 0.07 2017-11-16 10 | [ENHANCEMENTS] 11 | - it is now posible to say `required => 1` and have that 12 | expand to a default error message 13 | 14 | [FEATURE CHANGES] 15 | - renamed the `init_args` trait to `strict` and changed 16 | the docs to explain its purpose better 17 | - Trait::Provider modules have been re-arranged, we now have 18 | a classification for experimental features 19 | - added `lazy` and `private` as two features which 20 | now require you to pass the `:experimental` tag 21 | within the `traits` listing. 22 | - this may all change in future releases, we will see 23 | 24 | 0.06 2017-10-30 25 | [FEATURE CHANGES] 26 | - Changed the name of BUILDARGS:init_arg to BUILDARGS:init 27 | as the ARGS/args was redundant 28 | - updated SYNOPSIS to be sleaker 29 | - fixing a bug caught by CPAN testers 30 | - switched back to Carp::confess from Carp::cluck, the 31 | stack trace is vital until this module matures and 32 | the error messages improve 33 | - fixed a bug in the `init_args` trait that caused 34 | slot => 0 to not work 35 | 36 | 0.05 2017-10-21 37 | [NEW FEATURE] 38 | - added the `lazy(slot?)` trait, it uses the body of 39 | the method it is attached to as the initializer for 40 | the specified slot 41 | 42 | [FEATURE CHANGES] 43 | - restored the `private` trait and ceased it being 44 | the default behavior as a result of a `has` call 45 | 46 | [DEPENDENCIES] 47 | - dropped the Devel::Hook dependency for the MOP::Util 48 | functions (which just use Devel::Hook themselves) 49 | - restored the Padwalker dependency 50 | - removed the Sub::Inject dependency (see above) 51 | - bump the MOP dependency 52 | 53 | 0.04 2017-09-27 54 | [FEATURE CHANGES] 55 | - moved the Moxie::Slot::Intitializer class to 56 | the MOP instead of here 57 | - lexical private lvalue slot accessors are now 58 | always generated, no need to specify them 59 | youself 60 | 61 | [DEPENDENCIES] 62 | - removed the B::CompilerPhase::Hook dependency 63 | and just use straight up Devel::Hook instead 64 | - removed the PadWalker dependency because we 65 | can now generate the slot accessor at BEGIN 66 | time and install them with Sub::Inject 67 | - added Sub::Inject dependency 68 | - bump the MOP dependency to support use of the 69 | MOP::Slot::Initializer class 70 | 71 | 0.03 2017-08-17 72 | [GITHUB] 73 | - generous typo fixes from my internet friends 74 | - Pierre Vigier 75 | - Evan Carroll 76 | 77 | [FEATURE CHANGES] 78 | - the way the BUILDARGS:init_args trait works now 79 | is very different and not backwards compatible 80 | - added tests in t/100-annotations/010-init-args.t 81 | - docs added to the Moxie module 82 | - This change is NOT backwards compatible 83 | 84 | - `has` now (also) takes a set of option pairs and 85 | generates the correct initializer based on those 86 | options 87 | - docs added to the Moxie module 88 | - This change is backwards compatible 89 | 90 | [BUG FIXES] 91 | - classes can now be loaded at runtime 92 | - added tests for this 93 | 94 | [DEPENDENCIES] 95 | - version bump for BEGIN::Lift and Method::Traits 96 | to make sure classes can be loaded at runtime 97 | 98 | - version bump for MOP to better support the 99 | custom slot initializer usage 100 | 101 | 0.02 05-07-2017 102 | - fixing missing dependency (PadWalker) 103 | - fixing some simple kwalitee issues 104 | 105 | 0.01 21-06-2017 106 | - Initial release to an unsuspecting world 107 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Moxie 2 | 3 | ![Moxie](https://drinkmoxie.com/img/prod_moxie.png) 4 | 5 | [![CPAN version](https://badge.fury.io/pl/Moxie.svg)](https://metacpan.org/pod/Moxie) 6 | [![Build Status](https://travis-ci.org/stevan/p5-Moxie.svg?branch=master)](https://travis-ci.org/stevan/p5-Moxie) 7 | 8 | # Copyright and License 9 | 10 | This software is copyright (c) 2017 by Stevan Little. 11 | 12 | This is free software; you can redistribute it and/or modify it under 13 | the same terms as the Perl 5 programming language system itself. 14 | -------------------------------------------------------------------------------- /dist.ini: -------------------------------------------------------------------------------- 1 | name = Moxie 2 | author = Stevan Little 3 | license = Perl_5 4 | copyright_holder = Stevan Little 5 | copyright_year = 2017 6 | 7 | version = 0.07 8 | 9 | [@Basic] 10 | 11 | [TestRelease] 12 | [ConfirmRelease] 13 | [MetaProvides::Package] 14 | [PodWeaver] 15 | [MetaJSON] 16 | [TravisYML] 17 | 18 | [MetaResources] 19 | repository.url = https://github.com/stevan/p5-Moxie.git 20 | repository.web = https://github.com/stevan/p5-Moxie 21 | repository.type = git 22 | bugtracker.web = https://github.com/stevan/p5-Moxie/issues 23 | 24 | [Prereqs] 25 | perl = v5.22 26 | experimental = 0 27 | Module::Runtime = 0 28 | Sub::Util = 0 29 | PadWalker = 0 30 | UNIVERSAL::Object = 0.13 31 | MOP = 0.12 32 | BEGIN::Lift = 0.06 33 | Method::Traits = 0.08 34 | 35 | [Prereqs / TestRequires] 36 | Test::More = 0 37 | Test::Fatal = 0 38 | -------------------------------------------------------------------------------- /lib/Moxie.pm: -------------------------------------------------------------------------------- 1 | package Moxie; 2 | # ABSTRACT: Not Another Moose Clone 3 | 4 | use v5.22; 5 | use warnings; 6 | use experimental qw[ 7 | signatures 8 | postderef 9 | ]; 10 | 11 | use experimental (); # need this later when we load features 12 | use Module::Runtime (); # load things so they DWIM 13 | use BEGIN::Lift (); # fake some keywords 14 | use Method::Traits (); # for accessor/method generators 15 | 16 | use MOP; 17 | use MOP::Util; 18 | 19 | use Moxie::Object; 20 | use Moxie::Object::Immutable; 21 | use Moxie::Traits::Provider; 22 | 23 | our $VERSION = '0.07'; 24 | our $AUTHORITY = 'cpan:STEVAN'; 25 | 26 | sub import ($class, %opts) { 27 | # get the caller ... 28 | my $caller = caller; 29 | 30 | # make the assumption that if we are 31 | # loaded outside of main then we are 32 | # likely being loaded in a class, so 33 | # turn on all the features 34 | if ( $caller ne 'main' ) { 35 | $class->import_into( $caller, \%opts ); 36 | } 37 | } 38 | 39 | sub import_into ($class, $caller, $opts) { 40 | 41 | # NOTE: 42 | # create the meta-object, we start 43 | # with this as a role, but it will 44 | # get "cast" to a class if there 45 | # is a need for it. 46 | my $meta = MOP::Role->new( name => $caller ); 47 | 48 | # turn on strict/warnings 49 | strict->import; 50 | warnings->import; 51 | 52 | # so we can have fun with attributes ... 53 | warnings->unimport('reserved'); 54 | 55 | # turn on signatures and more 56 | experimental->import($_) foreach qw[ 57 | signatures 58 | 59 | postderef 60 | postderef_qq 61 | 62 | current_sub 63 | lexical_subs 64 | 65 | say 66 | state 67 | ]; 68 | 69 | # turn on refaliasing if we have it ... 70 | experimental->import('refaliasing') if $] >= 5.022; 71 | 72 | # turn on declared refs if we have it ... 73 | experimental->import('declared_refs') if $] >= 5.026; 74 | 75 | # import has, extend and with keyword 76 | 77 | BEGIN::Lift::install( 78 | ($caller, 'has') => sub ($name, @args) { 79 | 80 | # NOTE: 81 | # Handle the simple case of `has $name => $code` 82 | # by converting it into the more complex 83 | # `has $name => %opts` version, just easier 84 | # to maintain internal consistency. 85 | # - SL 86 | 87 | @args = ( default => $args[0] ) 88 | if scalar @args == 1 89 | && ref $args[0] eq 'CODE'; 90 | 91 | my %args = @args; 92 | 93 | # NOTE: 94 | # handle the simple case of `required => 1` 95 | # by providing this default error message 96 | # with the name embedded. This has to be done 97 | # here because the Initializer object does 98 | # not know the name (nor does it need to) 99 | # - SL 100 | 101 | # TODO - i18n the error message 102 | $args{required} = 'A value for `'.$name.'` is required' 103 | if exists $args{required} 104 | && $args{required} =~ /^1$/; 105 | 106 | my $initializer = MOP::Slot::Initializer->new( 107 | within_package => $meta->name, 108 | %args 109 | ); 110 | 111 | $meta->add_slot( $name, $initializer ); 112 | return; 113 | } 114 | ); 115 | 116 | BEGIN::Lift::install( 117 | ($caller, 'extends') => sub (@isa) { 118 | Module::Runtime::use_package_optimistically( $_ ) foreach @isa; 119 | ($meta->isa('MOP::Class') 120 | ? $meta 121 | : do { 122 | # FIXME: 123 | # This is gross ... - SL 124 | Internals::SvREADONLY( $$meta, 0 ); 125 | bless $meta => 'MOP::Class'; # cast into class 126 | Internals::SvREADONLY( $$meta, 1 ); 127 | $meta; 128 | } 129 | )->set_superclasses( @isa ); 130 | return; 131 | } 132 | ); 133 | 134 | BEGIN::Lift::install( 135 | ($caller, 'with') => sub (@does) { 136 | Module::Runtime::use_package_optimistically( $_ ) foreach @does; 137 | $meta->set_roles( @does ); 138 | return; 139 | } 140 | ); 141 | 142 | # setup the base traits, 143 | my @traits = Moxie::Traits::Provider::list_providers(); 144 | # and anything we were asked to load ... 145 | if ( exists $opts->{'traits'} ) { 146 | foreach my $trait ( $opts->{'traits'}->@* ) { 147 | if ( $trait eq ':experimental' ) { 148 | push @traits => Moxie::Traits::Provider::list_experimental_providers();; 149 | } 150 | else { 151 | push @traits => $trait; 152 | } 153 | } 154 | } 155 | 156 | # then schedule the trait collection ... 157 | Method::Traits->import_into( $meta->name, @traits ); 158 | 159 | # install our class finalizer 160 | MOP::Util::defer_until_UNITCHECK(sub { 161 | 162 | # pre-populate the cache for all the slots (if it is a class) 163 | MOP::Util::inherit_slots( $meta ); 164 | 165 | # apply roles ... 166 | MOP::Util::compose_roles( $meta ); 167 | 168 | # TODO: 169 | # Consider locking the %HAS hash now, this will 170 | # prevent anyone from adding new fields after 171 | # compile time. 172 | # - SL 173 | 174 | }); 175 | } 176 | 177 | 1; 178 | 179 | __END__ 180 | 181 | =pod 182 | 183 | =head1 SYNOPSIS 184 | 185 | package Point { 186 | use Moxie; 187 | 188 | extends 'Moxie::Object'; 189 | 190 | has x => ( default => sub { 0 } ); 191 | has y => ( default => sub { 0 } ); 192 | 193 | sub x : ro; 194 | sub y : ro; 195 | 196 | sub clear ($self) { 197 | $self->@{ 'x', 'y' } = (0, 0); 198 | } 199 | } 200 | 201 | package Point3D { 202 | use Moxie; 203 | 204 | extends 'Point'; 205 | 206 | has z => ( default => sub { 0 } ); 207 | 208 | sub z : ro; 209 | 210 | sub clear ($self) { 211 | $self->next::method; 212 | $self->{z} = 0; 213 | } 214 | } 215 | 216 | =head1 DESCRIPTION 217 | 218 | L is a new object system for Perl 5 that aims to be a 219 | successor to the L module. The goal is to provide the same 220 | key features of L: syntactic sugar, common base class, slot 221 | management, role composition, accessor generation and a meta-object 222 | protocol – but to do it in a more straightforward and resource-efficient 223 | way that requires lower cognitive overhead. 224 | 225 | The key tenets of L are as follows: 226 | 227 | =head2 Aims to be ultra-modern 228 | 229 | L was a post-modern object system, so what is after post 230 | modernism? Post, post modernism? Who knows, it is 2017 and instead 231 | of flying cars we are careening towards a dystopian timeline and 232 | a future that none of us can foresee. So given that, B seemed 233 | to work as well as anything else. 234 | 235 | This tenet means that we will not shy away from new Perl features 236 | and we have a core commitment to helping to push the language forward. 237 | 238 | =head2 Better distinction between public & private 239 | 240 | The clean separation of the public and private interfaces of your 241 | class is key to maintaining good encapsulation. This is one of the key 242 | features required for writing robust and reusable software that can 243 | resist the abuses of fellow programmers and still retain its 244 | usefulness over time. 245 | 246 | =head2 Re-use existing Perl features 247 | 248 | Perl is a large language with many features, some of which are useful 249 | and some – I believe – people just haven't found a good use for I. 250 | L aims to use as many existing B features in Perl as 251 | possible. This can be seen as just another facet of the commitment to 252 | modernity mentioned above, ... it is not old, it is B! 253 | 254 | =head2 Reduce cognitive burden of the MOP 255 | 256 | The Meta-Object Protocol that powered all the L features was 257 | large, complex and difficult to understand unless you were willing to 258 | put in the cognitive investment. Because the MOP was the primary means 259 | of extension for L, this meant it was not optional if you wanted 260 | to extend L. L instead turns the tables, such that it has 261 | multiple means of extension, most (but not all) of which are empowered 262 | by the L. This means that an understanding of the L is no 263 | longer required to extend L, but when needed the full power of 264 | a L is available. 265 | 266 | =head2 Better resource usage 267 | 268 | L is famous for its high startup overhead and heavy memory 269 | usage. These were consequences of the way in which L was 270 | implemented. With L we instead try to do the least amount of 271 | work possible so as to introduce the least amount of overhead. 272 | 273 | 274 | =head1 KEYWORDS 275 | 276 | L exports a few keywords using the L module 277 | described above. These keywords are responsible for setting 278 | the correct state in the current package such that it conforms 279 | to the expectations of the L and L 280 | modules. 281 | 282 | All of these keywords are executed during the C phase, 283 | and the keywords themselves are removed in the C 284 | phase. This prevents them from being mistaken as methods by 285 | both L and the L. 286 | 287 | =over 4 288 | 289 | =item C 290 | 291 | This creates an inheritance relationship between the current 292 | class and the classes listed in C<@superclasses>. 293 | 294 | If this is called, L will assume you are a building a 295 | class, otherwise it will assume you are building a role. For the 296 | most part, you don't need to care about the difference. 297 | 298 | This will populate the C<@ISA> variable in the current package. 299 | 300 | =item C 301 | 302 | This sets up a role relationship between the current class or 303 | role and the roles listed in C<@roles>. 304 | 305 | This will cause L to compose the C<@roles> into the current 306 | class or role during the next C phase. 307 | 308 | This will populate the C<@DOES> variable in the current package. 309 | 310 | =item C<< has $name => sub { $default_value } >> 311 | 312 | This creates a new slot in the current class or role, with 313 | C<$name> being the name of the slot and a subroutine which, 314 | when called, returns the C<$default_value> for that slot. 315 | 316 | This will populate the C<%HAS> variable in the current package. 317 | 318 | =back 319 | 320 | =head1 METHOD TRAITS 321 | 322 | It is possible to have L load your L providers, 323 | this is done when Cing L like this: 324 | 325 | use Moxie traits => [ 'My::Trait::Provider', ... ]; 326 | 327 | By default L will enable the L module 328 | to supply this set of traits for use in L classes. 329 | 330 | Some traits below are listed as experimental; in order to enable those 331 | traits the string C<:experimental> (with the leading colon) must appear 332 | in your traits list. 333 | 334 | use Moxie traits => [ ':experimental' ]; 335 | # or 336 | use Moxie traits => [ 'My::Trait::Provider', ..., ':experimental' ]; 337 | 338 | =head3 B 339 | 340 | The way C parses C attributes is that everything within the 341 | C<()> is just passed onto your code for parsing. This means that it is 342 | not necessary to quote slot names within the argument list of a trait, 343 | and all examples (eventually) will conform to this syntax. This is a matter 344 | of choice, do as you prefer, but I promise you there is no additional 345 | safety or certainty you get from quoting slot names in trait arguments. 346 | 347 | =head2 CONSTRUCTOR TRAITS 348 | 349 | =over 4 350 | 351 | =item C<< strict( arg_key => slot_name, ... ) >> 352 | 353 | This is a trait that is exclusively applied to the C 354 | method. This is a means for generating a strict interface for the 355 | C method that will map a set of constructor parameters 356 | to a set of given slots. This is useful for maintaining encapsulation 357 | for things like a private slot with a different public name. 358 | 359 | # declare a slot with a private name 360 | has _bar => sub {}; 361 | 362 | # map the `foo` key to the `_bar` slot 363 | sub BUILDARGS : strict( foo => _bar ); 364 | 365 | All other parameters will be rejected and an exception thrown. If 366 | you wish to have an optional parameter, simply follow the parameter 367 | name with a question mark, like so: 368 | 369 | # declare a slot with a private name 370 | has _bar => sub {}; 371 | 372 | # the `foo` key is optional, but if 373 | # given, will store in the `_bar` slot 374 | sub BUILDARGS : strict( foo? => _bar ); 375 | 376 | If you wish to accept parameters for your superclass's constructor 377 | but do not want to specify storage location because of encapsulation 378 | concerns, simply use the C designator, like so: 379 | 380 | 381 | # map the `foo` key to the local `_bar` slot 382 | # with the `bar` key, let the superclass decide ... 383 | sub BUILDARGS : strict( 384 | foo => _bar, 385 | bar => super(bar) 386 | ); 387 | 388 | If you wish to have a constructor that accepts no parameters at 389 | all, then simply do this. 390 | 391 | sub BUILDARGS : strict; 392 | 393 | And the constructor will throw an exception if any arguments at 394 | all are passed in. 395 | 396 | =head2 ACCESSOR TRAITS 397 | 398 | =over 4 399 | 400 | =item C 401 | 402 | This will generate a simple read-only accessor for a slot. The 403 | C<$slot_name> can optionally be specified, otherwise it will use the 404 | name of the method that the trait is being applied to. 405 | 406 | sub foo : ro; 407 | sub foo : ro(_foo); 408 | 409 | If the method name is prefixed with C, then this trait will 410 | infer that the slot name intended is the remainder of the method's 411 | name, minus the C prefix, such that this: 412 | 413 | sub get_foo : ro; 414 | 415 | Is the equivalent of writing this: 416 | 417 | sub get_foo : ro(foo); 418 | 419 | =item C 420 | 421 | This will generate a simple read-write accessor for a slot. The 422 | C<$slot_name> can optionally be specified, otherwise it will use the 423 | name of the method that the trait is being applied to. 424 | 425 | sub foo : rw; 426 | sub foo : rw(_foo); 427 | 428 | If the method name is prefixed with C, then this trait will 429 | infer that the slot name intended is the remainder of the method's 430 | name, minus the C prefix, such that this: 431 | 432 | sub set_foo : ro; 433 | 434 | Is the equivalent of writing this: 435 | 436 | sub set_foo : ro(foo); 437 | 438 | =item C 439 | 440 | This will generate a simple write-only accessor for a slot. The 441 | C<$slot_name> can optionally be specified, otherwise it will use the 442 | name of the method that the trait is being applied to. 443 | 444 | sub foo : wo; 445 | sub foo : wo(_foo); 446 | 447 | If the method name is prefixed with C, then this trait will 448 | infer that the slot name intended is the remainder of the method's 449 | name, minus the C prefix, such that this: 450 | 451 | sub set_foo : wo; 452 | 453 | Is the equivalent of writing this: 454 | 455 | sub set_foo : wo(foo); 456 | 457 | =item C 458 | 459 | This will generate a simple predicate method for a slot. The 460 | C<$slot_name> can optionally be specified, otherwise it will use the 461 | name of the method that the trait is being applied to. 462 | 463 | sub foo : predicate; 464 | sub foo : predicate(_foo); 465 | 466 | If the method name is prefixed with C, then this trait will 467 | infer that the slot name intended is the remainder of the method's 468 | name, minus the C prefix, such that this: 469 | 470 | sub has_foo : predicate; 471 | 472 | Is the equivalent of writing this: 473 | 474 | sub has_foo : predicate(foo); 475 | 476 | =item C 477 | 478 | This will generate a simple clearing method for a slot. The 479 | C<$slot_name> can optionally be specified, otherwise it will use the 480 | name of the method that the trait is being applied to. 481 | 482 | sub foo : clearer; 483 | sub foo : clearer(_foo); 484 | 485 | If the method name is prefixed with C, then this trait will 486 | infer that the slot name intended is the remainder of the method's 487 | name, minus the C prefix, such that this: 488 | 489 | sub clear_foo : clearer; 490 | 491 | Is the equivalent of writing this: 492 | 493 | sub clear_foo : clearer(foo); 494 | 495 | =back 496 | 497 | =head2 EXPERIMENTAL TRAITS 498 | 499 | In order to enable these traits, you must pass the C 500 | flag for L. The interfaces to these traits may change until 501 | we settle upon one we like, use them bravely and/or sparingly. 502 | 503 | =over 4 504 | 505 | =item C 506 | 507 | This will transform the associated subroutine into a lazy read-only 508 | accessor for a slot. The body of the subroutine is expected to be 509 | the initializer for the slot and will receive the instance as its 510 | first argument. The C<$slot_name> can optionally be specified, 511 | otherwise it will use the name of the method that the trait is being 512 | applied to. 513 | 514 | sub foo : lazy { ... } 515 | sub foo : lazy(_foo) { ... } 516 | 517 | =item C<< handles( $slot_name->$delegate_method ) >> 518 | 519 | This will generate a simple delegate method for a slot. The 520 | C<$slot_name> and C<$delegate_method>, separated by an arrow 521 | (C<< -> >>), must be specified or an exception is thrown. 522 | 523 | sub foobar : handles(foo->bar); 524 | 525 | No attempt will be made to verify that the value stored in 526 | C<$slot_name> is an object, or that it responds to the 527 | C<$delegate_method> specified; this is the responsibility of 528 | the writer of the class. 529 | 530 | =item C 531 | 532 | This will generate a private read-write accessor for a slot. The 533 | C<$slot_name> can optionally be specified, otherwise it will use the 534 | name of the method that the trait is being applied to. 535 | 536 | my sub foo : private; 537 | my sub foo : private(_foo); 538 | 539 | The privacy is accomplished via the use of a lexical method, this means 540 | that the method is not availble outside of the package scope and is 541 | not available to participate in method dispatch, however it does 542 | know the current invocant, so there is no need to pass that in. This 543 | results in code that looks like this: 544 | 545 | sub my_method ($self, @stuff) { 546 | # simple access ... 547 | my $foo = foo; 548 | 549 | # passing to other methods ... 550 | $self->do_something_with_foo( foo ); 551 | 552 | # calling methods on an embedded object ... 553 | foo->call_method_on_foo(); 554 | } 555 | 556 | =back 557 | 558 | =head1 USED MODULES 559 | 560 | L could be thought of as a reference implementation for an 561 | object system built on top of a set of modules (listed below). 562 | 563 | =over 4 564 | 565 | =item L 566 | 567 | This is the suggested base class (through L) for 568 | all L classes. 569 | 570 | =item L 571 | 572 | This provides an API to Classes, Roles, Methods and Slots, which 573 | is used by many elements within this module. 574 | 575 | =item L 576 | 577 | This module is used to create three new keywords; C, 578 | C and C. These keywords are executed during compile 579 | time and just make calls to the L to affect the class 580 | being built. 581 | 582 | =item L 583 | 584 | This module is used to handle the method traits which are used 585 | mostly for method generation (accessors, predicates, etc.). 586 | 587 | =back 588 | 589 | =head1 FEATURES ENABLED 590 | 591 | This module enables a number of features in Perl which are 592 | currently considered experimental, see the L 593 | module for more information. 594 | 595 | =over 4 596 | 597 | =item C 598 | 599 | =item C 600 | 601 | =item C 602 | 603 | =item C 604 | 605 | =item C 606 | 607 | =item C 608 | 609 | =item C 610 | 611 | =item C 612 | 613 | =item C 614 | 615 | =back 616 | 617 | =head1 PRAGMAS ENABLED 618 | 619 | We enable both the L and L pragmas, but we disable the 620 | C warning so that we can use lowercase C attributes with 621 | L. 622 | 623 | =over 4 624 | 625 | =item L 626 | 627 | =item L 628 | 629 | =back 630 | 631 | =cut 632 | -------------------------------------------------------------------------------- /lib/Moxie/Enum.pm: -------------------------------------------------------------------------------- 1 | package Moxie::Enum; 2 | # ABSTRACT: Yet Another Enum Generator 3 | 4 | use v5.22; 5 | use warnings; 6 | use experimental qw[ 7 | signatures 8 | postderef 9 | ]; 10 | 11 | use Scalar::Util (); 12 | use BEGIN::Lift (); 13 | 14 | our $VERSION = '0.07'; 15 | our $AUTHORITY = 'cpan:STEVAN'; 16 | 17 | # ... 18 | 19 | our %PACKAGE_TO_ENUM; 20 | 21 | sub import ($class) { 22 | # get the caller ... 23 | my $caller = caller; 24 | # and call import_into ... 25 | $class->import_into( $caller ); 26 | } 27 | 28 | sub import_into ($class, $caller) { 29 | BEGIN::Lift::install( 30 | ($caller, 'enum') => sub ($type, @args) { 31 | my %enum; 32 | if ( scalar @args == 1 && ref $args[0] eq 'HASH' ) { 33 | %enum = $args[0]->%*; 34 | } 35 | else { 36 | my $idx = 0; 37 | %enum = map { $_ => ++$idx } @args; 38 | } 39 | 40 | foreach my $key ( keys %enum ) { 41 | no strict 'refs'; 42 | $enum{ $key } = Scalar::Util::dualvar( $enum{ $key }, $key ); 43 | *{$caller.'::'.$key} = sub (@) { $enum{ $key } }; 44 | } 45 | 46 | $PACKAGE_TO_ENUM{ $caller } //= {}; 47 | $PACKAGE_TO_ENUM{ $caller }->{ $type } = \%enum; 48 | 49 | return; 50 | } 51 | ); 52 | } 53 | 54 | ## ... 55 | 56 | sub get_enum_for ($pkg, $type) { 57 | return unless exists $PACKAGE_TO_ENUM{ $pkg } 58 | && exists $PACKAGE_TO_ENUM{ $pkg }->{ $type }; 59 | return $PACKAGE_TO_ENUM{ $pkg }->{ $type }->%*; 60 | } 61 | 62 | sub get_value_for ($pkg, $type, $name) { 63 | my %enum = get_enum_for( $pkg, $type ); 64 | return $enum{ $name }; 65 | } 66 | 67 | sub has_value_for ($pkg, $type, $name) { 68 | my %enum = get_enum_for( $pkg, $type ); 69 | return exists $enum{ $name }; 70 | } 71 | 72 | sub get_keys_for ($pkg, $type) { my %enum = get_enum_for( $pkg, $type ); keys %enum } 73 | sub get_values_for ($pkg, $type) { my %enum = get_enum_for( $pkg, $type ); values %enum } 74 | 75 | 1; 76 | 77 | __END__ 78 | 79 | =pod 80 | 81 | =head1 DESCRIPTION 82 | 83 | This provides a simple enumeration type for use with 84 | Moxie classes. 85 | 86 | =cut 87 | -------------------------------------------------------------------------------- /lib/Moxie/Object.pm: -------------------------------------------------------------------------------- 1 | package Moxie::Object; 2 | # ABSTRACT: Yet Another Base Class 3 | 4 | use v5.22; 5 | use warnings; 6 | use experimental qw[ 7 | signatures 8 | postderef 9 | ]; 10 | 11 | use UNIVERSAL::Object; 12 | 13 | our $VERSION = '0.07'; 14 | our $AUTHORITY = 'cpan:STEVAN'; 15 | 16 | our @ISA; BEGIN { @ISA = ('UNIVERSAL::Object') } 17 | 18 | sub DOES ($self, $role) { 19 | my $class = ref $self || $self; 20 | # if we inherit from this, we are good ... 21 | return 1 if $class->isa( $role ); 22 | # next check the roles ... 23 | my $meta = MOP::Class->new( name => $class ); 24 | # test just the local (and composed) roles first ... 25 | return 1 if $meta->does_role( $role ); 26 | # then check the inheritance hierarchy next ... 27 | return 1 if scalar grep { MOP::Class->new( name => $_ )->does_role( $role ) } $meta->mro->@*; 28 | return 0; 29 | } 30 | 31 | 1; 32 | 33 | __END__ 34 | 35 | =pod 36 | 37 | =head1 DESCRIPTION 38 | 39 | This is an extension of L to add a C method 40 | because L doesn't know about roles (or the L). 41 | 42 | =head1 METHOD 43 | 44 | =over 4 45 | 46 | =item C 47 | 48 | =back 49 | 50 | =cut 51 | -------------------------------------------------------------------------------- /lib/Moxie/Object/Immutable.pm: -------------------------------------------------------------------------------- 1 | package Moxie::Object::Immutable; 2 | # ABSTRACT: Yet Another (Immutable) Base Class 3 | 4 | use v5.22; 5 | use warnings; 6 | use experimental qw[ 7 | signatures 8 | postderef 9 | ]; 10 | 11 | use UNIVERSAL::Object::Immutable; 12 | 13 | our $VERSION = '0.07'; 14 | our $AUTHORITY = 'cpan:STEVAN'; 15 | 16 | our @ISA; BEGIN { 17 | @ISA = ( 18 | 'UNIVERSAL::Object::Immutable', 19 | 'Moxie::Object', 20 | ); 21 | } 22 | 23 | 1; 24 | 25 | __END__ 26 | 27 | =pod 28 | 29 | =head1 DESCRIPTION 30 | 31 | This is an extension of L and 32 | L. 33 | 34 | =cut 35 | -------------------------------------------------------------------------------- /lib/Moxie/Traits/Provider.pm: -------------------------------------------------------------------------------- 1 | package Moxie::Traits::Provider; 2 | # ABSTRACT: built in traits 3 | 4 | use v5.22; 5 | use warnings; 6 | use experimental qw[ 7 | signatures 8 | postderef 9 | ]; 10 | 11 | our $VERSION = '0.07'; 12 | our $AUTHORITY = 'cpan:STEVAN'; 13 | 14 | use Module::Runtime (); 15 | 16 | use Moxie::Traits::Provider::Accessor (); 17 | use Moxie::Traits::Provider::Constructor (); 18 | 19 | our @PROVIDERS = qw( 20 | Moxie::Traits::Provider::Accessor 21 | Moxie::Traits::Provider::Constructor 22 | ); 23 | 24 | our @EXPERIMENTAL_PROVIDERS = qw( 25 | Moxie::Traits::Provider::Experimental 26 | ); 27 | 28 | ## ... 29 | 30 | sub list_providers () { @PROVIDERS } 31 | sub list_experimental_providers () { @EXPERIMENTAL_PROVIDERS } 32 | 33 | ## ... 34 | 35 | sub load_experimental_providers { 36 | map Module::Runtime::use_package_optimistically( $_ ), list_experimental_providers() 37 | } 38 | 39 | 1; 40 | 41 | __END__ 42 | 43 | =pod 44 | 45 | =head1 DESCRIPTION 46 | 47 | This is a L provider module which L enables by 48 | default. These are documented in the L section of the 49 | L documentation. 50 | 51 | =cut 52 | -------------------------------------------------------------------------------- /lib/Moxie/Traits/Provider/Accessor.pm: -------------------------------------------------------------------------------- 1 | package Moxie::Traits::Provider::Accessor; 2 | # ABSTRACT: built in traits 3 | 4 | use v5.22; 5 | use warnings; 6 | use experimental qw[ 7 | signatures 8 | postderef 9 | ]; 10 | 11 | use Method::Traits ':for_providers'; 12 | 13 | use Carp (); 14 | use MOP::Util (); 15 | 16 | our $VERSION = '0.07'; 17 | our $AUTHORITY = 'cpan:STEVAN'; 18 | 19 | sub ro ( $meta, $method, @args ) : OverwritesMethod { 20 | 21 | my $method_name = $method->name; 22 | 23 | my $slot_name; 24 | if ( $args[0] ) { 25 | $slot_name = shift @args; 26 | } 27 | else { 28 | if ( $method_name =~ /^get_(.*)$/ ) { 29 | $slot_name = $1; 30 | } 31 | else { 32 | $slot_name = $method_name; 33 | } 34 | } 35 | 36 | Carp::confess('Unable to build `ro` accessor for slot `' . $slot_name.'` in `'.$meta->name.'` because the slot cannot be found.') 37 | unless $meta->has_slot( $slot_name ) 38 | || $meta->has_slot_alias( $slot_name ); 39 | 40 | $meta->add_method( $method_name => sub { 41 | Carp::confess("Cannot assign to `$slot_name`, it is a readonly") if scalar @_ != 1; 42 | $_[0]->{ $slot_name }; 43 | }); 44 | } 45 | 46 | sub rw ( $meta, $method, @args ) : OverwritesMethod { 47 | 48 | my $method_name = $method->name; 49 | 50 | my $slot_name; 51 | if ( $args[0] ) { 52 | $slot_name = shift @args; 53 | } 54 | else { 55 | $slot_name = $method_name; 56 | } 57 | 58 | Carp::confess('Unable to build `rw` accessor for slot `' . $slot_name.'` in `'.$meta->name.'` because class is immutable.') 59 | if ($meta->name)->isa('Moxie::Object::Immutable'); 60 | 61 | Carp::confess('Unable to build `rw` accessor for slot `' . $slot_name.'` in `'.$meta->name.'` because the slot cannot be found.') 62 | unless $meta->has_slot( $slot_name ) 63 | || $meta->has_slot_alias( $slot_name ); 64 | 65 | $meta->add_method( $method_name => sub { 66 | $_[0]->{ $slot_name } = $_[1] if scalar( @_ ) > 1; 67 | $_[0]->{ $slot_name }; 68 | }); 69 | } 70 | 71 | sub wo ( $meta, $method, @args ) : OverwritesMethod { 72 | 73 | my $method_name = $method->name; 74 | 75 | my $slot_name; 76 | if ( $args[0] ) { 77 | $slot_name = shift @args; 78 | } 79 | else { 80 | if ( $method_name =~ /^set_(.*)$/ ) { 81 | $slot_name = $1; 82 | } 83 | else { 84 | $slot_name = $method_name; 85 | } 86 | } 87 | 88 | Carp::confess('Unable to build `wo` accessor for slot `' . $slot_name.'` in `'.$meta->name.'` because class is immutable.') 89 | if ($meta->name)->isa('Moxie::Object::Immutable'); 90 | 91 | Carp::confess('Unable to build `wo` accessor for slot `' . $slot_name.'` in `'.$meta->name.'` because the slot cannot be found.') 92 | unless $meta->has_slot( $slot_name ) 93 | || $meta->has_slot_alias( $slot_name ); 94 | 95 | $meta->add_method( $method_name => sub { 96 | Carp::confess("You must supply a value to write to `$slot_name`") if scalar(@_) < 1; 97 | $_[0]->{ $slot_name } = $_[1]; 98 | }); 99 | } 100 | 101 | sub predicate ( $meta, $method, @args ) : OverwritesMethod { 102 | 103 | my $method_name = $method->name; 104 | 105 | my $slot_name; 106 | if ( $args[0] ) { 107 | $slot_name = shift @args; 108 | } 109 | else { 110 | if ( $method_name =~ /^has_(.*)$/ ) { 111 | $slot_name = $1; 112 | } 113 | else { 114 | $slot_name = $method_name; 115 | } 116 | } 117 | 118 | Carp::confess('Unable to build predicate for slot `' . $slot_name.'` in `'.$meta->name.'` because the slot cannot be found.') 119 | unless $meta->has_slot( $slot_name ) 120 | || $meta->has_slot_alias( $slot_name ); 121 | 122 | $meta->add_method( $method_name => sub { defined $_[0]->{ $slot_name } } ); 123 | } 124 | 125 | sub clearer ( $meta, $method, @args ) : OverwritesMethod { 126 | 127 | my $method_name = $method->name; 128 | 129 | my $slot_name; 130 | if ( $args[0] ) { 131 | $slot_name = shift @args; 132 | } 133 | else { 134 | if ( $method_name =~ /^clear_(.*)$/ ) { 135 | $slot_name = $1; 136 | } 137 | else { 138 | $slot_name = $method_name; 139 | } 140 | } 141 | 142 | Carp::confess('Unable to build `clearer` accessor for slot `' . $slot_name.'` in `'.$meta->name.'` because class is immutable.') 143 | if ($meta->name)->isa('Moxie::Object::Immutable'); 144 | 145 | Carp::confess('Unable to build `clearer` accessor for slot `' . $slot_name.'` in `'.$meta->name.'` because the slot cannot be found.') 146 | unless $meta->has_slot( $slot_name ) 147 | || $meta->has_slot_alias( $slot_name ); 148 | 149 | $meta->add_method( $method_name => sub { undef $_[0]->{ $slot_name } } ); 150 | } 151 | 152 | 153 | 1; 154 | 155 | __END__ 156 | 157 | =pod 158 | 159 | =head1 DESCRIPTION 160 | 161 | This is a L provider module which L enables by 162 | default. These are documented in the L section of the 163 | L documentation. 164 | 165 | =cut 166 | -------------------------------------------------------------------------------- /lib/Moxie/Traits/Provider/Constructor.pm: -------------------------------------------------------------------------------- 1 | package Moxie::Traits::Provider::Constructor; 2 | # ABSTRACT: built in traits 3 | 4 | use v5.22; 5 | use warnings; 6 | use experimental qw[ 7 | signatures 8 | postderef 9 | ]; 10 | 11 | use Method::Traits ':for_providers'; 12 | 13 | use Carp (); 14 | use MOP::Util (); 15 | 16 | our $VERSION = '0.07'; 17 | our $AUTHORITY = 'cpan:STEVAN'; 18 | 19 | sub strict ( $meta, $method, %signature ) : OverwritesMethod { 20 | 21 | # XXX: 22 | # Consider perhaps supporting something 23 | # like the Perl 6 signature format here, 24 | # which would give us a more sophisticated 25 | # way to specify the constructor API 26 | # 27 | # The way MAIN is handled is good inspiration maybe ... 28 | # http://perl6maven.com/parsing-command-line-arguments-perl6 29 | # 30 | # - SL 31 | 32 | my $class_name = $meta->name; 33 | my $method_name = $method->name; 34 | 35 | Carp::confess('The `strict` trait can only be applied to BUILDARGS') 36 | if $method_name ne 'BUILDARGS'; 37 | 38 | if ( %signature ) { 39 | 40 | my @all = sort keys %signature; 41 | my @required = grep !/\?$/, @all; 42 | 43 | my $max_arity = 2 * scalar @all; 44 | my $min_arity = 2 * scalar @required; 45 | 46 | # use Data::Dumper; 47 | # warn Dumper { 48 | # class => $meta->name, 49 | # all => \@all, 50 | # required => \@required, 51 | # min_arity => $min_arity, 52 | # max_arity => $max_arity, 53 | # }; 54 | 55 | $meta->add_method('BUILDARGS' => sub ($self, @args) { 56 | 57 | my $arity = scalar @args; 58 | 59 | Carp::confess('Constructor for ('.$class_name.') expected ' 60 | . (($max_arity == $min_arity) 61 | ? ($min_arity) 62 | : ('between '.$min_arity.' and '.$max_arity)) 63 | . ' arguments, got ('.$arity.')') 64 | if $arity < $min_arity || $arity > $max_arity; 65 | 66 | my $proto = $self->UNIVERSAL::Object::BUILDARGS( @args ); 67 | 68 | my @missing; 69 | # make sure all the expected parameters exist ... 70 | foreach my $param ( @required ) { 71 | push @missing => $param unless exists $proto->{ $param }; 72 | } 73 | 74 | Carp::confess('Constructor for ('.$class_name.') missing (`'.(join '`, `' => @missing).'`) parameters, got (`'.(join '`, `' => sort keys $proto->%*).'`), expected (`'.(join '`, `' => @all).'`)') 75 | if @missing; 76 | 77 | my (%final, %super); 78 | 79 | #warn "---------------------------------------"; 80 | #warn join ', ' => @all; 81 | 82 | # do any kind of slot assignment shuffling needed .... 83 | foreach my $param ( @all ) { 84 | 85 | #warn "CHECKING param: $param"; 86 | 87 | my $from = $param; 88 | $from =~ s/\?$//; 89 | my $to = $signature{ $param }; 90 | 91 | #warn "PARAM: $param FROM: ($from) TO: ($to)"; 92 | 93 | if ( $to =~ /^super\((.*)\)$/ ) { 94 | $super{ $1 } = delete $proto->{ $from } 95 | if $proto->{ $from }; 96 | } 97 | else { 98 | if ( exists $proto->{ $from } ) { 99 | 100 | #use Data::Dumper; 101 | #warn "BEFORE:", Dumper $proto; 102 | 103 | # now grab the slot by the correct name ... 104 | $final{ $to } = delete $proto->{ $from }; 105 | 106 | #warn "AFTER:", Dumper $proto; 107 | } 108 | #else { 109 | #use Data::Dumper; 110 | #warn "NOT FOUND ($from) :", Dumper $proto; 111 | #} 112 | } 113 | } 114 | 115 | # inherit keys ... 116 | if ( keys %super ) { 117 | my $super_proto = $self->next::method( %super ); 118 | %final = ( $super_proto->%*, %final ); 119 | } 120 | 121 | if ( keys $proto->%* ) { 122 | 123 | #use Data::Dumper; 124 | #warn Dumper +{ 125 | # proto => $proto, 126 | # final => \%final, 127 | # super => \%super, 128 | # meta => { 129 | # class => $meta->name, 130 | # all => \@all, 131 | # required => \@required, 132 | # min_arity => $min_arity, 133 | # max_arity => $max_arity, 134 | # } 135 | #}; 136 | 137 | Carp::confess('Constructor for ('.$class_name.') got unrecognized parameters (`'.(join '`, `' => keys $proto->%*).'`)'); 138 | } 139 | 140 | return \%final; 141 | }); 142 | } 143 | else { 144 | $meta->add_method('BUILDARGS' => sub ($self, @args) { 145 | Carp::confess('Constructor for ('.$class_name.') expected 0 arguments, got ('.(scalar @args).')') 146 | if @args; 147 | return $self->UNIVERSAL::Object::BUILDARGS(); 148 | }); 149 | } 150 | } 151 | 152 | 1; 153 | 154 | __END__ 155 | 156 | =pod 157 | 158 | =head1 DESCRIPTION 159 | 160 | This is a L provider module which L enables by 161 | default. These are documented in the L section of the 162 | L documentation. 163 | 164 | =cut 165 | -------------------------------------------------------------------------------- /lib/Moxie/Traits/Provider/Experimental.pm: -------------------------------------------------------------------------------- 1 | package Moxie::Traits::Provider::Experimental; 2 | # ABSTRACT: built in traits 3 | 4 | use v5.22; 5 | use warnings; 6 | use experimental qw[ 7 | signatures 8 | postderef 9 | ]; 10 | 11 | use Method::Traits ':for_providers'; 12 | 13 | use Carp (); 14 | use Sub::Util (); # for setting the prototype of the lexical accessors 15 | use PadWalker (); # for generating lexical accessors 16 | use MOP::Util (); 17 | 18 | our $VERSION = '0.07'; 19 | our $AUTHORITY = 'cpan:STEVAN'; 20 | 21 | sub lazy ( $meta, $method, @args ) : OverwritesMethod { 22 | 23 | my $method_name = $method->name; 24 | 25 | my $slot_name; 26 | if ( $args[0] ) { 27 | $slot_name = shift @args; 28 | } 29 | else { 30 | if ( $method_name =~ /^build_(.*)$/ ) { 31 | $slot_name = $1; 32 | } 33 | else { 34 | $slot_name = $method_name; 35 | } 36 | } 37 | 38 | Carp::confess('Unable to build `lazy` accessor for slot `' . $slot_name.'` in `'.$meta->name.'` because class is immutable.') 39 | if ($meta->name)->isa('Moxie::Object::Immutable'); 40 | 41 | Carp::confess('Unable to build `lazy` accessor for slot `' . $slot_name.'` in `'.$meta->name.'` because the slot cannot be found.') 42 | unless $meta->has_slot( $slot_name ) 43 | || $meta->has_slot_alias( $slot_name ); 44 | 45 | 46 | # NOTE: 47 | # lazy is read-only by design, if you want 48 | # a rw+lazy, write it yourself 49 | # - SL 50 | 51 | my $orig = $meta->get_method( $method_name )->body; 52 | 53 | $meta->add_method( $method_name => sub { 54 | $_[0]->{ $slot_name } //= $orig->( @_ ); 55 | }); 56 | } 57 | 58 | 59 | sub handles ( $meta, $method, @args ) : OverwritesMethod { 60 | 61 | my $method_name = $method->name; 62 | 63 | my ($slot_name, $delegate) = ($args[0] =~ /^(.*)\-\>(.*)$/); 64 | 65 | Carp::confess('Delegation spec must be in the pattern `slot->method`, not '.$args[0]) 66 | unless $slot_name && $delegate; 67 | 68 | Carp::confess('Unable to build delegation method for slot `' . $slot_name.'` in `'.$meta->name.'` because the slot cannot be found.') 69 | unless $meta->has_slot( $slot_name ) 70 | || $meta->has_slot_alias( $slot_name ); 71 | 72 | $meta->add_method( $method_name => sub { 73 | $_[0]->{ $slot_name }->$delegate( @_[ 1 .. $#_ ] ); 74 | }); 75 | } 76 | 77 | sub private ( $meta, $method, @args ) { 78 | 79 | my $method_name = $method->name; 80 | 81 | my $slot_name; 82 | if ( $args[0] ) { 83 | $slot_name = shift @args; 84 | } 85 | else { 86 | $slot_name = $method_name; 87 | } 88 | 89 | Carp::confess('Unable to build private accessor for slot `' . $slot_name.'` in `'.$meta->name.'` because the slot cannot be found.') 90 | unless $meta->has_slot( $slot_name ) 91 | || $meta->has_slot_alias( $slot_name ); 92 | 93 | # NOTE: 94 | # These are lexical accessors ... 95 | 96 | # we should not be able to find it in the symbol table ... 97 | if ( $meta->has_method( $method_name ) || $meta->has_method_alias( $method_name ) || $meta->requires_method( $method_name ) ) { 98 | Carp::confess('Unable to install private (lexical) accessor for slot('.$slot_name.') named (' 99 | .$method_name.') because we found a conflicting non-lexical method of that name. ' 100 | .'Private methods must be defined before any public methods of the same name.'); 101 | } 102 | else { 103 | # set the prototype here so that the compiler sees 104 | # this as early as possible ... 105 | Sub::Util::set_prototype( '', $method->body ); 106 | 107 | # at this point we can assume that we have a lexical 108 | # method which we need to transform, and in order to 109 | # do that we need to look at all the methods in this 110 | # class and find all the ones who 'close over' the 111 | # lexical method and then re-write their lexical pad 112 | # to use the accessor method that I will generate. 113 | 114 | # NOTE: 115 | # we need to delay this until the UNITCHECK phase 116 | # because we need all the methods of this class to 117 | # have been compiled, at this moment, they are not. 118 | MOP::Util::defer_until_UNITCHECK(sub { 119 | 120 | # now see if this class is immutable or not, it will 121 | # determine the type of accessor we generate ... 122 | my $class_is_immutable = ($meta->name)->isa('Moxie::Object::Immutable'); 123 | 124 | # now check the class local methods .... 125 | foreach my $m ( $meta->methods ) { 126 | # get a HASH of the things the method closes over 127 | my $closed_over = PadWalker::closed_over( $m->body ); 128 | 129 | #warn Data::Dumper::Dumper({ 130 | # class => $meta->name, 131 | # method => $m->name, 132 | # closed_over => $closed_over, 133 | # looking_for => $method_name, 134 | #}); 135 | 136 | # XXX: 137 | # Consider using something like Text::Levenshtein 138 | # to check for typos in the accessor usage. 139 | # - SL 140 | 141 | # if the private method is used, then it will be 142 | # here with a prepended `&` sigil ... 143 | if ( exists $closed_over->{ '&' . $method_name } ) { 144 | # now we know that we have someone using the 145 | # lexical method inside the method body, so 146 | # we need to generate our accessor accordingly 147 | 148 | # XXX: 149 | # The DB::args stuff below is fragile because it 150 | # is susceptible to alteration of @_ in the 151 | # method that calls these accessors. Perhaps this 152 | # can be fixed with XS, but for now we are going 153 | # to assume people aren't doing this since they 154 | # *should* be using the signatures that we enable 155 | # for them. 156 | # - SL 157 | 158 | my $accessor; 159 | if ( $class_is_immutable ) { 160 | # NOTE: 161 | # if the class is immutable, perl will sometimes 162 | # complain about accessing a read-only value in 163 | # a way it is not comfortable, and this can be 164 | # annoying. However, since we actually told perl 165 | # that we want to be immutable, there actually is 166 | # no need to generate the lvalue accessor when 167 | # we can make a read-only one. 168 | # - SL 169 | $accessor = sub { 170 | package DB; @DB::args = (); my () = caller(1); 171 | my ($self) = @DB::args; 172 | $self->{ $slot_name }; 173 | }; 174 | } 175 | else { 176 | $accessor = sub : lvalue { 177 | package DB; @DB::args = (); my () = caller(1); 178 | my ($self) = @DB::args; 179 | $self->{ $slot_name }; 180 | }; 181 | } 182 | 183 | # then this is as simple as assigning the HASH key 184 | $closed_over->{ '&' . $method_name } = $accessor; 185 | 186 | # okay, now restore the closed over vars 187 | # with our new addition... 188 | PadWalker::set_closed_over( $m->body, $closed_over ); 189 | } 190 | } 191 | }); 192 | } 193 | 194 | } 195 | 196 | 1; 197 | 198 | __END__ 199 | 200 | =pod 201 | 202 | =head1 DESCRIPTION 203 | 204 | This is a L provider module which L enables by 205 | default. These are documented in the L section of the 206 | L documentation. 207 | 208 | =cut 209 | -------------------------------------------------------------------------------- /t/000-samples/000-synopsis.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Data::Dumper; 8 | 9 | BEGIN { 10 | use_ok('MOP'); 11 | } 12 | 13 | package Point { 14 | use Moxie; 15 | 16 | extends 'Moxie::Object'; 17 | 18 | has x => ( default => sub { 0 } ); 19 | has y => ( default => sub { 0 } ); 20 | 21 | sub x : ro; 22 | sub y : ro; 23 | 24 | sub clear ($self) { 25 | $self->@{ 'x', 'y' } = (0, 0); 26 | } 27 | } 28 | 29 | # ... subclass it ... 30 | 31 | package Point3D { 32 | use Moxie; 33 | 34 | extends 'Point'; 35 | 36 | has z => ( default => sub { 0 } ); 37 | 38 | sub z : ro; 39 | 40 | sub clear ($self) { 41 | $self->next::method; 42 | $self->{z} = 0; 43 | } 44 | } 45 | 46 | ## Test an instance 47 | subtest '... test an instance of Point' => sub { 48 | my $p = Point->new; 49 | isa_ok($p, 'Point'); 50 | 51 | is $p->x, 0, '... got the default value for x'; 52 | is $p->y, 0, '... got the default value for y'; 53 | }; 54 | 55 | subtest '... test an instance of Point with args' => sub { 56 | my $p = Point->new( x => 10, y => 20 ); 57 | isa_ok($p, 'Point'); 58 | 59 | is $p->x, 10, '... got the expected value for x'; 60 | is $p->y, 20, '... got the expected value for y'; 61 | 62 | $p->clear; 63 | 64 | is $p->x, 0, '... got the default value for x'; 65 | is $p->y, 0, '... got the default value for y'; 66 | }; 67 | 68 | ## Test the instance 69 | subtest '... test an instance of Point3D' => sub { 70 | my $p3d = Point3D->new(); 71 | isa_ok($p3d, 'Point3D'); 72 | isa_ok($p3d, 'Point'); 73 | 74 | is $p3d->x, 0, '... got the default value for x'; 75 | is $p3d->y, 0, '... got the default value for y'; 76 | is $p3d->z, 0, '... got the default value for z'; 77 | }; 78 | 79 | subtest '... test an instance of Point3D with args' => sub { 80 | my $p3d = Point3D->new( x => 1, y => 2, z => 3 ); 81 | isa_ok($p3d, 'Point3D'); 82 | isa_ok($p3d, 'Point'); 83 | 84 | is $p3d->x, 1, '... got the supplied value for x'; 85 | is $p3d->y, 2, '... got the supplied value for y'; 86 | is $p3d->z, 3, '... got the supplied value for z'; 87 | 88 | $p3d->clear; 89 | 90 | is $p3d->x, 0, '... got the default value for x'; 91 | is $p3d->y, 0, '... got the default value for y'; 92 | is $p3d->z, 0, '... got the default value for z'; 93 | }; 94 | 95 | done_testing; 96 | 97 | 98 | -------------------------------------------------------------------------------- /t/000-samples/001-point.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Data::Dumper; 8 | 9 | BEGIN { 10 | use_ok('MOP'); 11 | } 12 | 13 | package Point { 14 | use Moxie 15 | traits => [':experimental']; 16 | 17 | extends 'Moxie::Object'; 18 | 19 | has _x => ( default => sub { 0 } ); 20 | has _y => ( default => sub { 0 } ); 21 | 22 | my sub _x : private; 23 | my sub _y : private; 24 | 25 | sub BUILDARGS : strict( 26 | x? => _x, 27 | y? => _y, 28 | ); 29 | 30 | sub x : ro(_x); 31 | sub y : ro(_y); 32 | 33 | sub set_x : wo(_x); 34 | sub set_y : wo(_y); 35 | 36 | sub clear ($self) { 37 | (_x, _y) = (0, 0); 38 | } 39 | 40 | sub pack ($self) { 41 | +{ x => _x, y => _y } 42 | } 43 | } 44 | 45 | # ... subclass it ... 46 | 47 | package Point3D { 48 | use Moxie 49 | traits => [':experimental']; 50 | 51 | extends 'Point'; 52 | 53 | has _z => ( default => sub { 0 } ); 54 | 55 | my sub _z : private; 56 | 57 | sub BUILDARGS : strict( 58 | x? => super(x), 59 | y? => super(y), 60 | z? => _z 61 | ); 62 | 63 | sub z : ro( _z ); 64 | sub set_z : wo( _z ); 65 | 66 | sub pack ($self) { 67 | my $data = $self->next::method; 68 | $data->{z} = _z; 69 | $data; 70 | } 71 | } 72 | 73 | ## Test an instance 74 | subtest '... test an instance of Point' => sub { 75 | my $p = Point->new; 76 | isa_ok($p, 'Point'); 77 | 78 | is_deeply( 79 | mro::get_linear_isa('Point'), 80 | [ 'Point', 'Moxie::Object', 'UNIVERSAL::Object' ], 81 | '... got the expected linear isa' 82 | ); 83 | 84 | is $p->x, 0, '... got the default value for x'; 85 | is $p->y, 0, '... got the default value for y'; 86 | 87 | $p->set_x(10); 88 | is $p->x, 10, '... got the right value for x'; 89 | 90 | $p->set_y(320); 91 | is $p->y, 320, '... got the right value for y'; 92 | 93 | is_deeply $p->pack, { x => 10, y => 320 }, '... got the right value from pack'; 94 | }; 95 | 96 | subtest '... test an instance of Point with args' => sub { 97 | my $p = Point->new( x => 10, y => 20 ); 98 | isa_ok($p, 'Point'); 99 | 100 | is_deeply( 101 | mro::get_linear_isa('Point'), 102 | [ 'Point', 'Moxie::Object', 'UNIVERSAL::Object' ], 103 | '... got the expected linear isa' 104 | ); 105 | 106 | is $p->x, 10, '... got the expected value for x'; 107 | is $p->y, 20, '... got the expected value for y'; 108 | 109 | $p->set_x(10); 110 | is $p->x, 10, '... got the right value for x'; 111 | 112 | $p->set_y(320); 113 | is $p->y, 320, '... got the right value for y'; 114 | 115 | is_deeply $p->pack, { x => 10, y => 320 }, '... got the right value from pack'; 116 | }; 117 | 118 | ## Test the instance 119 | subtest '... test an instance of Point3D' => sub { 120 | my $p3d = Point3D->new(); 121 | isa_ok($p3d, 'Point3D'); 122 | isa_ok($p3d, 'Point'); 123 | 124 | is_deeply( 125 | mro::get_linear_isa('Point3D'), 126 | [ 'Point3D', 'Point', 'Moxie::Object', 'UNIVERSAL::Object' ], 127 | '... got the expected linear isa' 128 | ); 129 | 130 | is $p3d->z, 0, '... got the default value for z'; 131 | 132 | $p3d->set_x(10); 133 | is $p3d->x, 10, '... got the right value for x'; 134 | 135 | $p3d->set_y(320); 136 | is $p3d->y, 320, '... got the right value for y'; 137 | 138 | $p3d->set_z(30); 139 | is $p3d->z, 30, '... got the right value for z'; 140 | 141 | is_deeply $p3d->pack, { x => 10, y => 320, z => 30 }, '... got the right value from pack'; 142 | }; 143 | 144 | subtest '... test an instance of Point3D with args' => sub { 145 | my $p3d = Point3D->new( x => 1, y => 2, z => 3 ); 146 | isa_ok($p3d, 'Point3D'); 147 | isa_ok($p3d, 'Point'); 148 | 149 | is_deeply( 150 | mro::get_linear_isa('Point3D'), 151 | [ 'Point3D', 'Point', 'Moxie::Object', 'UNIVERSAL::Object' ], 152 | '... got the expected linear isa' 153 | ); 154 | 155 | is $p3d->x, 1, '... got the supplied value for x'; 156 | is $p3d->y, 2, '... got the supplied value for y'; 157 | is $p3d->z, 3, '... got the supplied value for z'; 158 | 159 | $p3d->set_x(10); 160 | is $p3d->x, 10, '... got the right value for x'; 161 | 162 | $p3d->set_y(320); 163 | is $p3d->y, 320, '... got the right value for y'; 164 | 165 | $p3d->set_z(30); 166 | is $p3d->z, 30, '... got the right value for z'; 167 | 168 | is_deeply $p3d->pack, { x => 10, y => 320, z => 30 }, '... got the right value from pack'; 169 | }; 170 | 171 | subtest '... meta test' => sub { 172 | 173 | my @MOP_object_methods = qw[ 174 | new BUILDARGS CREATE DESTROY 175 | ]; 176 | 177 | my @Point_methods = qw[ 178 | x set_x 179 | y set_y 180 | pack 181 | clear 182 | ]; 183 | 184 | my @Point3D_methods = qw[ 185 | z set_z 186 | clear 187 | ]; 188 | 189 | subtest '... test Point' => sub { 190 | 191 | my $Point = MOP::Class->new( name => 'Point' ); 192 | isa_ok($Point, 'MOP::Class'); 193 | isa_ok($Point, 'UNIVERSAL::Object'); 194 | 195 | is_deeply($Point->mro, [ 'Point', 'Moxie::Object', 'UNIVERSAL::Object' ], '... got the expected mro'); 196 | is_deeply([ $Point->superclasses ], [ 'Moxie::Object' ], '... got the expected superclasses'); 197 | 198 | foreach ( @Point_methods ) { 199 | ok($Point->has_method( $_ ), '... Point has method ' . $_); 200 | 201 | my $m = $Point->get_method( $_ ); 202 | isa_ok($m, 'MOP::Method'); 203 | is($m->name, $_, '... got the right method name (' . $_ . ')'); 204 | ok(!$m->is_required, '... the ' . $_ . ' method is not a required method'); 205 | is($m->origin_stash, 'Point', '... the ' . $_ . ' method was defined in Point class') 206 | } 207 | 208 | ok(Point->can( $_ ), '... Point can call method ' . $_) 209 | foreach @MOP_object_methods, @Point_methods; 210 | 211 | { 212 | my $m = $Point->get_method( 'set_y' ); 213 | is_deeply([ map $_->original, $m->get_code_attributes ], ['wo(_y)'], '... we show one CODE attribute'); 214 | } 215 | 216 | { 217 | my $m = $Point->get_method( 'y' ); 218 | is_deeply([ map $_->original, $m->get_code_attributes ], ['ro(_y)'], '... we show one CODE attribute'); 219 | } 220 | 221 | }; 222 | 223 | }; 224 | 225 | done_testing; 226 | 227 | 228 | -------------------------------------------------------------------------------- /t/000-samples/002-bank-account.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | use Data::Dumper; 9 | 10 | BEGIN { 11 | use_ok('MOP'); 12 | } 13 | 14 | package BankAccount { 15 | use Moxie 16 | traits => [':experimental']; 17 | 18 | extends 'Moxie::Object'; 19 | 20 | has name => ( required => 'A `name` is required' ); 21 | 22 | has _balance => sub { 0 }; 23 | 24 | my sub _balance : private; 25 | 26 | sub BUILDARGS : strict( 27 | name => name, 28 | balance? => _balance, 29 | ); 30 | 31 | sub name : ro; 32 | sub balance : ro(_balance); 33 | 34 | sub deposit ($self, $amount) { _balance += $amount } 35 | 36 | sub withdraw ($self, $amount) { 37 | (_balance >= $amount) 38 | || die "Account overdrawn"; 39 | _balance -= $amount; 40 | } 41 | } 42 | 43 | package CheckingAccount { 44 | use Moxie 45 | traits => [':experimental']; 46 | 47 | extends 'BankAccount'; 48 | 49 | has _overdraft_account => ( required => 1 ); 50 | 51 | my sub _overdraft_account : private; 52 | 53 | sub BUILDARGS : strict( 54 | name => super(name), 55 | balance? => super(balance), 56 | overdraft_account => _overdraft_account, 57 | ); 58 | 59 | sub overdraft_account : ro(_overdraft_account); 60 | sub available_overdraft_funds : handles(_overdraft_account->balance); 61 | 62 | sub withdraw ($self, $amount) { 63 | my $overdraft_amount = $amount - $self->balance; 64 | if ( _overdraft_account && $overdraft_amount > 0 ) { 65 | _overdraft_account->withdraw( $overdraft_amount ); 66 | $self->deposit( $overdraft_amount ); 67 | } 68 | $self->next::method( $amount ); 69 | } 70 | } 71 | 72 | subtest '... testing the BankAccount class' => sub { 73 | my $savings = BankAccount->new( 74 | name => 'S. Little', 75 | balance => 250, 76 | ); 77 | isa_ok($savings, 'BankAccount' ); 78 | 79 | is $savings->name, 'S. Little', '... got the name we expected'; 80 | is $savings->balance, 250, '... got the savings balance we expected'; 81 | 82 | $savings->withdraw( 50 ); 83 | is $savings->balance, 200, '... got the savings balance we expected'; 84 | 85 | $savings->deposit( 150 ); 86 | is $savings->balance, 350, '... got the savings balance we expected'; 87 | 88 | subtest '... testing the CheckingAccount class' => sub { 89 | 90 | my $checking = CheckingAccount->new( 91 | name => 'S. Little', 92 | overdraft_account => $savings, 93 | ); 94 | isa_ok($checking, 'CheckingAccount'); 95 | isa_ok($checking, 'BankAccount'); 96 | 97 | is $checking->available_overdraft_funds, $savings->balance, '... we have the expected overdraft balance'; 98 | 99 | is $checking->name, 'S. Little', '... got the name we expected'; 100 | is $checking->balance, 0, '... got the checking balance we expected'; 101 | 102 | $checking->deposit( 100 ); 103 | is $checking->balance, 100, '... got the checking balance we expected'; 104 | is $checking->overdraft_account, $savings, '... got the right overdraft account'; 105 | 106 | $checking->withdraw( 50 ); 107 | is $checking->balance, 50, '... got the checking balance we expected'; 108 | is $savings->balance, 350, '... got the savings balance we expected'; 109 | 110 | $checking->withdraw( 200 ); 111 | is $checking->balance, 0, '... got the checking balance we expected'; 112 | is $savings->balance, 200, '... got the savings balance we expected'; 113 | }; 114 | 115 | subtest '... testing the CheckingAccount class (with balance)' => sub { 116 | 117 | my $checking = CheckingAccount->new( 118 | name => 'S. Little', 119 | balance => 300, 120 | overdraft_account => $savings, 121 | ); 122 | isa_ok($checking, 'CheckingAccount'); 123 | isa_ok($checking, 'BankAccount'); 124 | 125 | is $checking->available_overdraft_funds, $savings->balance, '... we have the expected overdraft balance'; 126 | 127 | is $checking->name, 'S. Little', '... got the name we expected'; 128 | is $checking->balance, 300, '... got the checking balance we expected'; 129 | 130 | $checking->deposit( 100 ); 131 | is $checking->balance, 400, '... got the checking balance we expected'; 132 | is $checking->overdraft_account, $savings, '... got the right overdraft account'; 133 | 134 | $checking->withdraw( 50 ); 135 | is $checking->balance, 350, '... got the checking balance we expected'; 136 | is $savings->balance, 200, '... got the savings balance we expected'; 137 | 138 | $checking->withdraw( 400 ); 139 | is $checking->balance, 0, '... got the checking balance we expected'; 140 | is $savings->balance, 150, '... got the savings balance we expected'; 141 | }; 142 | 143 | }; 144 | 145 | subtest '... testing some error conditions' => sub { 146 | 147 | like( 148 | exception { BankAccount->new }, 149 | qr/Constructor for \(BankAccount\) expected between 2 and 4 arguments\, got \(0\)/, 150 | '... the balance argument is required' 151 | ); 152 | 153 | like( 154 | exception { BankAccount->new( foo => 10 ) }, 155 | qr/Constructor for \(BankAccount\) missing \(`.*`\) parameters\, got \(`foo`\)\, expected \(`balance\?`\, `name`\)/, 156 | '... the balance argument is required and unknown arguments are rejected' 157 | ); 158 | 159 | 160 | like( 161 | exception { CheckingAccount->new }, 162 | qr/Constructor for \(CheckingAccount\) expected between 4 and 6 arguments\, got \(0\)/, 163 | '... the balance argument is required' 164 | ); 165 | 166 | like( 167 | exception { CheckingAccount->new( balance => 10 ) }, 168 | qr/Constructor for \(CheckingAccount\) expected between 4 and 6 arguments\, got \(2\)/, 169 | '... the balance argument is required' 170 | ); 171 | 172 | like( 173 | exception { CheckingAccount->new( name => 'Test', balance => 10 ) }, 174 | qr/Constructor for \(CheckingAccount\) missing \(`overdraft_account`\) parameters\, got \(`balance`\, `name`\)\, expected \(`balance\?`\, `name`\, `overdraft_account`\)/, 175 | '... the balance argument is required' 176 | ); 177 | 178 | }; 179 | 180 | done_testing; 181 | 182 | 183 | -------------------------------------------------------------------------------- /t/000-samples/003-binary-tree.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | use Data::Dumper; 9 | use Scalar::Util; 10 | 11 | BEGIN { 12 | use_ok('MOP'); 13 | } 14 | 15 | =pod 16 | 17 | TODO: 18 | 19 | =cut 20 | 21 | 22 | package BinaryTree { 23 | use Moxie 24 | traits => [':experimental']; 25 | 26 | use Scalar::Util (); 27 | 28 | extends 'Moxie::Object'; 29 | 30 | has node => (); 31 | has left => (); 32 | has right => (); 33 | 34 | has _parent => (); 35 | 36 | my sub _parent : private; 37 | 38 | sub BUILDARGS : strict( 39 | node? => _node, 40 | parent? => _parent, 41 | ); 42 | 43 | sub BUILD ($self, $) { Scalar::Util::weaken( _parent ) } 44 | 45 | sub node : rw; 46 | sub parent : ro(_parent); 47 | 48 | sub has_parent : predicate(_parent); 49 | sub has_left : predicate; 50 | sub has_right : predicate; 51 | 52 | sub left ($self) : lazy { $self->new( parent => $self ) } 53 | sub right ($self) : lazy { $self->new( parent => $self ) } 54 | } 55 | 56 | { 57 | my $t = BinaryTree->new; 58 | ok($t->isa('BinaryTree'), '... this is a BinaryTree object'); 59 | 60 | ok(!$t->has_parent, '... this tree has no parent'); 61 | 62 | ok(!$t->has_left, '... left node has not been created yet'); 63 | ok(!$t->has_right, '... right node has not been created yet'); 64 | 65 | ok($t->left->isa('BinaryTree'), '... left is a BinaryTree object'); 66 | ok($t->right->isa('BinaryTree'), '... right is a BinaryTree object'); 67 | 68 | ok($t->has_left, '... left node has now been created'); 69 | ok($t->has_right, '... right node has now been created'); 70 | 71 | ok($t->left->has_parent, '... left has a parent'); 72 | is($t->left->parent, $t, '... and it is us'); 73 | 74 | ok(Scalar::Util::isweak( $t->left->{_parent} ), '... the field was weakened correctly'); 75 | 76 | ok($t->right->has_parent, '... right has a parent'); 77 | is($t->right->parent, $t, '... and it is us'); 78 | 79 | ok(Scalar::Util::isweak( $t->right->{_parent} ), '... the field was weakened correctly'); 80 | } 81 | 82 | { 83 | my $left = BinaryTree->new; 84 | like( 85 | exception { BinaryTree->new( left => $left ) }, 86 | qr/^Constructor for \(BinaryTree\) got unrecognized parameters \(`left`\)/, 87 | '... got the exception we expected' 88 | ); 89 | } 90 | 91 | package MyBinaryTree { 92 | use Moxie; 93 | 94 | extends 'BinaryTree'; 95 | } 96 | 97 | { 98 | my $t = MyBinaryTree->new; 99 | ok($t->isa('MyBinaryTree'), '... this is a MyBinaryTree object'); 100 | ok($t->isa('BinaryTree'), '... this is a BinaryTree object'); 101 | 102 | ok(!$t->has_parent, '... this tree has no parent'); 103 | 104 | ok(!$t->has_left, '... left node has not been created yet'); 105 | ok(!$t->has_right, '... right node has not been created yet'); 106 | 107 | ok($t->left->isa('BinaryTree'), '... left is a BinaryTree object'); 108 | ok($t->right->isa('BinaryTree'), '... right is a BinaryTree object'); 109 | 110 | ok($t->has_left, '... left node has now been created'); 111 | ok($t->has_right, '... right node has now been created'); 112 | 113 | ok(Scalar::Util::isweak( $t->left->{_parent} ), '... the field was weakened correctly'); 114 | ok(Scalar::Util::isweak( $t->right->{_parent} ), '... the field was weakened correctly'); 115 | } 116 | 117 | done_testing; 118 | -------------------------------------------------------------------------------- /t/000-samples/004-linked-list.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Data::Dumper; 8 | 9 | BEGIN { 10 | use_ok('MOP'); 11 | } 12 | 13 | package LinkedList { 14 | use Moxie 15 | traits => [':experimental']; 16 | 17 | extends 'Moxie::Object'; 18 | 19 | has '_head'; 20 | has '_tail'; 21 | has '_count' => ( default => sub { 0 } ); 22 | 23 | my sub _head : private; 24 | my sub _tail : private; 25 | my sub _count : private; 26 | 27 | # public read only accessors 28 | 29 | sub head : ro( _head ); 30 | sub tail : ro( _tail ); 31 | sub count : ro( _count ); 32 | 33 | # methods 34 | 35 | sub append ($self, $node) { 36 | unless ( _tail ) { 37 | _tail = $node; 38 | _head = $node; 39 | _count++; 40 | return; 41 | } 42 | _tail->set_next($node); 43 | $node->set_previous(_tail); 44 | _tail = $node; 45 | _count++; 46 | } 47 | 48 | sub insert ($self, $index, $node) { 49 | die "Index ($index) out of bounds" 50 | if $index < 0 or $index > _count - 1; 51 | 52 | my $tmp = _head; 53 | $tmp = $tmp->get_next while($index--); 54 | $node->set_previous($tmp->get_previous); 55 | $node->set_next($tmp); 56 | $tmp->get_previous->set_next($node); 57 | $tmp->set_previous($node); 58 | _count++; 59 | } 60 | 61 | sub remove ($self, $index) { 62 | die "Index ($index) out of bounds" 63 | if $index < 0 or $index > _count - 1; 64 | 65 | my $tmp = _head; 66 | $tmp = $tmp->get_next while($index--); 67 | $tmp->get_previous->set_next($tmp->get_next); 68 | $tmp->get_next->set_previous($tmp->get_previous); 69 | _count--; 70 | $tmp->detach(); 71 | } 72 | 73 | sub prepend ($self, $node) { 74 | unless ( _head ) { 75 | _tail = $node; 76 | _head = $node; 77 | _count++; 78 | return; 79 | } 80 | _head->set_previous($node); 81 | $node->set_next(_head); 82 | _head = $node; 83 | _count++; 84 | } 85 | 86 | sub sum ($self) { 87 | my $sum = 0; 88 | my $tmp = _head; 89 | do { $sum += $tmp->get_value } while($tmp = $tmp->get_next); 90 | return $sum; 91 | } 92 | } 93 | 94 | package LinkedListNode { 95 | use Moxie 96 | traits => [':experimental']; 97 | 98 | extends 'Moxie::Object'; 99 | 100 | # private slots 101 | 102 | has '_prev'; 103 | has '_next'; 104 | 105 | my sub _prev : private; 106 | my sub _next : private; 107 | 108 | # public slot 109 | 110 | has 'value'; 111 | 112 | # public r/w API 113 | 114 | sub get_previous : ro( _prev ); 115 | sub get_next : ro( _next ); 116 | sub get_value : ro; 117 | 118 | sub set_previous : wo( _prev ); 119 | sub set_next : wo( _next ); 120 | sub set_value : wo; 121 | 122 | sub detach { 123 | _prev = undef; 124 | _next = undef; 125 | $_[0] 126 | } 127 | } 128 | 129 | { 130 | my $ll = LinkedList->new(); 131 | 132 | for (0..9) { 133 | $ll->append( 134 | LinkedListNode->new('value' => $_) 135 | ); 136 | } 137 | 138 | is($ll->head->get_value, 0, '... head is 0'); 139 | is($ll->tail->get_value, 9, '... tail is 9'); 140 | is($ll->count, 10, '... count is 10'); 141 | 142 | $ll->prepend(LinkedListNode->new('value' => -1)); 143 | is($ll->count, 11, '... count is now 11'); 144 | 145 | $ll->insert(5, LinkedListNode->new('value' => 11)); 146 | is($ll->count, 12, '... count is now 12'); 147 | 148 | my $node = $ll->remove(8); 149 | is($ll->count, 11, '... count is 11 again'); 150 | 151 | ok(!$node->get_next, '... detached node does not have a next'); 152 | ok(!$node->get_previous, '... detached node does not have a previous'); 153 | is($node->get_value, 6, '... detached node has the right value'); 154 | ok($node->isa('LinkedListNode'), '... node is a LinkedListNode'); 155 | 156 | eval { $ll->remove(99) }; 157 | like($@, qr/^Index \(99\) out of bounds/, '... removing out of range produced error'); 158 | eval { $ll->insert(-1, LinkedListNode->new('value' => 2)) }; 159 | like($@, qr/^Index \(-1\) out of bounds/, '... inserting out of range produced error'); 160 | 161 | is($ll->sum, 49, '... things sum correctly'); 162 | } 163 | 164 | done_testing; 165 | -------------------------------------------------------------------------------- /t/000-samples/007-currency.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use v5.20; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Data::Dumper; 8 | 9 | BEGIN { 10 | use_ok('MOP'); 11 | } 12 | 13 | BEGIN { 14 | 15 | package Eq { 16 | use Moxie; 17 | 18 | sub equal_to; 19 | 20 | sub not_equal_to ($self, $other) { 21 | not $self->equal_to($other); 22 | } 23 | } 24 | 25 | package Comparable { 26 | use Moxie; 27 | 28 | with 'Eq'; 29 | 30 | sub compare; 31 | 32 | sub equal_to ($self, $other) { 33 | $self->compare($other) == 0; 34 | } 35 | 36 | sub greater_than ($self, $other) { 37 | $self->compare($other) == 1; 38 | } 39 | 40 | sub less_than ($self, $other) { 41 | $self->compare($other) == -1; 42 | } 43 | 44 | sub greater_than_or_equal_to ($self, $other) { 45 | $self->greater_than($other) || $self->equal_to($other); 46 | } 47 | 48 | sub less_than_or_equal_to ($self, $other) { 49 | $self->less_than($other) || $self->equal_to($other); 50 | } 51 | } 52 | 53 | package Printable 0.01 { 54 | use Moxie; 55 | 56 | sub to_string; 57 | } 58 | 59 | package US::Currency 0.01 { 60 | use Moxie; 61 | 62 | extends 'Moxie::Object'; 63 | with 'Comparable', 'Printable'; 64 | 65 | has _amount => ( default => sub { 0 } ); 66 | 67 | sub BUILDARGS : strict( amount? => _amount ); 68 | 69 | sub amount : ro(_amount); 70 | 71 | sub compare ($self, $other) { 72 | $self->amount <=> $other->amount; 73 | } 74 | 75 | sub to_string ($self) { 76 | sprintf '$%0.2f USD' => $self->amount; 77 | } 78 | } 79 | 80 | } 81 | 82 | my $Eq = MOP::Role->new( name => 'Eq' ); 83 | my $Comparable = MOP::Role->new( name => 'Comparable'); 84 | my $Printable = MOP::Role->new( name => 'Printable'); 85 | my $USCurrency = MOP::Class->new( name => 'US::Currency'); 86 | 87 | ok($Comparable->does_role( 'Eq' ), '... Comparable does the Eq role'); 88 | 89 | ok($USCurrency->does_role( 'Eq' ), '... US::Currency does Eq'); 90 | ok($USCurrency->does_role( 'Comparable' ), '... US::Currency does Comparable'); 91 | ok($USCurrency->does_role( 'Printable' ), '... US::Currency does Printable'); 92 | 93 | ok($Eq->requires_method('equal_to'), '... EQ::equal_to is a stub method'); 94 | ok(!$Eq->requires_method('not_equal_to'), '... EQ::not_equal_to is NOT a stub method'); 95 | 96 | is($USCurrency->version, '0.01', '... got the expected version number'); 97 | is($Printable->version, '0.01', '... got the expected version number'); 98 | 99 | { 100 | my $dollar = US::Currency->new( amount => 10 ); 101 | ok($dollar->isa( 'US::Currency' ), '... the dollar is a US::Currency instance'); 102 | ok($dollar->DOES( 'Eq' ), '... the dollar does the Eq role'); 103 | ok($dollar->DOES( 'Comparable' ), '... the dollar does the Comparable role'); 104 | ok($dollar->DOES( 'Printable' ), '... the dollar does the Printable role'); 105 | 106 | can_ok($dollar, 'equal_to'); 107 | can_ok($dollar, 'not_equal_to'); 108 | 109 | can_ok($dollar, 'greater_than'); 110 | can_ok($dollar, 'greater_than_or_equal_to'); 111 | can_ok($dollar, 'less_than'); 112 | can_ok($dollar, 'less_than_or_equal_to'); 113 | 114 | can_ok($dollar, 'compare'); 115 | can_ok($dollar, 'to_string'); 116 | 117 | is($dollar->to_string, '$10.00 USD', '... got the right to_string value'); 118 | 119 | ok($dollar->equal_to( $dollar ), '... we are equal to ourselves'); 120 | ok(!$dollar->not_equal_to( $dollar ), '... we are not not equal to ourselves'); 121 | 122 | ok(US::Currency->new( 'amount' => 20 )->greater_than( $dollar ), '... 20 is greater than 10'); 123 | ok(!US::Currency->new( 'amount' => 2 )->greater_than( $dollar ), '... 2 is not greater than 10'); 124 | 125 | ok(!US::Currency->new( 'amount' => 10 )->greater_than( $dollar ), '... 10 is not greater than 10'); 126 | ok(US::Currency->new( 'amount' => 10 )->greater_than_or_equal_to( $dollar ), '... 10 is greater than or equal to 10'); 127 | } 128 | 129 | { 130 | my $dollar = US::Currency->new; 131 | ok($dollar->isa( 'US::Currency' ), '... the dollar is a US::Currency instance'); 132 | 133 | is($dollar->to_string, '$0.00 USD', '... got the right to_string value'); 134 | } 135 | 136 | done_testing; 137 | 138 | 139 | -------------------------------------------------------------------------------- /t/000-samples/008-cache.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Data::Dumper; 8 | 9 | BEGIN { 10 | use_ok('MOP'); 11 | } 12 | 13 | package Cache { 14 | use Moxie 15 | traits => [':experimental']; 16 | 17 | extends 'Moxie::Object'; 18 | 19 | has '_fetcher' => ( required => 1 ); 20 | has '_data'; 21 | 22 | sub BUILDARGS : strict( fetcher => _fetcher ); 23 | 24 | sub data ($self) : lazy(_data) { $self->{_fetcher}->() } 25 | 26 | sub has_data : predicate(_data); 27 | sub clear : clearer(_data); 28 | } 29 | 30 | my @data = qw[ 31 | one 32 | two 33 | three 34 | ]; 35 | 36 | my $c = Cache->new( fetcher => sub { shift @data } ); 37 | isa_ok($c, 'Cache'); 38 | 39 | ok(!Cache->can('fetcher'), '... out private accessor is not available outside'); 40 | ok(!$c->can('fetcher'), '... out private accessor is not available outside'); 41 | 42 | is($c->data, 'one', '... the data we got is correct'); 43 | ok($c->has_data, '... we have data'); 44 | 45 | $c->clear; 46 | 47 | is($c->data, 'two', '... the data we got is correct (cache has been cleared)'); 48 | is($c->data, 'two', '... the data is still the same'); 49 | ok($c->has_data, '... we have data'); 50 | 51 | $c->clear; 52 | 53 | is($c->data, 'three', '... the data we got is correct (cache has been cleared)'); 54 | ok($c->has_data, '... we have data'); 55 | 56 | $c->clear; 57 | 58 | ok(!$c->has_data, '... we no longer have data'); 59 | is($c->data, undef, '... the cache is empty now'); 60 | 61 | done_testing; 62 | -------------------------------------------------------------------------------- /t/000-samples/009-counter.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Data::Dumper; 8 | 9 | BEGIN { 10 | use_ok('MOP'); 11 | } 12 | 13 | package Counter { 14 | use Moxie 15 | traits => [':experimental']; 16 | 17 | extends 'Moxie::Object'; 18 | 19 | use overload ( 20 | '++' => 'inc', 21 | '--' => 'dec', 22 | ); 23 | 24 | has _count => ( default => sub { 0 } ); 25 | 26 | my sub _count : private; 27 | 28 | sub count : ro(_count); 29 | 30 | # NOTE: 31 | # so apparently the overload 32 | # will pass more values to the 33 | # subroutines then just the 34 | # instance, no idea why though 35 | # it is mostly just garbage. 36 | # - SL 37 | sub inc ($self, @) { _count++ } 38 | sub dec ($self, @) { _count-- } 39 | } 40 | 41 | my $c = Counter->new; 42 | isa_ok($c, 'Counter'); 43 | 44 | is($c->count, 0, '... count is 0'); 45 | 46 | $c++; 47 | is($c->count, 1, '... count is 1'); 48 | 49 | $c->inc; 50 | is($c->count, 2, '... count is 2'); 51 | 52 | $c--; 53 | is($c->count, 1, '... count is 1 again'); 54 | 55 | $c->dec; 56 | is($c->count, 0, '... count is 0 again'); 57 | 58 | done_testing; 59 | -------------------------------------------------------------------------------- /t/000-samples/010-web-framework.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Data::Dumper; 8 | 9 | BEGIN { 10 | use_ok('MOP'); 11 | } 12 | 13 | # traits ... 14 | 15 | package Entity::Traits::Provider { 16 | use Moxie; 17 | 18 | use Method::Traits ':for_providers'; 19 | 20 | sub JSONParameter { () } 21 | } 22 | 23 | package Service::Traits::Provider { 24 | use Moxie; 25 | 26 | use Method::Traits ':for_providers'; 27 | 28 | sub Path ($meta, $method_name, $path) { () } 29 | 30 | sub GET ($meta, $method_name) { () } 31 | sub PUT ($meta, $method_name) { () } 32 | 33 | sub Consumes ($meta, $method_name, $media_type) { () } 34 | sub Produces ($meta, $method_name, $media_type) { () } 35 | } 36 | 37 | # this is the entity class 38 | 39 | package Todo { 40 | use Moxie 41 | traits => [ 'Entity::Traits::Provider' ]; 42 | 43 | extends 'Moxie::Object'; 44 | 45 | has _description => (); 46 | has _is_done => (); 47 | 48 | sub description : ro(_description) JSONParameter; 49 | sub is_done : ro(_is_done) JSONParameter; 50 | } 51 | 52 | # this is the web-service for it 53 | 54 | package TodoService { 55 | use Moxie 56 | traits => [ 'Service::Traits::Provider', ':experimental' ]; 57 | 58 | extends 'Moxie::Object'; 59 | 60 | has 'todos' => ( default => sub { +{} } ); 61 | 62 | my sub todos : private; 63 | 64 | sub get_todo ($self, $id) : Path('/:id') GET Produces('application/json') { 65 | todos->{ $id }; 66 | } 67 | 68 | sub update_todo ($self, $id, $todo) : Path('/:id') PUT Consumes('application/json') { 69 | return unless todos->{ $id }; 70 | todos->{ $id } = $todo; 71 | } 72 | } 73 | 74 | done_testing; 75 | 76 | 77 | =pod 78 | # this is what it ultimately generates ... 79 | package TodoResource { 80 | use Moxie; 81 | 82 | extends 'Web::Machine::Resource'; 83 | 84 | has 'JSON' => sub { JSONinator->new }; 85 | has 'service' => sub { TodoService->new }; 86 | 87 | sub allowed_methods { [qw[ GET PUT ]] } 88 | sub content_types_provided { [{ 'application/json' => 'get_as_json' }]} 89 | sub content_types_accepted { [{ 'application/json' => 'update_with_json' }]} 90 | 91 | sub get_as_json ($self) { 92 | my $id = bind_path('/:id' => $self->request->path_info); 93 | my $res = $self->{service}->get_todo( $id ); 94 | return \404 unless $res; 95 | return $self->{JSON}->collapse( $res ); 96 | } 97 | 98 | sub update_with_json ($self) { 99 | my $id = bind_path('/:id' => $self->request->path_info); 100 | my $e = $self->{JSON}->expand( $self->{service}->entity_class, $self->request->content ) 101 | my $res = $self->{service}->update_todo( $id, $e ); 102 | return \404 unless $res; 103 | return; 104 | } 105 | } 106 | =cut 107 | 108 | -------------------------------------------------------------------------------- /t/001-basic/001-basic.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | package Foo { 9 | use Moxie 10 | traits => [':experimental']; 11 | 12 | extends 'Moxie::Object'; 13 | 14 | has foo => (); 15 | 16 | my sub foo : private; 17 | 18 | sub bar { 'Foo::bar' } 19 | 20 | sub baz ($self, $x) { 21 | join "::" => $self, 'baz', $x 22 | } 23 | 24 | sub test ($self, $x = undef) { 25 | foo = $x if $x; 26 | foo; 27 | } 28 | 29 | sub test_bar ($self) { $self->bar . "x2" } 30 | } 31 | 32 | is_deeply( 33 | mro::get_linear_isa('Foo'), 34 | [ 'Foo', 'Moxie::Object', 'UNIVERSAL::Object' ], 35 | '... got the expected linear isa' 36 | ); 37 | 38 | is(Foo->bar, 'Foo::bar', '... simple test works'); 39 | is(Foo->baz('hi'), 'Foo::baz::hi', '... another test works'); 40 | 41 | my $foo = Foo->new; 42 | isa_ok($foo, 'Foo'); 43 | 44 | is($foo->bar, 'Foo::bar', '... simple test works'); 45 | is($foo->baz('hi'), $foo . '::baz::hi', '... another test works'); 46 | 47 | is($foo->test(10), 10, '... got the right value'); 48 | is($foo->test, 10, '... got the right value'); 49 | is($foo->test(20), 20, '... got the right value'); 50 | is($foo->test, 20, '... got the right value'); 51 | is_deeply($foo->test([ 1, 2, 3 ]), [ 1, 2, 3 ], '... got the right value'); 52 | is_deeply($foo->test, [ 1, 2, 3 ], '... got the right value'); 53 | 54 | is($foo->test_bar, 'Foo::barx2', '... got the value we expected'); 55 | 56 | done_testing; 57 | -------------------------------------------------------------------------------- /t/001-basic/001-new.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | 9 | =pod 10 | 11 | Every new instance created should be a new reference 12 | but it should link back to the same class data. 13 | 14 | =cut 15 | 16 | package Foo { 17 | use Moxie; 18 | 19 | extends 'Moxie::Object'; 20 | } 21 | 22 | my $foo = Foo->new; 23 | ok( $foo->isa( 'Foo' ), '... the object is from class Foo' ); 24 | ok( $foo->isa( 'UNIVERSAL::Object' ), '... the object is derived from class Object' ); 25 | is( Scalar::Util::blessed($foo), 'Foo', '... the class of this object is Foo' ); 26 | 27 | { 28 | my $foo2 = Foo->new; 29 | ok( $foo2->isa( 'Foo' ), '... the object is from class Foo' ); 30 | ok( $foo2->isa( 'UNIVERSAL::Object' ), '... the object is derived from class Object' ); 31 | is( Scalar::Util::blessed($foo), 'Foo', '... the class of this object is Foo' ); 32 | 33 | isnt( $foo, $foo2, '... these are not the same objects' ); 34 | is( Scalar::Util::blessed($foo), Scalar::Util::blessed($foo2), '... these two objects share the same class' ); 35 | } 36 | 37 | package Bar { 38 | use Moxie 39 | traits => [':experimental']; 40 | 41 | extends 'Moxie::Object'; 42 | 43 | has _foo => (); 44 | 45 | my sub _foo : private; 46 | 47 | sub BUILDARGS : strict( foo? => _foo ); 48 | 49 | sub foo { _foo } 50 | } 51 | 52 | { 53 | my $bar = Bar->new; 54 | isa_ok($bar, 'Bar'); 55 | is($bar->foo, undef, '... defaults to undef'); 56 | } 57 | 58 | { 59 | my $bar = Bar->new( foo => 10 ); 60 | isa_ok($bar, 'Bar'); 61 | is($bar->foo, 10, '... keyword args to new work'); 62 | } 63 | 64 | { 65 | my $bar = Bar->new({ foo => 10 }); 66 | isa_ok($bar, 'Bar'); 67 | is($bar->foo, 10, '... keyword args to new work'); 68 | } 69 | 70 | done_testing; 71 | -------------------------------------------------------------------------------- /t/001-basic/002-new-w-attributes.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | =pod 9 | 10 | Every new instance created should be a new reference 11 | and all slot data in it should be a clone of the 12 | original data itself, unless you reference something 13 | that already exists, then it will work as expected. 14 | 15 | This also illustrates that everything happens at 16 | compile time. 17 | 18 | NOTE: 19 | This test might not be that useful, consider reworking 20 | it to something that actually illustrates both sides 21 | of the case. 22 | 23 | =cut 24 | 25 | our $BAZ; BEGIN { $BAZ = [] }; 26 | 27 | package Foo { 28 | use Moxie 29 | traits => [':experimental']; 30 | 31 | extends 'Moxie::Object'; 32 | 33 | has _bar => (default => sub { +{ baz => $::BAZ } }); 34 | 35 | my sub _bar : private; 36 | 37 | sub bar { _bar } 38 | } 39 | 40 | my $foo = Foo->new; 41 | is_deeply( $foo->bar, { baz => [] }, '... got the expected value' ); 42 | is( $foo->bar->{'baz'}, $BAZ, '... these are the same values' ); 43 | 44 | { 45 | my $foo2 = Foo->new; 46 | is_deeply( $foo2->bar, { baz => [] }, '... got the expected value' ); 47 | 48 | isnt( $foo->bar, $foo2->bar, '... these are the same values' ); 49 | is( $foo2->bar->{'baz'}, $BAZ, '... these are the same values' ); 50 | is( $foo->bar->{'baz'}, $foo2->bar->{'baz'}, '... these are the same values' ); 51 | } 52 | 53 | package Bar { 54 | use Moxie 55 | traits => [':experimental']; 56 | 57 | extends 'Moxie::Object'; 58 | 59 | has _bar => (default => sub { +{ baz => $::BAZ } }); 60 | 61 | my sub _bar : private; 62 | 63 | sub bar { _bar } 64 | } 65 | 66 | my $bar = Bar->new; 67 | is_deeply( $bar->bar, { baz => [] }, '... got the expected value' ); 68 | 69 | { 70 | my $bar2 = Bar->new; 71 | is_deeply( $bar2->bar, { baz => [] }, '... got the expected value' ); 72 | 73 | isnt( $bar->bar, $bar2->bar, '... these are not the same values' ); 74 | is( $bar->bar->{'baz'}, $bar2->bar->{'baz'}, '... these are not the same values' ); 75 | } 76 | 77 | done_testing; 78 | 79 | -------------------------------------------------------------------------------- /t/001-basic/003-BUILD.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | package Foo { 9 | use Moxie 10 | traits => [':experimental']; 11 | 12 | extends 'Moxie::Object'; 13 | 14 | has _collector => ( default => sub { [] } ); 15 | 16 | my sub _collector : private; 17 | 18 | sub collector : ro(_collector); 19 | 20 | sub collect ($self, $stuff) { 21 | push _collector->@* => $stuff; 22 | } 23 | 24 | sub BUILD ($self, $params) { 25 | $self->collect( 'Foo' ); 26 | } 27 | } 28 | 29 | package Bar { 30 | use Moxie; 31 | 32 | extends 'Foo'; 33 | 34 | sub BUILD ($self, $params) { 35 | $self->collect( 'Bar' ); 36 | } 37 | } 38 | 39 | package Baz { 40 | use Moxie; 41 | 42 | extends 'Bar'; 43 | 44 | sub BUILD ($self, $params) { 45 | $self->collect( 'Baz' ); 46 | } 47 | } 48 | 49 | my $foo = Foo->new; 50 | is_deeply($foo->collector, ['Foo'], '... got the expected collection'); 51 | 52 | { 53 | my $foo2 = Foo->new; 54 | isnt( $foo->collector, $foo2->collector, '... we have two different array refs' ); 55 | } 56 | 57 | my $bar = Bar->new; 58 | is_deeply($bar->collector, ['Foo', 'Bar'], '... got the expected collection'); 59 | isnt( $foo->collector, $bar->collector, '... we have two different array refs' ); 60 | 61 | my $baz = Baz->new; 62 | is_deeply($baz->collector, ['Foo', 'Bar', 'Baz'], '... got the expected collection'); 63 | isnt( $foo->collector, $baz->collector, '... we have two different array refs' ); 64 | isnt( $bar->collector, $baz->collector, '... we have two different array refs' ); 65 | 66 | done_testing; 67 | -------------------------------------------------------------------------------- /t/001-basic/004-DEMOLISH.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | my $collector; 9 | 10 | package Foo { 11 | use Moxie; 12 | 13 | extends 'Moxie::Object'; 14 | 15 | sub collect ($self, $stuff) { 16 | push @{ $collector } => $stuff; 17 | } 18 | 19 | sub DEMOLISH ($self) { 20 | $self->collect( 'Foo' ); 21 | } 22 | } 23 | 24 | package Bar { 25 | use Moxie; 26 | 27 | extends 'Foo'; 28 | 29 | sub DEMOLISH ($self) { 30 | $self->collect( 'Bar' ); 31 | } 32 | } 33 | 34 | package Baz { 35 | use Moxie; 36 | 37 | extends 'Bar'; 38 | 39 | sub DEMOLISH ($self) { 40 | $self->collect( 'Baz' ); 41 | } 42 | } 43 | 44 | 45 | $collector = []; 46 | Foo->new; 47 | is_deeply($collector, ['Foo'], '... got the expected collection'); 48 | 49 | $collector = []; 50 | Bar->new; 51 | is_deeply($collector, ['Bar', 'Foo'], '... got the expected collection'); 52 | 53 | $collector = []; 54 | Baz->new; 55 | is_deeply($collector, ['Baz', 'Bar', 'Foo'], '... got the expected collection'); 56 | 57 | done_testing; 58 | -------------------------------------------------------------------------------- /t/001-basic/005-attribute-override.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | =pod 9 | 10 | This test is from p5-MOP-redux to show an oddity 11 | that worked the opposite of what people might 12 | expect, which is not the case here, so we keep 13 | the test, but change what is expected. We keep the 14 | original comment for posterity. 15 | 16 | # NOTE FROM p5-MOP-redux TEST 17 | 18 | This test illustrates how the slots are 19 | private and allocated on a per-class basis. 20 | So when you override an slot in a subclass 21 | the methods of the superclass will not get 22 | the value 'virtually', since the storage is 23 | class specific. 24 | 25 | This is perhaps not ideal, the older p5-MOP 26 | prototype did the opposite and in some ways 27 | that is more what I think people would expect. 28 | 29 | The solution to making this work like the 30 | older prototype would be to lookup the 31 | slot storage hash on each method call, 32 | this should then give us the virtual behavior 33 | but it seems a lot of overhead, so perhaps 34 | I will just punt until we do the real thing. 35 | 36 | =cut 37 | 38 | package Foo { 39 | use Moxie; 40 | 41 | extends 'Moxie::Object'; 42 | 43 | has _bar => ( default => sub { 10 } ); 44 | 45 | sub bar : ro(_bar); 46 | } 47 | 48 | package FooBar { 49 | use Moxie; 50 | 51 | extends 'Foo'; 52 | 53 | has _bar => ( default => sub { 100 } ); 54 | 55 | sub derived_bar : ro(_bar); 56 | } 57 | 58 | my $foobar = FooBar->new; 59 | 60 | is($foobar->bar, 100, '... got the expected value (for the superclass method)'); 61 | is($foobar->derived_bar, 100, '... got the expected value (for the derived method)'); 62 | 63 | done_testing; 64 | -------------------------------------------------------------------------------- /t/001-basic/006-next-method.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | package Foo { 9 | use Moxie; 10 | 11 | extends 'Moxie::Object'; 12 | 13 | sub foo { "FOO" } 14 | sub baz { "BAZ" } 15 | } 16 | 17 | package FooBar { 18 | use Moxie; 19 | 20 | extends 'Foo'; 21 | 22 | sub foo ($self) { $self->next::method . "-FOOBAR" } 23 | sub bar ($self) { $self->next::can } 24 | sub baz ($self) { $self->next::can } 25 | } 26 | 27 | package FooBarBaz { 28 | use Moxie; 29 | 30 | extends 'FooBar'; 31 | 32 | sub foo ($self) { $self->next::method . "-FOOBARBAZ" } 33 | } 34 | 35 | package FooBarBazGorch { 36 | use Moxie; 37 | 38 | extends 'FooBarBaz'; 39 | 40 | sub foo ($self) { $self->next::method . "-FOOBARBAZGORCH" } 41 | } 42 | 43 | my $foo = FooBarBazGorch->new; 44 | ok( $foo->isa( 'FooBarBazGorch' ), '... the object is from class FooBarBazGorch' ); 45 | ok( $foo->isa( 'FooBarBaz' ), '... the object is from class FooBarBaz' ); 46 | ok( $foo->isa( 'FooBar' ), '... the object is from class FooBar' ); 47 | ok( $foo->isa( 'Foo' ), '... the object is from class Foo' ); 48 | ok( $foo->isa( 'UNIVERSAL::Object' ), '... the object is derived from class Object' ); 49 | 50 | is( $foo->foo, 'FOO-FOOBAR-FOOBARBAZ-FOOBARBAZGORCH', '... got the chained super calls as expected'); 51 | 52 | is($foo->bar, undef, '... no next method'); 53 | 54 | my $method = $foo->baz; 55 | is(ref $method, 'CODE', '... got back a code ref'); 56 | is($method->($foo), 'BAZ', '... got the method we expected'); 57 | 58 | done_testing; 59 | -------------------------------------------------------------------------------- /t/001-basic/007-class-methods.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | package Foo { 9 | use Moxie 10 | traits => [':experimental']; 11 | 12 | extends 'Moxie::Object'; 13 | 14 | has _bar => (); 15 | 16 | my sub _bar : private; 17 | 18 | sub bar ($self, $x = undef) { 19 | _bar = $x if $x; 20 | _bar + 1; 21 | } 22 | } 23 | 24 | eval { Foo->bar(10) }; 25 | like( 26 | $@, 27 | qr/^Can\'t use string \(\"Foo\"\) as a HASH ref while \"strict refs\" in use/, 28 | '... got the error we expected' 29 | ); 30 | 31 | eval { Foo->bar() }; 32 | like( 33 | $@, 34 | qr/^Can\'t use string \(\"Foo\"\) as a HASH ref while \"strict refs\" in use/, 35 | '... got the error we expected' 36 | ); 37 | 38 | my $foo = Foo->new; 39 | isa_ok($foo, 'Foo'); 40 | { 41 | my $result = eval { $foo->bar(10) }; 42 | is($@, "", '... did not die'); 43 | is($result, 11, '... and the method worked'); 44 | is($foo->bar, 11, '... and the slot assignment worked'); 45 | } 46 | 47 | done_testing; 48 | -------------------------------------------------------------------------------- /t/001-basic/014-loading-from-disk.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use File::Basename (); 7 | use File::Spec (); 8 | use lib File::Spec->catdir( File::Spec->rel2abs( File::Basename::dirname(__FILE__) ), '../lib' ); 9 | 10 | use Test::More; 11 | 12 | use Foo::Bar; 13 | 14 | my $foo = Foo::Bar->new; 15 | ok( $foo->isa( 'Foo::Bar' ), '... the object is from class Foo' ); 16 | ok( $foo->isa( 'Moxie::Object' ), '... the object is derived from class Object' ); 17 | ok( $foo->isa( 'UNIVERSAL::Object' ), '... the object is derived from base Object' ); 18 | 19 | done_testing; 20 | -------------------------------------------------------------------------------- /t/001-basic/015-inheritance-loading-from-disk.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use File::Basename (); 7 | use File::Spec (); 8 | use lib File::Spec->catdir( File::Spec->rel2abs( File::Basename::dirname(__FILE__) ), '../lib' ); 9 | 10 | use Test::More; 11 | 12 | use_ok 'Level3', '... use Level3 works'; 13 | 14 | is_deeply( 15 | mro::get_linear_isa('Level3'), 16 | [ 'Level3', 'Level2', 'Level1', 'Root', 'Moxie::Object', 'UNIVERSAL::Object' ], 17 | '... Level3 MRO contains all relevant classes' 18 | ); 19 | 20 | my $level3 = Level3->new( foo => 10 ); 21 | isa_ok($level3, 'Level3'); 22 | isa_ok($level3, 'Level2'); 23 | isa_ok($level3, 'Level1'); 24 | isa_ok($level3, 'Root'); 25 | isa_ok($level3, 'Moxie::Object'); 26 | isa_ok($level3, 'UNIVERSAL::Object'); 27 | 28 | is($level3->foo, 10, '... got the right value from our attribute'); 29 | 30 | done_testing; 31 | 32 | __END__ 33 | -------------------------------------------------------------------------------- /t/001-basic/017-method-closures.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | 6 | use MOP; 7 | 8 | our $x; 9 | 10 | package Foo { 11 | use Moxie; 12 | 13 | extends 'Moxie::Object'; 14 | 15 | sub inc { ++$::x } 16 | sub dec { --$::x } 17 | } 18 | 19 | { 20 | $x = 1; 21 | 22 | my $foo = Foo->new; 23 | 24 | is($x, 1); 25 | is($foo->inc, 2); 26 | is($foo->inc, 3); 27 | is($x, 3); 28 | is($foo->dec, 2); 29 | is($foo->dec, 1); 30 | is($x, 1); 31 | } 32 | 33 | our $y; 34 | 35 | package Bar { 36 | use Moxie; 37 | 38 | extends 'Moxie::Object'; 39 | 40 | sub get_y; 41 | 42 | sub inc { ++$::y } 43 | sub dec { --$::y } 44 | } 45 | 46 | package Baz { 47 | use Moxie; 48 | 49 | extends 'Bar'; 50 | 51 | sub get_y { $::y } 52 | } 53 | 54 | { 55 | $y = 1; 56 | 57 | my $baz = Baz->new; 58 | 59 | is($baz->get_y, 1); 60 | is($baz->inc, 2); 61 | is($baz->inc, 3); 62 | is($baz->get_y, 3); 63 | is($baz->dec, 2); 64 | is($baz->dec, 1); 65 | is($baz->get_y, 1); 66 | } 67 | 68 | done_testing; 69 | -------------------------------------------------------------------------------- /t/001-basic/020-simple-attributes.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | =pod 9 | 10 | ... 11 | 12 | =cut 13 | 14 | package Foo { 15 | use Moxie 16 | traits => [':experimental']; 17 | 18 | extends 'Moxie::Object'; 19 | 20 | has _bar => (); 21 | 22 | my sub _bar : private; 23 | 24 | sub BUILDARGS : strict( bar? => _bar ); 25 | 26 | sub bar ($self) { _bar } 27 | 28 | sub has_bar ($self) { defined _bar } 29 | sub set_bar ($self, $b) { _bar = $b } 30 | sub init_bar ($self) { _bar = 200 } 31 | sub clear_bar ($self) { undef _bar } 32 | } 33 | 34 | package Foo::Auto { 35 | use Moxie 36 | traits => [':experimental']; 37 | 38 | extends 'Moxie::Object'; 39 | 40 | has _bar => (); 41 | 42 | my sub _bar : private; 43 | 44 | sub BUILDARGS : strict( bar? => _bar ); 45 | 46 | sub bar : ro(_bar); 47 | sub set_bar : wo(_bar); 48 | sub has_bar : predicate(_bar); 49 | sub clear_bar : clearer(_bar); 50 | 51 | sub init_bar ($self) { $self->{_bar} = 200 } 52 | } 53 | 54 | foreach my $foo ( Foo->new, Foo::Auto->new ) { 55 | ok( $foo->isa( 'UNIVERSAL::Object' ), '... the object is from class UNIVERSAL::Object' ); 56 | ok( $foo->isa( 'Foo' ) || $foo->isa( 'Foo::Auto' ), '... the object is from class Foo or Foo::Auto' ); 57 | 58 | ok(!$foo->has_bar, '... no bar is set'); 59 | is($foo->bar, undef, '... values are undefined when they are not initialized'); 60 | 61 | eval { $foo->init_bar }; 62 | is($@, "", '... initialized bar without error'); 63 | ok($foo->has_bar, '... bar is set'); 64 | is($foo->bar, 200, '... value is initialized by the init_bar method'); 65 | 66 | eval { $foo->set_bar(1000) }; 67 | is($@, "", '... set bar without error'); 68 | ok($foo->has_bar, '... bar is set'); 69 | is($foo->bar, 1000, '... value is set by the set_bar method'); 70 | 71 | eval { $foo->clear_bar }; 72 | is($@, "", '... set bar without error'); 73 | ok(!$foo->has_bar, '... no bar is set'); 74 | is($foo->bar, undef, '... values has been cleared'); 75 | } 76 | 77 | foreach my $foo ( Foo->new( bar => 10 ), Foo::Auto->new( bar => 10 ) ) { 78 | ok( $foo->isa( 'UNIVERSAL::Object' ), '... the object is from class UNIVERSAL::Object' ); 79 | ok( $foo->isa( 'Foo' ) || $foo->isa( 'Foo::Auto' ), '... the object is from class Foo or Foo::Auto' ); 80 | 81 | ok($foo->has_bar, '... a bar is set'); 82 | is($foo->bar, 10, '... values are initialized via the constructor'); 83 | 84 | eval { $foo->init_bar }; 85 | is($@, "", '... initialized bar without error'); 86 | ok($foo->has_bar, '... bar is set'); 87 | is($foo->bar, 200, '... value is initialized by the init_bar method'); 88 | 89 | eval { $foo->set_bar(1000) }; 90 | is($@, "", '... set bar without error'); 91 | ok($foo->has_bar, '... bar is set'); 92 | is($foo->bar, 1000, '... value is set by the set_bar method'); 93 | 94 | eval { $foo->clear_bar }; 95 | is($@, "", '... set bar without error'); 96 | ok(!$foo->has_bar, '... no bar is set'); 97 | is($foo->bar, undef, '... values has been cleared'); 98 | } 99 | 100 | 101 | done_testing; 102 | -------------------------------------------------------------------------------- /t/001-basic/021-attributes-w-defaults.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | =pod 9 | 10 | ... 11 | 12 | =cut 13 | 14 | package Foo { 15 | use Moxie 16 | traits => [':experimental']; 17 | 18 | extends 'Moxie::Object'; 19 | 20 | has _bar => sub { 100 }; 21 | 22 | my sub _bar : private; 23 | 24 | sub BUILDARGS : strict( bar? => _bar ); 25 | 26 | sub bar ($self) { _bar } 27 | 28 | sub has_bar ($self) { defined _bar } 29 | sub set_bar ($self, $b) { _bar = $b } 30 | sub init_bar ($self) { _bar = 200 } 31 | sub clear_bar ($self) { undef _bar } 32 | } 33 | 34 | package Foo::Auto { 35 | use Moxie 36 | traits => [':experimental']; 37 | 38 | extends 'Moxie::Object'; 39 | 40 | has _bar => sub { 100 }; 41 | 42 | my sub _bar : private; 43 | 44 | sub BUILDARGS : strict( bar? => _bar ); 45 | 46 | sub bar : ro(_bar); 47 | sub set_bar : wo(_bar); 48 | sub has_bar : predicate(_bar); 49 | sub clear_bar : clearer(_bar); 50 | 51 | sub init_bar ($self) { _bar = 200 } 52 | } 53 | 54 | foreach my $foo ( Foo->new, Foo::Auto->new ) { 55 | ok( $foo->isa( 'UNIVERSAL::Object' ), '... the object is from class UNIVERSAL::Object' ); 56 | ok( $foo->isa( 'Foo' ) || $foo->isa( 'Foo::Auto' ), '... the object is from class Foo or Foo::Auto' ); 57 | 58 | ok($foo->has_bar, '... a bar is set'); 59 | is($foo->bar, 100, '... values are defined'); 60 | 61 | eval { $foo->init_bar }; 62 | is($@, "", '... initialized bar without error'); 63 | is($foo->bar, 200, '... value is initialized by the init_bar method'); 64 | 65 | eval { $foo->set_bar(1000) }; 66 | is($@, "", '... set bar without error'); 67 | is($foo->bar, 1000, '... value is set by the set_bar method'); 68 | 69 | eval { $foo->clear_bar }; 70 | is($@, "", '... set bar without error'); 71 | ok(!$foo->has_bar, '... no bar is set'); 72 | is($foo->bar, undef, '... values has been cleared'); 73 | } 74 | 75 | foreach my $foo ( Foo->new( bar => 10 ), Foo::Auto->new( bar => 10 ) ) { 76 | ok( $foo->isa( 'UNIVERSAL::Object' ), '... the object is from class UNIVERSAL::Object' ); 77 | ok( $foo->isa( 'Foo' ) || $foo->isa( 'Foo::Auto' ), '... the object is from class Foo or Foo::Auto' ); 78 | 79 | ok($foo->has_bar, '... a bar is set'); 80 | is($foo->bar, 10, '... values are initialized via the constructor'); 81 | 82 | eval { $foo->init_bar }; 83 | is($@, "", '... initialized bar without error'); 84 | ok($foo->has_bar, '... a bar is set'); 85 | is($foo->bar, 200, '... value is initialized by the init_bar method'); 86 | 87 | eval { $foo->set_bar(1000) }; 88 | is($@, "", '... set bar without error'); 89 | ok($foo->has_bar, '... a bar is set'); 90 | is($foo->bar, 1000, '... value is set by the set_bar method'); 91 | 92 | eval { $foo->clear_bar }; 93 | is($@, "", '... set bar without error'); 94 | ok(!$foo->has_bar, '... no bar is set'); 95 | is($foo->bar, undef, '... values has been cleared'); 96 | } 97 | 98 | 99 | done_testing; 100 | -------------------------------------------------------------------------------- /t/001-basic/022-attributes-w-lazy-defaults.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | =pod 9 | 10 | ... 11 | 12 | =cut 13 | 14 | package Foo { 15 | use Moxie 16 | traits => [':experimental']; 17 | 18 | extends 'Moxie::Object'; 19 | 20 | has _bar => (); 21 | 22 | my sub _bar : private; 23 | 24 | sub BUILDARGS : strict( bar? => _bar ); 25 | 26 | sub init_bar ($self) { _bar = 200 } 27 | sub bar ($self) { _bar //= 333 } 28 | 29 | sub has_bar : predicate(_bar); 30 | sub set_bar : wo(_bar); 31 | sub clear_bar : clearer(_bar); 32 | } 33 | 34 | { 35 | my $foo = Foo->new; 36 | ok( $foo->isa( 'Foo' ), '... the object is from class Foo' ); 37 | 38 | ok(!$foo->has_bar, '... no bar is set'); 39 | is($foo->bar, 333, '... values are defined'); 40 | 41 | ok($foo->has_bar, '... bar is now set'); 42 | 43 | eval { $foo->init_bar }; 44 | is($@, "", '... initialized bar without error'); 45 | is($foo->bar, 200, '... value is initialized by the init_bar method'); 46 | 47 | eval { $foo->set_bar(1000) }; 48 | is($@, "", '... set bar without error'); 49 | is($foo->bar, 1000, '... value is set by the set_bar method'); 50 | 51 | eval { $foo->clear_bar }; 52 | is($@, "", '... set bar without error'); 53 | ok(!$foo->has_bar, '... no bar is set'); 54 | is($foo->bar, 333, '... lazy value is recalculated'); 55 | 56 | eval { $foo->set_bar(undef) }; 57 | is($@, "", '... set bar without error'); 58 | ok(!$foo->has_bar, '... no bar is set'); 59 | is($foo->bar, 333, '... lazy value is recalculated'); 60 | } 61 | 62 | { 63 | my $foo = Foo->new( bar => 10 ); 64 | ok( $foo->isa( 'Foo' ), '... the object is from class Foo' ); 65 | 66 | ok($foo->has_bar, '... bar is set'); 67 | is($foo->bar, 10, '... values are initialized via the constructor'); 68 | 69 | eval { $foo->init_bar }; 70 | is($@, "", '... initialized bar without error'); 71 | is($foo->bar, 200, '... value is initialized by the init_bar method'); 72 | 73 | eval { $foo->set_bar(1000) }; 74 | is($@, "", '... set bar without error'); 75 | is($foo->bar, 1000, '... value is set by the set_bar method'); 76 | 77 | eval { $foo->clear_bar }; 78 | is($@, "", '... set bar without error'); 79 | ok(!$foo->has_bar, '... no bar is set'); 80 | is($foo->bar, 333, '... lazy value is recalculated'); 81 | 82 | eval { $foo->set_bar(undef) }; 83 | is($@, "", '... set bar without error'); 84 | ok(!$foo->has_bar, '... no bar is set'); 85 | is($foo->bar, 333, '... lazy value is recalculated'); 86 | } 87 | 88 | 89 | done_testing; 90 | -------------------------------------------------------------------------------- /t/001-basic/023-attributes-w-lazy-accessor.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | =pod 9 | 10 | ... 11 | 12 | =cut 13 | 14 | package Foo { 15 | use Moxie 16 | traits => [':experimental']; 17 | 18 | extends 'Moxie::Object'; 19 | 20 | has '_bar'; 21 | 22 | my sub _bar : private; 23 | 24 | sub BUILDARGS : strict( bar? => _bar ); 25 | 26 | sub init_bar ($self) { _bar = 200 } 27 | sub bar ($self, $b = undef) { 28 | _bar = $b if $b; 29 | _bar //= 333; 30 | } 31 | 32 | sub has_bar : predicate(_bar); 33 | sub clear_bar : clearer(_bar); 34 | } 35 | 36 | { 37 | my $foo = Foo->new; 38 | ok( $foo->isa( 'Foo' ), '... the object is from class Foo' ); 39 | 40 | ok(!$foo->has_bar, '... no bar is set'); 41 | is($foo->bar, 333, '... values are defined'); 42 | 43 | ok($foo->has_bar, '... bar is now set'); 44 | eval { $foo->bar(1000) }; 45 | is($@, "", '... set bar without error'); 46 | is($foo->bar, 1000, '... value is set by the set_bar method'); 47 | 48 | eval { $foo->init_bar }; 49 | is($@, "", '... initialized bar without error'); 50 | is($foo->bar, 200, '... value is initialized by the init_bar method'); 51 | 52 | eval { $foo->clear_bar }; 53 | is($@, "", '... set bar without error'); 54 | ok(!$foo->has_bar, '... no bar is set'); 55 | is($foo->bar, 333, '... lazy value is recalculated'); 56 | } 57 | 58 | { 59 | my $foo = Foo->new( bar => 10 ); 60 | ok( $foo->isa( 'Foo' ), '... the object is from class Foo' ); 61 | 62 | ok($foo->has_bar, '... bar is set'); 63 | is($foo->bar, 10, '... values are initialized via the constructor'); 64 | 65 | eval { $foo->bar(1000) }; 66 | is($@, "", '... set bar without error'); 67 | is($foo->bar, 1000, '... value is set by the set_bar method'); 68 | 69 | eval { $foo->init_bar }; 70 | is($@, "", '... initialized bar without error'); 71 | is($foo->bar, 200, '... value is initialized by the init_bar method'); 72 | 73 | eval { $foo->clear_bar }; 74 | is($@, "", '... set bar without error'); 75 | ok(!$foo->has_bar, '... no bar is set'); 76 | is($foo->bar, 333, '... lazy value is recalculated'); 77 | } 78 | 79 | 80 | done_testing; 81 | -------------------------------------------------------------------------------- /t/001-basic/024-attributes-w-complex-defaults.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | =pod 9 | 10 | ... 11 | 12 | =cut 13 | 14 | package Foo { 15 | use Moxie 16 | traits => [':experimental']; 17 | 18 | extends 'Moxie::Object'; 19 | 20 | has '_bar' => sub { [] }; 21 | 22 | my sub _bar : private; 23 | 24 | sub BUILDARGS : strict( bar? => _bar ); 25 | 26 | sub bar : ro(_bar); 27 | sub has_bar : predicate(_bar); 28 | sub set_bar : wo(_bar); 29 | sub clear_bar : clearer(_bar); 30 | 31 | sub init_bar ($self) { _bar = [ 1, 2, 3 ] } 32 | } 33 | 34 | { 35 | my $foo = Foo->new; 36 | ok( $foo->isa( 'Foo' ), '... the object is from class Foo' ); 37 | 38 | ok($foo->has_bar, '... a bar is set'); 39 | is_deeply($foo->bar, [], '... values are defined'); 40 | 41 | eval { $foo->init_bar }; 42 | is($@, "", '... initialized bar without error'); 43 | is_deeply($foo->bar, [ 1, 2, 3 ], '... value is initialized by the init_bar method'); 44 | 45 | eval { $foo->set_bar([1000]) }; 46 | is($@, "", '... set bar without error'); 47 | is_deeply($foo->bar, [1000], '... value is set by the set_bar method'); 48 | 49 | eval { $foo->clear_bar }; 50 | is($@, "", '... set bar without error'); 51 | ok(!$foo->has_bar, '... no bar is set'); 52 | is($foo->bar, undef, '... values has been cleared'); 53 | 54 | { 55 | my $foo2 = Foo->new; 56 | isnt($foo->bar, $foo2->bar, '... different instances have different refs'); 57 | } 58 | } 59 | 60 | { 61 | my $foo = Foo->new( bar => [10] ); 62 | ok( $foo->isa( 'Foo' ), '... the object is from class Foo' ); 63 | 64 | ok($foo->has_bar, '... a bar is set'); 65 | is_deeply($foo->bar, [10], '... values are initialized via the constructor'); 66 | 67 | eval { $foo->init_bar }; 68 | is($@, "", '... initialized bar without error'); 69 | ok($foo->has_bar, '... a bar is set'); 70 | is_deeply($foo->bar, [1, 2, 3], '... value is initialized by the init_bar method'); 71 | 72 | eval { $foo->set_bar([1000]) }; 73 | is($@, "", '... set bar without error'); 74 | ok($foo->has_bar, '... a bar is set'); 75 | is_deeply($foo->bar, [1000], '... value is set by the set_bar method'); 76 | 77 | eval { $foo->clear_bar }; 78 | is($@, "", '... set bar without error'); 79 | ok(!$foo->has_bar, '... no bar is set'); 80 | is($foo->bar, undef, '... values has been cleared'); 81 | } 82 | 83 | 84 | done_testing; 85 | -------------------------------------------------------------------------------- /t/001-basic/025-attributes-w-lazy-complex-default.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | 9 | =pod 10 | 11 | ... 12 | 13 | =cut 14 | 15 | package Foo { 16 | use Moxie 17 | traits => [':experimental']; 18 | 19 | extends 'Moxie::Object'; 20 | 21 | has '_bar'; 22 | 23 | my sub _bar : private; 24 | 25 | sub BUILDARGS : strict( bar? => _bar ); 26 | 27 | sub init_bar { _bar = [ 1, 2, 3 ] } 28 | sub bar { _bar //= [ 5, 10, 15 ] } 29 | 30 | sub has_bar : predicate(_bar); 31 | sub set_bar : wo(_bar); 32 | sub clear_bar : clearer(_bar); 33 | } 34 | 35 | { 36 | my $foo = Foo->new; 37 | ok( $foo->isa( 'Foo' ), '... the object is from class Foo' ); 38 | 39 | ok(!$foo->has_bar, '... no bar is set'); 40 | is_deeply($foo->bar, [ 5, 10, 15 ], '... values are defined'); 41 | 42 | my $bar_1 = $foo->bar; 43 | 44 | ok($foo->has_bar, '... bar is now set'); 45 | 46 | eval { $foo->init_bar }; 47 | is($@, "", '... initialized bar without error'); 48 | is_deeply($foo->bar, [ 1, 2, 3 ], '... value is initialized by the init_bar method'); 49 | 50 | eval { $foo->set_bar([1000]) }; 51 | is($@, "", '... set bar without error'); 52 | is_deeply($foo->bar, [1000], '... value is set by the set_bar method'); 53 | 54 | eval { $foo->clear_bar }; 55 | is($@, "", '... set bar without error'); 56 | ok(!$foo->has_bar, '... no bar is set'); 57 | is_deeply($foo->bar, [ 5, 10, 15 ], '... values are defined'); 58 | 59 | isnt($foo->bar, $bar_1, '... new values are regnerated by the lazy init'); 60 | } 61 | 62 | { 63 | my $foo = Foo->new( bar => [10] ); 64 | ok( $foo->isa( 'Foo' ), '... the object is from class Foo' ); 65 | 66 | ok($foo->has_bar, '... a bar is set'); 67 | is_deeply($foo->bar, [10], '... values are initialized via the constructor'); 68 | 69 | eval { $foo->init_bar }; 70 | is($@, "", '... initialized bar without error'); 71 | ok($foo->has_bar, '... a bar is set'); 72 | is_deeply($foo->bar, [1, 2, 3], '... value is initialized by the init_bar method'); 73 | 74 | eval { $foo->set_bar([1000]) }; 75 | is($@, "", '... set bar without error'); 76 | ok($foo->has_bar, '... a bar is set'); 77 | is_deeply($foo->bar, [1000], '... value is set by the set_bar method'); 78 | 79 | eval { $foo->clear_bar }; 80 | is($@, "", '... set bar without error'); 81 | ok(!$foo->has_bar, '... no bar is set'); 82 | is_deeply($foo->bar, [ 5, 10, 15 ], '... values are defined'); 83 | } 84 | 85 | 86 | done_testing; 87 | -------------------------------------------------------------------------------- /t/001-basic/026-complex-attributes.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use MOP; 9 | 10 | =pod 11 | 12 | ... 13 | 14 | =cut 15 | 16 | package Bar { 17 | use Moxie; 18 | 19 | extends 'Moxie::Object'; 20 | } 21 | 22 | package Foo { 23 | use Moxie; 24 | 25 | extends 'Moxie::Object'; 26 | 27 | has _bar => sub { Bar->new }; 28 | 29 | sub bar : ro(_bar); 30 | sub has_bar : predicate(_bar); 31 | sub set_bar : wo(_bar); 32 | sub clear_bar : clearer(_bar); 33 | } 34 | 35 | { 36 | my $foo = Foo->new; 37 | ok( $foo->isa( 'Foo' ), '... the object is from class Foo' ); 38 | 39 | ok($foo->has_bar, '... bar is set as a default'); 40 | ok($foo->bar->isa( 'Bar' ), '... value isa Bar object'); 41 | 42 | my $bar = $foo->bar; 43 | 44 | eval { $foo->set_bar( Bar->new ) }; 45 | is($@, "", '... set bar without error'); 46 | ok($foo->has_bar, '... bar is set'); 47 | ok($foo->bar->isa( 'Bar' ), '... value is set by the set_bar method'); 48 | isnt($foo->bar, $bar, '... the new value has been set'); 49 | 50 | eval { $foo->clear_bar }; 51 | is($@, "", '... set bar without error'); 52 | ok(!$foo->has_bar, '... no bar is set'); 53 | is($foo->bar, undef, '... values has been cleared'); 54 | } 55 | 56 | 57 | done_testing; 58 | -------------------------------------------------------------------------------- /t/001-basic/027-multi-complex-attributes.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | =pod 9 | 10 | ... 11 | 12 | =cut 13 | 14 | package Bar { 15 | use Moxie; 16 | 17 | extends 'Moxie::Object'; 18 | } 19 | 20 | package Baz { 21 | use Moxie; 22 | 23 | extends 'Moxie::Object'; 24 | } 25 | 26 | package Foo { 27 | use Moxie; 28 | 29 | extends 'Moxie::Object'; 30 | 31 | has _bar => sub { Bar->new }; 32 | has _baz => sub { Baz->new }; 33 | 34 | sub bar : ro(_bar); 35 | sub has_bar : predicate(_bar); 36 | sub set_bar : wo(_bar); 37 | sub clear_bar : clearer(_bar); 38 | 39 | sub baz : ro(_baz); 40 | sub has_baz : predicate(_baz); 41 | sub set_baz : wo(_baz); 42 | sub clear_baz : clearer(_baz); 43 | } 44 | 45 | { 46 | my $foo = Foo->new; 47 | ok( $foo->isa( 'Foo' ), '... the object is from class Foo' ); 48 | 49 | ok($foo->has_bar, '... bar is set as a default'); 50 | ok($foo->bar->isa( 'Bar' ), '... value isa Bar object'); 51 | 52 | ok($foo->has_baz, '... baz is set as a default'); 53 | ok($foo->baz->isa( 'Baz' ), '... value isa Baz object'); 54 | 55 | my $bar = $foo->bar; 56 | my $baz = $foo->baz; 57 | 58 | #diag $bar; 59 | #diag $baz; 60 | 61 | eval { $foo->set_bar( Bar->new ) }; 62 | is($@, "", '... set bar without error'); 63 | ok($foo->has_bar, '... bar is set'); 64 | ok($foo->bar->isa( 'Bar' ), '... value is set by the set_bar method'); 65 | isnt($foo->bar, $bar, '... the new value has been set'); 66 | 67 | eval { $foo->set_baz( Baz->new ) }; 68 | is($@, "", '... set baz without error'); 69 | ok($foo->has_baz, '... baz is set'); 70 | ok($foo->baz->isa( 'Baz' ), '... value is set by the set_baz method'); 71 | isnt($foo->baz, $baz, '... the new value has been set'); 72 | 73 | eval { $foo->clear_bar }; 74 | is($@, "", '... set bar without error'); 75 | ok(!$foo->has_bar, '... no bar is set'); 76 | is($foo->bar, undef, '... values has been cleared'); 77 | 78 | eval { $foo->clear_baz }; 79 | is($@, "", '... set baz without error'); 80 | ok(!$foo->has_baz, '... no baz is set'); 81 | is($foo->baz, undef, '... values has been cleared'); 82 | } 83 | 84 | 85 | done_testing; 86 | -------------------------------------------------------------------------------- /t/001-basic/028-attributes-in-class-methods.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | # this comes up in, for instance, Plack::Middleware::wrap 9 | 10 | package Foo { 11 | use Moxie 12 | traits => [':experimental']; 13 | 14 | extends 'Moxie::Object'; 15 | 16 | has _bar => (); 17 | 18 | my sub _bar : private; 19 | 20 | sub BUILDARGS : strict( bar? => _bar ); 21 | 22 | sub bar : ro(_bar); 23 | 24 | sub baz ($self, $bar) { 25 | if (ref($self)) { 26 | _bar = $bar; 27 | } 28 | else { 29 | $self = __PACKAGE__->new( bar => $bar ); 30 | } 31 | 32 | return $self->bar; 33 | } 34 | } 35 | 36 | is(Foo->baz('BAR-class'), 'BAR-class'); 37 | is(Foo->new->baz('BAR-instance'), 'BAR-instance'); 38 | 39 | done_testing; 40 | -------------------------------------------------------------------------------- /t/001-basic/040-handles.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | 9 | package Foo { 10 | use Moxie traits => [':experimental']; 11 | 12 | extends 'Moxie::Object'; 13 | 14 | has _bar => sub { 'FOO::BAR' }; 15 | 16 | sub bar : ro(_bar); 17 | } 18 | 19 | package Bar { 20 | use Moxie traits => [':experimental']; 21 | 22 | extends 'Moxie::Object'; 23 | 24 | has _foo => sub { Foo->new }; 25 | 26 | sub BUILDARGS : strict( foo? => _foo ); 27 | 28 | sub foo : ro(_foo); 29 | sub foobar : handles('_foo->bar'); 30 | } 31 | 32 | { 33 | my $bar = Bar->new; 34 | isa_ok($bar, 'Bar'); 35 | 36 | can_ok($bar, 'foo'); 37 | can_ok($bar, 'foobar'); 38 | 39 | my $foo = $bar->foo; 40 | isa_ok($foo, 'Foo'); 41 | 42 | is($foo->bar, $bar->foobar, '... the delegated method worked correctly'); 43 | } 44 | 45 | { 46 | my $bar = Bar->new( foo => 10 ); 47 | isa_ok($bar, 'Bar'); 48 | 49 | can_ok($bar, 'foo'); 50 | can_ok($bar, 'foobar'); 51 | 52 | my $foo = $bar->foo; 53 | is($foo, 10, '... got the value we expected'); 54 | 55 | like( 56 | exception { $bar->foobar }, 57 | qr/^Can\'t locate object method \"bar\" via package \"10\"/, 58 | '... the delegated method failed correctly' 59 | ); 60 | } 61 | 62 | 63 | done_testing; 64 | -------------------------------------------------------------------------------- /t/001-basic/041-required.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | 9 | package Foo { 10 | use Moxie; 11 | 12 | extends 'Moxie::Object'; 13 | 14 | has _foo => ( default => sub { 'DFOO' } ); 15 | has _bar => ( required => 1 ); 16 | 17 | sub BUILDARGS : strict( 18 | foo? => _foo, 19 | bar? => _bar, 20 | ); 21 | 22 | sub foo : ro(_foo); 23 | sub bar : ro(_bar); 24 | } 25 | 26 | { 27 | my $foo = Foo->new(foo => 'FOO', bar => 'BAR'); 28 | is($foo->foo, 'FOO', 'slot with default and arg'); 29 | is($foo->bar, 'BAR', 'required slot with arg'); 30 | } 31 | 32 | { 33 | my $foo = Foo->new(bar => 'BAR'); 34 | is($foo->foo, 'DFOO', 'slot with default and no arg'); 35 | is($foo->bar, 'BAR', 'required slot with arg'); 36 | } 37 | 38 | like( 39 | exception { Foo->new }, 40 | qr/^A value for \`_bar\` is required/, 41 | 'missing required slot throws an exception' 42 | ); 43 | 44 | 45 | done_testing; 46 | -------------------------------------------------------------------------------- /t/030-roles/002-compose-into-role.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use MOP; 9 | 10 | package Foo { 11 | use Moxie 12 | traits => [':experimental']; 13 | 14 | has _bar => sub { 'bar' }; 15 | 16 | my sub _bar : private; 17 | 18 | sub bar { _bar } 19 | } 20 | 21 | package Baz { 22 | use Moxie; 23 | 24 | with 'Foo'; 25 | 26 | sub baz ($self) { join ", " => $self->bar, 'baz' } 27 | } 28 | 29 | package Gorch { 30 | use Moxie; 31 | 32 | extends 'Moxie::Object'; 33 | with 'Baz'; 34 | } 35 | 36 | { 37 | my $baz_meta = MOP::Role->new( name => 'Baz' ); 38 | 39 | ok( $baz_meta->does_role( 'Foo' ), '... Baz does the Foo role'); 40 | 41 | my $bar_method = $baz_meta->get_method('bar'); 42 | ok( $bar_method->isa( 'MOP::Method' ), '... got a method object' ); 43 | is( $bar_method->name, 'bar', '... got the method we expected' ); 44 | 45 | my $baz_method = $baz_meta->get_method('baz'); 46 | ok( $baz_method->isa( 'MOP::Method' ), '... got a method object' ); 47 | is( $baz_method->name, 'baz', '... got the method we expected' ); 48 | 49 | my $bar_slot = $baz_meta->get_slot_alias('_bar'); 50 | ok( $bar_slot->isa( 'MOP::Slot' ), '... got an slot object' ); 51 | is( $bar_slot->name, '_bar', '... got the slot we expected' ); 52 | 53 | my $bar_method_alias = $baz_meta->get_method_alias('bar'); 54 | ok( $bar_method_alias->isa( 'MOP::Method' ), '... got a method object' ); 55 | is( $bar_method_alias->name, 'bar', '... got the method we expected' ); 56 | } 57 | 58 | { 59 | my $gorch_meta = MOP::Role->new( name => 'Gorch' ); 60 | 61 | is_deeply([ $gorch_meta->roles ], [ 'Baz' ], '... got the list of expected roles'); 62 | 63 | my $bar_method = $gorch_meta->get_method_alias('bar'); 64 | ok( $bar_method->isa( 'MOP::Method' ), '... got a method object' ); 65 | is( $bar_method->name, 'bar', '... got the method we expected' ); 66 | 67 | my $baz_method = $gorch_meta->get_method_alias('baz'); 68 | ok( $baz_method->isa( 'MOP::Method' ), '... got a method object' ); 69 | is( $baz_method->name, 'baz', '... got the method we expected' ); 70 | 71 | my $bar_slot = $gorch_meta->get_slot_alias('_bar'); 72 | ok( $bar_slot->isa( 'MOP::Slot' ), '... got an slot object' ); 73 | is( $bar_slot->name, '_bar', '... got the slot we expected' ); 74 | } 75 | 76 | { 77 | my $gorch = Gorch->new; 78 | isa_ok($gorch, 'Gorch'); 79 | 80 | ok($gorch->DOES('Baz'), '... gorch does Baz'); 81 | ok($gorch->DOES('Foo'), '... gorch does Foo'); 82 | 83 | can_ok($gorch, 'bar'); 84 | can_ok($gorch, 'baz'); 85 | 86 | is($gorch->baz, 'bar, baz', '... got the expected output'); 87 | } 88 | 89 | done_testing; 90 | -------------------------------------------------------------------------------- /t/030-roles/003-multiple-role-compose.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | package Foo { 9 | use Moxie 10 | traits => [':experimental']; 11 | 12 | has _bar => sub { 'bar' }; 13 | 14 | my sub _bar : private; 15 | 16 | sub bar { _bar } 17 | } 18 | 19 | package Bar { 20 | use Moxie 21 | traits => [':experimental']; 22 | 23 | has _foo => sub { 'foo' }; 24 | 25 | my sub _foo : private; 26 | 27 | sub foo { _foo } 28 | } 29 | 30 | package Baz { 31 | use Moxie; 32 | 33 | with 'Foo', 'Bar'; 34 | 35 | sub baz ($self) { join ", " => $self->bar, 'baz', $self->foo } 36 | } 37 | 38 | package Gorch { 39 | use Moxie; 40 | 41 | extends 'Moxie::Object'; 42 | with 'Baz'; 43 | } 44 | 45 | ok( MOP::Role->new(name => 'Baz')->does_role( 'Foo' ), '... Baz does the Foo role'); 46 | ok( MOP::Role->new(name => 'Baz')->does_role( 'Bar' ), '... Baz does the Foo role'); 47 | 48 | my $bar_method = MOP::Role->new(name => 'Baz')->get_method('bar'); 49 | ok( $bar_method->isa( 'MOP::Method' ), '... got a method object' ); 50 | is( $bar_method->name, 'bar', '... got the method we expected' ); 51 | 52 | my $bar_slot = MOP::Role->new(name => 'Baz')->get_slot('_bar'); 53 | ok( $bar_slot->isa( 'MOP::Slot' ), '... got an slot object' ); 54 | is( $bar_slot->name, '_bar', '... got the slot we expected' ); 55 | 56 | my $foo_method = MOP::Role->new(name => 'Baz')->get_method('foo'); 57 | ok( $foo_method->isa( 'MOP::Method' ), '... got a method object' ); 58 | is( $foo_method->name, 'foo', '... got the method we expected' ); 59 | 60 | my $foo_slot = MOP::Role->new(name => 'Baz')->get_slot('_foo'); 61 | ok( $foo_slot->isa( 'MOP::Slot' ), '... got an slot object' ); 62 | is( $foo_slot->name, '_foo', '... got the slot we expected' ); 63 | 64 | my $baz_method = MOP::Role->new(name => 'Baz')->get_method('baz'); 65 | ok( $baz_method->isa( 'MOP::Method' ), '... got a method object' ); 66 | is( $baz_method->name, 'baz', '... got the method we expected' ); 67 | 68 | my $gorch = Gorch->new; 69 | isa_ok($gorch, 'Gorch'); 70 | ok($gorch->DOES('Baz'), '... gorch does Baz'); 71 | ok($gorch->DOES('Bar'), '... gorch does Bar'); 72 | ok($gorch->DOES('Foo'), '... gorch does Foo'); 73 | 74 | is($gorch->baz, 'bar, baz, foo', '... got the expected output'); 75 | 76 | done_testing; 77 | -------------------------------------------------------------------------------- /t/030-roles/004-DOES.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | # roles ... 9 | package Foo { 10 | use Moxie; 11 | } 12 | package Bar { 13 | use Moxie; 14 | } 15 | package Baz { 16 | use Moxie; 17 | } 18 | package Bat { 19 | use Moxie; 20 | 21 | with 'Baz'; 22 | } 23 | 24 | # classes ... 25 | package Quux { 26 | use Moxie; 27 | 28 | extends 'Moxie::Object'; 29 | with 'Foo', 'Bar'; 30 | } 31 | 32 | package Quuux { 33 | use Moxie; 34 | 35 | extends 'Quux'; 36 | with 'Foo', 'Baz'; 37 | } 38 | 39 | package Xyzzy { 40 | use Moxie; 41 | 42 | extends 'Moxie::Object'; 43 | with 'Foo', 'Bat'; 44 | } 45 | 46 | ok(Quux->DOES($_), "... Quux DOES $_") for qw( Foo Bar Quux UNIVERSAL::Object UNIVERSAL ); 47 | ok(Quuux->DOES($_), "... Quuux DOES $_") for qw( Foo Bar Baz Quux Quuux UNIVERSAL::Object UNIVERSAL ); 48 | ok(Xyzzy->DOES($_), "... Xyzzy DOES $_") for qw( Foo Baz Bat Xyzzy UNIVERSAL::Object UNIVERSAL ); 49 | 50 | #{ local $TODO = "broken in core perl" if $] < 5.019005; 51 | #push @UNIVERSAL::ISA, 'Blorg'; 52 | #ok(Quux->DOES('Blorg')); 53 | #ok(Quuux->DOES('Blorg')); 54 | #ok(Xyzzy->DOES('Blorg')); 55 | #} 56 | 57 | done_testing; 58 | -------------------------------------------------------------------------------- /t/030-roles/007-next-method.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | 9 | my ($foo, $bar); 10 | 11 | package Foo { 12 | use Moxie; 13 | 14 | extends 'Moxie::Object'; 15 | 16 | sub foo ($self) { $::foo++ } 17 | } 18 | 19 | package Bar { 20 | use Moxie; 21 | 22 | sub foo ($self) { 23 | $self->next::method; 24 | $::bar++; 25 | } 26 | } 27 | 28 | package Baz { 29 | use Moxie; 30 | 31 | extends 'Foo'; 32 | with 'Bar'; 33 | } 34 | 35 | TODO: { 36 | local $TODO = 'next::method does not work unless we rename the method with Sub::Util::subname'; 37 | my $baz = Baz->new; 38 | ($::foo, $::bar) = (0, 0); 39 | is(exception { $baz->foo }, undef, '... no exception calling ->foo'); 40 | is($::foo, 1, '... Foo::foo was called (via next::method)'); 41 | is($::bar, 1, '... Bar::foo was called (it was composed into Baz)'); 42 | } 43 | 44 | done_testing; 45 | -------------------------------------------------------------------------------- /t/030-roles/008-multilevel-does.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | package Foo { 9 | use Moxie; 10 | } 11 | 12 | package Bar { 13 | use Moxie; 14 | 15 | with 'Foo'; 16 | } 17 | 18 | package Baz { 19 | use Moxie; 20 | 21 | extends 'Moxie::Object'; 22 | with 'Bar'; 23 | } 24 | 25 | ok(Baz->DOES('Bar'), '... Baz DOES Bar'); 26 | ok(Baz->DOES('Foo'), '... Baz DOES Foo'); 27 | 28 | package R1 { 29 | use Moxie; 30 | } 31 | 32 | package R2 { 33 | use Moxie; 34 | } 35 | 36 | package R3 { 37 | use Moxie; 38 | 39 | with 'R1', 'R2'; 40 | } 41 | 42 | package C1 { 43 | use Moxie; 44 | 45 | extends 'Moxie::Object'; 46 | with 'R3'; 47 | } 48 | 49 | ok(C1->DOES('R3'), '... C1 DOES R3'); 50 | ok(C1->DOES('R2'), '... C1 DOES R2'); 51 | ok(C1->DOES('R1'), '... C1 DOES R1'); 52 | 53 | done_testing; 54 | -------------------------------------------------------------------------------- /t/030-roles/020-attribute-conflict.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | our ( 9 | $FOO_EXCEPTION, 10 | $FOO_BAR_EXCEPTION, 11 | $FOO_BAZ_EXCEPTION, 12 | ); 13 | 14 | BEGIN { 15 | package Foo { 16 | use Moxie; 17 | 18 | has 'foo'; 19 | } 20 | package Bar { 21 | use Moxie; 22 | 23 | has 'foo'; 24 | } 25 | 26 | eval q[ 27 | package Foo2 { 28 | use Moxie; 29 | with 'Foo'; 30 | has 'foo'; 31 | } 32 | ]; 33 | $FOO_EXCEPTION = $@; 34 | 35 | eval q[ 36 | package FooBar { 37 | use Moxie; 38 | with 'Foo', 'Bar'; 39 | } 40 | ]; 41 | $FOO_BAR_EXCEPTION = $@; 42 | 43 | eval q[ 44 | package FooBaz { 45 | use Moxie; 46 | 47 | extends 'Moxie::Object'; 48 | with 'Foo'; 49 | 50 | has 'foo'; 51 | } 52 | ]; 53 | $FOO_BAZ_EXCEPTION = $@; 54 | } 55 | 56 | like($FOO_EXCEPTION, qr/^\[CONFLICT\] Role Conflict, cannot compose slot \(foo\) into \(Foo2\) because \(foo\) already exists/, '... got the expected error message (role on role)'); 57 | like($FOO_BAR_EXCEPTION, qr/^\[CONFLICT\] There should be no conflicting slots when composing \(Foo, Bar\) into \(FooBar\)/, '... got the expected error message (composite role)'); 58 | like($FOO_BAZ_EXCEPTION, qr/^\[CONFLICT\] Role Conflict, cannot compose slot \(foo\) into \(FooBaz\) because \(foo\) already exists/, '... got the expected error message (role on class)'); 59 | 60 | done_testing; 61 | -------------------------------------------------------------------------------- /t/030-roles/021-deep-attribute-conflict.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | our $EXCEPTION; 9 | 10 | BEGIN { 11 | 12 | package Service { 13 | use Moxie; 14 | 15 | has 'is_locked' => sub { 0 }; 16 | } 17 | 18 | package WithClass { 19 | use Moxie; 20 | 21 | with 'Service'; 22 | } 23 | 24 | package WithParameters { 25 | use Moxie; 26 | 27 | with 'Service'; 28 | } 29 | 30 | package WithDependencies { 31 | use Moxie; 32 | 33 | with 'Service'; 34 | } 35 | 36 | eval q[ 37 | package ConstructorInjection { 38 | use Moxie; 39 | 40 | extends 'Moxie::Object'; 41 | with 'WithClass', 'WithParameters', 'WithDependencies'; 42 | } 43 | ]; 44 | $EXCEPTION = $@; 45 | } 46 | 47 | is($EXCEPTION, '', '... this worked'); 48 | 49 | foreach my $role (map { MOP::Role->new( name => $_ ) } qw[ 50 | WithClass 51 | WithParameters 52 | WithDependencies 53 | ]) { 54 | ok($role->has_slot('is_locked'), '... the is_locked slot is treated as a proper slot because it was composed from a role'); 55 | ok($role->has_slot_alias('is_locked'), '... the is_locked slot is also an alias, because that is how we install things in roles'); 56 | is_deeply( 57 | [ map { $_->name } $role->slots ], 58 | [ 'is_locked' ], 59 | '... these roles should then show the is_locked slot' 60 | ); 61 | }; 62 | 63 | done_testing; 64 | -------------------------------------------------------------------------------- /t/030-roles/022-deep-method-conflict.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | our $EXCEPTION; 9 | 10 | BEGIN { 11 | 12 | package Service { 13 | use Moxie; 14 | 15 | sub is_locked { 0 } 16 | } 17 | 18 | package WithClass { 19 | use Moxie; 20 | 21 | with 'Service'; 22 | } 23 | 24 | package WithParameters { 25 | use Moxie; 26 | 27 | with 'Service'; 28 | } 29 | 30 | package WithDependencies { 31 | use Moxie; 32 | 33 | with 'Service'; 34 | } 35 | 36 | eval q[ 37 | package ConstructorInjection { 38 | use Moxie; 39 | 40 | extends 'Moxie::Object'; 41 | with 'WithClass', 'WithParameters', 'WithDependencies'; 42 | } 43 | ]; 44 | $EXCEPTION = $@; 45 | } 46 | 47 | is($EXCEPTION, '', '... this worked'); 48 | 49 | foreach my $role (map { MOP::Role->new( name => $_ ) } qw[ 50 | WithClass 51 | WithParameters 52 | WithDependencies 53 | ]) { 54 | ok($role->has_method('is_locked'), '... the is_locked method is treated as a proper method because it was composed from a role'); 55 | ok($role->has_method_alias('is_locked'), '... the is_locked method is also an alias, because that is how we install things in roles'); 56 | is_deeply( 57 | [ map { $_->name } $role->methods ], 58 | [ 'is_locked' ], 59 | '... these roles should then show the is_locked method' 60 | ); 61 | }; 62 | 63 | done_testing; 64 | -------------------------------------------------------------------------------- /t/030-roles/025-method-conflict.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | package Foo { 9 | use Moxie; 10 | 11 | sub foo { 'Foo::foo' } 12 | } 13 | 14 | package Foo2 { 15 | use Moxie; 16 | 17 | with 'Foo'; 18 | 19 | sub foo { 'Foo2::foo' } 20 | } 21 | 22 | package Bar { 23 | use Moxie; 24 | 25 | sub foo { 'Bar::foo' } 26 | } 27 | 28 | 29 | { 30 | my $Foo2 = MOP::Role->new( name => 'Foo2' ); 31 | is_deeply([$Foo2->required_methods], [], '... no method conflict here'); 32 | ok($Foo2->has_method('foo'), '... Foo2 has the foo method'); 33 | is($Foo2->get_method('foo')->body->(), 'Foo2::foo', '... the method in Foo2 is as we expected'); 34 | } 35 | 36 | 37 | BEGIN { 38 | local $@ = undef; 39 | eval q[ 40 | package FooBarBrokenRole { 41 | use Moxie; 42 | 43 | with 'Foo', 'Bar'; 44 | } 45 | ]; 46 | like( 47 | "$@", 48 | qr/^\[CONFLICT\] There should be no conflicting methods when composing \(Foo, Bar\) into \(FooBarBrokenRole\) but instead we found \(foo\)/, 49 | '... got the exception we expected' 50 | ); 51 | } 52 | 53 | package FooBarClass { 54 | use Moxie; 55 | 56 | extends 'Moxie::Object'; 57 | with 'Foo', 'Bar'; 58 | 59 | sub foo { 'FooBarClass::foo' } 60 | } 61 | 62 | { 63 | my $FooBarClass = MOP::Class->new( name => 'FooBarClass' ); 64 | my ($Foo, $Bar) = map { MOP::Role->new( name => $_ ) } qw[ Foo Bar ]; 65 | is_deeply([$FooBarClass->required_methods], [], '... method conflict between roles results in required method'); 66 | ok($FooBarClass->has_method('foo'), '... FooBarClass does have the foo method'); 67 | is($FooBarClass->get_method('foo')->body->(), 'FooBarClass::foo', '... FooBarClass foo method is what makes sense'); 68 | ok($Foo->has_method('foo'), '... Foo still has the foo method'); 69 | ok($Bar->has_method('foo'), '... Bar still has the foo method'); 70 | } 71 | 72 | BEGIN { 73 | local $@ = undef; 74 | eval q[ 75 | package FooBarBrokenClass1 { 76 | use Moxie; 77 | 78 | extends 'Moxie::Object'; 79 | with 'Foo', 'Bar'; 80 | } 81 | ]; 82 | like( 83 | "$@", 84 | qr/^\[CONFLICT\] There should be no conflicting methods when composing \(Foo, Bar\) into \(FooBarBrokenClass1\) but instead we found \(foo\)/, 85 | '... got the exception we expected' 86 | ); 87 | } 88 | 89 | package Baz { 90 | use Moxie; 91 | 92 | extends 'Moxie::Object'; 93 | with 'Foo'; 94 | 95 | sub foo { 'Baz::foo' } 96 | } 97 | 98 | { 99 | my ($Baz, $Foo) = map { MOP::Class->new( name => $_ ) } qw[ Baz Foo ]; 100 | is_deeply([$Baz->required_methods], [], '... no method conflict between class/role'); 101 | ok($Foo->has_method('foo'), '... Foo still has the foo method'); 102 | is(Baz->new->foo, 'Baz::foo', '... got the right method'); 103 | } 104 | 105 | done_testing; 106 | -------------------------------------------------------------------------------- /t/030-roles/026-multiple-method-conflict.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | 6 | 7 | 8 | package R1 { 9 | use Moxie; 10 | 11 | sub foo { 1 } 12 | } 13 | 14 | package R2 { 15 | use Moxie; 16 | 17 | sub foo { 1 } 18 | } 19 | 20 | package R3 { 21 | use Moxie; 22 | 23 | sub foo { 1 } 24 | } 25 | 26 | package R4 { 27 | use Moxie; 28 | 29 | sub foo { 1 } 30 | } 31 | 32 | package R5 { 33 | use Moxie; 34 | 35 | sub foo { 1 } 36 | } 37 | 38 | BEGIN { 39 | local $@ = undef; 40 | eval q[ 41 | package C1 { 42 | use Moxie; 43 | 44 | extends 'Moxie::Object'; 45 | with 'R1'; 46 | } 47 | ]; 48 | ok(!$@, '... no exception, C1 does R1'); 49 | } 50 | 51 | BEGIN { 52 | local $@ = undef; 53 | eval q[ 54 | package C2 { 55 | use Moxie; 56 | 57 | extends 'Moxie::Object'; 58 | with 'R1', 'R2'; 59 | } 60 | ]; 61 | like( 62 | "$@", 63 | qr/^\[CONFLICT\] There should be no conflicting methods when composing \(R1, R2\) into \(C2\) but instead we found \(foo\)/, 64 | '... got an exception, C2 does R1, R2' 65 | ); 66 | } 67 | 68 | BEGIN { 69 | local $@ = undef; 70 | eval q[ 71 | package C3 { 72 | use Moxie; 73 | 74 | extends 'Moxie::Object'; 75 | with 'R1', 'R2', 'R3'; 76 | } 77 | ]; 78 | like( 79 | "$@", 80 | qr/^\[CONFLICT\] There should be no conflicting methods when composing \(R1, R2, R3\) into \(C3\) but instead we found \(foo\)/, 81 | '... got an exception, C3 does R1, R2, R3' 82 | ); 83 | } 84 | 85 | BEGIN { 86 | local $@ = undef; 87 | eval q[ 88 | package C4 { 89 | use Moxie; 90 | 91 | extends 'Moxie::Object'; 92 | with 'R1', 'R2', 'R3', 'R4'; 93 | } 94 | ]; 95 | like( 96 | "$@", 97 | qr/^\[CONFLICT\] There should be no conflicting methods when composing \(R1, R2, R3, R4\) into \(C4\) but instead we found \(foo\)/, 98 | '... got an exception, C4 does R1, R2, R3, R4' 99 | ); 100 | } 101 | 102 | BEGIN { 103 | local $@ = undef; 104 | eval q[ 105 | package C5 { 106 | use Moxie; 107 | 108 | extends 'Moxie::Object'; 109 | with 'R1', 'R2', 'R3', 'R4', 'R5'; 110 | } 111 | ]; 112 | like( 113 | "$@", 114 | qr/^\[CONFLICT\] There should be no conflicting methods when composing \(R1, R2, R3, R4, R5\) into \(C5\) but instead we found \(foo\)/, 115 | '... got an exception, C5 does R1, R2, R3, R4, R5' 116 | ); 117 | } 118 | 119 | package R1_required { 120 | use Moxie; 121 | 122 | sub foo; 123 | } 124 | 125 | BEGIN { 126 | local $@ = undef; 127 | eval q[ 128 | package C1_required { 129 | use Moxie; 130 | 131 | extends 'Moxie::Object'; 132 | with 'R1_required', 'R2'; 133 | } 134 | ]; 135 | ok(!$@, '... no exception, C1 does R1'); 136 | } 137 | 138 | done_testing; 139 | -------------------------------------------------------------------------------- /t/030-roles/030-required-methods.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | 9 | use MOP; 10 | 11 | our $EXCEPTION; 12 | 13 | BEGIN { 14 | 15 | package Foo { 16 | use Moxie; 17 | 18 | sub bar; 19 | } 20 | 21 | eval q[ 22 | package Bar::Incorrect { 23 | use Moxie; 24 | 25 | extends 'Moxie::Object'; 26 | with 'Foo'; 27 | 28 | has 'bar'; 29 | } 30 | ]; 31 | $EXCEPTION = $@; 32 | 33 | } 34 | 35 | like( 36 | $EXCEPTION, 37 | qr/^\[CONFLICT\] There should be no required methods when composing \(Foo\) into \(Bar\:\:Incorrect\) but instead we found \(bar\)/, 38 | '... this code failed to compile correctly' 39 | ); 40 | 41 | done_testing; 42 | -------------------------------------------------------------------------------- /t/030-roles/060-inherited-methods-fulfill-requirements.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | 9 | package Role::Table { 10 | use Moxie; 11 | 12 | sub query_by_id; 13 | } 14 | 15 | package Role::Table::RO { 16 | use Moxie; 17 | 18 | with 'Role::Table'; 19 | 20 | sub query_by_id; # continue to defer this ... 21 | 22 | sub count; 23 | sub select; 24 | } 25 | 26 | package Table { 27 | use Moxie; 28 | 29 | extends 'Moxie::Object'; 30 | with 'Role::Table'; 31 | 32 | sub query_by_id { 'Table::query_by_id' } 33 | } 34 | 35 | package Table::RO { 36 | use Moxie; 37 | 38 | extends 'Table'; 39 | with 'Role::Table::RO'; 40 | 41 | sub count { 'Table::RO::count' } 42 | sub select { 'Table::RO::select' } 43 | } 44 | 45 | my $t = Table::RO->new; 46 | isa_ok($t, 'Table::RO'); 47 | 48 | can_ok($t, 'count'); 49 | can_ok($t, 'select'); 50 | can_ok($t, 'query_by_id'); 51 | 52 | is($t->count, 'Table::RO::count', '... got the expected values'); 53 | is($t->select, 'Table::RO::select', '... got the expected values'); 54 | is($t->query_by_id, 'Table::query_by_id', '... got the expected values'); 55 | 56 | done_testing; 57 | -------------------------------------------------------------------------------- /t/040-method/001-basic.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use MOP; 9 | 10 | =pod 11 | 12 | This is just a basic test for what we have now, 13 | which is pretty basic and primative. The plan 14 | is to wait to see what happens with the 15 | function signature work and basically use what 16 | they have, only for methods. 17 | 18 | Eventually this test (and this test folder) will 19 | get a lot more tests when we know how things end 20 | up. 21 | 22 | =cut 23 | 24 | package Foo { 25 | use Moxie; 26 | 27 | extends 'Moxie::Object'; 28 | 29 | sub bar { 'BAR' } 30 | 31 | sub bar_with_empty_body {} 32 | 33 | sub bar_w_implicit_params { shift; join ', ' => 'BAR', @_ } 34 | 35 | sub bar_w_explicit_params ($self, @args) { join ', ' => 'BAR', @args } 36 | 37 | sub bar_w_explicit_param ($self, $a) { join ', ' => 'BAR', ($a // '') } 38 | 39 | sub bar_w_default_params ($self, $a = 10) { join ', ' => 'BAR', $a } 40 | 41 | sub bar_w_two_default_params ($self, $a = 10, $b = 20) { join ', ' => 'BAR', $a, $b } 42 | } 43 | 44 | my $foo = Foo->new; 45 | isa_ok($foo, 'Foo'); 46 | 47 | is($foo->bar, 'BAR', '... got the expected return value'); 48 | 49 | is($foo->bar_w_implicit_params, 'BAR', '... got the expected return value'); 50 | is($foo->bar_w_implicit_params(1, 2), 'BAR, 1, 2', '... got the expected return value'); 51 | 52 | is($foo->bar_w_explicit_params, 'BAR', '... got the expected return value'); 53 | is($foo->bar_w_explicit_params(1, 2), 'BAR, 1, 2', '... got the expected return value'); 54 | 55 | my $result = $foo->bar_with_empty_body; 56 | ok !defined $result, 'empty method bodies should not return a defined value'; 57 | my @result = $foo->bar_with_empty_body; 58 | ok !defined $result[0], '... even if they are called in list context'; 59 | 60 | { 61 | # NOTE: 62 | # We can sit on this one for now and 63 | # wait until the function sigs is more 64 | # nailed down. 65 | # - SL 66 | local $TODO = ' stevan: My recollection was "too few is an error, too many is not," but there is a thread... (but not a spec)...'; 67 | eval { $foo->bar_w_explicit_param; die 'Stupid uninitialized variable warnings, *sigh*' }; 68 | like( 69 | $@, 70 | qr/Not enough parameters/, 71 | '... got the expected error' 72 | ); 73 | } 74 | is($foo->bar_w_explicit_param(1), 'BAR, 1', '... got the expected return value'); 75 | 76 | is($foo->bar_w_default_params, 'BAR, 10', '... got the expected return value'); 77 | is($foo->bar_w_default_params(1), 'BAR, 1', '... got the expected return value'); 78 | 79 | is($foo->bar_w_two_default_params, 'BAR, 10, 20', '... got the expected return value'); 80 | is($foo->bar_w_two_default_params(1), 'BAR, 1, 20', '... got the expected return value'); 81 | is($foo->bar_w_two_default_params(1, 2), 'BAR, 1, 2', '... got the expected return value'); 82 | 83 | done_testing; 84 | -------------------------------------------------------------------------------- /t/050-non-mop-integration/001-inherit-from-non-mop.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | { 9 | package BaseObject; 10 | BEGIN { $INC{'BaseObject.pm'} = __FILE__ } 11 | use strict; 12 | use warnings; 13 | 14 | sub new { bless {} => shift } 15 | 16 | sub hello { 'Object::hello' } 17 | } 18 | 19 | 20 | { 21 | package Foo; 22 | use Moxie; 23 | 24 | extends 'Moxie::Object', 'BaseObject'; 25 | 26 | sub REPR { 27 | my ($class, $proto) = @_; 28 | $class->BaseObject::new( %$proto ); 29 | } 30 | 31 | sub bar { 'Foo::bar' } 32 | } 33 | 34 | { 35 | package Bar; 36 | use Moxie; 37 | 38 | extends 'Foo'; 39 | 40 | sub baz { 'Bar::baz' } 41 | } 42 | 43 | my $foo = Foo->new; 44 | is($foo->bar, 'Foo::bar', '... got the value we expected from $foo->bar'); 45 | 46 | is(Foo->bar, 'Foo::bar', '... got the value we expected from Foo->bar'); 47 | 48 | my $bar = Bar->new; 49 | is($bar->baz, 'Bar::baz', '... got the value we expected from $bar->baz'); 50 | is($bar->bar, 'Foo::bar', '... got the value we expected from $bar->bar'); 51 | 52 | is(Bar->baz, 'Bar::baz', '... got the value we expected from Bar->baz'); 53 | is(Bar->bar, 'Foo::bar', '... got the value we expected from Bar->bar'); 54 | 55 | is(Bar->hello, 'Object::hello', '... got the value we expected from Bar->hello'); 56 | is(Foo->hello, 'Object::hello', '... got the value we expected from Foo->hello'); 57 | 58 | is_deeply( 59 | mro::get_linear_isa('Foo'), 60 | [ 'Foo', 'Moxie::Object', 'UNIVERSAL::Object', 'BaseObject' ], 61 | '... got the expected linear isa' 62 | ); 63 | 64 | is_deeply( 65 | mro::get_linear_isa('Bar'), 66 | [ 'Bar', 'Foo', 'Moxie::Object', 'UNIVERSAL::Object', 'BaseObject' ], 67 | '... got the expected linear isa' 68 | ); 69 | 70 | done_testing; 71 | 72 | 73 | -------------------------------------------------------------------------------- /t/050-non-mop-integration/002-more-non-mop.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | BEGIN { 9 | eval { require Moose; 1 } 10 | or plan skip_all => "This test requires Moose"; 11 | } 12 | 13 | { 14 | package Person; 15 | BEGIN { $INC{'Person.pm'} = __FILE__ } 16 | use Moose; 17 | 18 | # NOTE: 19 | # we have to make these attribute lazy 20 | # because of how Moose does constructors 21 | # that are inherited by non-Moose classes 22 | # - SL 23 | 24 | has 'first_name' => (is => 'rw', default => 'stevan', lazy => 1); 25 | has 'last_name' => (is => 'rw', default => 'little', lazy => 1); 26 | 27 | __PACKAGE__->meta->make_immutable; 28 | } 29 | 30 | { 31 | package Employee; 32 | use Moxie; 33 | 34 | extends 'Moxie::Object', 'Person'; 35 | 36 | has _manager => (); 37 | 38 | sub BUILDARGS ($class, @args) { 39 | my $proto = $class->next::method( @args ); 40 | $proto->{_manager} = delete $proto->{manager} 41 | if exists $proto->{manager}; 42 | return $proto; 43 | } 44 | 45 | sub REPR ($class, $proto) { 46 | $class->Person::new( $proto ); 47 | } 48 | 49 | sub manager : rw(_manager); 50 | } 51 | 52 | #warn Dumper mop::meta('Employee'); 53 | 54 | my $e = Employee->new; 55 | isa_ok($e, 'Employee'); 56 | isa_ok($e, 'Person'); 57 | 58 | ok($e->can('first_name'), '... $e can call first_name'); 59 | ok($e->can('last_name'), '... $e can call last_name'); 60 | ok($e->can('manager'), '... $e can call manager'); 61 | 62 | is($e->first_name, 'stevan', '... got the expected default value'); 63 | is($e->last_name, 'little', '... got the expected default value'); 64 | 65 | my $m = Employee->new( first_name => 'pointy', last_name => 'hairedboss' ); 66 | 67 | $e->manager($m); 68 | is_deeply($e->manager, $m, '... got the expected manager'); 69 | 70 | my $m2 = Employee->new( first_name => 'mr', last_name => 'burns', manager => $m ); 71 | 72 | is_deeply($m2->manager, $m, '... got the expected manager'); 73 | 74 | #warn Dumper $e; 75 | #warn Dumper mop::meta('Employee'); 76 | 77 | is_deeply( 78 | mro::get_linear_isa('Employee'), 79 | [ 'Employee', 'Moxie::Object', 'UNIVERSAL::Object', 'Person', 'Moose::Object' ], 80 | '... got the expected linear isa' 81 | ); 82 | 83 | done_testing; 84 | -------------------------------------------------------------------------------- /t/050-non-mop-integration/003-attributes-in-non-mop-inherited-class.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | { 9 | package My::Component; 10 | BEGIN { $INC{'My/Component.pm'} = __FILE__ } 11 | use strict; 12 | use warnings; 13 | 14 | sub new { 15 | my $class = shift; 16 | bless { @_ } => $class; 17 | } 18 | } 19 | 20 | { 21 | package App; 22 | use Moxie 23 | traits => [':experimental']; 24 | 25 | extends 'Moxie::Object', 'My::Component'; 26 | 27 | has _foo => (); 28 | has _bar => sub { "BAR" }; 29 | 30 | my sub _foo : private; 31 | 32 | sub bar : ro(_bar); 33 | 34 | sub REPR { 35 | my ($class, $proto) = @_; 36 | $class->My::Component::new( %$proto ); 37 | } 38 | 39 | sub BUILD ($self, $params) { 40 | _foo = $params->{'foo'}; 41 | } 42 | 43 | sub call { "HELLO " . _foo } 44 | } 45 | 46 | my $app = App->new( foo => 'WORLD' ); 47 | isa_ok($app, 'App'); 48 | isa_ok($app, 'My::Component'); 49 | 50 | is($app->call, 'HELLO WORLD', '... got the value we expected'); 51 | is($app->bar, 'BAR'); 52 | 53 | { 54 | package My::DBI; 55 | BEGIN { $INC{'My/DBI.pm'} = __FILE__ } 56 | use strict; 57 | use warnings; 58 | 59 | sub connect { 60 | my $class = shift; 61 | my ($dsn) = @_; 62 | bless { dsn => $dsn } => $class; 63 | } 64 | 65 | sub dsn { shift->{dsn} } 66 | } 67 | 68 | { 69 | package My::DBI::MOP; 70 | use Moxie 71 | traits => [':experimental']; 72 | 73 | extends 'Moxie::Object', 'My::DBI'; 74 | 75 | has _foo => (); 76 | has _bar => sub { "BAR" }; 77 | 78 | my sub _foo : private; 79 | 80 | sub bar : ro(_bar); 81 | 82 | sub connect { (shift)->new( dsn => @_ ) } 83 | 84 | sub REPR { 85 | my ($class, $proto) = @_; 86 | $class->My::DBI::connect( $proto->{dsn} ); 87 | } 88 | 89 | sub BUILD ($self, $params) { 90 | _foo = 'WORLD'; 91 | } 92 | 93 | sub call { "HELLO " . _foo } 94 | } 95 | 96 | my $dbh = My::DBI::MOP->connect('dbi:hash'); 97 | isa_ok($dbh, 'My::DBI::MOP'); 98 | isa_ok($dbh, 'My::DBI'); 99 | 100 | is($dbh->call, 'HELLO WORLD', '... got the value we expected'); 101 | is($dbh->bar, 'BAR'); 102 | is($dbh->dsn, 'dbi:hash'); 103 | 104 | done_testing; 105 | -------------------------------------------------------------------------------- /t/080-enum/001-basic.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | package Foo { 9 | use v5.22; 10 | use warnings; 11 | 12 | use Moxie::Enum; 13 | 14 | enum Gorch => qw[ BAR BAZ ]; 15 | } 16 | 17 | subtest '... checking array version' => sub { 18 | can_ok('Foo', 'BAR'); 19 | can_ok('Foo', 'BAZ'); 20 | 21 | my $bar = Foo->BAR; 22 | my $baz = Foo->BAZ; 23 | 24 | is($bar+0, 1, '... got the expected numeric value for BAR'); 25 | is($bar.'', 'BAR', '... got the expected string value for BAR'); 26 | 27 | is($baz+0, 2, '... got the expected numeric value for BAZ'); 28 | is($baz.'', 'BAZ', '... got the expected string value for BAZ'); 29 | 30 | my %enum = Moxie::Enum::get_enum_for( Foo => 'Gorch' ); 31 | is(scalar keys %enum, 2, '... got the expected number of keys in the enum'); 32 | 33 | is($enum{BAR}, $bar, '... got the same value back'); 34 | is($enum{BAZ}, $baz, '... got the same value back'); 35 | 36 | ok(Moxie::Enum::has_value_for( Foo => 'Gorch', 'BAR' ), '... we have the value expected'); 37 | ok(Moxie::Enum::has_value_for( Foo => 'Gorch', 'BAZ' ), '... we have the value expected'); 38 | ok(!Moxie::Enum::has_value_for( Foo => 'Gorch', 'FOO' ), '... we do not have the value expected'); 39 | 40 | is(Moxie::Enum::get_value_for( Foo => 'Gorch', 'BAR' ), $bar, '... got the same value back'); 41 | is(Moxie::Enum::get_value_for( Foo => 'Gorch', 'BAZ' ), $baz, '... got the same value back'); 42 | 43 | is_deeply( 44 | [ sort { $a cmp $b } Moxie::Enum::get_keys_for( Foo => 'Gorch' ) ], 45 | [qw[ BAR BAZ ]], 46 | '... got the keys expected' 47 | ); 48 | 49 | is_deeply( 50 | [ sort { $a <=> $b } map 0+$_, Moxie::Enum::get_values_for( Foo => 'Gorch' ) ], 51 | [ 1, 2 ], 52 | '... got the values expected' 53 | ); 54 | }; 55 | 56 | package Foo::Bar { 57 | use v5.22; 58 | use warnings; 59 | 60 | use Moxie::Enum; 61 | 62 | enum Gorch => { BAR => 10, BAZ => 20 }; 63 | } 64 | 65 | subtest '... checking hash version' => sub { 66 | can_ok('Foo::Bar', 'BAR'); 67 | can_ok('Foo::Bar', 'BAZ'); 68 | 69 | my $bar = Foo::Bar->BAR; 70 | my $baz = Foo::Bar->BAZ; 71 | 72 | is($bar+0, 10, '... got the expected numeric value for BAR'); 73 | is($bar.'', 'BAR', '... got the expected string value for BAR'); 74 | 75 | is($baz+0, 20, '... got the expected numeric value for BAZ'); 76 | is($baz.'', 'BAZ', '... got the expected string value for BAZ'); 77 | }; 78 | 79 | done_testing; 80 | -------------------------------------------------------------------------------- /t/100-annotations/001-basic.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Data::Dumper; 8 | 9 | BEGIN { 10 | use_ok('MOP'); 11 | } 12 | 13 | =pod 14 | 15 | This just shows that we can apply our 16 | traits and add others in if we want 17 | 18 | =cut 19 | 20 | { 21 | package Bar::Traits::Provider; 22 | use strict; 23 | use warnings; 24 | 25 | our $TRAIT_USED = 0; 26 | 27 | sub Bar { $TRAIT_USED++; return } 28 | 29 | package Foo; 30 | use Moxie 31 | traits => ['Bar::Traits::Provider']; 32 | 33 | extends 'Moxie::Object'; 34 | 35 | has _foo => sub { 'FOO' }; 36 | 37 | sub foo : ro(_foo) Bar; 38 | } 39 | 40 | BEGIN { 41 | is($Bar::Traits::Provider::TRAIT_USED, 1, '...the trait was used in BEGIN'); 42 | } 43 | 44 | { 45 | my $foo = Foo->new; 46 | isa_ok($foo, 'Foo'); 47 | can_ok($foo, 'foo'); 48 | 49 | is($foo->foo, 'FOO', '... the generated accessor worked as expected'); 50 | } 51 | 52 | { 53 | my $method = MOP::Class->new( 'Foo' )->get_method('foo'); 54 | isa_ok($method, 'MOP::Method'); 55 | is_deeply( 56 | [ map $_->original, $method->get_code_attributes ], 57 | [qw[ ro(_foo) Bar ]], 58 | '... got the expected attributes' 59 | ); 60 | } 61 | 62 | done_testing; 63 | 64 | -------------------------------------------------------------------------------- /t/100-annotations/010-init_args.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | use Data::Dumper; 9 | 10 | BEGIN { 11 | use_ok('MOP'); 12 | } 13 | 14 | =pod 15 | 16 | This test 17 | 18 | =cut 19 | 20 | { 21 | package Foo::NoArgs; 22 | use Moxie; 23 | 24 | extends 'Moxie::Object'; 25 | 26 | has foo => sub { 'foo' }; 27 | 28 | sub BUILDARGS : strict; 29 | } 30 | 31 | { 32 | package Foo::AssignSlot; 33 | use Moxie; 34 | 35 | extends 'Moxie::Object'; 36 | 37 | has foo => sub { 'foo' }; 38 | 39 | sub BUILDARGS : strict( foo => 'foo' ); 40 | } 41 | 42 | { 43 | package Foo::CustomArg; 44 | use Moxie; 45 | 46 | extends 'Moxie::Object'; 47 | 48 | has foo => sub { 'foo' }; 49 | has bar => sub { 'bar' }; 50 | 51 | sub BUILDARGS : strict( 52 | bar => 'foo', 53 | foo => 'bar', 54 | ); 55 | } 56 | 57 | { 58 | package Foo::OptionalArg; 59 | use Moxie; 60 | 61 | extends 'Moxie::Object'; 62 | 63 | has foo => sub { 'foo' }; 64 | has bar => sub { 'bar' }; 65 | 66 | sub BUILDARGS : strict( 67 | bar => 'bar', 68 | foo? => 'foo', 69 | ); 70 | } 71 | 72 | subtest '... NoArgs' => sub { 73 | my $foo; 74 | is(exception { $foo = Foo::NoArgs->new }, undef, '... no exception'); 75 | isa_ok($foo, 'Foo::NoArgs'); 76 | 77 | is($foo->{foo}, 'foo', '... got the expected default'); 78 | 79 | { 80 | like( 81 | exception { Foo::NoArgs->new( foo => 10 ) }, 82 | qr/^Constructor for \(Foo\:\:NoArgs\) expected 0 arguments, got \(2\)/, 83 | '... got the expected exception (`foo` is not accepted)' 84 | ); 85 | 86 | like( 87 | exception { Foo::NoArgs->new( bar => 10 ) }, 88 | qr/^Constructor for \(Foo\:\:NoArgs\) expected 0 arguments, got \(2\)/, 89 | '... got the expected exception (no arguments are accepted)' 90 | ); 91 | 92 | like( 93 | exception { Foo::NoArgs->new( bar => 10, foo => 100 ) }, 94 | qr/^Constructor for \(Foo\:\:NoArgs\) expected 0 arguments, got \(4\)/, 95 | '... got the expected exception (`foo` and other arguments are not accepted)' 96 | ); 97 | 98 | like( 99 | exception { Foo::NoArgs->new( bar => 10, foo => 100, baz => 1000 ) }, 100 | qr/^Constructor for \(Foo\:\:NoArgs\) expected 0 arguments, got \(6\)/, 101 | '... got the expected exception (nothing is accepted, seriously people)' 102 | ); 103 | } 104 | }; 105 | 106 | subtest '... AssignSlot' => sub { 107 | my $foo; 108 | is(exception { $foo = Foo::AssignSlot->new( foo => 10 ) }, undef, '... no exception'); 109 | isa_ok($foo, 'Foo::AssignSlot'); 110 | 111 | is($foo->{foo}, 10, '... got the expected slot'); 112 | 113 | { 114 | like( 115 | exception { Foo::AssignSlot->new }, 116 | qr/Constructor for \(Foo\:\:AssignSlot\) expected 2 arguments, got \(0\)/, 117 | '... got the expected exception (the `foo` param is required)' 118 | ); 119 | 120 | like( 121 | exception { Foo::AssignSlot->new( bar => 10, baz => 1000 ) }, 122 | qr/Constructor for \(Foo\:\:AssignSlot\) expected 2 arguments, got \(4\)/, 123 | '... got the expected exception (the `foo` param is (still) required)' 124 | ); 125 | 126 | like( 127 | exception { Foo::AssignSlot->new( bar => 10, foo => 1000 ) }, 128 | qr/Constructor for \(Foo\:\:AssignSlot\) expected 2 arguments, got \(4\)/, 129 | '... got the expected exception (the `foo` param must be alone)' 130 | ); 131 | 132 | like( 133 | exception { Foo::AssignSlot->new( bar => 10 ) }, 134 | qr/Constructor for \(Foo\:\:AssignSlot\) missing \(`foo`\) parameters, got \(`bar`\), expected \(`foo`\)/, 135 | '... got the expected exception (right arity, wrote param)' 136 | ); 137 | } 138 | }; 139 | 140 | subtest '... CustomArg' => sub { 141 | my $foo; 142 | is(exception { $foo = Foo::CustomArg->new( bar => 10, foo => 20 ) }, undef, '... no exception'); 143 | isa_ok($foo, 'Foo::CustomArg'); 144 | 145 | is($foo->{foo}, 10, '... got the expected slot'); 146 | is($foo->{bar}, 20, '... got the expected slot'); 147 | 148 | { 149 | like( 150 | exception { Foo::CustomArg->new }, 151 | qr/Constructor for \(Foo\:\:CustomArg\) expected 4 arguments, got \(0\)/, 152 | '... got the expected exception (must supply arguments)' 153 | ); 154 | 155 | like( 156 | exception { Foo::CustomArg->new( foo => 200 ) }, 157 | qr/Constructor for \(Foo\:\:CustomArg\) expected 4 arguments, got \(2\)/, 158 | '... got the expected exception (must supply (both) arguments)' 159 | ); 160 | 161 | like( 162 | exception { Foo::CustomArg->new( foo => 200, bar => 300, baz => 400 ) }, 163 | qr/Constructor for \(Foo\:\:CustomArg\) expected 4 arguments, got \(6\)/, 164 | '... got the expected exception (must supply only the required arguments)' 165 | ); 166 | 167 | like( 168 | exception { Foo::CustomArg->new( foo => 10, baz => 100 ) }, 169 | qr/Constructor for \(Foo\:\:CustomArg\) missing \(`bar`\) parameters, got \(`baz`\, `foo`\), expected \(`bar`\, `foo`\)/, 170 | '... got the expected exception (right arity, wrong params)' 171 | ); 172 | 173 | like( 174 | exception { Foo::CustomArg->new( bar => 10, baz => 100 ) }, 175 | qr/Constructor for \(Foo\:\:CustomArg\) missing \(`foo`\) parameters, got \(`bar`\, `baz`\), expected \(`bar`\, `foo`\)/, 176 | '... got the expected exception (right arity, wrong params)' 177 | ); 178 | 179 | } 180 | }; 181 | 182 | subtest '... OptionalArg' => sub { 183 | { 184 | my $foo; 185 | is(exception { $foo = Foo::OptionalArg->new( bar => 10, foo => 20 ) }, undef, '... no exception'); 186 | isa_ok($foo, 'Foo::OptionalArg'); 187 | 188 | is($foo->{foo}, 20, '... got the expected slot'); 189 | is($foo->{bar}, 10, '... got the expected slot'); 190 | } 191 | 192 | { 193 | my $foo; 194 | is(exception { $foo = Foo::OptionalArg->new( bar => 10 ) }, undef, '... no exception'); 195 | isa_ok($foo, 'Foo::OptionalArg'); 196 | 197 | is($foo->{foo}, 'foo', '... got the expected slot'); 198 | is($foo->{bar}, 10, '... got the expected slot'); 199 | } 200 | 201 | { 202 | like( 203 | exception { Foo::OptionalArg->new }, 204 | qr/Constructor for \(Foo\:\:OptionalArg\) expected between 2 and 4 arguments, got \(0\)/, 205 | '... got the expected exception (must supply arguments)' 206 | ); 207 | 208 | like( 209 | exception { Foo::OptionalArg->new( foo => 200 ) }, 210 | qr/Constructor for \(Foo\:\:OptionalArg\) missing \(`bar`\) parameters, got \(`foo`\)\, expected \(`bar`\, `foo\?`\)/, 211 | '... got the expected exception (must supply (both) arguments)' 212 | ); 213 | 214 | like( 215 | exception { Foo::OptionalArg->new( foo => 200, bar => 300, baz => 400 ) }, 216 | qr/Constructor for \(Foo\:\:OptionalArg\) expected between 2 and 4 arguments, got \(6\)/, 217 | '... got the expected exception (must supply only the required arguments)' 218 | ); 219 | 220 | like( 221 | exception { Foo::OptionalArg->new( foo => 10, baz => 100 ) }, 222 | qr/Constructor for \(Foo\:\:OptionalArg\) missing \(`bar`\) parameters, got \(`baz`\, `foo`\)\, expected \(`bar`\, `foo\?`\)/, 223 | '... got the expected exception (right arity, wrong params)' 224 | ); 225 | 226 | like( 227 | exception { Foo::OptionalArg->new( bar => 10, baz => 100 ) }, 228 | qr/Constructor for \(Foo\:\:OptionalArg\) got unrecognized parameters \(`baz`\)/, 229 | '... got the expected exception (right arity, unrecognized param)' 230 | ); 231 | 232 | } 233 | }; 234 | 235 | done_testing; 236 | 237 | -------------------------------------------------------------------------------- /t/100-annotations/100-lexical-accessors.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Data::Dumper; 8 | 9 | BEGIN { 10 | use_ok('MOP'); 11 | } 12 | 13 | { 14 | package Foo; 15 | use Moxie 16 | traits => [':experimental']; 17 | 18 | extends 'Moxie::Object'; 19 | 20 | has foo => sub { 'FOO' }; 21 | has bar => sub { 'BAR' }; 22 | 23 | my sub foo : private; 24 | my sub bar : private; 25 | 26 | sub change_bar { 27 | my $self = shift; # we are safe even with modifications to @_ 28 | my ($value) = @_; 29 | bar = $value; 30 | $self; 31 | } 32 | 33 | sub to_string { 34 | my ($self) = @_; 35 | join ', ' => foo, bar; 36 | } 37 | } 38 | 39 | ok(!Foo->can('foo'), '... no public foo method'); 40 | ok(!Foo->can('bar'), '... no public foo method'); 41 | 42 | is(Foo->new->to_string, 'FOO, BAR', '... got the expected default values'); 43 | is(Foo->new( foo => 'foo' )->to_string, 'foo, BAR', '... got the expected changed values'); 44 | is(Foo->new( foo => 'foo', bar => 'bar' )->to_string, 'foo, bar', '... got the expected changed values again'); 45 | is(Foo->new( foo => 'foo')->change_bar( 'BARRR' )->to_string, 'foo, BARRR', '... values changed with the rw accessor now'); 46 | 47 | done_testing; 48 | 49 | -------------------------------------------------------------------------------- /t/lib/Foo/Bar.pm: -------------------------------------------------------------------------------- 1 | package Foo::Bar; 2 | use Moxie; 3 | 4 | extends 'Moxie::Object'; 5 | 6 | 1; 7 | -------------------------------------------------------------------------------- /t/lib/Level1.pm: -------------------------------------------------------------------------------- 1 | package Level1; 2 | use Moxie; 3 | 4 | extends 'Root'; 5 | 6 | 1; 7 | -------------------------------------------------------------------------------- /t/lib/Level2.pm: -------------------------------------------------------------------------------- 1 | package Level2; 2 | use Moxie; 3 | 4 | extends 'Level1'; 5 | 6 | 1; 7 | -------------------------------------------------------------------------------- /t/lib/Level3.pm: -------------------------------------------------------------------------------- 1 | package Level3; 2 | use Moxie; 3 | 4 | extends 'Level2'; 5 | 6 | 1; 7 | -------------------------------------------------------------------------------- /t/lib/Root.pm: -------------------------------------------------------------------------------- 1 | package Root; 2 | use Moxie 3 | traits => [':experimental']; 4 | 5 | extends 'Moxie::Object'; 6 | 7 | has '_foo'; 8 | 9 | my sub _foo : private; 10 | 11 | sub BUILDARGS : strict( foo? => _foo ); 12 | 13 | sub foo { _foo } 14 | 15 | 1; 16 | -------------------------------------------------------------------------------- /weaver.ini: -------------------------------------------------------------------------------- 1 | [@CorePrep] 2 | 3 | [Name] 4 | [Version] 5 | 6 | [Region / prelude] 7 | 8 | [Generic / SYNOPSIS] 9 | [Generic / DESCRIPTION] 10 | 11 | [Leftovers] 12 | 13 | [Region / postlude] 14 | 15 | [Authors] 16 | [Legal] 17 | --------------------------------------------------------------------------------