File Coverage

blib/lib/SQL/Statement/Function.pm

Criterion	Covered	Total	%
statement	121	132	91.6
branch	14	28	50.0
condition	4	4	100.0
subroutine	27	28	96.4
pod			n/a
total	166	192	86.4

package SQL::Statement::Function;

######################################################################
#
# This module is copyright (c), 2009-2020 by Jens Rehsack.
# All rights reserved.
#
# It may be freely distributed under the same terms as Perl itself.
# See below for help and copyright information (search for SYNOPSIS).
#
######################################################################

use strict;
use warnings FATAL => "all";
use vars qw(@ISA $VERSION);

use SQL::Statement::Term ();
@ISA = qw(SQL::Statement::Term);

$VERSION = '1.413_001';

=pod

=head1 NAME

SQL::Statement::Function - abstract base class for all function executing terms

=head1 SYNOPSIS

  # this class does not have a common constructor, because all derived classes
  # have their special requirements

=head1 DESCRIPTION

SQL::Statement::Function is an abstract base class providing the interface
for all function executing terms.

=head1 INHERITANCE

  SQL::Statement::Function
  ISA SQL::Statement::Term

=head1 METHODS

=head2 DESTROY

Destroys the term and undefines the weak reference to the owner as well
as the reference to the parameter list.

=cut

sub DESTROY
{
    my $self = $_[0];

    undef $self->{PARAMS};

    $self->SUPER::DESTROY();
}

package SQL::Statement::Function::UserFunc;

use vars qw(@ISA);

use Carp ();
use Params::Util qw(_INSTANCE);

use SQL::Statement::Functions;

@ISA = qw(SQL::Statement::Function);

=pod

=head1 NAME

SQL::Statement::Function::UserFunc - implements executing a perl subroutine

=head1 SYNOPSIS

  # create an user function term with an SQL::Statement object as owner,
  # specifying the function name, the subroutine name (full qualified)
  # and the parameters to the subroutine
  my $term = SQL::Statement::Function::UserFunc->new( $owner, $name, $sub, \@params );
  # access the result of that operation
  $term->value( $eval );

=head1 DESCRIPTION

SQL::Statement::Function::UserFunc implements a term which returns the result
of the specified subroutine.

=head1 INHERITANCE

  SQL::Statement::Function
  ISA SQL::Statement::Term

=head1 METHODS

=head2 new

Instantiates a new C instance.

=head2 value

Invokes the given subroutine with the values of the params and return it's
result:

    my @params = map { $_->value($eval); } @{ $self->{PARAMS} };
    return $subpkg->$subname( $self->{OWNER}, @params );

=cut

sub new
{
    my ( $class, $owner, $name, $subnm, $params ) = @_;

    my $self = $class->SUPER::new($owner);

    my ( $pkg, $sub ) = $subnm =~ m/^(.*::)([^:]+$)/;
    if ( !$sub )
    {
        $sub = $subnm;
        $pkg = 'main';
    }
    $pkg =~ s/::$//g;
    $pkg = 'main' unless ($pkg);

    $self->{SUB}    = $sub;
    $self->{PKG}    = $pkg;
    $self->{NAME}   = $name;
    $self->{PARAMS} = $params;

    unless ( UNIVERSAL::can( $pkg, $sub ) )
    {
        unless ( 'main' eq $pkg )
        {
            my $mod = $pkg;
            $mod =~ s|::|/|g;
            $mod .= '.pm';
            eval { require $mod; } unless ( defined( $INC{$mod} ) );
            return $owner->do_err($@) if ($@);
        }

        $pkg->can($sub) or return $owner->do_err( "Can't find subroutine $pkg" . "::$sub" );
    }

    return $self;
}

sub value($)
{
    my $self   = $_[0];
    my $eval   = $_[1];
    my $pkg    = $self->{PKG};
    my $sub    = $self->{SUB};
    my @params = map { $_->value($eval); } @{ $self->{PARAMS} };
    return $pkg->$sub( $self->{OWNER}, @params );    # FIXME is $pkg just a string?
}

