File Coverage

blib/lib/Mock/Data/Template.pm
Criterion Covered Total %
statement 72 75 96.0
branch 37 46 80.4
condition 11 17 64.7
subroutine 17 17 100.0
pod 6 6 100.0
total 143 161 88.8


line stmt bran cond sub pod time code
1             package Mock::Data::Template;
2 9     9   69 use strict;
  9         22  
  9         312  
3 9     9   62 use warnings;
  9         19  
  9         468  
4 9     9   57 use overload '""' => sub { shift->to_string };
  9     15   18  
  9         119  
  15         34  
5             require Carp;
6 9     9   794 use Mock::Data::Util qw( _parse_context _escape_str );
  9         20  
  9         12975  
7             require Mock::Data::Generator;
8             our @ISA= qw( Mock::Data::Generator );
9              
10             # ABSTRACT: Create a generator that plugs other templates into a string
11             our $VERSION = '0.02'; # VERSION
12              
13              
14             sub new {
15 57     57 1 106 my $class= shift;
16             my %self= (@_ == 1 && !ref $_[0])? ( template => $_[0] )
17 57 0 33     322 : (@_ == 1 && ref $_[0] eq 'HASH')? %{$_[0]}
  0 0 0     0  
    50          
18             : @_ > 1? @_
19             : Carp::croak("Invalid constructor arguments to $class");
20             # Parse now, to report errors
21 57         222 $self{_compiled}= $class->parse_template($self{template}, { compile => 1 });
22 55         233 bless \%self, $class;
23             }
24              
25              
26 15     15 1 94 sub template { shift->{template} }
27              
28              
29             sub compile {
30 4     4 1 11 my $cmp= $_[0]{_compiled};
31 4 100   1   25 return ref $cmp? $cmp : sub { $cmp };
  1         5  
32             }
33              
34             sub generate {
35 53     53 1 264 my $cmp= shift->{_compiled};
36 53 100       172 return ref $cmp? $cmp->(@_) : $cmp;
37             }
38              
39              
40             sub to_string {
41 15     15 1 39 "template('" . shift->template . "')";
42             }
43              
44              
45             sub parse_template {
46 57     57 1 131 my ($self, $str, $flags)= @_;
47 57         106 local $_= $str;
48 57         157 pos= 0;
49 57         113 my $ret;
50 57         91 local $@;
51 57 100 50     103 defined eval { $ret= _parse_template($flags || {}) }
  57         178  
52             or Carp::croak("$@ at "._parse_context);
53 55         193 return $ret;
54             }
55              
56             # Parse a template string in $_ from pos($_)
57             sub _parse_template {
58 71     71   139 my @parts;
59 71         157 my $outer= !$_[0]{inner};
60 71 100       213 local $_[0]{inner}= 1 if $outer;
61 71         104 while (1) {
62             # Consume run of literal characters
63 97 100       517 push @parts, $1 if $outer? /\G([^{]+)/gc : /\G([^ \t\{\}]+)/gc;
    100          
64             # at end of template, or beginning of a reference to something
65 97 100       340 last unless /\G(?=\{)/gc;
66 28         74 push @parts, _parse_template_reference(@_);
67             }
68             # Combine adjacent scalars in the list
69 69   100     373 @parts= grep ref $_ || length, @parts;
70 69         251 for (my $i= $#parts - 1; $i >= 0; --$i) {
71 8 100 100     36 if (!ref $parts[$i] and !ref $parts[$i+1]) {
72 5         18 $parts[$i] .= splice(@parts, $i+1, 1);
73             }
74             }
75 69 50       160 if ($_[0]{compile}) {
76             return @parts == 1 && !ref $parts[0]? $parts[0]
77 18 100   18   57 : sub { join '', map +(ref($_)? $_->(@_) : $_), @parts }
78 69 100 100     477 } else {
79 0         0 return \@parts;
80             }
81             }
82              
83             # Parse one of the curly-brace notations
84             sub _parse_template_reference {
85 28 100   28   88 if (/\G\{(\w+)/gc) {
86 19         65 my $generator_name= $1;
87 19         38 my (@named_param, @pos_param);
88 19 100       66 if (/\G[ \t]+/gc) {
89 13         36 while (!/\G\}/gc) {
90 14 100       40 if (/\G(\w+)=/gc) {
91 6         16 push @named_param, $1, _parse_template(@_);
92             } else {
93 8         32 push @pos_param, _parse_template(@_);
94             }
95 14         54 /\G[ \t]*/gc;
96             }
97             } else {
98 6 100       38 /\G\}/gc or die "Expected '}'";
99             }
100 18 50       45 if ($_[0]{compile}) {
101             # compile by making a list of which params are function calls, and update lists for only those positions
102 18         41 my @named_literal= @named_param;
103 18         45 my @dynamic_named= grep ref $named_param[$_], 0 .. $#named_param;
104 18         37 my @pos_literal= @pos_param;
105 18         34 my @dynamic_pos= grep ref $pos_literal[$_], 0 .. $#pos_param;
106 18 100       38 if (@named_param) {
107             return sub {
108 6     6   33 $named_literal[$_]= $named_param[$_]->(@_) for @dynamic_named;
109 6         11 $pos_literal[$_]= $pos_param[$_]->(@_) for @dynamic_pos;
110 6         23 $_[0]->call($generator_name, { @named_literal }, @pos_literal);
111             }
112 6         36 } else {
113             return sub {
114 13     13   42 $pos_literal[$_]= $pos_param[$_]->(@_) for @dynamic_pos;
115 13         97 $_[0]->call($generator_name, @pos_literal);
116             }
117 12         101 }
118             } else {
119 0 0       0 return [ $generator_name, (@named_param? { @named_param }:()), @pos_param ];
120             }
121             }
122 9 100       51 return chr hex $1 if /\G\{ [#] ([0-9A-Za-z]+) \}/xgc;
123 2 100       8 return '' if /\G\{\}/xgc;
124 1         14 die "Invalid template notation\n";
125             }
126              
127             1;
128              
129             __END__