File Coverage

blib/lib/DBIx/POS/Template.pm

Criterion	Covered	Total	%
statement	116	131	88.5
branch	40	66	60.6
condition	13	28	46.4
subroutine	23	26	88.4
pod	3	7	42.8
total	195	258	75.5

package DBIx::POS::Template;
use strict;
use warnings;
use base qw{Pod::Parser};
use Hash::Merge qw(merge);

our $VERSION = '0.021';

# Hold data for our pending statement
my $info = {};

# SQL instance
my %sql;

# What command we're looking at
my $cmd;

my $enc; # PODs enc

# Text::Template->new(%TT, %tt)
our %TT = (
    DELIMITERS => ['{%', '%}'],
    #~ BROKEN => sub { die @_;},
);

my %tt = (); # instance scope: Text::Template->new(..., tt=>{%TT, %tt}, )
my $tt = {}; # new scope: Text::Template->new(..., tt=>{%TT, %$tt}, )
my %template = (); # instance scope: Text::Template->new(..., template=>\%template, )
my $template = {}; # new scope: Text::Template->new(..., template=>$template, )
my $scope; # 'new' | 'instance'

# separate object
sub new {
    my ($class, $file, %arg) = @_;
    $scope = 'new';
    my %back = %sql;

    $tt = $arg{TT} || $arg{tt} || {};
    $template = $arg{template} || {};
    %sql = ();

    $class->_process( $file,);
    my $new = { %sql };

    %sql = %back;

    bless $new, $class;
}

# Taken directly from Class::Singleton
#~ sub instance000 {
    #~ my $class = shift;
    #~ $scope = 'instance';
    #~ # get a reference to the _instance variable in the $class package
    #~ no strict 'refs';
    #~ my $instance = \${ "$class\::_instance" };

    #~ defined $$instance
        #~ ? $$instance
        #~ : ($$instance = $class->_instance(@_));
#~ }

my $instance;
sub instance {
    my ($class, $file, %arg) = @_;
    $scope = 'instance';
    # merge prev tt opts
    my $tt = $arg{TT} || $arg{tt};
    @tt{ keys %$tt } = values %$tt
        if $tt;
    #~ @template{ keys %{$arg{template}} } = values %{$arg{template}} хэш сложный!

    %template = %{merge($arg{template}, \%template)}
        if $arg{template} && %{$arg{template}};

    $class->_process( $file,);
    $instance ||= bless \%sql, $class;
}

sub _process {# pos file
    my ($class, $file,) = @_;
    return unless $file;
    $file .='.pm'
        if $file =~ s/::/\//g;
    #~ warn "Processing file [$file]";
    $enc = undef;
    $class->SUPER::new->parse_from_file($file);
}

sub template {
    my ($self, $key, %arg) = @_;
    die "No such item by key [$key] on this POS, please check processed file(s)"
        unless $self->{$key};
    $self->{$key}->template(%arg);
}

########### Parser ################

# Handle =whatever commands
sub command {
    my ($self, $command, $paragraph, $line) = @_;

    # Get rid of all trailing whitespace
    $paragraph =~ s/\s+$//ms;

    # There may be a short description right after the command
    if ($command eq 'desc') {
        $info->{desc} = $paragraph || "";
    }

    # The name comes right after the command
    if ($command eq 'name') {
        $self->end_input;
        $info->{name} = $paragraph;
    }

    # The noreturn comes right after the command
    if ($command eq 'noreturn') {
        $info->{noreturn} = 1;
    }

    if ($command eq 'encoding') {
        $enc = $paragraph;
    }

    # Remember what command we're in
    $cmd = $command;
}

sub end_input {
    my ($self) = @_;
    # If there's stuff to try and construct from
    if (%{$info}) {
        # If we have the necessary bits
        #~ if (scalar (grep {m/^(?:name|short|desc|sql)$/} keys %{$info}) == 3) {
        if (defined($info->{name}) && defined($info->{sql})) {
            # Grab the entire content for the %sql hash
            $sql{$info->{name}} = DBIx::POS::Statement->new (
                $info,
                tt => {%TT, $scope eq 'new' ? %$tt : %tt},
                template => $scope eq 'new' ? $template : \%template,
                enc=>$enc,
            );
            # Start with a new empty hashref
            $info = {};
        } else {# Something's missing
            warn "Malformed entry: ", %$info;# . Dump (\%sql, $info);
        }
    }
}


# Handle the blocks of text between commands
sub textblock {
    my ($parser, $paragraph, $line) = @_;

    # Collapse trailing whitespace to a \n
    $paragraph =~ s/\s+$/\n/ms;

    if ($cmd eq 'desc') {
        $info->{desc} .= $paragraph;
    }

    elsif ($cmd eq 'param') {
        $info->{param} .= $paragraph;
    }

    elsif ($cmd eq 'sql') {
        $info->{sql} .= $paragraph;
    }
}

# We handle verbatim sections the same way
sub verbatim {
    my ($parser, $paragraph, $line) = @_;

    # Collapse trailing whitespace to a \n
    $paragraph =~ s/\s+$/\n/ms;

    if ($cmd eq 'desc') {
        $info->{desc} .= $paragraph;
    }

    elsif ($cmd eq 'param') {
        $info->{param} .= $paragraph;
    }

    elsif ($cmd eq 'sql') {
        $info->{sql} .= $paragraph;
    }
}