package SQL::Statement::Function::NumericEval;

use vars qw(@ISA);

use Params::Util qw(_NUMBER _INSTANCE);

@ISA = qw(SQL::Statement::Function);

=pod

=head1 NAME

SQL::Statement::Function::NumericEval - implements numeric evaluation of a term

=head1 SYNOPSIS

  # create an user function term with an SQL::Statement object as owner,
  # specifying the expression to evaluate and the parameters to the subroutine
  my $term = SQL::Statement::NumericEval->new( $owner, $expr, \@params );
  # access the result of that operation
  $term->value( $eval );

=head1 DESCRIPTION

SQL::Statement::Function::NumericEval implements the numeric evaluation of a
term. All parameters are expected to be numeric.

=head1 INHERITANCE

  SQL::Statement::Function::NumericEval
  ISA SQL::Statement::Function
    ISA SQL::Statement::Term

=head1 METHODS

=head2 new

Instantiates a new C instance.
Takes I<$owner>, I<$expr> and I<\@params> as arguments (in specified order).

=head2 value

Returns the result of the evaluated expression.

=cut

sub new
{
    my ( $class, $owner, $expr, $params ) = @_;

    my $self = $class->SUPER::new($owner);

    $self->{EXPR}   = $expr;
    $self->{PARAMS} = $params;

    return $self;
}

sub value($)
{
    my ( $self, $eval ) = @_;
    my @vals =
      map { _INSTANCE( $_, 'SQL::Statement::Term' ) ? $_->value($eval) : $_ } @{ $self->{PARAMS} };
    foreach my $val (@vals)
    {
        return $self->{OWNER}->do_err(qq~Bad numeric expression '$val'!~)
          unless ( defined( _NUMBER($val) ) );
    }
    my $expr = $self->{EXPR};
    $expr =~ s/\?(\d+)\?/$vals[$1]/g;
    $expr =~ s/\s//g;
    $expr =~ s/^([\)\(+\-\*\/\%0-9]+)$/$1/;    # untaint
    return eval $expr;
}

package SQL::Statement::Function::Trim;

use vars qw(@ISA);

BEGIN { @ISA = qw(SQL::Statement::Function); }

=pod

=head1 NAME

SQL::Statement::Function::Trim - implements the built-in trim function support

=head1 SYNOPSIS

  # create an trim function term with an SQL::Statement object as owner,
  # specifying the spec, char and the parameters to the subroutine
  my $term = SQL::Statement::Trim->new( $owner, $spec, $char, \@params );
  # access the result of that operation
  $term->value( $eval );

=head1 DESCRIPTION

SQL::Statement::Function::Trim implements string trimming.

=head1 INHERITANCE

  SQL::Statement::Function::Trim
  ISA SQL::Statement::Function
    ISA SQL::Statement::Term

=head1 METHODS

=head2 new

Instantiates a new C instance.
Takes I<$owner>, I<$spec>, I<$char> and I<\@params> as arguments
(in specified order).

Meaning of the parameters:

=over 4

=item I<$spec>

Can be on of 'LEADING', 'TRAILING' 'BOTH'. Trims the leading chars, trailing
chars or at both ends, respectively.

Defaults to 'BOTH'.

=item I<$char>

The character to trim - defaults to C<' '>

=item I<\@params>

Expected to be an array with exact 1 element (more are not evaluated).

=back

=head2 value

Returns the trimmed value of first parameter argument.

=cut

