Move most of the functor logic into a new LT::Functor::Role class

[perl/modules/LaTeX-TikZ.git] / lib / LaTeX / TikZ / Functor / Rule.pm

diff --git a/lib/LaTeX/TikZ/Functor/Rule.pm b/lib/LaTeX/TikZ/Functor/Rule.pm
new file mode 100644 (file)
index 0000000..efaff7b
--- /dev/null
+++ b/lib/LaTeX/TikZ/Functor/Rule.pm
@@ -0,0 +1,216 @@
+package LaTeX::TikZ::Functor::Rule;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+LaTeX::TikZ::Functor::Rule - An object that specifies how functors should handle a certain kind of set or mod.
+
+=head1 VERSION
+
+Version 0.01
+
+=cut
+
+our $VERSION = '0.01';
+
+=head1 DESCRIPTION
+
+A rule specifies how functors should handle a certain kind of set or mod.
+A functor is basically an ordered collection of rules.
+
+=cut
+
+use Carp ();
+
+use Any::Moose;
+use Any::Moose 'Util' => [ qw[find_meta does_role] ];
+use Any::Moose 'Util::TypeConstraints';
+
+=head1 ATTRIBUTES
+
+=head2 C<target>
+
+=cut
+
+has 'target' => (
+ is       => 'ro',
+ isa      => 'ClassName|RoleName',
+ required => 1,
+);
+
+=head2 C<handler>
+
+=cut
+
+has 'handler' => (
+ is       => 'ro',
+ isa      => 'CodeRef',
+ required => 1,
+);
+
+=head2 C<is_role>
+
+=cut
+
+has 'is_role' => (
+ is       => 'ro',
+ isa      => 'Bool',
+ required => 1,
+);
+
+=head2 C<is_set>
+
+=cut
+
+has 'is_set' => (
+ is       => 'ro',
+ isa      => 'Bool',
+ required => 1,
+);
+
+my $ltfrl_tc = subtype 'LaTeX::TikZ::Functor::RuleList'
+                    => as 'ArrayRef[LaTeX::TikZ::Functor::Rule]';
+
+=head1 METHODS
+
+=head2 C<< new target => $target, handler => $handler >>
+
+=cut
+
+around 'BUILDARGS' => sub {
+ my ($orig, $class, %args) = @_;
+
+ my $target = $args{target};
+ __PACKAGE__->meta->find_attribute_by_name('target')
+                  ->type_constraint->assert_valid($target);
+
+ (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;
+ $args{is_role} = $meta->isa(any_moose('Meta::Role'));
+
+ 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");
+ }
+ $args{is_set} = $is_set;
+
+ $class->$orig(%args);
+};
+
+=head2 C<< insert into => \@list, overwrite => $overwrite, replace => $replace >>
+
+Inserts the current rule into the list of rules C<@list>.
+
+If C<$replace> is false, then the rule will be appended to the C<@list> ; except if there already is 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.
+
+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.
+All the subsequent rules in the list that inherit or consume the target will be removed.
+
+=cut
+
+sub insert {
+ my ($rule, %args) = @_;
+
+ my $list = $args{into};
+ $ltfrl_tc->assert_valid($list);
+
+ my $overwrite = $args{overwrite};
+ my $replace   = $args{replace};
+
+ my $target  = $rule->target;
+ my $is_role = $rule->is_role;
+
+ if ($replace) {
+  my @remove;
+
+  for my $i (0 .. $#$list) {
+   my $old_target = $list->[$i]->target;
+   if ($rule->handles($old_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]->target;
+   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 0;
+}
+
+=head2 C<handles $obj>
+
+Returns true if and only if the current rule can handle the object or class/role name C<$obj>.
+
+=cut
+
+sub handles {
+ my ($rule, $obj) = @_;
+
+ $rule->is_role ? does_role($obj, $rule->target) : $obj->isa($rule->target);
+}
+
+__PACKAGE__->meta->make_immutable;
+
+=head1 SEE ALSO
+
+L<LaTeX::TikZ>, L<LaTeX::TikZ::Functor>.
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+You can contact me by mail or on C<irc.perl.org> (vincent).
+
+=head1 BUGS
+
+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>.
+I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+    perldoc LaTeX::TikZ
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2010 Vincent Pit, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1; # End of LaTeX::TikZ::Functor::Rule