libdbix-dr-perl 0.26-1 / usr / share / perl5 / DBIx / DR / PerlishTemplate.pm

use utf8;
use strict;
use warnings;

package DBIx::DR::PerlishTemplate;
use Mouse;
use Carp;
use Scalar::Util;
use DBIx::DR::ByteStream;

has     line_tag        => (is => 'rw', isa => 'Str',   default => '%');
has     open_tag        => (is => 'rw', isa => 'Str',   default => '<%');
has     close_tag       => (is => 'rw', isa => 'Str',   default => '%>');
has     quote_mark      => (is => 'rw', isa => 'Str',   default => '=');
has     immediate_mark  => (is => 'rw', isa => 'Str',   default => '==');

has     sql             => (is => 'ro', isa => 'Str',   default => '');
has     variables       => (is => 'ro', isa => 'ArrayRef');

has     template        => (is => 'rw', isa => 'Str',   default => '');
has     template_file   => (is => 'rw', isa => 'Str',   default => '');
has     utf8_open       => (is => 'rw', isa => 'Bool',  default => 1);

has     stashes         => (is => 'ro', isa => 'ArrayRef');
has     pretokens       => (is => 'ro', isa => 'ArrayRef');
has     prepretokens    => (is => 'ro', isa => 'ArrayRef');
has     parsed_template => (is => 'ro', isa => 'Str',   default => '');
has     namespace       => (is => 'rw', isa => 'Str',
                        default => 'DBIx::DR::PerlishTemplate::Sandbox');


sub _render {
    my ($_PTPL) = @_;
    my $_PTSUB;

    unless ($_PTPL->parsed_template) {
        $_PTSUB = $_PTPL->{parsed_template} = $_PTPL->_parse;
    } else {
        $_PTSUB = $_PTPL->parsed_template;
    }

    $_PTPL->{parsed_template} = $_PTSUB;

    my $esub = eval $_PTSUB;
    if (my $e = $@) {
        my $do_croak;
        my $template;
        if ($_PTPL->template_file) {
            $template = $_PTPL->template_file;
        } else {
            $do_croak = 1;
            $template = 'inline template';
        };
        $e =~ s{ at .*?line (\d+)(\.\s*|,\s+.*?)?$}
            [" at $template line " . ( $1 - $_PTPL->pre_lines )]gsme;

        if ($1) {
            $e =~ s/\s*$/\n/g;
            die $e unless $do_croak;
            croak $e;
        }

        croak "$e at $template";
    }

    $_PTPL->{sql} = '';
    $_PTPL->{variables} = [];

    $esub->( @{ $_PTPL->stashes } );
    1;
}

sub render {
    my ($self, $tpl, @args) = @_;
    $self->{parsed_template} = '';
    $self->template($tpl);
    $self->template_file('');
    $self->{stashes} = \@args;
    $self->clean_namespace;
    return $self->_render;
}

sub render_file {
    my ($self, $file, @args)  = @_;
    croak "File '@{[ $file // 'undef' ]}' not found or readable"
        unless -r $file;
    open my $fh, '<', $file;
    my $data;

    { local $/; $data = <$fh> }
    $self->{parsed_template} = '';
    $self->template_file($file);
    $self->template($data);
    $self->{stashes} = \@args;
    $self->clean_namespace;
    return $self->_render;
}

sub clean_prepends {
    my ($self) = @_;
    $self->{pretokens} = [];
    $self;
}

sub clean_preprepends {
    my ($self) = @_;
    $self->{prepretokens} = [];
    $self;
}


sub immediate {
    my ($self, $str) = @_;
    if (Scalar::Util::blessed $str) {
        if ('DBIx::DR::ByteStream' eq Scalar::Util::blessed $str) {
            $self->{sql} .= $str->content;
        } elsif ($str->can('content')) {
            $self->{sql} .= $str->content;
        } else {
            croak "Can't extract content from " . Scalar::Util::blessed $str;
        }
    } else {
        $self->{sql} .= $str;
    }
    return DBIx::DR::ByteStream->new('');
}

sub add_bind_value {
    my ($self, @values) = @_;
    push @{ $self->variables } => @values;
}


sub quote {
    my ($self, $variable) = @_;

    if (Scalar::Util::blessed $variable) {
        return $self->immediate($variable)
            if 'DBIx::DR::ByteStream' eq Scalar::Util::blessed $variable;
    }

    $self->{sql} .= '?';
    $self->add_bind_value($variable);
    return DBIx::DR::ByteStream->new('');
}


