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<< default_rule $spec => $handler >>
 126
 127 Adds to all subsequently created functors a default rule for the class or role C<$spec>.
 128
 129 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.
 130 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).
 131
 132 Returns true if and only if an existent rule was replaced.
 133
 134 =cut
 135
 136 sub default_rule {
 137  shift;
 138
 139  my $rule = $validate_rule->(@_);
 140
 141  $insert_rule->(
 142   $rule,
 143   $rule->[4] ? \@default_set_rules : \@default_mod_rules,
 144   0,
 145  );
 146 }
 147
 148 =head2 C<< new rules => [ $spec1 => $handler1, $spec2 => $handler2, ... ] >>
 149
 150 Creates a new functor object that will use both the default and these user-specified rules.
 151 The functor is also a code reference that expects to be called against L<LaTeX::TikZ::Set> objects.
 152
 153 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.
 154
 155     # The default is a clone method
 156     my $clone = Tikz->functor;
 157     my $dup = $set->$clone;
 158
 159 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.
 160
 161     # A translator
 162     my $translate = Tikz->functor(
 163      # Only replace the way point sets are cloned
 164      'LaTeX::TikZ::Set::Point' => sub {
 165       my ($functor, $set, $x, $y) = @_;
 166
 167       $set->new(
 168        point => [
 169         $set->x + $x,
 170         $set->y + $y,
 171        ],
 172        label => $set->label,
 173        pos   => $set->pos,
 174       );
 175      },
 176     );
 177     my $shifted = $set->$translate(1, 1);
 178
 179 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).
 180
 181     # A mod stripper
 182     my $strip = Tikz->functor(
 183      # Replace all existent mod rules by this simple one
 184      '+LaTeX::TikZ::Mod' => sub { return },
 185     );
 186     my $naked = $set->$strip;
 187
 188 The functor will map unhandled sets and mods to themselves without cloning them, since it has no way to know how to do it.
 189 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.
 190
 191 =cut
 192
 193 sub new {
 194  my ($class, %args) = @_;
 195
 196  my @set_rules = @default_set_rules;
 197  my @mod_rules = @default_mod_rules;
 198
 199  my @user_rules = @{$args{rules} || []};
 200  while (@user_rules) {
 201   my ($spec, $handler) = splice @user_rules, 0, 2;
 202
 203   my $rule = $validate_rule->($spec, $handler);
 204
 205   $insert_rule->($rule, $rule->[4] ? \@set_rules : \@mod_rules, 1);
 206  }
 207
 208  my %dispatch  = map { $_->[0] => $_ } @set_rules, @mod_rules;
 209
 210  my $self;
 211
 212  $self = bless sub {
 213   my $set = shift;
 214
 215   $lts_tc->assert_valid($set);
 216
 217   my $rule = $dispatch{ref($set)};
 218   unless ($rule) {
 219    for (@set_rules) {
 220     if ($_->[2] ? $set->does($_->[0]) : $set->isa($_->[0])) {
 221      $rule = $_;
 222      last;
 223     }
 224    }
 225    $rule = [ undef, sub { $_[1] } ] unless $rule;
 226   }
 227   my $new_set = $rule->[1]->($self, $set, @_);
 228   my $is_new  = $new_set ne $set;
 229
 230   my @new_mods;
 231 MOD:
 232   for my $mod ($set->mods) {
 233    my $rule = $dispatch{ref($mod)};
 234    unless ($rule) {
 235     for (@mod_rules) {
 236      if ($_->[2] ? $mod->does($_->[0]) : $mod->isa($_->[0])) {
 237       $rule = $_;
 238       last;
 239      }
 240     }
 241     unless ($rule) {
 242      push @new_mods, $mod;
 243      next MOD;
 244     }
 245    }
 246    push @new_mods, $rule->[1]->($self, $mod, @_);
 247   }
 248
 249   $new_set->mod(@new_mods) if $is_new;
 250
 251   return $new_set;
 252  }, $class;
 253 }
 254
 255 LaTeX::TikZ::Interface->register(
 256  functor => sub {
 257   shift;
 258
 259   __PACKAGE__->new(rules => \@_);
 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