1# Template::Mustache is an implementation of the fabulous Mustache templating
2# language for Perl 5.8 and later.
3#
4# @author Pieter van de Bruggen
5# @see http://mustache.github.com
6package Template::Mustache;
7use strict;
8use warnings;
9
10use CGI ();
11use File::Spec;
12
13use version 0.77; our $VERSION = qv("v0.5.1");
14
15my %TemplateCache;
16
17# Constructs a new regular expression, to be used in the parsing of Mustache
18# templates.
19# @param [String] $otag The tag opening delimiter.
20# @param [String] $ctag The tag closing delimiter.
21# @return [Regex] A regular expression that will match tags with the specified
22#   delimiters.
23# @api private
24sub build_pattern {
25    my ($otag, $ctag) = @_;
26    return qr/
27        (.*?)                       # Capture the pre-tag content
28        ([ \t]*)                    # Capture the pre-tag whitespace
29        (?:\Q$otag\E \s*)           # Match the opening of the tag
30        (?:
31            (=)   \s* (.+?) \s* = | # Capture Set Delimiters
32            ({)   \s* (.+?) \s* } | # Capture Triple Mustaches
33            (\W?) \s* (.+?)         # Capture everything else
34        )
35        (?:\s* \Q$ctag\E)           # Match the closing of the tag
36    /xsm;
37}
38
39# Reads a file into a string, returning the empty string if the file does not
40# exist.
41# @param [String] $filename The name of the file to read.
42# @return [String] The contents of the given filename, or the empty string.
43# @api private
44sub read_file {
45    my ($filename) = @_;
46    return '' unless -f $filename;
47
48    local *FILE;
49    open FILE, $filename or die "Cannot read from file $filename!";
50    sysread(FILE, my $data, -s FILE);
51    close FILE;
52
53    return $data;
54}
55
56# @overload parse($tmpl)
57#   Creates an AST from the given template.
58#   @param [String] $tmpl The template to parse.
59#   @return [Array] The AST represented by the given template.
60#   @api private
61# @overload parse($tmpl, $delims)
62#   Creates an AST from the given template, with non-standard delimiters.
63#   @param [String] $tmpl The template to parse.
64#   @param [Array<String>[2]] $delims The delimiter pair to begin parsing with.
65#   @return [Array] The AST represented by the given template.
66#   @api private
67# @overload parse($tmpl, $delims, $section, $start)
68#   Parses out a section tag from the given template.
69#   @param [String] $tmpl The template to parse.
70#   @param [Array<String>[2]] $delims The delimiter pair to begin parsing with.
71#   @param [String] $section The name of the section we're parsing.
72#   @param [Int] $start The index of the first character of the section.
73#   @return [(String, Int)] The raw text of the section, and the index of the
74#       character immediately following the close section tag.
75#   @api internal
76sub parse {
77    my ($tmpl, $delims, $section, $start) = @_;
78    my @buffer;
79
80    # Pull the parse tree out of the cache, if we can...
81    $delims ||= [qw'{{ }}'];
82    my $cache = $TemplateCache{join ' ', @$delims} ||= {};
83    return $cache->{$tmpl} if exists $cache->{$tmpl};
84
85    my $error = sub {
86        my ($message, $errorPos) = @_;
87        my @lineCount = split("\n", substr($tmpl, 0, $errorPos));
88
89        die $message . "\nLine " . length(@lineCount);
90    };
91
92    # Build the pattern, and instruct the regex engine to begin at `$start`.
93    my $pattern = build_pattern(@$delims);
94    my $pos = pos($tmpl) = $start ||= 0;
95
96    # Begin parsing out tags
97    while ($tmpl =~ m/\G$pattern/gc) {
98        my ($content, $whitespace) = ($1, $2);
99        my $type = $3 || $5 || $7;
100        my $tag  = $4 || $6 || $8;
101
102        # Buffer any non-tag content we have.
103        push @buffer, $content if $content;
104
105        # Grab the index for the end of the content, and update our pointer.
106        my $eoc = $pos + length($content) - 1;
107        $pos = pos($tmpl);
108
109        # A tag is considered standalone if it is the only non-whitespace
110        # content on a line.
111        my $is_standalone = (substr($tmpl, $eoc, 1) || "\n") eq "\n" &&
112                            (substr($tmpl, $pos, 1) || "\n") eq "\n";
113
114        # Standalone tags should consume the newline that follows them, unless
115        # the tag is of an interpolation type.
116        # Otherwise, any whitespace we've captured should be added to the
117        # buffer, and the end of content index should be advanced.
118        if ($is_standalone && ($type ne '{' && $type ne '&' && $type ne '')) {
119            $pos += 1;
120        } elsif ($whitespace) {
121            $eoc += length($whitespace);
122            push @buffer, $whitespace;
123            $whitespace = '';
124        }
125
126        if ($type eq '!') {
127            # Comment Tag - No-op.
128        } elsif ($type eq '{' || $type eq '&' || $type eq '') {
129            # Interpolation Tag - Buffers the tag type and name.
130            push @buffer, [ $type, $tag ];
131        } elsif ($type eq '>') {
132            # Partial Tag - Buffers the tag type, name, and any indentation
133            push @buffer, [ $type, $tag, $whitespace ];
134        } elsif ($type eq '=') {
135            # Set Delimiter Tag - Changes the delimiter pair and updates the
136            # tag pattern.
137            $delims = [ split(/\s+/, $tag) ];
138
139            $error->("Set Delimiters tags must have exactly two values!", $pos)
140                if @$delims != 2;
141
142            $pattern = build_pattern(@$delims);
143        } elsif ($type eq '#' || $type eq '^') {
144            # Section Tag - Recursively calls #parse (starting from the current
145            # index), and receives the raw section string and a new index.
146            # Buffers the tag type, name, the section string and delimiters.
147            (my $raw, $pos) = parse($tmpl, $delims, $tag, $pos);
148            push @buffer, [ $type, $tag, [$raw, $delims] ];
149        } elsif ($type eq '/') {
150            # End Section Tag - Short circuits a recursive call to #parse,
151            # caches the buffer for the raw section template, and returns the
152            # raw section template and the index immediately following the tag.
153            my $msg;
154            if (!$section) {
155                $msg = "End Section tag '$tag' found, but not in a section!";
156            } elsif ($tag ne $section) {
157                $msg = "End Section tag closes '$tag'; expected '$section'!";
158            }
159            $error->($msg, $pos) if $msg;
160
161            my $raw_section = substr($tmpl, $start, $eoc + 1 - $start);
162            $cache->{$raw_section} = [@buffer];
163            return ($raw_section, $pos);
164        } else {
165            $error->("Unknown tag type -- $type", $pos);
166        }
167
168        # Update our match pointer to coincide with any changes we've made.
169        pos($tmpl) = $pos
170    }
171
172    # Buffer any remaining template, cache the template for later, and return
173    # a reference to the buffer.
174    push @buffer, substr($tmpl, $pos);
175    $cache->{$tmpl} = [@buffer];
176    return \@buffer;
177}
178
179# Produces an expanded version of the template represented by the given parse
180# tree.
181# @param [Array<String,Array>] $parse_tree The AST of a Mustache template.
182# @param [Code] $partials A subroutine that looks up partials by name.
183# @param [(Any)] @context The context stack to perform key lookups against.
184# @return [String] The fully rendered template.
185# @api private
186sub generate {
187    my ($parse_tree, $partials, @context) = @_;
188
189    # Build a helper function to abstract away subtemplate expansion.
190    # Recursively calls generate after parsing the given template.  This allows
191    # us to use the call stack as our context stack.
192    my $build = sub { generate(parse(@_[0,1]), $partials, $_[2], @context) };
193
194    # Walk through the parse tree, handling each element in turn.
195    join '', map {
196        # If the given element is a string, treat it literally.
197        my @result = ref $_ ? () : $_;
198
199        # Otherwise, it's a three element array, containing a tag's type, name,
200        # and accessory data.  As a precautionary step, we can prefetch any
201        # data value from the context stack (which will be useful in every case
202        # except partial tags).
203        unless (@result) {
204            my ($type, $tag, $data) = @$_;
205            my $render = sub { $build->(shift, $data->[1]) };
206
207            my ($ctx, $value) = lookup($tag, @context) unless $type eq '>';
208
209            if ($type eq '{' || $type eq '&' || $type eq '') {
210                # Interpolation Tags
211                # If the value is a code reference, we should treat it
212                # according to Mustache's lambda rules.  Specifically, we
213                # should call the sub (passing a "render" function as a
214                # convenience), render its contents against the current
215                # context, and cache the value (if possible).
216                if (ref $value eq 'CODE') {
217                    $value = $build->($value->($render));
218                    $ctx->{$tag} = $value if ref $ctx eq 'HASH';
219                }
220                # An empty `$type` represents an HTML escaped tag.
221                $value = CGI::escapeHTML($value) unless $type;
222                @result = $value;
223            } elsif ($type eq '#') {
224                # Section Tags
225                # `$data` will contain an array reference with the raw template
226                # string, and the delimiter pair being used when the section
227                # tag was encountered.
228                # There are four special cases for section tags.
229                #  * If the value is falsey, the section is skipped over.
230                #  * If the value is an array reference, the section is
231                #    rendered once using each element of the array.
232                #  * If the value is a code reference, the raw section string
233                #    and a rendering function are passed to the sub; the return
234                #    value is then automatically rendered.
235                #  * Otherwise, the section is rendered using given value.
236                if (ref $value eq 'ARRAY') {
237                    @result = map { $build->(@$data, $_) } @$value;
238                } elsif ($value) {
239                    my @x = @$data;
240                    $x[0] = $value->($x[0], $render) if ref $value eq 'CODE';
241                    @result = $build->(@x, $value);
242                }
243            } elsif ($type eq '^') {
244                # Inverse Section Tags
245                # These should only be rendered if the value is falsey or an
246                # empty array reference.  `$data` is as for Section Tags.
247                $value = @$value if ref $value eq 'ARRAY';
248                @result = $build->(@$data) unless $value;
249            } elsif ($type eq '>') {
250                # Partial Tags
251                # `$data` contains indentation to be applied to the partial.
252                # The partial template is looked up thanks to the `$partials`
253                # code reference, rendered, and non-empty lines are indented.
254                my $partial = scalar $partials->($tag);
255                $partial =~ s/^(?=.)/${data}/gm if $data;
256                @result = $build->($partial);
257            }
258        }
259        @result; # Collect the results...
260    } @$parse_tree;
261}
262
263# Performs a lookup of a `$field` in a context stack.
264# @param [String] $field The field to lookup.
265# @param [(Any)] @context The context stack.
266# @return [(Any, Any)] The context element and value for the given `$field`.
267# @api private
268sub lookup {
269    my ($field, @context) = @_;
270    my ($value, $ctx) = '';
271
272    for my $index (0..$#{[@context]}) {
273        $ctx = $context[$index];
274        if (ref $ctx eq 'HASH') {
275            next unless exists $ctx->{$field};
276            $value = $ctx->{$field};
277            last;
278        } else {
279            next unless UNIVERSAL::can($ctx, $field);
280            $value = $ctx->$field();
281            last;
282        }
283    }
284
285    return ($ctx, $value);
286}
287
288use namespace::clean;
289
290# Standard hash constructor.
291# @param %args Initialization data.
292# @return [Template::Mustache] A new instance.
293sub new {
294    my ($class, %args) = @_;
295    return bless({ %args }, $class);
296}
297
298our $template_path = '.';
299
300# Filesystem path for template and partial lookups.
301# @return [String] +$Template::Mustache::template_path+ (defaults to '.').
302# @scope dual
303sub template_path { $Template::Mustache::template_path }
304
305our $template_extension = 'mustache';
306
307# File extension for templates and partials.
308# @return [String] +$Template::Mustache::template_extension+ (defaults to
309#   'mustache').
310# @scope dual
311sub template_extension { $Template::Mustache::template_extension }
312
313# Package namespace to ignore during template lookups.
314#
315# As an example, if you subclass +Template::Mustache+ as the class
316# +My::Heavily::Namepaced::Views::SomeView+, calls to {render} will
317# automatically try to load the template
318# +./My/Heavily/Namespaced/Views/SomeView.mustache+ under the {template_path}.
319# Since views will very frequently all live in a common namespace, you can
320# override this method in your subclass, and save yourself some headaches.
321#
322#    Setting template_namespace to:      yields template name:
323#      My::Heavily::Namespaced::Views => SomeView.mustache
324#      My::Heavily::Namespaced        => Views/SomeView.mustache
325#      Heavily::Namespaced            => My/Heavily/Namespaced/Views/SomeView.mustache
326#
327# As noted by the last example, namespaces will only be removed from the
328# beginning of the package name.
329# @return [String] The empty string.
330# @scope dual
331sub template_namespace { '' }
332
333our $template_file;
334
335# The template filename to read.  The filename follows standard Perl module
336# lookup practices (e.g. My::Module becomes My/Module.pm) with the following
337# differences:
338# * Templates have the extension given by {template_extension} ('mustache' by
339#   default).
340# * Templates will have {template_namespace} removed, if it appears at the
341#   beginning of the package name.
342# * Template filename resolution will short circuit if
343#   +$Template::Mustache::template_file+ is set.
344# * Template filename resolution may be overriden in subclasses.
345# * Template files will be resolved against {template_path}, not +$PERL5LIB+.
346# @return [String] The path to the template file, relative to {template_path}.
347# @see template
348sub template_file {
349    my ($receiver) = @_;
350    return $Template::Mustache::template_file
351        if $Template::Mustache::template_file;
352
353    my $class = ref $receiver || $receiver;
354    $class =~ s/^@{[$receiver->template_namespace()]}:://;
355    my $ext  = $receiver->template_extension();
356    return File::Spec->catfile(split(/::/, "${class}.${ext}"));
357};
358
359# Reads the template off disk.
360# @return [String] The contents of the {template_file} under {template_path}.
361sub template {
362    my ($receiver) = @_;
363    my $path = $receiver->template_path();
364    my $template_file = $receiver->template_file();
365    return read_file(File::Spec->catfile($path, $template_file));
366}
367
368# Reads a named partial off disk.
369# @param [String] $name The name of the partial to lookup.
370# @return [String] The contents of the partial (in {template_path}, of type
371#   {template_extension}), or the empty string, if the partial does not exist.
372sub partial {
373    my ($receiver, $name) = @_;
374    my $path = $receiver->template_path();
375    my $ext  = $receiver->template_extension();
376    return read_file(File::Spec->catfile($path, "${name}.${ext}"));
377}
378
379# @overload render()
380#   Renders a class or instance's template with data from the receiver.  The
381#   template will be retrieved by calling the {template} method.  Partials
382#   will be fetched by {partial}.
383#   @return [String] The fully rendered template.
384# @overload render($tmpl)
385#   Renders the given template with data from the receiver.  Partials will be
386#   fetched by {partial}.
387#   @param [String] $tmpl The template to render.
388#   @return [String] The fully rendered template.
389# @overload render($data)
390#   Renders a class or instance's template with data from the receiver.  The
391#   template will be retrieved by calling the {template} method.  Partials
392#   will be fetched by {partial}.
393#   @param [Hash,Object] $data Data to be interpolated into the template.
394#   @return [String] The fully rendered template.
395# @overload render($tmpl, $data)
396#   Renders the given template with the given data.  Partials will be fetched
397#   by {partial}.
398#   @param [String] $tmpl The template to render.
399#   @param [Hash,Class,Object] $data Data to be interpolated into the template.
400#   @return [String] The fully rendered template.
401# @overload render($tmpl, $data, $partials)
402#   Renders the given template with the given data.  Partials will be looked up
403#   by calling the given code reference with the partial's name.
404#   @param [String] $tmpl The template to render.
405#   @param [Hash,Class,Object] $data Data to be interpolated into the template.
406#   @param [Code] $partials A function used to lookup partials.
407#   @return [String] The fully rendered template.
408# @overload render($tmpl, $data, $partials)
409#   Renders the given template with the given data.  Partials will be looked up
410#   by calling the partial's name as a method on the given class or object.
411#   @param [String] $tmpl The template to render.
412#   @param [Hash,Class,Object] $data Data to be interpolated into the template.
413#   @param [Class,Object] $partials A thing that responds to partial names.
414#   @return [String] The fully rendered template.
415# @overload render($tmpl, $data, $partials)
416#   Renders the given template with the given data.  Partials will be looked up
417#   in the given hash.
418#   @param [String] $tmpl The template to render.
419#   @param [Hash,Class,Object] $data Data to be interpolated into the template.
420#   @param [Hash] $partials A hash containing partials.
421#   @return [String] The fully rendered template.
422sub render {
423    my ($receiver, $tmpl, $data, $partials) = @_;
424    ($data, $tmpl) = ($tmpl, $data) if !(ref $data) && (ref $tmpl);
425
426    $tmpl       = $receiver->template() unless defined $tmpl;
427    $data     ||= $receiver;
428    $partials ||= sub {
429        unshift @_, $receiver;
430        goto &{$receiver->can('partial')};
431    };
432
433    my $part = $partials;
434    $part = sub { lookup(shift, $partials) } unless ref $partials eq 'CODE';
435
436    my $parsed = parse($tmpl);
437    return generate($parsed, $part, $data);
438}
439
4401;
441