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