lib/LaTeX/TikZ.pm
lib/LaTeX/TikZ/Formatter.pm
lib/LaTeX/TikZ/Functor.pm
+lib/LaTeX/TikZ/Functor/Rule.pm
lib/LaTeX/TikZ/Interface.pm
lib/LaTeX/TikZ/Meta/TypeConstraint/Autocoerce.pm
lib/LaTeX/TikZ/Mod.pm
use Sub::Name ();
+use LaTeX::TikZ::Functor::Rule;
+
use LaTeX::TikZ::Interface;
use LaTeX::TikZ::Tools;
-use Any::Moose 'Util' => [ qw[find_meta does_role] ];
-
my $lts_tc = LaTeX::TikZ::Tools::type_constraint('LaTeX::TikZ::Set');
-my @default_set_rules;
-my @default_mod_rules;
-
-my ($validate_rule, $insert_rule);
+my $validate_spec;
BEGIN {
- $validate_rule = Sub::Name::subname('validate_rule' => sub {
- my ($spec, $handler) = @_;
+ $validate_spec = Sub::Name::subname('validate_spec' => sub {
+ my ($spec) = @_;
my ($replace, $target);
if (defined $spec and ref $spec eq ''
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;
- } elsif (does_role($target, 'LaTeX::TikZ::Mod')) {
- $is_set = 0;
- } else {
- Carp::confess("Target $target is neither a set nor a mod");
- }
-
- Carp::confess("Invalid handler for rule spec $spec")
- unless defined $handler and ref $handler eq 'CODE';
-
- return [ $target, $handler, $replace, $is_role, $is_set ];
- });
-
- $insert_rule = Sub::Name::subname('insert_rule' => sub {
- 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 0;
+ return $target, $replace;
});
}
=cut
+my @default_set_rules;
+my @default_mod_rules;
+
sub new {
my ($class, %args) = @_;
while (@user_rules) {
my ($spec, $handler) = splice @user_rules, 0, 2;
- my $rule = $validate_rule->($spec, $handler);
+ my ($target, $replace) = $validate_spec->($spec);
- $insert_rule->($rule, $rule->[4] ? \@set_rules : \@mod_rules, 1);
+ my $rule = LaTeX::TikZ::Functor::Rule->new(
+ target => $target,
+ handler => $handler,
+ );
+
+ $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;
my $rule = $dispatch{ref($set)};
unless ($rule) {
for (@set_rules) {
- if ($_->[2] ? $set->does($_->[0]) : $set->isa($_->[0])) {
+ if ($_->handles($set)) {
$rule = $_;
last;
}
}
- $rule = [ undef, sub { $_[1] } ] unless $rule;
}
- 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;
my $rule = $dispatch{ref($mod)};
unless ($rule) {
for (@mod_rules) {
- if ($_->[2] ? $mod->does($_->[0]) : $mod->isa($_->[0])) {
+ if ($_->handles($mod)) {
$rule = $_;
last;
}
}
- unless ($rule) {
- push @new_mods, $mod;
- next MOD;
- }
}
- push @new_mods, $rule->[1]->($self, $mod, @_);
+ push @new_mods, $rule ? $rule->handler->($self, $mod, @_)
+ : $mod;
}
$new_set->mod(@new_mods) if $is_new;
sub default_rule {
shift;
+ my ($spec, $handler) = @_;
- my $rule = $validate_rule->(@_);
+ my ($target, $replace) = $validate_spec->($spec);
+
+ my $rule = LaTeX::TikZ::Functor::Rule->new(
+ target => $target,
+ handler => $handler,
+ );
- $insert_rule->(
- $rule,
- $rule->[4] ? \@default_set_rules : \@default_mod_rules,
- 0,
+ $rule->insert(
+ into => $rule->is_set ? \@default_set_rules : \@default_mod_rules,
+ overwrite => 0,
+ replace => $replace,
);
}
--- /dev/null
+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
use strict;
use warnings;
-use Test::More tests => 33;
+use Test::More tests => 34;
BEGIN {
use_ok( 'LaTeX::TikZ' );
use_ok( 'LaTeX::TikZ::Formatter' );
use_ok( 'LaTeX::TikZ::Functor' );
+ use_ok( 'LaTeX::TikZ::Functor::Rule' );
use_ok( 'LaTeX::TikZ::Interface' );
use_ok( 'LaTeX::TikZ::Meta::TypeConstraint::Autocoerce' );
use_ok( 'LaTeX::TikZ::Mod' );
eval "use Pod::Coverage $min_pc";
plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@;
-plan tests => 33;
+plan tests => 34;
my $moose_private = { also_private => [ qr/^BUILD$/, qr/^DEMOLISH$/ ] };
pod_coverage_ok( 'LaTeX::TikZ' );
pod_coverage_ok( 'LaTeX::TikZ::Formatter' );
pod_coverage_ok( 'LaTeX::TikZ::Functor' );
+pod_coverage_ok( 'LaTeX::TikZ::Functor::Rule' );
pod_coverage_ok( 'LaTeX::TikZ::Meta::TypeConstraint::Autocoerce' );
pod_coverage_ok( 'LaTeX::TikZ::Mod' );
pod_coverage_ok( 'LaTeX::TikZ::Mod::Clip' );
projects / perl / modules / LaTeX-TikZ.git / commitdiff