lib/LaTeX/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 Any::Moose;
  28 use Any::Moose 'Util' => [ qw[find_meta does_role] ];
  29 use Any::Moose '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(any_moose('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
 127 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.
 128
 129 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.
 130 All the subsequent rules in the list that inherit or consume the target will be removed.
 131
 132 Returns true if and only if an existent rule was replaced.
 133
 134 =cut
 135
 136 sub insert {
 137  my ($rule, %args) = @_;
 138
 139  my $list = $args{into};
 140  $ltfrl_tc->assert_valid($list);
 141
 142  my $overwrite = $args{overwrite};
 143  my $replace   = $args{replace};
 144
 145  if ($replace) {
 146   my (@remove, $replaced);
 147
 148   for my $i (0 .. $#$list) {
 149    my $old_target = $list->[$i]->target;
 150    if ($rule->handles($old_target)) {
 151     if ($replaced) {
 152      push @remove, $i;
 153     } else {
 154      splice @$list, $i, 1, $rule;
 155      $replaced = 1;
 156     }
 157    }
 158   }
 159
 160   my $shift = 0;
 161   for (@remove) {
 162    splice @$list, $_ - $shift, 1;
 163    ++$shift;
 164   }
 165   return 1 if $replaced;
 166
 167  } else { # Replace only an existent rule
 168   my $target  = $rule->target;
 169
 170   for my $i (0 .. $#$list) {
 171    my $old_target = $list->[$i]->target;
 172    if ($old_target eq $target) {
 173     Carp::confess("Default rule already defined for target $target")
 174                                                               unless $overwrite;
 175     splice @$list, $i, 1, $rule;
 176     return 1;
 177    }
 178   }
 179  }
 180
 181  push @$list, $rule;
 182  return 0;
 183 }
 184
 185 =head2 C<handles $obj>
 186
 187 Returns true if and only if the current rule can handle the object or class/role name C<$obj>.
 188
 189 =cut
 190
 191 sub handles {
 192  my ($rule, $obj) = @_;
 193
 194  $rule->is_role ? does_role($obj, $rule->target) : $obj->isa($rule->target);
 195 }
 196
 197 __PACKAGE__->meta->make_immutable;
 198
 199 =head1 SEE ALSO
 200
 201 L<LaTeX::TikZ>, L<LaTeX::TikZ::Functor>.
 202
 203 =head1 AUTHOR
 204
 205 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 206
 207 You can contact me by mail or on C<irc.perl.org> (vincent).
 208
 209 =head1 BUGS
 210
 211 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>.
 212 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 213
 214 =head1 SUPPORT
 215
 216 You can find documentation for this module with the perldoc command.
 217
 218     perldoc LaTeX::TikZ
 219
 220 =head1 COPYRIGHT & LICENSE
 221
 222 Copyright 2010 Vincent Pit, all rights reserved.
 223
 224 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 225
 226 =cut
 227
 228 1; # End of LaTeX::TikZ::Functor::Rule