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');
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;
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<default_rule>
+=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<all> 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
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<LaTeX::TikZ::Set> 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<all> 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<LaTeX::TikZ::Set> or L<LaTeX::TikZ::Mod> object, be sure to register a default rule for it with the L</default_rule> method.
=cut
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;
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, @_);
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;
projects / perl / modules / LaTeX-TikZ.git / commitdiff