Locale::Maketext::Extract::Plugin::TT2 - Template Toolkit format parser

    $plugin = Locale::Maketext::Extract::Plugin::TT2->new(
        $lexicon            # A Locale::Maketext::Extract object
        @file_types         # Optionally specify a list of recognised file types
    )

    $plugin->extract($filename,$filecontents);

    tt2

package Locale::Maketext::Extract::Plugin::TT2;

use strict;
use base qw(Locale::Maketext::Extract::Plugin::Base);
use Template::Constants qw( :debug );
use Template::Parser;

# import strip_quotes
*strip_quotes
    = \&Locale::Maketext::Extract::Plugin::TT2::Directive::strip_quotes;

our %PARSER_OPTIONS;

#===================================
sub file_types {
#===================================
    return ( qw( tt tt2 html ), qr/\.tt2?\./ );
}

my %Escapes = map { ( "\\$_" => eval("qq(\\$_)") ) } qw(t n r f b a e);

#===================================
sub extract {
#===================================
    my $self = shift;
    my $data = shift;

    $Template::Directive::PRETTY = 1;
    my $parser =
        Locale::Maketext::Extract::Plugin::TT2::Parser->new(
               %PARSER_OPTIONS,
               FACTORY => 'Locale::Maketext::Extract::Plugin::TT2::Directive',
               FILE_INFO => 0,
        );
    _init_overrides($parser);

    $parser->{extracted} = [];

    $Locale::Maketext::Extract::Plugin::TT2::Directive::PARSER
        = $parser;    # hack
    $parser->parse($data)
        || die $parser->error;

    foreach my $entry ( @{ $parser->{extracted} } ) {
        $entry->[2] =~ s/^\((.*)\)$/$1/s;    # Remove () from vars
        $_ =~ s/\\'/'/gs                     # Unescape \'
            for @{$entry}[ 0, 2 ];
        $entry->[2] =~ s/\\(?!")/\\\\/gs;    # Escape all \ not followed by "
                                             # Escape argument lists correctly
        while ( my ( $char, $esc ) = each %Escapes ) {
            $entry->[2] =~ s/$esc/$char/g;
        }
        $entry->[1] =~ s/\D+.*$//;
        $self->add_entry(@$entry);
    }
}

#===================================
sub _init_overrides {
#===================================
    my $parser = shift;

    # Override the concatenation sub to return _ instead of .
    my $states = $parser->{STATES};
    foreach my $state ( @{$states} ) {
        if ( my $CAT_no = $state->{ACTIONS}{CAT} ) {
            my $CAT_rule_no
                = $states->[ $states->[$CAT_no]{GOTOS}{expr} ]->{DEFAULT};

            # override the TT::Grammar sub which cats two args
            $parser->{RULES}[ -$CAT_rule_no ][2] = sub {
                my $first  = ( $_[1] );
                my $second = ( $_[3] );
                if ( strip_quotes($first) && strip_quotes($second) ) {

                    # both are literal
                    return "'${first}${second}'";
                }
                else {

                    # at least one is an ident
                    return "$_[1] _ $_[3]";
                }
            };
            last;
        }
    }
}

#===================================
#===================================
package Locale::Maketext::Extract::Plugin::TT2::Parser;
#===================================
#===================================

use base 'Template::Parser';

# disabled location() because it was adding unneccessary text
# to filter blocks
#===================================
sub location {''}
#===================================

# Custom TT parser for Locale::Maketext::Lexicon
#
# Written by Andy Wardley http://wardley.org/
#
# 18 September 2008
#

#-----------------------------------------------------------------------
# custom directive generator to capture filters, variables and
# massage a few other elements to make life easy.
#-----------------------------------------------------------------------

#===================================
#===================================
package Locale::Maketext::Extract::Plugin::TT2::Directive;
#===================================
#===================================

use base 'Template::Directive';

our $PARSER;

#===================================
sub textblock {
#===================================
    my ( $class, $text ) = @_;
    $text =~ s/([\\'])/\\$1/g;
    return "'$text'";
}

#===================================
sub ident {
#===================================
    my ( $class, $ident ) = @_;
    return "NULL" unless @$ident;
    if ( scalar @$ident <= 2 && !$ident->[1] ) {
        my $var = $ident->[0];
        $var =~ s/^'(.+)'$/$1/;
        return $var;
    }
    else {
        my @source = @$ident;
        my @dotted;
        my $first = 1;
        my $first_literal;
        while (@source) {
            my ( $name, $args ) = splice( @source, 0, 2 );
            if ($first) {
                strip_quotes($name);
                my $first_arg = $args && @$args ? $args->[0] : '';
                $first_literal = strip_quotes($first_arg);
                $first--;
            }
            elsif ( !strip_quotes($name) && $name =~ /\D/ ) {
                $name = '$' . $name;
            }
            $name .= join_args($args);
            push( @dotted, $name );
        }
        if ( $first_literal
             && ( $ident->[0] eq "'l'" or $ident->[0] eq "'loc'" ) )
        {
            my $string = shift @{ $ident->[1] };
            strip_quotes($string);
            $string =~ s/\\\\/\\/g;
            my $args = join_args( $ident->[1] );
            push @{ $PARSER->{extracted} },
                [ $string, ${ $PARSER->{LINE} }, $args ];
        }
        return join( '.', @dotted );
    }
}

#===================================
sub text {
#===================================
    my ( $class, $text ) = @_;
    $text =~ s/\\/\\\\/g;
    return "'$text'";
}

#===================================
sub quoted {
#===================================
    my ( $class, $items ) = @_;
    return '' unless @$items;
    return ( $items->[0] ) if scalar @$items == 1;
    return '(' . join( ' _ ', @$items ) . ')';
}

#===================================
sub args {
#===================================
    my ( $class, $args ) = @_;
    my $hash = shift @$args;
    push( @$args, '{ ' . join( ', ', @$hash ) . ' }' )    # named params
        if @$hash;
    return $args;
}

#===================================
sub get {
#===================================
    my ( $class, $expr ) = @_;
    return $expr;
}

#===================================
sub filter {
#===================================
    my ( $class, $lnameargs, $block ) = @_;
    my ( $name,  $args,      $alias ) = @$lnameargs;
    $name = $name->[0];
    return ''
        unless $name eq "'l'"
            or $name eq "'loc'";
    if ( strip_quotes($block) ) {
        $block =~ s/\\\\/\\/g;
        $args = join_args( $class->args($args) );

        # NOTE: line number is at end of block, and can be a range
        my ($end) = ( ${ $PARSER->{LINE} } =~ /^(\d+)/ );
        my $start = $end;

        # rewind line count for newlines
        $start -= $block =~ tr/\n//;
        my $line = $start == $end ? $start : "$start-$end";
        push @{ $PARSER->{extracted} }, [ $block, $line, $args ];

    }
    return '';
}

# strips outer single quotes from a string (modifies original string)
# returns true if stripped, or false
#===================================
sub strip_quotes {
#===================================
    return scalar $_[0] =~ s/^'(.*)'$/$1/s;
}

#===================================
sub join_args {
#===================================
    my $args = shift;
    return '' unless $args && @$args;
    my @new_args = (@$args);
    for (@new_args) {
        s/\\\\/\\/g;
        if ( strip_quotes($_) ) {
            s/"/\\"/g;
            $_ = qq{"$_"};
        }
    }
    return '(' . join( ', ', @new_args ) . ')';
}

1;