From: Vincent Pit Date: Sun, 1 Aug 2010 16:13:01 +0000 (+0200) Subject: Functors overhaul X-Git-Tag: v0.02~17 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FLaTeX-TikZ.git;a=commitdiff_plain;h=594156dad44851e8a31499dfb83b9c6f089abdd4 Functors overhaul --- diff --git a/lib/LaTeX/TikZ.pm b/lib/LaTeX/TikZ.pm index 5e5b731..eda4ca6 100644 --- a/lib/LaTeX/TikZ.pm +++ b/lib/LaTeX/TikZ.pm @@ -325,7 +325,7 @@ C<@rules> should be a list of array references whose first element is the class/ # A mod stripper my $strip = Tikz->functor( - 'LaTeX::TikZ::Mod' => sub { return }, + '+LaTeX::TikZ::Mod' => sub { return }, ); my $naked = $set->$strip; diff --git a/lib/LaTeX/TikZ/Functor.pm b/lib/LaTeX/TikZ/Functor.pm index 2b6974e..7e64142 100644 --- a/lib/LaTeX/TikZ/Functor.pm +++ b/lib/LaTeX/TikZ/Functor.pm @@ -29,7 +29,7 @@ use LaTeX::TikZ::Interface; use LaTeX::TikZ::Tools; -use Any::Moose 'Util' => [ 'does_role' ]; +use Any::Moose 'Util' => [ qw[find_meta does_role] ]; my $lts_tc = LaTeX::TikZ::Tools::type_constraint('LaTeX::TikZ::Set'); @@ -39,17 +39,26 @@ my @default_mod_rules; my ($validate_rule, $insert_rule); BEGIN { $validate_rule = Sub::Name::subname('validate_rule' => sub { - my ($target, $handler) = @_; + my ($spec, $handler) = @_; - unless (defined $target and ref $target eq '' - and $target =~ /[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z][A-Za-z0-9_]*)*/) { - Carp::confess("Invalid target $target"); + my ($replace, $target); + if (defined $spec and ref $spec eq '' + and $spec =~ /^(\+?)([A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z][A-Za-z0-9_]*)*)$/) { + $replace = defined($1) && $1 eq '+'; + $target = $2; + } else { + Carp::confess("Invalid rule spec $spec"); } (my $pm = $target) =~ s{::}{/}g; $pm .= '.pm'; require $pm; + my $meta = find_meta($target); + Carp::confess("No meta object associated with target $target") + unless defined $meta; + my $is_role = $meta->isa(any_moose('Meta::Role')); + my $is_set; if (does_role($target, 'LaTeX::TikZ::Set')) { $is_set = 1; @@ -59,32 +68,68 @@ BEGIN { Carp::confess("Target $target is neither a set nor a mod"); } - Carp::confess("Invalid handler for target $target") + Carp::confess("Invalid handler for rule spec $spec") unless defined $handler and ref $handler eq 'CODE'; - return [ $target, $handler, $is_set ]; + return [ $target, $handler, $replace, $is_role, $is_set ]; }); $insert_rule = Sub::Name::subname('insert_rule' => sub { - my ($rule, $list) = @_; - - my $spec = $rule->[0]; - for my $i (0 .. $#$list) { - my $old_spec = $list->[$i]->[0]; - if ($old_spec->isa($spec) or does_role($old_spec, $spec)) { - splice @$list, $i, 1, $rule; - return 1; + my ($rule, $list, $overwrite) = @_; + + my ($target, $replace, $is_role) = @{$rule}[0, 2, 3]; + + if ($replace) { + my @remove; + + for my $i (0 .. $#$list) { + my $old_target = $list->[$i]->[0]; + if ($is_role ? does_role($old_target, $target) + : $old_target->isa($target)) { + if (defined $rule) { + splice @$list, $i, 1, $rule; + $rule = undef; + } else { + push @remove, $i; + } + } + } + + my $shift; + for (@remove) { + splice @$list, $_ - $shift, 1; + ++$shift; + } + return 1 unless defined $rule; + + } else { # Replace only an existent rule + + for my $i (0 .. $#$list) { + my $old_target = $list->[$i]->[0]; + if ($old_target eq $target) { + Carp::confess("Default rule already defined for target $target") + unless $overwrite; + splice @$list, $i, 1, $rule; + return 1; + } } } push @$list, $rule; - return $#$list; + return 0; }); } =head1 METHODS -=head2 C +=head2 C<< default_rule $spec => $handler >> + +Adds to all subsequently created functors a default rule for the class or role C<$spec>. + +An exception is thrown if there is already a default rule for C<$spec> ; otherwise, the new rule is appended to the current list of rules. +But if C<$spec> begins with C<'+'>, the rule will replace I default rules that apply to subclasses or subroles of C<$spec> (including C<$spec> itself). + +Returns true if and only if an existent rule was replaced. =cut @@ -93,10 +138,55 @@ sub default_rule { my $rule = $validate_rule->(@_); - $insert_rule->($rule, $rule->[2] ? \@default_set_rules : \@default_mod_rules); + $insert_rule->( + $rule, + $rule->[4] ? \@default_set_rules : \@default_mod_rules, + 0, + ); } -=head2 C<< new rules => [ $class_name => sub { ... }, ... ] >> +=head2 C<< new rules => [ $spec1 => $handler1, $spec2 => $handler2, ... ] >> + +Creates a new functor object that will use both the default and these user-specified rules. +The functor is also a code reference that expects to be called against L objects. + +The default set and mod rules clone their relevant objects, so you get a clone functor (for the default set types) if you don't specify any user rule. + + # The default is a clone method + my $clone = Tikz->functor; + my $dup = $set->$clone; + +If there is already a default rule for one of the C<$spec>s, it is replaced by the new one ; otherwise, the user rule is appended to the list of default rules. + + # A translator + my $translate = Tikz->functor( + # Only replace the way point sets are cloned + 'LaTeX::TikZ::Set::Point' => sub { + my ($functor, $set, $x, $y) = @_; + + $set->new( + point => [ + $set->x + $x, + $set->y + $y, + ], + label => $set->label, + pos => $set->pos, + ); + }, + ); + my $shifted = $set->$translate(1, 1); + +But if one of the C<$spec>s begins with C<'+'>, the rule will replace I default rules that apply to subclasses or subroles of C<$spec> (including C<$spec> itself). + + # A mod stripper + my $strip = Tikz->functor( + # Replace all existent mod rules by this simple one + '+LaTeX::TikZ::Mod' => sub { return }, + ); + my $naked = $set->$strip; + +The functor will map unhandled sets and mods to themselves without cloning them, since it has no way to know how to do it. +Thus, if you define your own L or L object, be sure to register a default rule for it with the L method. =cut @@ -108,11 +198,11 @@ sub new { my @user_rules = @{$args{rules} || []}; while (@user_rules) { - my ($target, $handler) = splice @user_rules, 0, 2; + my ($spec, $handler) = splice @user_rules, 0, 2; - my $rule = $validate_rule->($target, $handler); + my $rule = $validate_rule->($spec, $handler); - $insert_rule->($rule, $rule->[2] ? \@set_rules : \@mod_rules); + $insert_rule->($rule, $rule->[4] ? \@set_rules : \@mod_rules, 1); } my %dispatch = map { $_->[0] => $_ } @set_rules, @mod_rules; @@ -126,7 +216,12 @@ sub new { my $rule = $dispatch{ref($set)}; unless ($rule) { - ($set->isa($_->[0]) or $set->does($_->[0])) and $rule = $_ for @set_rules; + for (@set_rules) { + if ($_->[2] ? $set->does($_->[0]) : $set->isa($_->[0])) { + $rule = $_; + last; + } + } $rule = [ undef, sub { $_[1] } ] unless $rule; } my $new_set = $rule->[1]->($self, $set, @_); @@ -137,7 +232,12 @@ MOD: for my $mod ($set->mods) { my $rule = $dispatch{ref($mod)}; unless ($rule) { - ($mod->isa($_->[0]) or $mod->does($_->[0])) and $rule = $_ for @mod_rules; + for (@mod_rules) { + if ($_->[2] ? $mod->does($_->[0]) : $mod->isa($_->[0])) { + $rule = $_; + last; + } + } unless ($rule) { push @new_mods, $mod; next MOD; diff --git a/t/30-functor.t b/t/30-functor.t index 86221e9..cda1ab1 100644 --- a/t/30-functor.t +++ b/t/30-functor.t @@ -90,7 +90,7 @@ RES my $strip = eval { Tikz->functor( - 'LaTeX::TikZ::Mod' => sub { return }, + '+LaTeX::TikZ::Mod' => sub { return }, ); }; is $@, '', 'creating a stripper doesn\'t croak';