]> git.vpit.fr Git - perl/modules/LaTeX-TikZ.git/blob - TikZ/Functor/Rule.pm
Update VPIT::TestHelpers to 15e8aee3
[perl/modules/LaTeX-TikZ.git] / TikZ / Functor / Rule.pm
1 package LaTeX::TikZ::Functor::Rule;
2
3 use strict;
4 use warnings;
5
6 =head1 NAME
7
8 LaTeX::TikZ::Functor::Rule - An object that specifies how functors should handle a certain kind of set or mod.
9
10 =head1 VERSION
11
12 Version 0.02
13
14 =cut
15
16 our $VERSION = '0.02';
17
18 =head1 DESCRIPTION
19
20 A rule specifies how functors (L<LaTeX::TikZ::Functor> objects) should handle a certain kind of set or mod.
21 A functor is basically an ordered collection of rules.
22
23 =cut
24
25 use Carp ();
26
27 use Mouse;
28 use Mouse::Util qw<find_meta does_role>;
29 use Mouse::Util::TypeConstraints;
30
31 =head1 ATTRIBUTES
32
33 =head2 C<target>
34
35 A class or role name against which set or mod candidates will be matched.
36 It must consume either L<LaTeX::TikZ::Set> or L<LaTeX::TikZ::Mod>, directly or through inheritance.
37
38 =cut
39
40 has 'target' => (
41  is       => 'ro',
42  isa      => 'ClassName|RoleName',
43  required => 1,
44 );
45
46 =head2 C<handler>
47
48 The code reference executed when the rule handles a given set or mod object.
49 It is called with the L<LaTeX::TikZ::Functor> object as its first argument, the set/mod object as its second, and then the arguments passed to the functor itself.
50
51 =cut
52
53 has 'handler' => (
54  is       => 'ro',
55  isa      => 'CodeRef',
56  required => 1,
57 );
58
59 =head2 C<is_role>
60
61 True if and only if the target is a role.
62
63 =cut
64
65 has 'is_role' => (
66  is       => 'ro',
67  isa      => 'Bool',
68  required => 1,
69 );
70
71 =head2 C<is_set>
72
73 True when the target does the L<LaTeX::TikZ::Set> role, and false when it does L<LaTeX::TikZ::Mod>.
74
75 =cut
76
77 has 'is_set' => (
78  is       => 'ro',
79  isa      => 'Bool',
80  required => 1,
81 );
82
83 my $ltfrl_tc = subtype 'LaTeX::TikZ::Functor::RuleList'
84                     => as 'ArrayRef[LaTeX::TikZ::Functor::Rule]';
85
86 =head1 METHODS
87
88 =head2 C<< new target => $target, handler => $handler >>
89
90 Constructs a new rule object with target C<$target> and handler C<$handler>.
91
92 =cut
93
94 around 'BUILDARGS' => sub {
95  my ($orig, $class, %args) = @_;
96
97  my $target = $args{target};
98  __PACKAGE__->meta->find_attribute_by_name('target')
99                   ->type_constraint->assert_valid($target);
100
101  (my $pm = $target) =~ s{::}{/}g;
102  $pm .= '.pm';
103  require $pm;
104
105  my $meta = find_meta($target);
106  Carp::confess("No meta object associated with target $target")
107                                                            unless defined $meta;
108  $args{is_role} = $meta->isa('Mouse::Meta::Role');
109
110  my $is_set;
111  if (does_role($target, 'LaTeX::TikZ::Set')) {
112   $is_set = 1;
113  } elsif (does_role($target, 'LaTeX::TikZ::Mod')) {
114   $is_set = 0;
115  } else {
116   Carp::confess("Target $target is neither a set nor a mod");
117  }
118  $args{is_set} = $is_set;
119
120  $class->$orig(%args);
121 };
122
123 =head2 C<< insert into => \@list, overwrite => $overwrite, replace => $replace >>
124
125 Inserts the current rule into the list of rules C<@list>.
126 The list is expected to be ordered, in that each rule must come after all the rules that have a target that inherits or consumes the original rule's own target.
127
128 If C<$replace> is false, then the rule will be inserted into C<@list> after all the rules applying to the target's subclasses/subroles and before all its superclasses/superroles ; except if there is already an existent entry for the same target, in which case it will be overwritten if C<$overwrite> is true, or an exception will be thrown if it is false.
129
130 If C<$replace> is true, then the rule will replace the first rule in the list that is a subclass or that consumes the role denoted by the target.
131 All the subsequent rules in the list that inherit or consume the target will be removed.
132
133 Returns true if and only if an existent rule was replaced.
134
135 =cut
136
137 sub insert {
138  my ($rule, %args) = @_;
139
140  my $list = $args{into};
141  $ltfrl_tc->assert_valid($list);
142
143  my $overwrite = $args{overwrite};
144  my $replace   = $args{replace};
145
146  if ($replace) {
147   my (@remove, $replaced);
148
149   for my $i (0 .. $#$list) {
150    my $old_target = $list->[$i]->target;
151    if ($rule->handles($old_target)) {
152     if ($replaced) {
153      push @remove, $i;
154     } else {
155      splice @$list, $i, 1, $rule;
156      $replaced = 1;
157     }
158    }
159   }
160
161   my $shift = 0;
162   for (@remove) {
163    splice @$list, $_ - $shift, 1;
164    ++$shift;
165   }
166   return 1 if $replaced;
167
168  } else { # Replace only an existent rule
169   my $target  = $rule->target;
170
171   my $last_descendant = undef;
172   my $first_ancestor  = undef;
173
174   for my $i (0 .. $#$list) {
175    my $old_rule   = $list->[$i];
176    my $old_target = $old_rule->target;
177    if ($old_target eq $target) {
178     Carp::confess("Default rule already defined for target $target")
179                                                               unless $overwrite;
180     splice @$list, $i, 1, $rule;
181     return 1;
182    } elsif ($rule->handles($old_target)) {
183     $last_descendant = $i;
184    } elsif ($old_rule->handles($target)) {
185     $first_ancestor  = $i;
186    }
187   }
188
189   my $pos;
190   if (defined $first_ancestor) {
191    Carp::confess("Unsorted rule list")
192             if defined $last_descendant and $first_ancestor <= $last_descendant;
193    $pos = $first_ancestor;
194   } elsif (defined $last_descendant) {
195    $pos = $last_descendant + 1;
196   }
197
198   if (defined $pos) {
199    splice @$list, $pos, 0, $rule;
200    return 0;
201   }
202  }
203
204  push @$list, $rule;
205  return 0;
206 }
207
208 =head2 C<handles $obj>
209
210 Returns true if and only if the current rule can handle the object or class/role name C<$obj>.
211
212 =cut
213
214 sub handles {
215  my ($rule, $obj) = @_;
216
217  $rule->is_role ? does_role($obj, $rule->target) : $obj->isa($rule->target);
218 }
219
220 __PACKAGE__->meta->make_immutable;
221
222 =head1 SEE ALSO
223
224 L<LaTeX::TikZ>, L<LaTeX::TikZ::Functor>.
225
226 =head1 AUTHOR
227
228 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
229
230 You can contact me by mail or on C<irc.perl.org> (vincent).
231
232 =head1 BUGS
233
234 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>.
235 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
236
237 =head1 SUPPORT
238
239 You can find documentation for this module with the perldoc command.
240
241     perldoc LaTeX::TikZ
242
243 =head1 COPYRIGHT & LICENSE
244
245 Copyright 2010 Vincent Pit, all rights reserved.
246
247 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
248
249 =cut
250
251 1; # End of LaTeX::TikZ::Functor::Rule