File Coverage

blib/lib/SQL/Statement/Util.pm

Criterion	Covered	Total	%
statement	58	68	85.2
branch	14	18	77.7
condition	7	12	58.3
subroutine	18	23	78.2
pod	1	1	100.0
total	98	122	80.3

package SQL::Statement::Util;

######################################################################
#
# This module is copyright (c), 2001,2005 by Jeff Zucker.
# This module is copyright (c), 2007-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($VERSION);
$VERSION = '1.414';

sub type
{
    my ($self) = @_;
    return 'function' if $self->isa('SQL::Statement::Util::Function');
    return 'column'   if $self->isa('SQL::Statement::Util::Column');
}

package SQL::Statement::Util::Column;

use vars qw(@ISA);
@ISA = qw(SQL::Statement::Util);

use Params::Util qw(_ARRAY _HASH0 _STRING);

sub new
{
    my ( $class, $col_name, $table_name, $term, $display_name, $full_orig_name, $coldef ) = @_;
    $display_name ||= $col_name;

    if ( $col_name && ( $col_name =~ m/^((?:"[^"]+")|(?:[^.]*))\.(.*)$/ ) )
    {
        $table_name = $1;
        $col_name   = $2;
    }
    elsif ( defined( _ARRAY($table_name) ) && ( scalar( @{$table_name} ) == 1 ) )
    {
        $table_name = $table_name->[0];
    }

    my %instance = (
        name           => $col_name,
        table          => $table_name,
        display_name   => $display_name,
        term           => $term,
        full_orig_name => $full_orig_name,
        coldef         => $coldef,
    );

    my $self = bless( \%instance, $class );

    return $self;
}

sub value($)         { $_[0]->{term}->value( $_[1] ); }
sub term()           { $_[0]->{term} }
sub display_name()   { $_[0]->{display_name} }
sub full_orig_name() { $_[0]->{full_orig_name} }
sub name()           { $_[0]->{name} }
sub table()          { $_[0]->{table} }
sub coldef()         { $_[0]->{coldef} }

package SQL::Statement::Util::Function;

use vars qw(@ISA);
@ISA = qw(SQL::Statement::Util);

sub new
{
    my ( $class, $name, $sub_name, $args ) = @_;
    my ( $pkg, $sub ) = $sub_name =~ /^(.*::)([^:]+$)/;
    if ( !$sub )
    {
        $pkg = 'main';
        $sub = $sub_name;
    }
    $pkg = 'main' if $pkg eq '::';
    $pkg =~ s/::$//;
    my %newfunc = (
        name     => $name,
        sub_name => $sub,
        pkg_name => $pkg,
        args     => $args,
        type     => 'function',
    );
    return bless \%newfunc, $class;
}
sub name     { shift->{name} }
sub pkg_name { shift->{pkg_name} }
sub sub_name { shift->{sub_name} }
sub args     { shift->{args} }

sub validate
{
    my ($self) = @_;
    my $pkg    = $self->pkg_name;
    my $sub    = $self->sub_name;
    $pkg =~ s,::,/,g;
    eval { require "$pkg.pm" }
      unless $pkg eq 'SQL/Statement/Functions'
      or $pkg eq 'main';
    die $@ if $@;
    $pkg =~ s,/,::,g;
    die "Can't find subroutine $pkg" . "::$sub\n" unless $pkg->can($sub);
    return 1;
}

sub run
{
    use SQL::Statement::Functions;

    my ($self) = shift;
    my $sub    = $self->sub_name;
    my $pkg    = $self->pkg_name;
    return $pkg->$sub(@_);
}

1;

=pod

=head1 NAME

SQL::Statement::Util

=head1 SYNOPSIS

  SQL::Statement::Util::Column->new($col_name, $table_name, $term, $display_name)
  SQL::Statement::Util::AggregatedColumns($col_name, $table_name, $term, $display_name)
  SQL::Statement::Util::Function($name, $sub_name, $args)

=head1 DESCRIPTION

This package contains three utility classes to handle deliverable columns.

=head1 INHERITANCE

  SQL::Statement::Util::Column
  ISA SQL::Statement::Util

  SQL::Statement::Util::AggregatedColumns
  ISA SQL::Statement::Util::Column
    ISA SQL::Statement::Util

  SQL::Statement::Util::Function
  ISA SQL::Statement::Util

=begin undocumented

=head1 METHODS

=head2 type

Returns the type of the SQL::Statement::Util instance.

=end undocumented

=head1 AUTHOR & COPYRIGHT

 This module is

 copyright (c) 2001,2005 by Jeff Zucker and
 copyright (c) 2007-2020 by Jens Rehsack.

 All rights reserved.

The module may be freely distributed under the same terms as
Perl itself using either the "GPL License" or the "Artistic
License" as specified in the Perl README file.

Jeff can be reached at: jzuckerATcpan.org
Jens can be reached at: rehsackATcpan.org or via dbi-devATperl.org

=cut