lib/LaTeX/TikZ/Functor.pm

   1 package LaTeX::TikZ::Functor;
   2
   3 use strict;
   4 use warnings;
   5
   6 =head1 NAME
   7
   8 LaTeX::TikZ::Functor - Build functor methods that recursively visit nodes of a LaTeX::TikZ::Set tree.
   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 functor takes a L<LaTeX::TikZ::Set> tree and clones it according to certain rules.
  21 Rules can apply not only to L<LaTeX::TikZ::Set> objects, but also to the L<LaTeX::TikZ::Mod> objects they contain.
  22
  23 =cut
  24
  25 use Carp ();
  26
  27 use Sub::Name ();
  28
  29 use LaTeX::TikZ::Interface;
  30
  31 use LaTeX::TikZ::Tools;
  32
  33 use Any::Moose 'Util' => [ qw[find_meta does_role] ];
  34
  35 my $lts_tc = LaTeX::TikZ::Tools::type_constraint('LaTeX::TikZ::Set');
  36
  37 my @default_set_rules;
  38 my @default_mod_rules;
  39
  40 my ($validate_rule, $insert_rule);
  41 BEGIN {
  42  $validate_rule = Sub::Name::subname('validate_rule' => sub {
  43   my ($spec, $handler) = @_;
  44
  45   my ($replace, $target);
  46   if (defined $spec and ref $spec eq ''
  47     and $spec =~ /^(\+?)([A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z][A-Za-z0-9_]*)*)$/) {
  48    $replace = defined($1) && $1 eq '+';
  49    $target  = $2;
  50   } else {
  51    Carp::confess("Invalid rule spec $spec");
  52   }
  53
  54   (my $pm = $target) =~ s{::}{/}g;
  55   $pm .= '.pm';
  56   require $pm;
  57
  58   my $meta = find_meta($target);
  59   Carp::confess("No meta object associated with target $target")
  60                                                            unless defined $meta;
  61   my $is_role = $meta->isa(any_moose('Meta::Role'));
  62
  63   my $is_set;
  64   if (does_role($target, 'LaTeX::TikZ::Set')) {
  65    $is_set = 1;
  66   } elsif (does_role($target, 'LaTeX::TikZ::Mod')) {
  67    $is_set = 0;
  68   } else {
  69    Carp::confess("Target $target is neither a set nor a mod");
  70   }
  71
  72   Carp::confess("Invalid handler for rule spec $spec")
  73                              unless defined $handler and ref $handler eq 'CODE';
  74
  75   return [ $target, $handler, $replace, $is_role, $is_set ];
  76  });
  77
  78  $insert_rule = Sub::Name::subname('insert_rule' => sub {
  79   my ($rule, $list, $overwrite) = @_;
  80
  81   my ($target, $replace, $is_role) = @{$rule}[0, 2, 3];
  82
  83   if ($replace) {
  84    my @remove;
  85
  86    for my $i (0 .. $#$list) {
  87     my $old_target = $list->[$i]->[0];
  88     if ($is_role ? does_role($old_target, $target)
  89                  : $old_target->isa($target)) {
  90      if (defined $rule) {
  91       splice @$list, $i, 1, $rule;
  92       $rule = undef;
  93      } else {
  94       push @remove, $i;
  95      }
  96     }
  97    }
  98
  99    my $shift;
 100    for (@remove) {
 101     splice @$list, $_ - $shift, 1;
 102     ++$shift;
 103    }
 104    return 1 unless defined $rule;
 105
 106   } else { # Replace only an existent rule
 107
 108    for my $i (0 .. $#$list) {
 109     my $old_target = $list->[$i]->[0];
 110     if ($old_target eq $target) {
 111      Carp::confess("Default rule already defined for target $target")
 112                                                               unless $overwrite;
 113      splice @$list, $i, 1, $rule;
 114      return 1;
 115     }
 116    }
 117   }
 118
 119   push @$list, $rule;
 120   return 0;
 121  });
 122 }
 123
 124 =head1 METHODS
 125
 126 =head2 C<< new rules => [ $spec1 => $handler1, $spec2 => $handler2, ... ] >>
 127
 128 Creates a new functor object that will use both the default and these user-specified rules.
 129 The functor is also a code reference that expects to be called against L<LaTeX::TikZ::Set> objects.
 130
 131 The default set and mod rules clone their relevant objects, so you get a clone functor (for the default set types) if you don't specify any user rule.
 132
 133     # The default is a clone method
 134     my $clone = Tikz->functor;
 135     my $dup = $set->$clone;
 136
 137 If there is already a default rule for one of the C<$spec>s, it is replaced by the new one ; otherwise, the user rule is appended to the list of default rules.
 138
 139     # A translator
 140     my $translate = Tikz->functor(
 141      # Only replace the way point sets are cloned
 142      'LaTeX::TikZ::Set::Point' => sub {
 143       my ($functor, $set, $x, $y) = @_;
 144
 145       $set->new(
 146        point => [
 147         $set->x + $x,
 148         $set->y + $y,
 149        ],
 150        label => $set->label,
 151        pos   => $set->pos,
 152       );
 153      },
 154     );
 155     my $shifted = $set->$translate(1, 1);
 156
 157 But if one of the C<$spec>s begins with C<'+'>, the rule will replace I<all> default rules that apply to subclasses or subroles of C<$spec> (including C<$spec> itself).
 158
 159     # A mod stripper
 160     my $strip = Tikz->functor(
 161      # Replace all existent mod rules by this simple one
 162      '+LaTeX::TikZ::Mod' => sub { return },
 163     );
 164     my $naked = $set->$strip;
 165
 166 The functor will map unhandled sets and mods to themselves without cloning them, since it has no way to know how to do it.
 167 Thus, if you define your own L<LaTeX::TikZ::Set> or L<LaTeX::TikZ::Mod> object, be sure to register a default rule for it with the L</default_rule> method.
 168
 169 =cut
 170
 171 sub new {
 172  my ($class, %args) = @_;
 173
 174  my @set_rules = @default_set_rules;
 175  my @mod_rules = @default_mod_rules;
 176
 177  my @user_rules = @{$args{rules} || []};
 178  while (@user_rules) {
 179   my ($spec, $handler) = splice @user_rules, 0, 2;
 180
 181   my $rule = $validate_rule->($spec, $handler);
 182
 183   $insert_rule->($rule, $rule->[4] ? \@set_rules : \@mod_rules, 1);
 184  }
 185
 186  my %dispatch  = map { $_->[0] => $_ } @set_rules, @mod_rules;
 187
 188  my $self;
 189
 190  $self = bless sub {
 191   my $set = shift;
 192
 193   $lts_tc->assert_valid($set);
 194
 195   my $rule = $dispatch{ref($set)};
 196   unless ($rule) {
 197    for (@set_rules) {
 198     if ($_->[2] ? $set->does($_->[0]) : $set->isa($_->[0])) {
 199      $rule = $_;
 200      last;
 201     }
 202    }
 203    $rule = [ undef, sub { $_[1] } ] unless $rule;
 204   }
 205   my $new_set = $rule->[1]->($self, $set, @_);
 206   my $is_new  = $new_set ne $set;
 207
 208   my @new_mods;
 209 MOD:
 210   for my $mod ($set->mods) {
 211    my $rule = $dispatch{ref($mod)};
 212    unless ($rule) {
 213     for (@mod_rules) {
 214      if ($_->[2] ? $mod->does($_->[0]) : $mod->isa($_->[0])) {
 215       $rule = $_;
 216       last;
 217      }
 218     }
 219     unless ($rule) {
 220      push @new_mods, $mod;
 221      next MOD;
 222     }
 223    }
 224    push @new_mods, $rule->[1]->($self, $mod, @_);
 225   }
 226
 227   $new_set->mod(@new_mods) if $is_new;
 228
 229   return $new_set;
 230  }, $class;
 231 }
 232
 233 LaTeX::TikZ::Interface->register(
 234  functor => sub {
 235   shift;
 236
 237   __PACKAGE__->new(rules => \@_);
 238  },
 239 );
 240
 241 =head2 C<< default_rule $spec => $handler >>
 242
 243 Adds to all subsequently created functors a default rule for the class or role C<$spec>.
 244
 245 An exception is thrown if there is already a default rule for C<$spec> ; otherwise, the new rule is appended to the current list of rules.
 246 But if C<$spec> begins with C<'+'>, the rule will replace I<all> default rules that apply to subclasses or subroles of C<$spec> (including C<$spec> itself).
 247
 248 Returns true if and only if an existent rule was replaced.
 249
 250 =cut
 251
 252 sub default_rule {
 253  shift;
 254
 255  my $rule = $validate_rule->(@_);
 256
 257  $insert_rule->(
 258   $rule,
 259   $rule->[4] ? \@default_set_rules : \@default_mod_rules,
 260   0,
 261  );
 262 }
 263
 264 =head1 SEE ALSO
 265
 266 L<LaTeX::TikZ>.
 267
 268 =head1 AUTHOR
 269
 270 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 271
 272 You can contact me by mail or on C<irc.perl.org> (vincent).
 273
 274 =head1 BUGS
 275
 276 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>.
 277 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 278
 279 =head1 SUPPORT
 280
 281 You can find documentation for this module with the perldoc command.
 282
 283     perldoc LaTeX::TikZ
 284
 285 =head1 COPYRIGHT & LICENSE
 286
 287 Copyright 2010 Vincent Pit, all rights reserved.
 288
 289 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 290
 291 =cut
 292
 293 1; # End of LaTeX::TikZ::Functor