File Coverage

blib/lib/LaTeX/TikZ/Scope.pm
Criterion Covered Total %
statement 102 102 100.0
branch 37 38 97.3
condition 14 15 93.3
subroutine 13 13 100.0
pod 7 7 100.0
total 173 175 98.8


line stmt bran cond sub pod time code
1             package LaTeX::TikZ::Scope;
2              
3 10     10   52 use strict;
  10         19  
  10         305  
4 10     10   53 use warnings;
  10         27  
  10         462  
5              
6             =head1 NAME
7              
8             LaTeX::TikZ::Scope - An object modeling a TikZ scope or layer.
9              
10             =head1 VERSION
11              
12             Version 0.02
13              
14             =cut
15              
16             our $VERSION = '0.02';
17              
18 10     10   56 use Sub::Name ();
  10         18  
  10         165  
19              
20 10     10   52 use LaTeX::TikZ::Tools;
  10         17  
  10         201  
21              
22 10     10   58 use Any::Moose;
  10         15  
  10         91  
23              
24             =head1 ATTRIBUTES
25              
26             =head2 C<mods>
27              
28             =cut
29              
30             has '_mods' => (
31             is => 'ro',
32             isa => 'Maybe[ArrayRef[LaTeX::TikZ::Mod::Formatted]]',
33             init_arg => undef,
34             default => sub { [ ] },
35             );
36              
37 161     161 1 217 sub mods { @{$_[0]->_mods} }
  161         650  
38              
39             has '_mods_cache' => (
40             is => 'ro',
41             isa => 'Maybe[HashRef[LaTeX::TikZ::Mod::Formatted]]',
42             init_arg => undef,
43             default => sub { +{ } },
44             );
45              
46             =head2 C<body>
47              
48             =cut
49              
50             has '_body' => (
51             is => 'rw',
52             isa => 'LaTeX::TikZ::Scope|ArrayRef[Str]',
53             init_arg => 'body',
54             );
55              
56             my $my_tc = LaTeX::TikZ::Tools::type_constraint(__PACKAGE__);
57             my $ltmf_tc = LaTeX::TikZ::Tools::type_constraint('LaTeX::TikZ::Mod::Formatted');
58             my $_body_tc = __PACKAGE__->meta->find_attribute_by_name('_body')
59             ->type_constraint;
60              
61             =head1 METHODS
62              
63             =head2 C<mod>
64              
65             =cut
66              
67             sub mod {
68 199     199 1 906 my $scope = shift;
69              
70 199         475 my $cache = $scope->_mods_cache;
71              
72 199         423 for (@_) {
73 238         1029 my $mod = $ltmf_tc->coerce($_);
74 238         2803 $ltmf_tc->assert_valid($mod);
75 238         2358 my $tag = $mod->tag;
76 238 100       840 next if exists $cache->{$tag};
77 236         597 $cache->{$tag} = $mod;
78 236         291 push @{$scope->_mods}, $mod;
  236         1052  
79             }
80              
81 199         1220 $scope;
82             }
83              
84             =head2 C<body>
85              
86             =cut
87              
88             sub body {
89 340     340 1 547 my $scope = shift;
90              
91 340 100       743 if (@_) {
92 199         923 $scope->_body($_[0]);
93 199         816 $scope;
94             } else {
95 141         195 @{$scope->_body};
  141         639  
96             }
97             }
98              
99             use overload (
100 10         70 '@{}' => 'dereference',
101 10     10   29103 );
  10         9566  
