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 =cut
 133
 134 sub insert {
 135  my ($rule, %args) = @_;
 136
 137  my $list = $args{into};
 138  $ltfrl_tc->assert_valid($list);
 139
 140  my $overwrite = $args{overwrite};
 141  my $replace   = $args{replace};
 142
 143  my $target  = $rule->target;
 144  my $is_role = $rule->is_role;
 145
 146  if ($replace) {
 147   my @remove;
 148
 149   for my $i (0 .. $#$list) {
 150    my $old_target = $list->[$i]->target;
 151    if ($rule->handles($old_target)) {
 152     if (defined $rule) {
 153      splice @$list, $i, 1, $rule;
 154      $rule = undef;
 155     } else {
 156      push @remove, $i;
 157     }
 158    }
 159   }
 160
 161   my $shift;
 162   for (@remove) {
 163    splice @$list, $_ - $shift, 1;
 164    ++$shift;
 165   }
 166   return 1 unless defined $rule;
 167
 168  } else { # Replace only an existent rule
 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