1# (X)Emacs mode: -*- cperl -*- 2 3package Class::MethodMaker::V1Compat; 4 5=head1 NAME 6 7Class::MethodMaker::V1Compat - V1 compatibility code for C::MM 8 9=head1 SYNOPSIS 10 11This class is for internal implementation only. It is not a public API. 12 13=head1 DESCRIPTION 14 15Class::MethodMaker version 2 strives for backward-compatibility with version 1 16as far as possible. That is to say, classes built with version 1 should work 17with few if any changes. However, the calling conventions for building new 18classes are significantly different: this is necessary to achieve a greater 19consistency of arguments. 20 21Version 2 takes all arguments within a single arrayref: 22 23 use Class::MethodMaker 24 [ scalar => 'a' ]; 25 26If arguments are presented as a list, then Class::MethodMaker assumes that 27this is a version 1 call, and acts accordingly. Version 1 arguments are 28passed and internally rephrased to version 2 arguments, and passed off to the 29version 2 engine. Thus, the majority of version 1 calls can be upgraded to 30version 2 merely by rephrasing. However, there are a number of behaviours 31that in version 1 that are internally inconsistent. These behaviours are 32mimicked in version 1 mode as far as possible, but are not reproducible in 33version 2 (to allow version 2 clients to rely on a more internally consistent 34interface). 35 36=head2 Version 2 Implementations 37 38The nearest equivalent to each 1 component (slot) available in version 2 is 39shown below using the indicated data-structures & options to create a 40component called C<a> that mimics the V1 component behaviour as closely as 41possible: 42 43=over 4 44 45=item abstract 46 47 use Class::MethodMaker 48 [ abstract => 'a' ]; 49 50=item boolean 51 52Boolean is available as a backwards compatibility hack, but there is currently 53no V2 equivalent. It is likely that some replacement mechanism will be 54introduced in the future, but that it will be incompatible with the version 1 55boolean. 56 57=item code 58 59 use Class::MethodMaker 60 [ scalar => 'a' ]; 61 62Let's face it, the v1 store-if-it's-a-coderef-else-retrieve semantics are 63rather broken. How do you pass a coderef as argument to one of these? It is 64on the TODO list to recognize code as fundamental restricted type (analogous 65to INTEGER), which would add in a C<*_invoke> method. 66 67=item copy 68 69 use Class::MethodMaker 70 [ copy => 'a' ]; 71 72The v2 method is the same as v1. 73 74=item counter 75 76 use Class::MethodMaker 77 [ scalar => [{-type => Class::MethodMaker::Constants::INTEGER}, 'a'] ]; 78 79=item copy 80 81=item deep_copy 82 83 use Class::MethodMaker 84 [ copy => [ -deep => 'a' ] ]; 85 86=item get_concat 87 88 use Class::MethodMaker 89 [ scalar => [{ -store_cb => sub { 90 defined $_[1] ? ( defined $_[3] ? 91 "$_[3] $_[1]" : $_[1] ) 92 : undef; 93 } 94 }, 95 'a' ] 96 ]; 97 98=item get_set 99 100 use Class::MethodMaker 101 [ scalar => 'a' ]; 102 103=item hash 104 105 use Class::MethodMaker 106 [ hash => 'a' ]; 107 108=item key_attrib 109 110Although v1 calls will continue to work, this is not supported in v2. 111 112=item key_with_create 113 114Although v1 calls will continue to work, this is not supported in v2. 115 116=item list 117 118 use Class::MethodMaker 119 [ list => 'a' ]; 120 121Note that the C<*> method now I<sets> the whole array if given arguments. 122 123=item method 124 125See C<code>. 126 127=item new 128 129 use Class::MethodMaker 130 [ new => 'a' ]; 131 132=item new_hash_init 133 134 use Class::MethodMaker 135 [ new => [ -hash => 'a' ] ]; 136 137=item new_hash_with_init 138 139 use Class::MethodMaker 140 [ new => [ -hash => -init => 'a' ] ]; 141 142=item new_with_args 143 144Although v1 calls will continue to work, this is not supported in v2, for it 145is a trivial application of C<new_with_init>. 146 147=item new_with_init 148 149 use Class::MethodMaker 150 [ new => [ -init => 'a' ] ]; 151 152=item object 153 154 use Class::MethodMaker 155 [ scalar => [{ -type => 'MyClass', 156 -forward => [qw/ method1 method2 /] }, 'a' ] 157 ]; 158 159=item object_tie_hash 160 161 use Class::MethodMaker 162 [ hash => [{ -type => 'MyClass', 163 -forward => [qw/ method1 method2 /], 164 -tie_class => 'Tie::MyTie', 165 -tie_args => [qw/ foo bar baz /], 166 }, 'a' ] 167 ]; 168 169=item object_tie_list 170 171 use Class::MethodMaker 172 [ array => [{ -type => 'MyClass', 173 -forward => [qw/ method1 method2 /], 174 -tie_class => 'Tie::MyTie', 175 -tie_args => [qw/ foo bar baz /], 176 }, 'a' ] 177 ]; 178 179=item set_once 180 181 use Class::MethodMaker 182 [ scalar => [{ -store_cb => sub { 183 die "Already stored $_[3]" 184 if @_ > 3; 185 } 186 }, 187 'a' ] 188 ]; 189 190 191=item set_once_static 192 193 use Class::MethodMaker 194 [ scalar => [{ -store_cb => sub { 195 die "Already stored $_[3]" 196 if @_ > 3; 197 }, 198 -static => 1, 199 }, 200 'a' ] 201 ]; 202 203 204=item singleton 205 206 use Class::MethodMaker 207 [ new => [ -singleton => -hash => -init => 'a' ] ]; 208 209=item static_get_set 210 211 use Class::MethodMaker 212 [ scalar => [ -static => 'a' ], ]; 213 214=item static_hash 215 216 use Class::MethodMaker 217 [ hash => [ -static => 'a' ], ]; 218 219=item static_list 220 221 use Class::MethodMaker 222 [ list => [ -static => 'a' ], ]; 223 224=item tie_hash 225 226 use Class::MethodMaker 227 [ hash => [ { -tie_class => 'MyTie', 228 -tie_args => [qw/ foo bar baz /], 229 } => 'a' ], ]; 230 231=item tie_list 232 233 use Class::MethodMaker 234 [ array => [ { -tie_class => 'MyTie', 235 -tie_args => [qw/ foo bar baz /], 236 } => 'a' ], ]; 237 238=item tie_scalar 239 240 use Class::MethodMaker 241 [ scalar => [ { -tie_class => 'MyTie', 242 -tie_args => [qw/ foo bar baz /], 243 } => 'a' ], ]; 244 245=back 246 247=head2 Caveats & Expected Breakages 248 249The following version 1 component (slot) types are not currently supported in 250version 2: 251 252=over 4 253 254=item grouped_fields 255 256=item hash_of_lists 257 258=item listed_attrib 259 260=item struct 261 262=back 263 264=cut 265 266# ---------------------------------------------------------------------------- 267 268# Pragmas ----------------------------- 269 270require 5.006; 271use strict; 272use warnings; 273 274# Inheritance ------------------------- 275 276use base qw( Exporter ); 277our @EXPORT_OK = qw( V1COMPAT ); 278 279# Utility ----------------------------- 280 281use Carp qw( ); 282use Class::MethodMaker::Constants qw( ); 283 284# ---------------------------------------------------------------------------- 285 286# CLASS METHODS -------------------------------------------------------------- 287 288# ------------------------------------- 289# CLASS CONSTANTS 290# ------------------------------------- 291 292use constant INTEGER => Class::MethodMaker::Constants::INTEGER; 293 294use constant SCALAR_RENAME => +{ '*_clear' => 'clear_*', 295 '*_get' => 'get_*', 296 '*_set' => 'set_*', }; 297 298use constant SCALAR_ONLY_X_RENAME => +{ '*_clear' => undef, 299 '*_reset' => undef, 300 '*_isset' => undef, }; 301use constant GET_SET_PATTERN_MAP => 302 +{ -java => [ undef, undef, 'get*', 'set*' ], 303 -eiffel => [ undef, undef, '*', 'set_*' ], 304 -compatibility => [ '*', 'clear_*', undef, undef ], 305 -noclear => [ '*', undef, undef, undef ], 306 }; 307 308use constant LIST_RENAME => +{ '*_ref' => '*_ref', 309 '*_reset' => ['*_clear', 'clear_*' ], 310 '*_isset' => undef, 311 '*_get' => undef, 312 '*_set' => undef, 313 314 '*_count' => ['*_count', 'count_*' ], 315 '*_index' => ['*_index', 'index_*' ], 316 '*_pop' => ['*_pop', 'pop_*' ], 317 '*_push' => ['*_push', 'push_*' ], 318 '*_set' => ['*_set', 'set_*' ], 319 '*_shift' => ['*_shift', 'shift_*' ], 320 '*_splice' => ['*_splice', 'splice_*' ], 321 '*_unshift' => ['*_unshift', 'unshift_*'], }; 322 323use constant HASH_RENAME => +{ '*_v1compat' => '*', 324 '*_tally' => '*_tally', 325 '*' => undef, }; 326 327use constant HASH_OPT_HANDLER => sub { $_[3]->{substr($_[1], 1)} = 1; }; 328 329# ------------------------------------- 330 331sub rephrase_prefix_option { 332 my @opts = @_; 333 return sub { 334 return [@opts, ref $_[0] eq 'ARRAY' ? @{$_[0]} : $_[0] ]; 335 } 336} 337 338sub rephrase_tie { 339 # This is deliberately low on error-handling. 340 # We're not supporting V1 programming; if it works 341 # with V1, all is well; if it doesn't, use the V2 342 # approach. We don't want people coding up new stuff 343 # in V1 mode. 344 # 345 # I.e., anything that currently works with V1 is supported, but 346 # only to avoid breakage of existing classes. All future development 347 # should be done in V2 mode. 348 my ($names) = @_; 349 my @names; # Result 350 for (my $i = 0; $i < @$names; $i+=2) { 351 352 my ($comps, $args) = @{$names}[$i,$i+1]; 353 my @comps = ref $comps eq 'ARRAY' ? @$comps : $comps; 354 my @args = ref $args eq 'ARRAY' ? @$args : $args; 355 my ($tie_class, @tie_args) = @args; 356 push @names, { -tie_class => $tie_class, 357 -tie_args => \@tie_args, 358 }; 359 push @names, @comps; 360 } 361 return \@names; 362} 363 364sub rephrase_object_tie { 365 # This is deliberately low on error-handling. 366 # We're not supporting V1 programming; if it works 367 # with V1, all is well; if it doesn't, use the V2 368 # approach. We don't want people coding up new stuff 369 # in V1 mode. 370 # 371 # I.e., anything that currently works with V1 is supported, but 372 # only to avoid breakage of existing classes. All future development 373 # should be done in V2 mode. 374 my ($comps) = @_; 375 376 my @args; 377 for my $comp (@$comps) { 378 my ($tie_class, @tie_args) = @{$comp->{tie_hash}}; 379 my ($class, @c_args) = @{$comp->{class}}; 380 my $dctor = @c_args ? 'new' : sub { $class->new(@c_args) }; 381 my %opts = (-type => $class, 382 -tie_class => $tie_class, 383 -default_ctor => $dctor, 384 ); 385 $opts{-tie_args} = \@tie_args 386 if @tie_args; 387 push @args, \%opts, ref($comp->{slot}) ? @{$comp->{slot}} : $comp->{slot}; 388 } 389 return \@args; 390} 391 392# ------------------------------------- 393 394sub code_store_cb { 395 # A call to read with args (that aren't code references) appears to V2 to 396 # be a store call 397 # :-( 398 # therefore we sneak the args in to an array for read to use when called 399 # ;-/ 400 if ( ref ( $_[1] ) eq 'CODE' ) { 401 # A store is immediately followed by a read. Use undef in position 1 402 # (second element) as a marker of a recent store that should therefore 403 # be returned without invocation. 404 return [ $_[1], undef ]; 405 } else { 406 return [ $_[3]->[0], [ @_[4..$#_] ] ]; 407 } 408} 409 410# ------------------------------------- 411 412sub passthrough_option { 413 # Simple pass through 414 my ($type, $opt, $rename, $local_opts) = @_; 415 if ( ref $opt ) { 416 while ( my ($optname, $optval) = each %$opt ) { 417 $local_opts->{substr($optname, 1)} = $optval; 418 } 419 } else { 420 $local_opts->{substr($opt, 1)} = 1; 421 } 422} 423 424sub get_set_option { 425 my ($type, $opt, $rename, $local_opts, $class) = @_; 426 my @names; 427 if ( ref $opt ) { 428 if ( UNIVERSAL::isa($opt, 'ARRAY') ) { 429 @names = @$opt; 430 } elsif ( UNIVERSAL::isa($opt, 'HASH') ) { 431 $local_opts->{substr($_, 1)} = $opt->{$_} 432 for keys %$opt; 433 } else { 434 die("Option type " . ref($opt) . " not handled by get_set\n"); 435 } 436 } else { 437 if ( exists GET_SET_PATTERN_MAP()->{$opt} ) { 438 @names = @{GET_SET_PATTERN_MAP()->{$opt}}; 439 } else { 440 if ( $opt eq '-static' ) { 441 $local_opts->{static} = 1; 442 } elsif ( $opt =~ /^-(?:set_once(?:_or_(\w+))?)/ ) { 443 my ($action_name) = $1 || 'die'; 444 445 my %is_set; 446 if ($action_name eq 'ignore') { 447 $local_opts->{store_cb} = sub { 448 # Have to do this here, not prior to the sub, because the 449 # options hash is not available until the methods have been 450 # installed 451 my $options = 452 Class::MethodMaker::Engine->_class_comp_options($class, 453 $_[2]); 454 if ( exists $options->{static} ) { 455 $is_set{$_[2]}++ ? $_[3] : $_[1]; 456 } else { 457 if ( exists $is_set{$_[2]} and 458 grep $_ == $_[0], @{$is_set{$_[2]}} ) { 459 $_[3]; 460 } else { 461 push @{$is_set{$_[2]}}, $_[0]; 462 $_[1]; 463 } 464 } 465 }; 466 } elsif ($action_name =~ /carp|cluck|croak|confess/) { 467 $local_opts->{store_cb} = sub { 468 # Have to do this here, not prior to the sub, because the 469 # options hash is not available until the methods have been 470 # installed 471 my $options = 472 Class::MethodMaker::Engine->_class_comp_options($class, 473 $_[2]); 474 my $action = join '::', 'Carp', $action_name; 475 no strict 'refs'; 476 if ( exists $options->{static} ) { 477 $is_set{$_[2]}++ ? &$action("Attempt to set slot ", 478 ref($_[0]), '::', $_[2], 479 " more than once") 480 : $_[1]; 481 } else { 482 if ( exists $is_set{$_[2]} and 483 grep $_ == $_[0], @{$is_set{$_[2]}} ) { 484 &$action("Attempt to set slot ", 485 ref($_[0]), '::', $_[2], 486 " more than once") 487 } else { 488 push @{$is_set{$_[2]}}, $_[0]; 489 $_[1]; 490 } 491 } 492 }; 493 } elsif ($action_name =~ /die|warn/){ 494 my $action = join '::', 'CORE', $action_name; 495 $action = eval("sub { $action(\@_) }"); 496 $local_opts->{store_cb} = sub { 497 # Have to do this here, not prior to the sub, because the 498 # options hash is not available until the methods have been 499 # installed 500 my $options = 501 Class::MethodMaker::Engine->_class_comp_options($class, 502 $_[2]); 503 if ( exists $options->{static} ) { 504 $is_set{$_[2]}++ ? $action->("Attempt to set slot ", 505 ref($_[0]), '::', $_[2], 506 " more than once") 507 : $_[1]; 508 } else { 509 if ( exists $is_set{$_[2]} and 510 grep $_ == $_[0], @{$is_set{$_[2]}} ) { 511 $action->("Attempt to set slot ", 512 ref($_[0]), '::', $_[2], 513 " more than once") 514 } else { 515 push @{$is_set{$_[2]}}, $_[0]; 516 $_[1]; 517 } 518 } 519 }; 520 } else { 521 $local_opts->{store_cb} = sub { 522 # Have to do this here, not prior to the sub, because the 523 # options hash is not available until the methods have been 524 # installed 525 my $options = 526 Class::MethodMaker::Engine->_class_comp_options($class, 527 $_[2]); 528 my $action = join '::', ref($_[0]), $action_name; 529 no strict 'refs'; 530 if ( exists $options->{static} ) { 531 $is_set{$_[2]}++ ? &{$action}(@_[4..$#_]) 532 : $_[1]; 533 } else { 534 if ( exists $is_set{$_[2]} and 535 grep $_ == $_[0], @{$is_set{$_[2]}} ) { 536 &{$action}(@_[4..$#_]); 537 } else { 538 push @{$is_set{$_[2]}}, $_[0]; 539 $_[1]; 540 } 541 } 542 }; 543 } 544 } else { 545 die "Option $opt not recognized for get_set\n"; 546 } 547 } 548 } 549 550 $local_opts->{static} = 1 551 if $type eq 'static_get_set'; 552 553 for (0..3) { 554 $rename->{qw( * *_clear *_get *_set )[$_]} = $names[$_] 555 if $_ < @names; 556 } 557}; 558 559sub key_option { 560 my ($v1type, $name, $rename, $local_opts, $target_class) = @_; 561 my %list; 562 563 if ( $name eq '-dummy' ) { 564 $local_opts->{_value_list} = \%list; 565 $local_opts->{key_create} = 1 566 if substr($v1type, -6) eq 'create'; 567 $local_opts->{store_cb} = sub { 568 if ( defined $_[3] ) { 569 # the object must be in the hash under its old 570 # value so that entry needs to be deleted 571 delete $list{$_[3]}; 572 } 573 if ( defined $_[1] and 574 exists $list{$_[1]} and 575 $list{$_[1]} ne $_[0] ) { 576 # There's already an object stored under that 577 # value so we need to unset it's value 578 my $x = $_[2]; 579 $list{$_[1]}->$x(undef); 580 } 581 582 $list{$_[1]} = $_[0] 583 if defined $_[1]; 584 $_[1]; 585 } 586 } else { 587 die "Option '$_' to get_concat unrecognized\n"; 588 } 589} 590 591sub object_tie_option { 592 my ($type, $opt, $rename, $local_opts) = @_; 593 if ( ref $opt ) { 594 while ( my ($optname, $optval) = each %$opt ) { 595 $local_opts->{substr($optname, 1)} = $optval 596 unless $optname eq '-ctor_args'; 597 } 598 } else { 599 $local_opts->{substr($opt, 1)} = 1; 600 } 601 602 my $el_type = $opt->{-type}; 603 my $ctor = $opt->{-default_ctor}; 604 my $ctor_args = $opt->{-ctor_args}; 605 $local_opts->{store_cb} = sub { 606 my (undef, $value) = @_; 607 608 [ map { 609 if ( UNIVERSAL::isa($_, $el_type) ) { 610 $_; 611 } elsif ( ref($_) eq 'ARRAY' ) { 612 # Nasty hack for nasty inconsistency in V1 implementations 613 my @args = index($type, 'hash') >= 0 ? (@$ctor_args, @$_) : @$_; 614 $el_type->$ctor(@args); 615 } else { 616 $el_type->$ctor(@$ctor_args); 617 } 618 } @$value ]; 619 }; 620} 621 622# ------------------------------------- 623 624# Hackery for get_concat 625my $gc_join = ''; 626 627# Recognized keys are: 628# v2name 629# Name of v2 component type that implements this v1 call under the hood 630# rename 631# Method renames to apply (see create_methods) to make this look like the 632# v1 call 633# option 634# Subr called to parse options. 635# Receieves args 636# type ) The type of the component, as called by the user 637# (e.g., static_get_set) 638# opt ) The name of the option (including any leading '-'). 639# rename ) The rename hashref, as set up by rename above 640# local_opts ) An option hash. This is initially empty, it is the job 641# of the subr to add/subtract items to this as necessary. 642# Items may/shall accumulate as options are invoked on a 643# single typecall. 644# rephrase 645# Subr to rephrase arguments to a type call. If defined, this subr is 646# handed the arguments to the component type, in raw incoming form, and 647# its return value is used in place. This is to allow arbitrary argument 648# juggling. 649use constant V1COMPAT => 650 { 651 # New Methods -------------------- 652 653 new => +{}, 654 655 new_hash_with_init => +{ v2name => 'new', 656 option => HASH_OPT_HANDLER, 657 rephrase => 658 rephrase_prefix_option(qw( -hash -init )), 659 }, 660 661 new_with_init => +{ v2name => 'new', 662 option => HASH_OPT_HANDLER, 663 rephrase => rephrase_prefix_option(qw( -init )) 664 }, 665 666 new_hash_init => +{ v2name => 'new', 667 option => HASH_OPT_HANDLER, 668 rephrase => rephrase_prefix_option(qw( -hash )), 669 }, 670 671 singleton => +{ v2name => 'new', 672 option => HASH_OPT_HANDLER, 673 rephrase => 674 rephrase_prefix_option(qw(-hash -singleton -init)), 675 }, 676 677 # This is provided only for v1 compatibility; no attempt is made to 678 # support this in V2, for it is a trivial application of new_with_init. 679 new_with_args => +{ v2name => 'new', 680 option => HASH_OPT_HANDLER, 681 rephrase => rephrase_prefix_option(qw( -direct-init )) 682 }, 683 684 685 # Copy Methods ------------------- 686 687 copy => +{}, 688 deep_copy => +{ v2name => 'copy', 689 option => sub { 690 $_[3]->{deep} = 1; 691 }, 692 rephrase => rephrase_prefix_option('-dummy'), 693 }, 694 695 # Scalar Methods ----------------- 696 697 get_set => { v2name => 'scalar', 698 rename => SCALAR_RENAME, 699 option => \&get_set_option, 700 }, 701 static_get_set => { 702 v2name => 'scalar', 703 rename => SCALAR_RENAME, 704 option => \&get_set_option, 705 rephrase => rephrase_prefix_option('-static'), 706 }, 707 tie_scalar => { v2name => 'scalar', 708 rename => SCALAR_RENAME, 709 rephrase => \&rephrase_tie, 710 option => \&get_set_option, 711 }, 712 counter => { v2name => 'scalar', 713 rename => SCALAR_RENAME, 714 option => \&passthrough_option, 715 rephrase => 716 rephrase_prefix_option(+{-type => INTEGER}), 717 }, 718 get_concat => { v2name => 'scalar', 719 rename => SCALAR_RENAME, 720 option => sub { 721 my ($type, $opt, $rename, $local_opts) = @_; 722 723 if ( ref $opt ) { 724 for ( keys %$opt ) { 725 if ( $_ eq '-join' ) { 726 $gc_join = $opt->{-join}; 727 } else { 728 die "Option '$_' to get_concat unrecognized\n"; 729 } 730 } 731 } elsif ( $opt eq '-dummy' ) { 732 my $join = $gc_join; 733 $local_opts->{store_cb} = 734 sub { 735 defined $_[1] ? 736 (defined $_[3] ? "$_[3]$join$_[1]" : $_[1] ) : 737 undef; 738 }; 739 $gc_join = ''; 740 } else { 741 $local_opts->{substr($opt, 1)} = 1; 742 } 743 }, 744 rephrase => sub { 745 my @opts = @_; 746 if ( UNIVERSAL::isa($_[0], 'HASH') ) { 747 return [ +{ -join => $_[0]->{join}}, 748 '-dummy', 749 $_[0]->{name} 750 ]; 751 } else { 752 return ['-dummy', 753 ref $_[0] eq 'ARRAY' ? @{$_[0]} : $_[0] ]; 754 } 755 }, 756 }, 757 key_attrib => { v2name => 'scalar', 758 rename => +{ %{SCALAR_RENAME()}, 759 '*_find' => 'find_*', }, 760 option => \&key_option, 761 rephrase => rephrase_prefix_option(qw( -dummy )), 762 }, 763 764 key_with_create =>{ v2name => 'scalar', 765 rename => +{ %{SCALAR_RENAME()}, 766 '*_find' => 'find_*', }, 767 option => \&key_option, 768 rephrase => rephrase_prefix_option(qw( -dummy )), 769 }, 770 771 # Code-Based Types 772 code => { v2name => 'scalar', 773 rename => SCALAR_ONLY_X_RENAME, 774 rephrase => rephrase_prefix_option('-dummy'), 775 option => sub { 776 my ($type, $opt, $rename, $local_opts) = @_; 777 # Let's face it, the V1 i/f, with it's 778 # store-if-it's-a-coderef-else-retrieve semantics 779 # is rather broken. Which is why we engage in such 780 # hackery... 781 $local_opts->{read_cb} = 782 sub { 783 if ( ref($_[1]) eq 'ARRAY' ) { 784 if ( @{$_[1]} == 1 ) { # No args 785 return $_[1]->[0]->(); 786 } elsif ( defined $_[1]->[1] ) { 787 # Read with args that was handed to store 788 return $_[1]->[0]->(@{$_[1]->[1]}); 789 } else { 790 # We're reading after a recent store 791 pop @{$_[1]}; 792 return $_[1]->[0]; 793 } 794 } 795 }; 796 $local_opts->{store_cb} = \&code_store_cb; 797 }, 798 }, 799 800 method => { v2name => 'scalar', 801 rename => SCALAR_ONLY_X_RENAME, 802 rephrase => rephrase_prefix_option('-dummy'), 803 option => sub { 804 my ($type, $opt, $rename, $local_opts) = @_; 805 # Let's face it, the V1 i/f, with it's 806 # store-if-it's-a-coderef-else-retrieve semantics 807 # is rather broken. Which is why we engage in such 808 # hackery... 809 $local_opts->{read_cb} = 810 sub { 811 if ( ref($_[1]) eq 'ARRAY' ) { 812 if ( @{$_[1]} == 1 ) { # No args 813 return $_[1]->[0]->($_[0]); 814 } elsif ( defined $_[1]->[1] ) { 815 # Read with args that was handed to store 816 return $_[1]->[0]->($_[0], @{$_[1]->[1]}); 817 } else { 818 # We're reading after a recent store 819 pop @{$_[1]}; 820 return $_[1]->[0]; 821 } 822 } 823 }; 824 $local_opts->{store_cb} = \&code_store_cb; 825 }, 826 }, 827 828 # List Methods ------------------- 829 830 object => { 831 v2name => 'scalar', 832 rephrase => sub { 833 my ($names) = @_; 834 835 die("v1 meta-method object requires an arrayref as it's ", 836 "argument\n") 837 unless UNIVERSAL::isa($names, 'ARRAY'); 838 839 my @Results; 840 841 while ( my($type, $args) = splice @$names, 0, 2 ) { 842 die("type specifier to v1 object must be a non-ref ", 843 "value\n") 844 if ref $type; 845 846 for (UNIVERSAL::isa($args, 'ARRAY') ? @$args : $args) { 847 my (@names, @fwds); 848 if ( ! ref $_ ) { 849 @names = $_; 850 } elsif ( UNIVERSAL::isa($_, 'HASH') ) { 851 @names = $_->{slot}; 852 @fwds = $_->{comp_mthds}; 853 @fwds = @{$fwds[0]} 854 if UNIVERSAL::isa($fwds[0], 'ARRAY'); 855 } else { 856 die("Argument $_ to 'object' v1 meta-method not ", 857 "comprehended\n"); 858 } 859 860 push (@Results, 861 { -type => $type, 862 -forward => \@fwds, 863 -default_ctor => 'new', 864 -v1_object => 1, 865 }, 866 @names); 867 } 868 } 869 \@Results; 870 }, 871 option => \&passthrough_option, 872 }, 873 874 list => { v2name => 'array', 875 rename => LIST_RENAME, 876 }, 877 static_list => { v2name => 'array', 878 rename => LIST_RENAME, 879 rephrase => rephrase_prefix_option('-static'), 880 option => sub { 881 my ($type, $opt, $rename, $local_opts) = @_; 882 $local_opts->{static} = 1; 883 }, 884 }, 885 886 object_list => { v2name => 'array', 887 rename => LIST_RENAME, 888 rephrase => sub { 889 # This is deliberately low on error-handling. 890 # We're not supporting V1 programming; if it works 891 # with V1, all is well; if it doesn't, use the V2 892 # approach. We don't want people coding up new stuff 893 # in V1 mode. 894 my ($names) = @_; 895 my @names; # Result 896 for (my $i = 0; $i < @$names; $i+=2) { 897 my ($class, $args) = @{$names}[$i,$i+1]; 898 my @args = ref $args eq 'ARRAY' ? @$args : $args; 899 900 push @names, +{ -type => $class, 901 -default_ctor => 'new' }; 902 903 for my $arg (@args) { 904 if ( ref $arg eq 'HASH' ) { 905 my ($slot, $comp_mthds) = 906 @{$arg}{qw( slot comp_mthds )}; 907 my @comp_mthds = 908 ref $comp_mthds ? @$comp_mthds : $comp_mthds; 909 push @names, +{ -forward => \@comp_mthds } 910 if @comp_mthds; 911 push @names, $slot; 912 } else { 913 push @names, $arg; 914 } 915 } 916 } 917 return \@names; 918 }, 919 option => \&passthrough_option, 920 }, 921 tie_list => { v2name => 'array', 922 rename => LIST_RENAME, 923 rephrase => \&rephrase_tie, 924 option => \&passthrough_option, 925 }, 926 object_tie_list => { v2name => 'array', 927 rename => LIST_RENAME, 928 rephrase => sub { 929 # This is deliberately low on error-handling. 930 # We're not supporting V1 programming; if it works 931 # with V1, all is well; if it doesn't, use the V2 932 # approach. We don't want people coding up new 933 # stuff in V1 mode. 934 my ($names) = @_; 935 my @names; # Result 936 for my $hashr (@$names) { 937 my ($slots, $class, $tie_args) = 938 @{$hashr}{qw( slot class tie_array )}; 939 my @slots = ref $slots eq 'ARRAY' ? 940 @$slots : $slots; 941 my @class_args; 942 ($class, @class_args) = @$class 943 if ref $class eq 'ARRAY'; 944 my $ctor; 945 if ( @class_args ) { 946 $ctor = sub { 947 return $class->new(@class_args); 948 }; 949 } else { 950 $ctor = 'new'; 951 } 952 my ($tie_class, @tie_args) = 953 @$tie_args; 954 push @names, +{ -type => $class, 955 -default_ctor => 'new', 956 -ctor_args => \@class_args, 957 -tie_class => $tie_class, 958 -tie_args => \@tie_args,}; 959 960 push @names, @slots; 961 } 962 return \@names; 963 }, 964 option => \&object_tie_option, 965 }, 966 object_tie_hash => { v2name => 'hash', 967 rename => HASH_RENAME, 968 rephrase => sub { 969 # This is deliberately low on error-handling. 970 # We're not supporting V1 programming; if it works 971 # with V1, all is well; if it doesn't, use the V2 972 # approach. We don't want people coding up new 973 # stuff in V1 mode. 974 my ($names) = @_; 975 my @names; # Result 976 for my $hashr (@$names) { 977 my ($slots, $class, $tie_args) = 978 @{$hashr}{qw( slot class tie_hash )}; 979 my @slots = ref $slots eq 'ARRAY' ? 980 @$slots : $slots; 981 my @class_args; 982 ($class, @class_args) = @$class 983 if ref $class eq 'ARRAY'; 984 my $ctor; 985 if ( @class_args ) { 986 $ctor = sub { 987 return $class->new(@class_args); 988 }; 989 } else { 990 $ctor = 'new'; 991 } 992 my ($tie_class, @tie_args) = 993 @$tie_args; 994 push @names, +{ -type => $class, 995 -default_ctor => 'new', 996 -ctor_args => \@class_args, 997 -tie_class => $tie_class, 998 -tie_args => \@tie_args,}; 999 1000 push @names, @slots; 1001 } 1002 return \@names; 1003 }, 1004 option => \&object_tie_option, 1005 }, 1006 1007 # Hash Methods ------------------- 1008 1009 hash => +{ 1010 rename => HASH_RENAME, 1011 }, 1012 static_hash => { 1013 v2name => 'hash', 1014 rename => HASH_RENAME, 1015 option => \&passthrough_option, 1016 rephrase => rephrase_prefix_option('-static'), 1017 }, 1018 tie_hash => { v2name => 'hash', 1019 rename => HASH_RENAME, 1020 rephrase => \&rephrase_tie, 1021 option => \&passthrough_option, 1022 }, 1023 1024 # Misc Methods ------------------- 1025 1026 abstract => +{}, 1027 boolean => { v2name => '_boolean', 1028 rename => +{ '*_set' => 'set_*', 1029 '*_clear' => 'clear_*', }, }, 1030 }; 1031 1032# ---------------------------------------------------------------------------- 1033 1034=head1 EXAMPLES 1035 1036Z<> 1037 1038=head1 BUGS 1039 1040Z<> 1041 1042=head1 REPORTING BUGS 1043 1044Email the development mailing list C<class-mmaker-devel@lists.sourceforge.net>. 1045 1046=head1 AUTHOR 1047 1048Martyn J. Pearce 1049 1050=head1 COPYRIGHT 1051 1052Copyright (c) 2003, 2004 Martyn J. Pearce. This program is free software; you 1053can redistribute it and/or modify it under the same terms as Perl itself. 1054 1055=head1 SEE ALSO 1056 1057Z<> 1058 1059=cut 1060 10611; # keep require happy. 1062 1063__END__ 1064