File Coverage

blib/lib/Data/TableData/Object/Base.pm

Criterion	Covered	Total	%
statement	127	136	93.3
branch	39	46	84.7
condition	13	17	76.4
subroutine	17	21	80.9
pod	14	14	100.0
total	210	234	89.7

package Data::TableData::Object::Base;

use 5.010001;
use strict;
use warnings;

use Scalar::Util::Numeric qw(isint isfloat);

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2021-11-17'; # DATE
our $DIST = 'Data-TableData-Object'; # DIST
our $VERSION = '0.114'; # VERSION

sub _array_is_numeric {
    my $self = shift;
    for (@{$_[0]}) {
        return 0 if defined($_) && !isint($_) && !isfloat($_);
    }
    return 1;
}

sub _list_is_numeric {
    my $self = shift;
    $self->_array_is_numeric(\@_);
}

sub cols_by_name {
    my $self = shift;
    $self->{cols_by_name};
}

sub cols_by_idx {
    my $self = shift;
    $self->{cols_by_idx};
}

sub col_exists {
    my ($self, $name_or_idx) = @_;
    if ($name_or_idx =~ /\A[0-9][1-9]*\z/) {
        return $name_or_idx <= @{ $self->{cols_by_idx} };
    } else {
        return exists $self->{cols_by_name}{$name_or_idx};
    }
}

sub col_name {
    my ($self, $name_or_idx) = @_;
    if ($name_or_idx =~ /\A[0-9][1-9]*\z/) {
        return $self->{cols_by_idx}[$name_or_idx];
    } else {
        return exists($self->{cols_by_name}{$name_or_idx}) ?
            $name_or_idx : undef;
    }
}

sub col_idx {
    my ($self, $name_or_idx) = @_;
    if ($name_or_idx =~ /\A[0-9][1-9]*\z/) {
        return $name_or_idx < @{ $self->{cols_by_idx} } ? $name_or_idx : undef;
    } else {
        return $self->{cols_by_name}{$name_or_idx};
    }
}

sub col_count {
    my $self = shift;
    scalar @{ $self->{cols_by_idx} };
}

sub col_content {
    my ($self, $name_or_idx) = @_;

    my $col_idx = $self->col_idx($name_or_idx);
    return undef unless defined $col_idx; ## no critic: Subroutines::ProhibitExplicitReturnUndef

    my $row_count = $self->row_count;
    return [] unless $row_count;

    my $col_content = [];
    for my $i (0 .. $row_count-1) {
        my $row = $self->row_as_aos($i);
        $col_content->[$i] = $row->[$col_idx];
    }
    $col_content;
}

sub _select {
    my ($self, $_as, $cols0, $excl_cols, $func_filter_row, $sorts) = @_;

    # determine result's columns & spec
    my $spec;
    my %newcols_to_origcols;
    my @cols0; # original column names but with '*' expanded
    my @newcols;
    if ($cols0) {
        $spec = {fields=>{}};
        my $i = 0;
        for my $col0 (@$cols0) {
            my @add;
            if ($col0 eq '*') {
                @add = @{ $self->{cols_by_idx} };
            } else {
                die "Column '$col0' does not exist" unless $self->col_exists($col0);
                @add = ($col0);
            }

            for my $add (@add) {
                next if $excl_cols && (grep {$add eq $_} @$excl_cols);
                push @cols0, $add;
                my $j = 1;
                my $col = $add;
                while (defined $newcols_to_origcols{$col}) {
                    $j++;
                    $col = "${add}_$j";
                }
                $newcols_to_origcols{$col} = $add;
                push @newcols, $col;

                $spec->{fields}{$col} = {
                    %{$self->{spec}{fields}{$add} // {}},
                    pos=>$i,
                };
                $i++;
            }
        }
        $cols0 = \@cols0;
    } else {
        # XXX excl_cols is not being observed
        $spec = $self->{spec};
        $cols0 = $self->{cols_by_idx};
        @newcols = @{ $self->{cols_by_idx} };
        for (@newcols) { $newcols_to_origcols{$_} = $_ }
    }

    my $rows = [];

    # filter rows
    for my $row (@{ $self->rows_as_aohos }) {
        next unless !$func_filter_row || $func_filter_row->($self, $row);
        push @$rows, $row;
    }

    # sort rows
    if ($sorts && @$sorts) {
        # determine whether each column mentioned in $sorts is numeric, to
        # decide whether to use <=> or cmp.
        my %col_is_numeric;
        for my $sortcol (@$sorts) {
            my ($reverse, $col) = $sortcol =~ /\A(-?)(.+)/
                or die "Invalid sort column specification '$sortcol'";
            next if defined $col_is_numeric{$col};
            my $sch = $self->{spec}{fields}{$col}{schema};
            if ($sch) {
                require Data::Sah::Util::Type;
                $col_is_numeric{$col} = Data::Sah::Util::Type::is_numeric($sch);
            } else {
                my $col_name = $self->col_name($col);
                defined($col_name) or die "Unknown sort column '$col'";
                $col_is_numeric{$col} = $self->_array_is_numeric(
                    [map {$_->{$col_name}} @$rows]);
            }
        }

        $rows = [sort {
            for my $sortcol (@$sorts) {
                my ($reverse, $col) = $sortcol =~ /\A(-?)(.+)/;
                my $name = $self->col_name($col);
                my $cmp = ($reverse ? -1:1) *
                    ($col_is_numeric{$col} ?
                     ($a->{$name} <=> $b->{$name}) :
                     ($a->{$name} cmp $b->{$name}));
                return $cmp if $cmp;
            }
            0;
        } @$rows];
    } # sort rows

    # select columns & convert back to aoaos if that's the requested form
    {
        my $rows2 = [];
        for my $row0 (@$rows) {
            my $row;
            if ($_as eq 'aoaos') {
                $row = [];
                for my $i (0..$#{$cols0}) {
                    $row->[$i] = $row0->{$cols0->[$i]};
                }
            } else {
                $row = {};
                for my $i (0..$#newcols) {
                    $row->{$newcols[$i]} =
                        $row0->{$newcols_to_origcols{$newcols[$i]}};
                }
            }
            push @$rows2, $row;
        }
        $rows = $rows2;
    }

    # return result as object
    if ($_as eq 'aoaos') {
        require Data::TableData::Object::aoaos;
        return Data::TableData::Object::aoaos->new($rows, $spec);
    } else {
        require Data::TableData::Object::aohos;
        return Data::TableData::Object::aohos->new($rows, $spec);
    }
}

sub select_as_aoaos {
    my ($self, $cols, $excl_cols, $func_filter_row, $sorts) = @_;
    $self->_select('aoaos', $cols, $excl_cols, $func_filter_row, $sorts);
}

sub select_as_aohos {
    my ($self, $cols, $excl_cols, $func_filter_row, $sorts) = @_;
    $self->_select('aohos', $cols, $excl_cols, $func_filter_row, $sorts);
}

sub uniq_col_names { die "Must be implemented by subclass" }

sub const_col_names { die "Must be implemented by subclass" }

sub del_col { die "Must be implemented by subclass" }

sub rename_col { die "Must be implemented by subclass" }

sub switch_cols { die "Must be implemented by subclass" }

1;
# ABSTRACT: Base class for Data::TableData::Object::*

__END__