1 package LaTeX::TikZ::Functor;
8 LaTeX::TikZ::Functor - Build functor methods that recursively visit nodes of a LaTeX::TikZ::Set tree.
16 our $VERSION = '0.01';
20 A functor takes a L<LaTeX::TikZ::Set> tree and clones it according to certain rules.
21 Rules can apply not only to L<LaTeX::TikZ::Set> objects, but also to the L<LaTeX::TikZ::Mod> objects they contain.
29 use LaTeX::TikZ::Interface;
31 use LaTeX::TikZ::Tools;
33 use Any::Moose 'Util' => [ qw[find_meta does_role] ];
35 my $lts_tc = LaTeX::TikZ::Tools::type_constraint('LaTeX::TikZ::Set');
37 my @default_set_rules;
38 my @default_mod_rules;
40 my ($validate_rule, $insert_rule);
42 $validate_rule = Sub::Name::subname('validate_rule' => sub {
43 my ($spec, $handler) = @_;
45 my ($replace, $target);
46 if (defined $spec and ref $spec eq ''
47 and $spec =~ /^(\+?)([A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z][A-Za-z0-9_]*)*)$/) {
48 $replace = defined($1) && $1 eq '+';
51 Carp::confess("Invalid rule spec $spec");
54 (my $pm = $target) =~ s{::}{/}g;
58 my $meta = find_meta($target);
59 Carp::confess("No meta object associated with target $target")
61 my $is_role = $meta->isa(any_moose('Meta::Role'));
64 if (does_role($target, 'LaTeX::TikZ::Set')) {
66 } elsif (does_role($target, 'LaTeX::TikZ::Mod')) {
69 Carp::confess("Target $target is neither a set nor a mod");
72 Carp::confess("Invalid handler for rule spec $spec")
73 unless defined $handler and ref $handler eq 'CODE';
75 return [ $target, $handler, $replace, $is_role, $is_set ];
78 $insert_rule = Sub::Name::subname('insert_rule' => sub {
79 my ($rule, $list, $overwrite) = @_;
81 my ($target, $replace, $is_role) = @{$rule}[0, 2, 3];
86 for my $i (0 .. $#$list) {
87 my $old_target = $list->[$i]->[0];
88 if ($is_role ? does_role($old_target, $target)
89 : $old_target->isa($target)) {
91 splice @$list, $i, 1, $rule;
101 splice @$list, $_ - $shift, 1;
104 return 1 unless defined $rule;
106 } else { # Replace only an existent rule
108 for my $i (0 .. $#$list) {
109 my $old_target = $list->[$i]->[0];
110 if ($old_target eq $target) {
111 Carp::confess("Default rule already defined for target $target")
113 splice @$list, $i, 1, $rule;
126 =head2 C<< new rules => [ $spec1 => $handler1, $spec2 => $handler2, ... ] >>
128 Creates a new functor object that will use both the default and these user-specified rules.
129 The functor is also a code reference that expects to be called against L<LaTeX::TikZ::Set> objects.
131 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.
133 # The default is a clone method
134 my $clone = Tikz->functor;
135 my $dup = $set->$clone;
137 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.
140 my $translate = Tikz->functor(
141 # Only replace the way point sets are cloned
142 'LaTeX::TikZ::Set::Point' => sub {
143 my ($functor, $set, $x, $y) = @_;
150 label => $set->label,
155 my $shifted = $set->$translate(1, 1);
157 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).
160 my $strip = Tikz->functor(
161 # Replace all existent mod rules by this simple one
162 '+LaTeX::TikZ::Mod' => sub { return },
164 my $naked = $set->$strip;
166 The functor will map unhandled sets and mods to themselves without cloning them, since it has no way to know how to do it.
167 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.
172 my ($class, %args) = @_;
174 my @set_rules = @default_set_rules;
175 my @mod_rules = @default_mod_rules;
177 my @user_rules = @{$args{rules} || []};
178 while (@user_rules) {
179 my ($spec, $handler) = splice @user_rules, 0, 2;
181 my $rule = $validate_rule->($spec, $handler);
183 $insert_rule->($rule, $rule->[4] ? \@set_rules : \@mod_rules, 1);
186 my %dispatch = map { $_->[0] => $_ } @set_rules, @mod_rules;
193 $lts_tc->assert_valid($set);
195 my $rule = $dispatch{ref($set)};
198 if ($_->[2] ? $set->does($_->[0]) : $set->isa($_->[0])) {
203 $rule = [ undef, sub { $_[1] } ] unless $rule;
205 my $new_set = $rule->[1]->($self, $set, @_);
206 my $is_new = $new_set ne $set;
210 for my $mod ($set->mods) {
211 my $rule = $dispatch{ref($mod)};
214 if ($_->[2] ? $mod->does($_->[0]) : $mod->isa($_->[0])) {
220 push @new_mods, $mod;
224 push @new_mods, $rule->[1]->($self, $mod, @_);
227 $new_set->mod(@new_mods) if $is_new;
233 LaTeX::TikZ::Interface->register(
237 __PACKAGE__->new(rules => \@_);
241 =head2 C<< default_rule $spec => $handler >>
243 Adds to all subsequently created functors a default rule for the class or role C<$spec>.
245 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.
246 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).
248 Returns true if and only if an existent rule was replaced.
255 my $rule = $validate_rule->(@_);
259 $rule->[4] ? \@default_set_rules : \@default_mod_rules,
270 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
272 You can contact me by mail or on C<irc.perl.org> (vincent).
276 Please report any bugs or feature requests to C<bug-latex-tikz at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=LaTeX-TikZ>.
277 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
281 You can find documentation for this module with the perldoc command.
285 =head1 COPYRIGHT & LICENSE
287 Copyright 2010 Vincent Pit, all rights reserved.
289 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
293 1; # End of LaTeX::TikZ::Functor