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.01
  13
  14 =cut
  15
  16 our $VERSION = '0.01';
  17
  18 =head1 DESCRIPTION
  19
  20 A rule specifies how functors 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 =cut
  36
  37 has 'target' => (
  38  is       => 'ro',
  39  isa      => 'ClassName|RoleName',
  40  required => 1,
  41 );
  42
  43 =head2 C<handler>
  44
  45 =cut
  46
  47 has 'handler' => (
  48  is       => 'ro',
  49  isa      => 'CodeRef',
  50  required => 1,
  51 );
  52
  53 =head2 C<is_role>
  54
  55 =cut
  56
  57 has 'is_role' => (
  58  is       => 'ro',
  59  isa      => 'Bool',
  60  required => 1,
  61 );
  62
  63 =head2 C<is_set>
  64
  65 =cut
  66
  67 has 'is_set' => (
  68  is       => 'ro',
  69  isa      => 'Bool',
  70  required => 1,
  71 );
  72
  73 my $ltfrl_tc = subtype 'LaTeX::TikZ::Functor::RuleList'
  74                     => as 'ArrayRef[LaTeX::TikZ::Functor::Rule]';
  75
  76 =head1 METHODS
  77
  78 =head2 C<< new target => $target, handler => $handler >>
  79
  80 =cut
  81
  82 around 'BUILDARGS' => sub {
  83  my ($orig, $class, %args) = @_;
  84
  85  my $target = $args{target};
  86  __PACKAGE__->meta->find_attribute_by_name('target')
  87                   ->type_constraint->assert_valid($target);
  88
  89  (my $pm = $target) =~ s{::}{/}g;
  90  $pm .= '.pm';
  91  require $pm;
  92
  93  my $meta = find_meta($target);
  94  Carp::confess("No meta object associated with target $target")
  95                                                            unless defined $meta;
  96  $args{is_role} = $meta->isa(any_moose('Meta::Role'));
  97
  98  my $is_set;
  99  if (does_role($target, 'LaTeX::TikZ::Set')) {
 100   $is_set = 1;
 101  } elsif (does_role($target, 'LaTeX::TikZ::Mod')) {
 102   $is_set = 0;
 103  } else {
 104   Carp::confess("Target $target is neither a set nor a mod");
 105  }
 106  $args{is_set} = $is_set;
 107
 108  $class->$orig(%args);
 109 };
 110
 111 =head2 C<< insert into => \@list, overwrite => $overwrite, replace => $replace >>
 112
 113 Inserts the current rule into the list of rules C<@list>.
 114
 115 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.
 116
 117 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.
 118 All the subsequent rules in the list that inherit or consume the target will be removed.
 119
 120 =cut
 121
 122 sub insert {
 123  my ($rule, %args) = @_;
 124
 125  my $list = $args{into};
 126  $ltfrl_tc->assert_valid($list);
 127
 128  my $overwrite = $args{overwrite};
 129  my $replace   = $args{replace};
 130
 131  my $target  = $rule->target;
 132  my $is_role = $rule->is_role;
 133
 134  if ($replace) {
 135   my @remove;
 136
 137   for my $i (0 .. $#$list) {
 138    my $old_target = $list->[$i]->target;
 139    if ($rule->handles($old_target)) {
 140     if (defined $rule) {
 141      splice @$list, $i, 1, $rule;
 142      $rule = undef;
 143     } else {
 144      push @remove, $i;
 145     }
 146    }
 147   }
 148
 149   my $shift;
 150   for (@remove) {
 151    splice @$list, $_ - $shift, 1;
 152    ++$shift;
 153   }
 154   return 1 unless defined $rule;
 155
 156  } else { # Replace only an existent rule
 157
 158   for my $i (0 .. $#$list) {
 159    my $old_target = $list->[$i]->target;
 160    if ($old_target eq $target) {
 161     Carp::confess("Default rule already defined for target $target")
 162                                                               unless $overwrite;
 163     splice @$list, $i, 1, $rule;
 164     return 1;
 165    }
 166   }
 167  }
 168
 169  push @$list, $rule;
 170  return 0;
 171 }
 172
 173 =head2 C<handles $obj>
 174
 175 Returns true if and only if the current rule can handle the object or class/role name C<$obj>.
 176
 177 =cut
 178
 179 sub handles {
 180  my ($rule, $obj) = @_;
 181
 182  $rule->is_role ? does_role($obj, $rule->target) : $obj->isa($rule->target);
 183 }
 184
 185 __PACKAGE__->meta->make_immutable;
 186
 187 =head1 SEE ALSO
 188
 189 L<LaTeX::TikZ>, L<LaTeX::TikZ::Functor>.
 190
 191 =head1 AUTHOR
 192
 193 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 194
 195 You can contact me by mail or on C<irc.perl.org> (vincent).
 196
 197 =head1 BUGS
 198
 199 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>.
 200 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 201
 202 =head1 SUPPORT
 203
 204 You can find documentation for this module with the perldoc command.
 205
 206     perldoc LaTeX::TikZ
 207
 208 =head1 COPYRIGHT & LICENSE
 209
 210 Copyright 2010 Vincent Pit, all rights reserved.
 211
 212 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 213
 214 =cut
 215
 216 1; # End of LaTeX::TikZ::Functor::Rule