1;
#=============================================
package DBIx::POS::Statement;
#=============================================
use Text::Template;
use Hash::Merge qw(merge);
use Encode;

use overload '""' => sub { shift->template };

sub new {
    my $proto = shift;
    my $class = ref $proto || $proto;
    my $self = shift;
    my %arg = @_;
    $self->{_TT} = $arg{TT} || $arg{tt} ;
    $self->{_template_default} = $arg{template};
    $self->{_enc} = $arg{enc};
    bless ($self, $class);
    if (my $enc = $self->{_enc}) {
        my @enc = qw(name desc param short sql);
        @$self{ @enc } = map Encode::decode($enc, $self->{$_}), @enc;
    }
    $self->_eval_param();
    return $self;
}

sub desc {
    my $self = shift;
    $self->{desc} = shift if (@_);
    return $self->{desc};
}

sub name {
    my $self = shift;
    $self->{name} = shift if (@_);
    return $self->{name};
}

sub noreturn {
    my $self = shift;
    $self->{noreturn} = shift if (@_);
    return $self->{noreturn};
}

sub param {# ->param() |  ->param('foo') | ->param('foo'=>'bar', ....)
    my $self = shift;
    return unless defined $self->{param};
    #~ $self->{param} ||= {};
    return $self->{param} unless ref $self->{param} eq 'HASH';
    return $self->{param} unless @_;
    return $self->{param}{ shift() } if @_ == 1;
    my %arg = @_;
    @{$self->{param} ||= {}}{ keys %arg } = values %arg;
}

sub _eval_param {
    my $self = shift;
    return unless $self->{param};
    my $param = eval $self->{param};
    die "Malformed perl code param [$self->{param}]: $@" if $@;
    $self->{param} = $param;
}


sub short {
    my $self = shift;
    $self->{short} = shift if (@_);
    return $self->{short};
}

sub sql {
    my $self = shift;
    $self->{sql} = shift if (@_);
    return $self->{sql};
}

sub template {
    my ($self, %arg) = @_;
    #~ return $self->{sql}
        #~ unless scalar(%arg) || scalar(%{$self->{_template_default}});
    $self->{_template} ||= Text::Template->new(
        TYPE => 'STRING',
        SOURCE => $self->sql,
        %{$self->{_TT}},
    );
    #~ $self->{_template}->fill_in(HASH=>{%{$self->{_template_default}}, %arg},);#BROKEN_ARG=>\'error!', BROKEN => sub { die @_;},
    return $self->{_template}->fill_in(HASH=>$self->{_template_default})
        unless %arg;
    return $self->{_template}->fill_in(HASH=>\%arg)
        unless %{$self->{_template_default}};
    $self->{_template}->fill_in(HASH=>merge(\%arg, $self->{_template_default}));
}


=pod

=encoding utf8

=head1 DBIx::POS::Template

Доброго всем

¡ ¡ ¡ ALL GLORY TO GLORIA ! ! !

=head1 VERSION

0.021

=head1 NAME

DBIx::POS::Template - is a fork of L. Define a dictionary of SQL statements in a POD dialect (POS) plus expand template sql with embedded Perl using L.

=head1 SYNOPSIS

  use DBIx::POS::Template;

  # separate object
  my $pos = DBIx::POS::Template->new(__FILE__, ...);
  # or singleton DBIx::POS::Template->instance($file, ...);

  my $sql = $pos->{test1}->template(where => "bar = ?");
  # or $pos->template('test1', where => "bar = ?")

  =pod

  =name test1

  =desc test the DBIx::POS::Template module

  =param

    # Some arbitrary parameters as perl code (eval)
    {
        cache=>1, # will be prepare_cached
    }

  =sql

    select * from foo
    {% $where %}
    ;

  =cut

Or:

  package POS::Foo;
  use DBIx::POS::Template;
  use Hash::Merge qw(merge);

  my $default = {foo=>'bar',};

  sub new {
    my $proto = shift;
    DBIx::POS::Template->new(__FILE__, template => merge({@_}, $default));
    # or DBIx::POS::Template->instance(...
  }

=head1 DESCRIPTION

DBIx::POS::Template is subclass Pod::Parser to define a POD dialect for writing a SQL dictionary(s) with templating.

By separating the SQL code from its normal context of execution, it
encourages you to do other things with it---for instance, it is easy
to create a script that can do performance testing of certain SQL
statements in isolation, or to create generic command-line wrapper
around your SQL statements.

By giving a framework for documenting the SQL, it encourages
documentation of the intent and/or implementation of the SQL code.  It
also provides all of that information in a format from which other
documentation could be generated---say, a chunk of DocBook for
incorporation into a guide to programming the application.

This class whould work as separate objects per pod-file or as singleton for all processed files with one dictionary of them.

=head1 METHODS

=head2 new($file, )

Create separate object and process $file POS with options names:

=over 4

=item * TT | tt

Optional hashref will passing to L->new() for each parsed statement. By default only defined the key:

  ..., TT => {DELIMITERS => ['{%', '%}'],},

For B this hashref will be merged with previous instance invokes.

=item * template

  ..., template => {foo=>1,},

Optional hashref of default values for each statement template. For B this hashref will be merged with previous instance invokes.

=back

=head2 instance($file, )

Return singleton dictionary object, parsed $file keys will collapse/override with previous instances files. Same options as C. B and B