sub new
{
    my ( $class, $owner, $spec, $char, $params ) = @_;
    $spec ||= 'BOTH';
    $char ||= ' ';

    my $self = $class->SUPER::new($owner);

    $self->{PARAMS} = $params;
    $self->{TRIMFN} = sub { my $s = $_[0]; $s =~ s/^$char*//g; return $s; }
      if ( $spec =~ m/LEADING/ );
    $self->{TRIMFN} = sub { my $s = $_[0]; $s =~ s/$char*$//g; return $s; }
      if ( $spec =~ m/TRAILING/ );
    $self->{TRIMFN} = sub { my $s = $_[0]; $s =~ s/^$char*//g; $s =~ s/$char*$//g; return $s; }
      if ( $spec =~ m/BOTH/ );

    return $self;
}

sub value($)
{
    my $val = $_[0]->{PARAMS}->[0]->value( $_[1] );
    $val = &{ $_[0]->{TRIMFN} }($val);
    return $val;
}

package SQL::Statement::Function::SubString;

use vars qw(@ISA);

@ISA = qw(SQL::Statement::Function);

=pod

=head1 NAME

SQL::Statement::Function::SubString - implements the built-in sub-string function support

=head1 SYNOPSIS

  # create an substr function term with an SQL::Statement object as owner,
  # specifying the start and length of the sub string to extract from the
  # first element of \@params
  my $term = SQL::Statement::SubString->new( $owner, $start, $length, \@params );
  # access the result of that operation
  $term->value( $eval );

=head1 DESCRIPTION

SQL::Statement::Function::SubString implements a sub-string extraction term.

=head1 INHERITANCE

  SQL::Statement::Function::SubString
  ISA SQL::Statement::Function
    ISA SQL::Statement::Term

=head1 METHODS

=head2 new

Instantiates a new C instance.
Takes I<$owner>, I<$start>, I<$length> and I<\@params> as arguments
(in specified order).

Meaning of the parameters:

=over 4

=item I<$start>

Specifies the start position to extract the sub-string. This is expected
to be a L instance. The first character in a string
has the position 1.

=item I<$length>

Specifies the length of the extracted sub-string. This is expected
to be a L instance.

If omitted, everything to the end of the string is returned.

=item I<\@params>

Expected to be an array with exact 1 element (more are not evaluated).

=back

=head2 value

Returns the extracted sub-string value from first parameter argument.

=cut

sub new
{
    my ( $class, $owner, $start, $length, $params ) = @_;

    my $self = $class->SUPER::new($owner);

    $self->{START}  = $start;
    $self->{LENGTH} = $length;
    $self->{PARAMS} = $params;

    return $self;
}

sub value($)
{
    my $val   = $_[0]->{PARAMS}->[0]->value( $_[1] );
    my $start = $_[0]->{START}->value( $_[1] ) - 1;
    my $length =
      defined( $_[0]->{LENGTH} ) ? $_[0]->{LENGTH}->value( $_[1] ) : length($val) - $start;
    return substr( $val, $start, $length );
}

package SQL::Statement::Function::StrConcat;

use vars qw(@ISA);

@ISA = qw(SQL::Statement::Function);

=pod

=head1 NAME

SQL::Statement::Function::StrConcat - implements the built-in string concatenation

=head1 SYNOPSIS

  # create an substr function term with an SQL::Statement object as owner
  # and \@params to concatenate
  my $term = SQL::Statement::StrConcat->new( $owner, \@params );
  # access the result of that operation
  $term->value( $eval );

=head1 DESCRIPTION

SQL::Statement::Function::StrConcat implements a string concatenation term.

=head1 INHERITANCE

  SQL::Statement::Function::StrConcat
  ISA SQL::Statement::Function
    ISA SQL::Statement::Term

=head1 METHODS

=head2 new

Instantiates a new C instance.

=head2 value

Returns the concatenated string composed of the parameter values.

=cut

sub new
{
    my ( $class, $owner, $params ) = @_;

    my $self = $class->SUPER::new($owner);

    $self->{PARAMS} = $params;

    return $self;
}

sub value($)
{
    my $rc = '';
    foreach my $val ( @{ $_[0]->{PARAMS} } )
    {
        my $catval = $val->value( $_[1] );
        $rc .= defined($catval) ? $catval : '';
    }
    return $rc;
}

=head1 AUTHOR AND COPYRIGHT

Copyright (c) 2009-2020 by Jens Rehsack: rehsackATcpan.org

All rights reserved.

You may distribute this module under the terms of either the GNU
General Public License or the Artistic License, as specified in
the Perl README file.

=cut

1;