sub _parse_token
{
    my ($self, $tpl, $prev) = @_;
    my $line_tag       = quotemeta $self->line_tag;
    my $open_tag       = quotemeta $self->open_tag;
    my $close_tag      = quotemeta $self->close_tag;

    my $prev_eol = $prev =~ /\n\s*\z/s;

    if ($tpl =~ s{$open_tag(.*?)$close_tag}{}s) {
        return
            { type => 'text', content =>  $` },
            { type => 'perl', content =>  $1 },
            { type => 'text', content =>  $' }
        ;
    }
    if ($tpl =~ s{^(\s*)$line_tag(.+?)$}{}sm) {
        return
            { type => 'text', content =>  $` . $1 },
            { type => 'perl', content =>  $2, line => 1 },
            { type => 'text', content =>  $' }
#                 if length $` or $prev_eol;

#         warn "aaaaaaaaaaaaaaaaaaaaaaaaaaaaa";
#         return
#             { type => 'text', content => $1 },
#             { type => 'text', content => "$line_tag$2$$'" }
#         ;
    }

    return {
        type        => 'text',
        content     => $tpl,
        text_only   => 1,
    }
}

sub _put_token {
    my ($self, $token, $next_token) = @_;

    my $content = $token->{content};
    my $variable;

    if ($token->{type} eq 'text') {
        $content =~ s/'/\\'/g;
        return "immediate('" . $content . "');";
    }

    my $eot = $token->{line} ? "\n" : '';

    my $immediate_mark = quotemeta $self->immediate_mark;
    my $quote_mark = quotemeta $self->quote_mark;

    if ($content =~ /^$immediate_mark/) {
        $content = substr $content, length $self->immediate_mark;
        return 'immediate(' . $content . ");$eot";
    }

    if ($content =~ /^$quote_mark/) {
        $content = substr $content, length $self->quote_mark;
        return 'quote(' . $content . ");$eot";
    }


    return "$content;$eot" if !$next_token or $next_token->{type} ne 'perl';
    return $content . $eot;
}

sub _parse {
    my ($self) = @_;

    my @tokens = { type => 'text', content => $self->template };

    while(1) {
        my $found_token = 0;
        for (reverse 0 .. $#tokens) {
            next unless $tokens[$_]{type} eq 'text';
            next if $tokens[$_]{text_only};
            my @t = $self->_parse_token($tokens[$_]{content},
                $_ ? $tokens[$_ - 1]{content} : "\n"
            );
            next if @t == 1;
            splice @tokens, $_, 1, grep { length $_->{content} } @t;
            $found_token = 1;
        }
        last unless $found_token;
    }

    my $sub = join "" => map {
        $self->_put_token($tokens[$_], $_ == $#tokens ? undef : $tokens[$_ + 1])
    } 0 .. $#tokens;

    return join '',
        'package ', $self->namespace, ';',
        'BEGIN { ',
        '*quote = sub { $_PTPL->quote(@_) };',
        '*immediate = sub { $_PTPL->immediate(@_) };',
        '};',
        $self->preprepend,
        'sub {', $self->prepend, $sub, '}';
}


sub preprepend {
    my ($self, @tokens) = @_;
    $self->{prepretokens} ||= [];
    push @{ $self->prepretokens } => map "$_;\n", @tokens if @tokens;
    return join '' => @{ $self->prepretokens } if defined wantarray;
}

sub prepend {
    my ($self, @tokens) = @_;
    $self->{pretokens} ||= [];
    push @{ $self->pretokens } => map "$_;", @tokens if @tokens;
    return join '' => @{ $self->pretokens } if defined wantarray;
}


sub pre_lines {
    my ($self) = @_;
    my $lines = 0;
    $lines += @{[ /\n/g ]} for ($self->preprepend, $self->prepend);
    return $lines;
}

sub clean_prepend {
    my ($self) = shift;
    $self->{pretokens} = [];
}

sub clean_namespace {
    my ($self) = @_;
    my $sb = $self->namespace;

    no strict 'refs';
    undef *{$sb . '::' . $_} for keys %{ $sb . '::' };
}

1;

=head1 NAME

DBIx::DR::PerlishTemplate - template engine for L<DBIx::DR>.

=head1 COPYRIGHT

 Copyright (C) 2011 Dmitry E. Oboukhov <unera@debian.org>
 Copyright (C) 2011 Roman V. Nikolaev <rshadow@rambler.ru>

 This program is free software, you can redistribute it and/or
 modify it under the terms of the Artistic License.

=cut