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