view release on metacpan or  search on metacpan

lib/App/CSVUtils.pm  view on Meta::CPAN

package App::CSVUtils;

use 5.010001;
use strict;
use warnings;
use Log::ger;

use Cwd;
use Exporter qw(import);

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2025-02-04'; # DATE
our $DIST = 'App-CSVUtils'; # DIST
our $VERSION = '1.036'; # VERSION

our @EXPORT_OK = qw(
                       gen_csv_util
                       compile_eval_code
                       eval_code
               );

our %SPEC;

our $sch_req_str_or_code = ['any*', of=>['str*', 'code*']];

sub _open_file_read {
    my $filename = shift;

    my ($fh, $err);
    if ($filename eq '-') {
        $fh = *STDIN;
    } else {
        open $fh, "<", $filename or do {
            $err = [500, "Can't open input filename '$filename': $!"];
            goto RETURN;
        };
    }
    binmode $fh, ":encoding(utf8)";

  RETURN:
    ($fh, $err);
}

sub _open_file_write {
    my $filename = shift;

    my ($fh, $err);
    if ($filename eq '-') {
        $fh = *STDOUT;
    } else {
        open $fh, ">", $filename or do {
            $err = [500, "Can't open output filename '$filename': $!"];
            goto RETURN;
        };
    }
    binmode $fh, ":encoding(utf8)";

  RETURN:
    ($fh, $err);
}

sub _return_or_write_file {
    my ($res, $filename, $overwrite) = @_;
    return $res if !defined($filename);

    my $fh;
    if ($filename eq '-') {
        $fh = \*STDOUT;
    } else {
        if (-f $filename) {
            if ($overwrite) {
                log_info "[csvutil] Overwriting output file $filename";
            } else {
                return [412, "Refusing to ovewrite existing output file '$filename', please select another path or specify --overwrite"];
            }
        }
        open my $fh, ">", $filename or do {
            return [500, "Can't open output file '$filename': $!"];
        };
        binmode $fh, ":encoding(utf8)";
        print $fh $res->[2];
        close $fh or warn "Can't write to '$filename': $!";
        return [$res->[0], $res->[1]];
    }
}

sub compile_eval_code {
    return $_[0] if ref $_[0] eq 'CODE';
    my ($str, $label) = @_;
    defined($str) && length($str) or die [400, "Please specify code ($label)"];
    $str = "package main; no strict; no warnings; sub { $str }";
    log_trace "[csvutil] Compiling Perl code: $str";
    my $code = eval $str; ## no critic: BuiltinFunctions::ProhibitStringyEval
    die [400, "Can't compile code ($label) '$str': $@"] if $@;
    $code;
}

sub eval_code {
    no warnings 'once';
    my ($code, $r, $value_for_topic, $return_topic) = @_;
    local $_ = $value_for_topic;
    local $main::r = $r;
    local $main::row = $r->{input_row};
    local $main::rownum = $r->{input_rownum};
    local $main::data_rownum = $r->{input_data_rownum};
    local $main::csv = $r->{input_parser};
    local $main::fields_idx = $r->{input_fields_idx};
    if ($return_topic) {
        $code->($_);
        $_;
    } else {
        $code->($_);
    }
}

sub _get_field_idx {
    my ($field, $field_idxs) = @_;
    defined($field) && length($field) or die "Please specify at least a field\n";
    my $idx = $field_idxs->{$field};
    die "Unknown field '$field' (known fields include: ".
        join(", ", map { "'$_'" } sort {$field_idxs->{$a} <=> $field_idxs->{$b}}
             keys %$field_idxs).")\n" unless defined $idx;
    $idx;
}

sub _get_csv_row {
    my ($csv, $row, $i, $outputs_header) = @_;
    #use DD; print "  "; dd $row;
    return "" if $i == 1 && !$outputs_header;
    my $status = $csv->combine(@$row)
        or die "Error in line $i: ".$csv->error_input."\n";
    $csv->string . "\n";
}

sub _instantiate_parser_default {
    require Text::CSV_XS;

    Text::CSV_XS->new({binary=>1});
}