X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FLaTeX-TikZ.git;a=blobdiff_plain;f=lib%2FLaTeX%2FTikZ%2FFunctor.pm;h=efa66a095283d48de76a5c120eded45e40946d40;hp=e302d3fbf591e31f9417555aa463f7367c5162ab;hb=a44105abc490869376ff448faa654f429324abe2;hpb=92147217516a40b35ca00c8e08939e8aa5478426 diff --git a/lib/LaTeX/TikZ/Functor.pm b/lib/LaTeX/TikZ/Functor.pm index e302d3f..efa66a0 100644 --- a/lib/LaTeX/TikZ/Functor.pm +++ b/lib/LaTeX/TikZ/Functor.pm @@ -15,72 +15,92 @@ Version 0.01 our $VERSION = '0.01'; +=head1 DESCRIPTION + +A functor takes a L tree and clones it according to certain rules. +Rules can apply not only to L objects, but also to the L objects they contain. + +=cut + use Carp (); use Sub::Name (); -use LaTeX::TikZ::Tools; +use LaTeX::TikZ::Functor::Rule; -use Any::Moose 'Util' => [ 'does_role' ]; +use LaTeX::TikZ::Interface; -my $lts_tc = LaTeX::TikZ::Tools::type_constraint('LaTeX::TikZ::Set'); +use LaTeX::TikZ::Tools; -my @default_set_rules; -my @default_mod_rules; +my $lts_tc = LaTeX::TikZ::Tools::type_constraint('LaTeX::TikZ::Set'); -my ($validate_rule, $insert_rule); +my $validate_spec; BEGIN { - $validate_rule = Sub::Name::subname('validate_rule' => sub { - my ($target, $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"); + $validate_spec = Sub::Name::subname('validate_spec' => sub { + my ($spec) = @_; + + 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; + return $target, $replace; + }); +} - my $is_set; - if (does_role($target, 'LaTeX::TikZ::Set')) { - $is_set = 1; - } elsif (does_role($target, 'LaTeX::TikZ::Mod')) { - $is_set = 0; - } else { - Carp::confess("Target $target is neither a set nor a mod"); - } +=head1 METHODS - Carp::confess("Invalid handler for target $target") - unless ref $handler eq 'CODE'; +=head2 C<< new rules => [ $spec1 => $handler1, $spec2 => $handler2, ... ] >> - return [ $target, $handler, $is_set ]; - }); +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. - $insert_rule = Sub::Name::subname('insert_rule' => sub { - my ($rule, $list) = @_; +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. - 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; - } - } + # The default is a clone method + my $clone = Tikz->functor; + my $dup = $set->$clone; - push @$list, $rule; - return $#$list; - }); -} +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. -sub default_rule { - shift; + # A translator + my $translate = Tikz->functor( + # Only replace the way point sets are cloned + 'LaTeX::TikZ::Set::Point' => sub { + my ($functor, $set, $x, $y) = @_; - my $rule = $validate_rule->(@_); + $set->new( + point => [ + $set->x + $x, + $set->y + $y, + ], + label => $set->label, + pos => $set->pos, + ); + }, + ); + my $shifted = $set->$translate(1, 1); - $insert_rule->($rule, $rule->[2] ? \@default_set_rules : \@default_mod_rules); -} +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 + +my @default_set_rules; +my @default_mod_rules; sub new { my ($class, %args) = @_; @@ -90,14 +110,23 @@ 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 ($target, $replace) = $validate_spec->($spec); - my $rule = $validate_rule->($target, $handler); + my $rule = LaTeX::TikZ::Functor::Rule->new( + target => $target, + handler => $handler, + ); - $insert_rule->($rule, $rule->[2] ? \@set_rules : \@mod_rules); + $rule->insert( + into => $rule->is_set ? \@set_rules : \@mod_rules, + overwrite => 1, + replace => $replace, + ); } - my %dispatch = map { $_->[0] => $_ } @set_rules, @mod_rules; + my %dispatch = map { $_->target => $_ } @set_rules, @mod_rules; my $self; @@ -108,10 +137,15 @@ sub new { my $rule = $dispatch{ref($set)}; unless ($rule) { - ($set->isa($_->[0]) or $set->does($_->[0])) and $rule = $_ for @set_rules; - $rule = [ undef, sub { $_[1] } ] unless $rule; + for (@set_rules) { + if ($_->handles($set)) { + $rule = $_; + last; + } + } } - my $new_set = $rule->[1]->($self, $set, @_); + my $new_set = $rule ? $rule->handler->($self, $set, @_) + : $set; my $is_new = $new_set ne $set; my @new_mods; @@ -119,13 +153,15 @@ 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; - unless ($rule) { - push @new_mods, $mod; - next MOD; + for (@mod_rules) { + if ($_->handles($mod)) { + $rule = $_; + last; + } } } - push @new_mods, $rule->[1]->($self, $mod, @_); + push @new_mods, $rule ? $rule->handler->($self, $mod, @_) + : $mod; } $new_set->mod(@new_mods) if $is_new; @@ -134,11 +170,46 @@ MOD: }, $class; } -use LaTeX::TikZ::Interface functor => sub { +LaTeX::TikZ::Interface->register( + functor => sub { + shift; + + __PACKAGE__->new(rules => \@_); + }, +); + +=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 + +sub default_rule { shift; + my ($spec, $handler) = @_; + + my ($target, $replace) = $validate_spec->($spec); + + my $rule = LaTeX::TikZ::Functor::Rule->new( + target => $target, + handler => $handler, + ); + + $rule->insert( + into => $rule->is_set ? \@default_set_rules : \@default_mod_rules, + overwrite => 0, + replace => $replace, + ); +} + +=head1 SEE ALSO - __PACKAGE__->new(rules => \@_); -}; +L. =head1 AUTHOR