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 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>
  89
  90     my $rule = LaTeX::TikZ::Functor::Rule->new(
  91      target  => $target,
  92      handler => $handler,
  93     );
  94
  95 Constructs a new rule object with target C<$target> and handler C<$handler>.
  96
  97 =cut
  98
  99 around 'BUILDARGS' => sub {
 100  my ($orig, $class, %args) = @_;
 101
 102  my $target = $args{target};
 103  __PACKAGE__->meta->find_attribute_by_name('target')
 104                   ->type_constraint->assert_valid($target);
 105
 106  (my $pm = $target) =~ s{::}{/}g;
 107  $pm .= '.pm';
 108  require $pm;
 109
 110  my $meta = find_meta($target);
 111  Carp::confess("No meta object associated with target $target")
 112                                                            unless defined $meta;
 113  $args{is_role} = $meta->isa('Mouse::Meta::Role');
 114
 115  my $is_set;
 116  if (does_role($target, 'LaTeX::TikZ::Set')) {
 117   $is_set = 1;
 118  } elsif (does_role($target, 'LaTeX::TikZ::Mod')) {
 119   $is_set = 0;
 120  } else {
 121   Carp::confess("Target $target is neither a set nor a mod");
 122  }
 123  $args{is_set} = $is_set;
 124
 125  $class->$orig(%args);
 126 };
 127
 128 =head2 C<insert>
 129
 130     my $has_replaced = $rule->insert(
 131      into      => \@list,
 132      overwrite => $overwrite,
 133      replace   => $replace,
 134     );
 135
 136 Inserts the current rule into the list of rules C<@list>.
 137 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.
 138
 139 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.
 140
 141 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.
 142 All the subsequent rules in the list that inherit or consume the target will be removed.
 143
 144 Returns true if and only if an existent rule was replaced.
 145
 146 =cut
 147
 148 sub insert {
 149  my ($rule, %args) = @_;
 150
 151  my $list = $args{into};
 152  $ltfrl_tc->assert_valid($list);
 153
 154  my $overwrite = $args{overwrite};
 155  my $replace   = $args{replace};
 156
 157  if ($replace) {
 158   my (@remove, $replaced);
 159
 160   for my $i (0 .. $#$list) {
 161    my $old_target = $list->[$i]->target;
 162    if ($rule->handles($old_target)) {
 163     if ($replaced) {
 164      push @remove, $i;
 165     } else {
 166      splice @$list, $i, 1, $rule;
 167      $replaced = 1;
 168     }
 169    }
 170   }
 171
 172   my $shift = 0;
 173   for (@remove) {
 174    splice @$list, $_ - $shift, 1;
 175    ++$shift;
 176   }
 177   return 1 if $replaced;
 178
 179  } else { # Replace only an existent rule
 180   my $target  = $rule->target;
 181
 182   my $last_descendant = undef;
 183   my $first_ancestor  = undef;
 184
 185   for my $i (0 .. $#$list) {
 186    my $old_rule   = $list->[$i];
 187    my $old_target = $old_rule->target;
 188    if ($old_target eq $target) {
 189     Carp::confess("Default rule already defined for target $target")
 190                                                               unless $overwrite;
 191     splice @$list, $i, 1, $rule;
 192     return 1;
 193    } elsif ($rule->handles($old_target)) {
 194     $last_descendant = $i;
 195    } elsif ($old_rule->handles($target)) {
 196     $first_ancestor  = $i;
 197    }
 198   }
 199
 200   my $pos;
 201   if (defined $first_ancestor) {
 202    Carp::confess("Unsorted rule list")
 203             if defined $last_descendant and $first_ancestor <= $last_descendant;
 204    $pos = $first_ancestor;
 205   } elsif (defined $last_descendant) {
 206    $pos = $last_descendant + 1;
 207   }
 208
 209   if (defined $pos) {
 210    splice @$list, $pos, 0, $rule;
 211    return 0;
 212   }
 213  }
 214
 215  push @$list, $rule;
 216  return 0;
 217 }
 218
 219 =head2 C<handles>
 220
 221     $rule->handles($obj);
 222
 223 Returns true if and only if the current rule can handle the object or class/role name C<$obj>.
 224
 225 =cut
 226
 227 sub handles {
 228  my ($rule, $obj) = @_;
 229
 230  $rule->is_role ? does_role($obj, $rule->target) : $obj->isa($rule->target);
 231 }
 232
 233 __PACKAGE__->meta->make_immutable;
 234
 235 =head1 SEE ALSO
 236
 237 L<LaTeX::TikZ>, L<LaTeX::TikZ::Functor>.
 238
 239 =head1 AUTHOR
 240
 241 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 242
 243 You can contact me by mail or on C<irc.perl.org> (vincent).
 244
 245 =head1 BUGS
 246
 247 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>.
 248 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 249
 250 =head1 SUPPORT
 251
 252 You can find documentation for this module with the perldoc command.
 253
 254     perldoc LaTeX::TikZ
 255
 256 =head1 COPYRIGHT & LICENSE
 257
 258 Copyright 2010,2011,2012,2013,2014,2015 Vincent Pit, all rights reserved.
 259
 260 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 261
 262 =cut
 263
 264 1; # End of LaTeX::TikZ::Functor::Rule