102              
103             =head2 C<flatten>
104              
105             =cut
106              
107             sub flatten {
108 269     269 1 367 my ($scope) = @_;
109              
110 269         1518 do {
111 279         655 my $body = $scope->_body;
112 279 100       1360 return $scope unless $my_tc->check($body);
113 10         65 $scope = $scope->new
114             ->mod ($scope->mods, $body->mods)
115             ->body($body->_body)
116             } while (1);
117             }
118              
119             my $inter = Sub::Name::subname('inter' => sub {
120             my ($lh, $rh) = @_;
121              
122             my (@left, @common, @right);
123             my %where;
124              
125             --$where{$_} for keys %$lh;
126             ++$where{$_} for keys %$rh;
127              
128             while (my ($key, $where) = each %where) {
129             if ($where < 0) {
130             push @left, $lh->{$key};
131             } elsif ($where > 0) {
132             push @right, $rh->{$key};
133             } else {
134             push @common, $rh->{$key};
135             }
136             }
137              
138             return \@left, \@common, \@right;
139             });
140              
141             =head2 C<instantiate>
142              
143             =cut
144              
145             sub instantiate {
146 141     141 1 212 my ($scope) = @_;
147              
148 141         306 $scope = $scope->flatten;
149              
150 141         220 my ($layer, @clips, @raw_mods);
151 141         335 for ($scope->mods) {
152 162         439 my $type = $_->type;
153 162 100       637 if ($type eq 'clip') {
    100          
154 38         165 unshift @clips, $_->content;
155             } elsif ($type eq 'layer') {
156 23 50       65 confess("Can't apply two layers in a row") if defined $layer;
157 23         82 $layer = $_->content;
158             } else { # raw
159 101         386 push @raw_mods, $_->content;
160             }
161             }
162              
163 141         429 my @body = $scope->body;
164              
165 141 100       529 my $mods_string = @raw_mods ? ' [' . join(',', @raw_mods) . ']' : undef;
166              
167 141 100 100     1070 if (@raw_mods and @body == 1 and $body[0] =~ /^\s*\\draw\b\s*([^\[].*)\s*$/) {
      66        
168 40         155 $body[0] = "\\draw$mods_string $1"; # Has trailing semicolon
169 40         69 $mods_string = undef; # Done with mods
170             }
171              
172 141         420 for (0 .. $#clips) {
173 38         60 my $clip = $clips[$_];
174 38         91 my $clip_string = "\\clip $clip ;";
175 38 100 100     185 my $mods_string = ($_ == $#clips and defined $mods_string)
176             ? $mods_string : '';
177 38         172 unshift @body, "\\begin{scope}$mods_string",
178             $clip_string;
179 38         114 push @body, "\\end{scope}",
180             }
181              
182 141 100 100     649 if (not @clips and defined $mods_string) {
183 37         123 unshift @body, "\\begin{scope}$mods_string";
184 37         69 push @body, "\\end{scope}";
185             }
186              
187 141 100       314 if (defined $layer) {
188 23         56 unshift @body, "\\begin{pgfonlayer}{$layer}";
189 23         45 push @body, "\\end{pgfonlayer}";
190             }
191              
192 141         1416 return @body;
193             }
194              
195             =head2 C<dereference>
196              
197             =cut
198              
199 51     51 1 186 sub dereference { [ $_[0]->instantiate ] }
200              
201             =head2 C<fold>
202              
203             =cut
204              
205             sub fold {
206 125     125 1 222 my ($left, $right, $rev) = @_;
207              
208 125         166 my (@left, @right);
209              
210 125 100       554 if ($my_tc->check($left)) {
211 73         273 $left = $left->flatten;
212              
213 73 100       306 if ($my_tc->check($right)) {
214 55         113 $right = $right->flatten;
215              
216 55         239 my ($only_left, $common, $only_right) = $inter->(
217             $left->_mods_cache,
218             $right->_mods_cache,
219             );
220              
221 55         81 my $has_different_layers;
222 55         118 for (@$only_left) {
223 29 100       143 if ($_->type eq 'layer') {
224 5         7 $has_different_layers = 1;
225 5         8 last;
226             }
227             }
228 55 100       138 unless ($has_different_layers) {
229 50         108 for (@$only_right) {
230 23 100       123 if ($_->type eq 'layer') {
231 1         4 $has_different_layers = 1;
232 1         3 last;
233             }
234             }
235             }
236              
237 55 100 100     277 if (!$has_different_layers and @$common) {
238 19         133 my $x = $left->new
239             ->mod(@$only_left)
240             ->body($left->_body);
241 19         129 my $y = $left->new
242             ->mod(@$only_right)
243             ->body($right->_body);
244 19         123 return $left->new
245             ->mod(@$common)
246             ->body(fold($x, $y, $rev));
247             } else {
248 36         110 @right = $right->instantiate;
249             }
250             } else {
251 18         86 $_body_tc->assert_valid($right);
252 18         188 @right = @$right;
253             }
254              
255 54         160 @left = $left->instantiate;
256             } else {
257 52 100       220 if ($my_tc->check($right)) {
258 12         61 return fold($right, $left, 1);
259             } else {
260 40         191 $_body_tc->assert_valid($_) for $left, $right;
261 40         673 @left = @$left;
262 40         87 @right = @$right;
263             }
264             }
265              
266 94 100       711 $rev ? [ @right, @left ] : [ @left, @right ];
267             }
268              
269             __PACKAGE__->meta->make_immutable;
270              
271             =head1 SEE ALSO
272              
273             L<LaTeX::TikZ>.
274              
275             =head1 AUTHOR
276              
277             Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
278              
279             You can contact me by mail or on C<irc.perl.org> (vincent).
280              
281             =head1 BUGS
282              
283             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>.
284             I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
285              
286             =head1 SUPPORT
287              
288             You can find documentation for this module with the perldoc command.
289              
290             perldoc LaTeX::TikZ
291              
292             =head1 COPYRIGHT & LICENSE
293              
294             Copyright 2010 Vincent Pit, all rights reserved.
295              
296             This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
297              
298             =cut
299              
300             1; # End of LaTeX::TikZ::Scope