|
376
|
0 |
0 |
if (exists ${my $v = {"abstract" => {},"boolean" => {"rename" => {"*_clear" => "clear_*","*_set" => "set_*"},"v2name" => "_boolean"},"code" => {"option" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; my($type, $opt, $rename, $local_opts) = @_; $local_opts->{'read_cb'} = sub { if (ref $_[1] eq 'ARRAY') { if (@{$_[1];} == 1) { return $_[1][0]->(); } elsif (defined $_[1][1]) { return $_[1][0]->(@{$_[1][1];}); } else { pop @{$_[1];}; return $_[1][0]; } } } ; $local_opts->{'store_cb'} = \&Class::MethodMaker::V1Compat::code_store_cb;},"rename" => {"*_clear" => undef,"*_isset" => undef,"*_reset" => undef},"rephrase" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; return [@opts, ref $_[0] eq 'ARRAY' ? @{$_[0];} : $_[0]];},"v2name" => "scalar"},"copy" => {},"counter" => {"option" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; my($type, $opt, $rename, $local_opts) = @_; if (ref $opt) { while (my($optname, $optval) = each %$opt) { do { $$local_opts{substr $optname, 1} = $optval }; } } else { $$local_opts{substr $opt, 1} = 1; }},"rename" => {"*_clear" => "clear_*","*_get" => "get_*","*_set" => "set_*"},"rephrase" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; return [@opts, ref $_[0] eq 'ARRAY' ? @{$_[0];} : $_[0]];},"v2name" => "scalar"},"deep_copy" => {"option" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; $_[3]{'deep'} = 1;},"rephrase" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; return [@opts, ref $_[0] eq 'ARRAY' ? @{$_[0];} : $_[0]];},"v2name" => "copy"},"get_concat" => {"option" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; my($type, $opt, $rename, $local_opts) = @_; if (ref $opt) { foreach $_ (keys %$opt) { if ($_ eq '-join') { $gc_join = $opt->{'-join'}; } else { die "Option '${_}' to get_concat unrecognized\n"; } } } elsif ($opt eq '-dummy') { my $join = $gc_join; $local_opts->{'store_cb'} = sub { defined $_[1] ? defined $_[3] ? "$_[3]$join$_[1]" : $_[1] : undef; } ; $gc_join = ''; } else { $$local_opts{substr $opt, 1} = 1; }},"rename" => {},"rephrase" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; my(@opts) = @_; if (UNIVERSAL::isa($_[0], 'HASH')) { return [{'-join', $_[0]{'join'}}, '-dummy', $_[0]{'name'}]; } else { return ['-dummy', ref $_[0] eq 'ARRAY' ? @{$_[0];} : $_[0]]; }},"v2name" => "scalar"},"get_set" => {"option" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; my($type, $opt, $rename, $local_opts, $class) = @_; my @names; if (ref $opt) { if (UNIVERSAL::isa($opt, 'ARRAY')) { @names = @$opt; } elsif (UNIVERSAL::isa($opt, 'HASH')) { $$local_opts{substr $_, 1} = $opt->{$_} foreach (keys %$opt); } else { die 'Option type ' . ref($opt) . " not handled by get_set\n"; } } else { if (exists {-compatibility => ['*', 'clear_*', undef, undef], -eiffel => [undef, undef, '*', 'set_*'], -java => [undef, undef, 'get*', 'set*'], -noclear => ['*', undef, undef, undef]}->{$opt}) { @names = @{{-compatibility => ['*', 'clear_*', undef, undef], -eiffel => [undef, undef, '*', 'set_*'], -java => [undef, undef, 'get*', 'set*'], -noclear => ['*', undef, undef, undef]}->{$opt};}; } else { if ($opt eq '-static') { $local_opts->{'static'} = 1; } elsif ($opt =~ /^-(?:set_once(?:_or_(\w+))?)/) { my($action_name) = $1 || 'die'; my %is_set; if ($action_name eq 'ignore') { $local_opts->{'store_cb'} = sub { my $options = 'Class::MethodMaker::Engine'->_class_comp_options($class, $_[2]); if (exists $options->{'static'}) { $is_set{$_[2]}++ ? $_[3] : $_[1]; } else { if (exists $is_set{$_[2]} and grep(($_ == $_[0]), @{$is_set{$_[2]};})) { $_[3]; } else { push @{$is_set{$_[2]};}, $_[0]; $_[1]; } } } ; } elsif ($action_name =~ /carp|cluck|croak|confess/) { $local_opts->{'store_cb'} = sub { my $options = 'Class::MethodMaker::Engine'->_class_comp_options($class, $_[2]); my $action = join('::', 'Carp', $action_name); no strict 'refs'; if (exists $options->{'static'}) { $is_set{$_[2]}++ ? &$action('Attempt to set slot ', ref $_[0], '::', $_[2], ' more than once') : $_[1]; } else { if (exists $is_set{$_[2]} and grep(($_ == $_[0]), @{$is_set{$_[2]};})) { &$action('Attempt to set slot ', ref $_[0], '::', $_[2], ' more than once'); } else { push @{$is_set{$_[2]};}, $_[0]; $_[1]; } } } ; } elsif ($action_name =~ /die|warn/) { my $action = join('::', 'CORE', $action_name); $action = eval "sub { $action(\@_) }"; $local_opts->{'store_cb'} = sub { my $options = 'Class::MethodMaker::Engine'->_class_comp_options($class, $_[2]); if (exists $options->{'static'}) { $is_set{$_[2]}++ ? &$action('Attempt to set slot ', ref $_[0], '::', $_[2], ' more than once') : $_[1]; } else { if (exists $is_set{$_[2]} and grep(($_ == $_[0]), @{$is_set{$_[2]};})) { &$action('Attempt to set slot ', ref $_[0], '::', $_[2], ' more than once'); } else { push @{$is_set{$_[2]};}, $_[0]; $_[1]; } } } ; } else { $local_opts->{'store_cb'} = sub { my $options = 'Class::MethodMaker::Engine'->_class_comp_options($class, $_[2]); my $action = join('::', ref $_[0], $action_name); no strict 'refs'; if (exists $options->{'static'}) { $is_set{$_[2]}++ ? &{$action;}(@_[4 .. $#_]) : $_[1]; } else { if (exists $is_set{$_[2]} and grep(($_ == $_[0]), @{$is_set{$_[2]};})) { &{$action;}(@_[4 .. $#_]); } else { push @{$is_set{$_[2]};}, $_[0]; $_[1]; } } } ; } } else { die "Option $opt not recognized for get_set\n"; } } } $local_opts->{'static'} = 1 if $type eq 'static_get_set'; foreach $_ (0 .. 3) { $$rename{('*', '*_clear', '*_get', '*_set')[$_]} = $names[$_] if $_ < @names; }},"rename" => {},"v2name" => "scalar"},"hash" => {"rename" => {"*" => undef,"*_tally" => "*_tally","*_v1compat" => "*"}},"key_attrib" => {"option" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; my($v1type, $name, $rename, $local_opts, $target_class) = @_; my %list; if ($name eq '-dummy') { $local_opts->{'_value_list'} = \%list; $local_opts->{'key_create'} = 1 if substr($v1type, -6) eq 'create'; $local_opts->{'store_cb'} = sub { if (defined $_[3]) { delete $list{$_[3]}; } if (defined $_[1] and exists $list{$_[1]} and $list{$_[1]} ne $_[0]) { my $x = $_[2]; $list{$_[1]}->$x(undef); } $list{$_[1]} = $_[0] if defined $_[1]; $_[1]; } ; } else { die "Option '${_}' to get_concat unrecognized\n"; }},"rename" => {"*_clear" => "clear_*","*_find" => "find_*","*_get" => "get_*","*_set" => "set_*"},"rephrase" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; return [@opts, ref $_[0] eq 'ARRAY' ? @{$_[0];} : $_[0]];},"v2name" => "scalar"},"key_with_create" => {"option" => do{my $o},"rename" => {"*_clear" => "clear_*","*_find" => "find_*","*_get" => "get_*","*_set" => "set_*"},"rephrase" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; return [@opts, ref $_[0] eq 'ARRAY' ? @{$_[0];} : $_[0]];},"v2name" => "scalar"},"list" => {"rename" => {"*_count" => ["*_count","count_*"],"*_get" => undef,"*_index" => ["*_index","index_*"],"*_isset" => undef,"*_pop" => ["*_pop","pop_*"],"*_push" => ["*_push","push_*"],"*_ref" => "*_ref","*_reset" => ["*_clear","clear_*"],"*_set" => ["*_set","set_*"],"*_shift" => ["*_shift","shift_*"],"*_splice" => ["*_splice","splice_*"],"*_unshift" => ["*_unshift","unshift_*"]},"v2name" => "array"},"method" => {"option" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; my($type, $opt, $rename, $local_opts) = @_; $local_opts->{'read_cb'} = sub { if (ref $_[1] eq 'ARRAY') { if (@{$_[1];} == 1) { return $_[1][0]->($_[0]); } elsif (defined $_[1][1]) { return $_[1][0]->($_[0], @{$_[1][1];}); } else { pop @{$_[1];}; return $_[1][0]; } } } ; $local_opts->{'store_cb'} = \&Class::MethodMaker::V1Compat::code_store_cb;},"rename" => {},"rephrase" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; return [@opts, ref $_[0] eq 'ARRAY' ? @{$_[0];} : $_[0]];},"v2name" => "scalar"},"new" => {},"new_hash_init" => {"option" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; $_[3]{substr $_[1], 1} = 1;},"rephrase" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; return [@opts, ref $_[0] eq 'ARRAY' ? @{$_[0];} : $_[0]];},"v2name" => "new"},"new_hash_with_init" => {"option" => do{my $o},"rephrase" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; return [@opts, ref $_[0] eq 'ARRAY' ? @{$_[0];} : $_[0]];},"v2name" => "new"},"new_with_args" => {"option" => do{my $o},"rephrase" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; return [@opts, ref $_[0] eq 'ARRAY' ? @{$_[0];} : $_[0]];},"v2name" => "new"},"new_with_init" => {"option" => do{my $o},"rephrase" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; return [@opts, ref $_[0] eq 'ARRAY' ? @{$_[0];} : $_[0]];},"v2name" => "new"},"object" => {"option" => do{my $o},"rephrase" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; my($names) = @_; die q[v1 meta-method object requires an arrayref as it's ], "argument\n" unless UNIVERSAL::isa($names, 'ARRAY'); my @Results; while (my($type, $args) = splice(@$names, 0, 2)) { do { die 'type specifier to v1 object must be a non-ref ', "value\n" if ref $type; foreach $_ (UNIVERSAL::isa($args, 'ARRAY') ? @$args : $args) { my(@names, @fwds); if (not ref $_) { @names = $_; } elsif (UNIVERSAL::isa($_, 'HASH')) { @names = $_->{'slot'}; @fwds = $_->{'comp_mthds'}; @fwds = @{$fwds[0];} if UNIVERSAL::isa($fwds[0], 'ARRAY'); } else { die "Argument $_ to 'object' v1 meta-method not ", "comprehended\n"; } push @Results, {'-type', $type, '-forward', \@fwds, '-default_ctor', 'new', '-v1_object', 1}, @names; } }; } \@Results;},"v2name" => "scalar"},"object_list" => {"option" => do{my $o},"rename" => {},"rephrase" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; my($names) = @_; my @names; for (my $i = 0; $i < @$names; $i += 2) { my($class, $args) = @{$names;}[$i, $i + 1]; my(@args) = ref $args eq 'ARRAY' ? @$args : $args; push @names, {'-type', $class, '-default_ctor', 'new'}; foreach my $arg (@args) { if (ref $arg eq 'HASH') { my($slot, $comp_mthds) = @{$arg;}{'slot', 'comp_mthds'}; my(@comp_mthds) = ref $comp_mthds ? @$comp_mthds : $comp_mthds; push @names, {'-forward', \@comp_mthds} if @comp_mthds; push @names, $slot; } else { push @names, $arg; } } } return \@names;},"v2name" => "array"},"object_tie_hash" => {"option" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; my($type, $opt, $rename, $local_opts) = @_; if (ref $opt) { while (my($optname, $optval) = each %$opt) { do { $$local_opts{substr $optname, 1} = $optval unless $optname eq '-ctor_args' }; } } else { $$local_opts{substr $opt, 1} = 1; } my $el_type = $opt->{'-type'}; my $ctor = $opt->{'-default_ctor'}; my $ctor_args = $opt->{'-ctor_args'}; $local_opts->{'store_cb'} = sub { my(undef, $value) = @_; [map({if (UNIVERSAL::isa($_, $el_type)) { $_; } elsif (ref $_ eq 'ARRAY') { my(@args) = index($type, 'hash') != -1 ? (@$ctor_args, @$_) : @$_; $el_type->$ctor(@args); } else { $el_type->$ctor(@$ctor_args); }} @$value)]; } ;},"rename" => {},"rephrase" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; my($names) = @_; my @names; foreach my $hashr (@$names) { my($slots, $class, $tie_args) = @{$hashr;}{'slot', 'class', 'tie_hash'}; my(@slots) = ref $slots eq 'ARRAY' ? @$slots : $slots; my @class_args; ($class, @class_args) = @$class if ref $class eq 'ARRAY'; my $ctor; if (@class_args) { $ctor = sub { return $class->new(@class_args); } ; } else { $ctor = 'new'; } my($tie_class, @tie_args) = @$tie_args; push @names, {'-type', $class, '-default_ctor', 'new', '-ctor_args', \@class_args, '-tie_class', $tie_class, '-tie_args', \@tie_args}; push @names, @slots; } return \@names;},"v2name" => "hash"},"object_tie_list" => {"option" => do{my $o},"rename" => {},"rephrase" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; my($names) = @_; my @names; foreach my $hashr (@$names) { my($slots, $class, $tie_args) = @{$hashr;}{'slot', 'class', 'tie_array'}; my(@slots) = ref $slots eq 'ARRAY' ? @$slots : $slots; my @class_args; ($class, @class_args) = @$class if ref $class eq 'ARRAY'; my $ctor; if (@class_args) { $ctor = sub { return $class->new(@class_args); } ; } else { $ctor = 'new'; } my($tie_class, @tie_args) = @$tie_args; push @names, {'-type', $class, '-default_ctor', 'new', '-ctor_args', \@class_args, '-tie_class', $tie_class, '-tie_args', \@tie_args}; push @names, @slots; } return \@names;},"v2name" => "array"},"singleton" => {"option" => do{my $o},"rephrase" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; return [@opts, ref $_[0] eq 'ARRAY' ? @{$_[0];} : $_[0]];},"v2name" => "new"},"static_get_set" => {"option" => do{my $o},"rename" => {},"rephrase" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; return [@opts, ref $_[0] eq 'ARRAY' ? @{$_[0];} : $_[0]];},"v2name" => "scalar"},"static_hash" => {"option" => do{my $o},"rename" => {},"rephrase" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; return [@opts, ref $_[0] eq 'ARRAY' ? @{$_[0];} : $_[0]];},"v2name" => "hash"},"static_list" => {"option" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; my($type, $opt, $rename, $local_opts) = @_; $local_opts->{'static'} = 1;},"rename" => {},"rephrase" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; return [@opts, ref $_[0] eq 'ARRAY' ? @{$_[0];} : $_[0]];},"v2name" => "array"},"tie_hash" => {"option" => do{my $o},"rename" => {},"rephrase" => sub { package Class::MethodMaker::V1Compat; use warnings; use strict; my($names) = @_; my @names; for (my $i = 0; $i < @$names; $i += 2) { my($comps, $args) = @{$names;}[$i, $i + 1]; my(@comps) = ref $comps eq 'ARRAY' ? @$comps : $comps; my(@args) = ref $args eq 'ARRAY' ? @$args : $args; my($tie_class, @tie_args) = @args; push @names, {'-tie_class', $tie_class, '-tie_args', \@tie_args}; push @names, @comps; } return \@names;},"v2name" => "hash"},"tie_list" => {"option" => do{my $o},"rename" => {},"rephrase" => do{my $o},"v2name" => "array"},"tie_scalar" => {"option" => do{my $o},"rename" => {},"rephrase" => do{my $o},"v2name" => "scalar"}};$v->{"get_concat"}{"rename"} = $v->{"counter"}{"rename"};$v->{"get_set"}{"rename"} = $v->{"counter"}{"rename"};$v->{"key_with_create"}{"option"} = $v->{"key_attrib"}{"option"};$v->{"method"}{"rename"} = $v->{"code"}{"rename"};$v->{"new_hash_with_init"}{"option"} = $v->{"new_hash_init"}{"option"};$v->{"new_with_args"}{"option"} = $v->{"new_hash_init"}{"option"};$v->{"new_with_init"}{"option"} = $v->{"new_hash_init"}{"option"};$v->{"object"}{"option"} = $v->{"counter"}{"option"};$v->{"object_list"}{"option"} = $v->{"counter"}{"option"};$v->{"object_list"}{"rename"} = $v->{"list"}{"rename"};$v->{"object_tie_hash"}{"rename"} = $v->{"hash"}{"rename"};$v->{"object_tie_list"}{"option"} = $v->{"object_tie_hash"}{"option"};$v->{"object_tie_list"}{"rename"} = $v->{"list"}{"rename"};$v->{"singleton"}{"option"} = $v->{"new_hash_init"}{"option"};$v->{"static_get_set"}{"option"} = $v->{"get_set"}{"option"};$v->{"static_get_set"}{"rename"} = $v->{"counter"}{"rename"};$v->{"static_hash"}{"option"} = $v->{"counter"}{"option"};$v->{"static_hash"}{"rename"} = $v->{"hash"}{"rename"};$v->{"static_list"}{"rename"} = $v->{"list"}{"rename"};$v->{"tie_hash"}{"option"} = $v->{"counter"}{"option"};$v->{"tie_hash"}{"rename"} = $v->{"hash"}{"rename"};$v->{"tie_list"}{"option"} = $v->{"counter"}{"option"};$v->{"tie_list"}{"rename"} = $v->{"list"}{"rename"};$v->{"tie_list"}{"rephrase"} = $v->{"tie_hash"}{"rephrase"};$v->{"tie_scalar"}{"option"} = $v->{"get_set"}{"option"};$v->{"tie_scalar"}{"rename"} = $v->{"counter"}{"rename"};$v->{"tie_scalar"}{"rephrase"} = $v->{"tie_hash"}{"rephrase"}; \$v}->{$v1type}) |