view release on metacpan or  search on metacpan

script/dt  view on Meta::CPAN

#!perl

our $DATE = '2020-01-08'; # DATE
our $DIST = 'App-dt'; # DIST
our $VERSION = '0.007'; # VERSION

use 5.010001;
use strict;
use warnings;

use Data::Dmp 'dmp';
use Getopt::Long qw(:config gnu_getopt no_ignore_case);

my %Opts = (
    code => undef,
    outputs => [],
    overwrite => 0,
    default_input_format => 'json',
    default_output_format => 'json',
    pretty => undef,
);
our @DATA;
our $DATA;

our $DEBUG = $ENV{DEBUG};

sub _debug {
    my $msg = shift;

    $msg .= "\n" unless $msg =~ /\n$/;
    warn "DEBUG: $msg" if $DEBUG;
}

sub _guess_format_from_filename {
    my $filename = shift;

    # try to detect type from filename
    if ($filename =~ /\.(json|js)\z/i) {
        return 'json';
    } elsif ($filename =~ /\.(yaml|yml)\z/i) {
        return 'yaml';
    } elsif ($filename =~ /\.(perl|pl|pm|pod|dd)\z/i) {
        return 'perl';
    }
    undef;
}

sub _read_file {
    my ($filename) = @_;

    my $fmt;
  DETERMINE_INPUT_FORMAT:
    {
        if ($filename eq '-') {
            $fmt = $Opts{default_input_format};
            last;
        } elsif ($filename =~ s/:(json|yaml|perl)\z//) {
            $fmt = $1;
            last;
        } else {
            $fmt = _guess_format_from_filename($filename);
            last if $fmt;
        }

        # XXX detect format by reading a few lines from it

        $fmt = $Opts{default_input_format};
    }
    _debug("input format=$fmt");

    my $fh;
    if ($filename eq '-') {
        _debug("input source=stdin");
        $fh = \*STDIN;
    } else {
        _debug("input file=$filename");
        open $fh, "<", $filename
            or die "Can't open '$filename': $!\n";
    }
    my $raw = do {
        local $/;
        scalar <$fh>;
    };

    if ($fmt eq 'json') {
        require JSON::MaybeXS;
        my $json = JSON::MaybeXS->new->allow_nonref;
        return $json->decode($raw);
    } elsif ($fmt eq 'yaml') {
        require YAML::XS;
        return YAML::XS::Load($raw);
    } elsif ($fmt eq 'perl') {
        my $res = scalar eval $raw;
        if ($@) {
            warn "Can't read '$filename' as Perl: $@\n";
            exit 99;
        }
        return $res;
    } else {
        warn "dt: Unknown input format '$fmt'\n";
        exit 99;
    }
}

sub _write_file {
    my ($filename, $data) = @_;

    my $fmt;
    my $pretty = $Opts{pretty};
  DETERMINE_OUTPUT_FORMAT:
    {
        if ($filename eq '-') {
            $fmt = $Opts{default_output_format};
            $pretty //= 1 if -t STDOUT;
            last;
        } elsif ($filename =~ s/:(json|yaml|perl)\z//) {
            $fmt = $1;
            last;
        } else {
            $fmt = _guess_format_from_filename($filename);
            last if $fmt;
        }

        $fmt = $Opts{default_output_format};
    }

    my $res;
    if ($fmt eq 'json') {
        if ($pretty) {
            require JSON::Color;
            $res = JSON::Color::encode_json($data, {pretty=>1});
        } else {
            require JSON::MaybeXS;
            my $json = JSON::MaybeXS->new->allow_nonref;
            $res = $json->encode($data);
        }
    } elsif ($fmt eq 'yaml') {
        if ($pretty) {
            require YAML::Tiny::Color;
            $res = YAML::Tiny::Color::Dump($data);
        } else {
            require YAML::XS;
            $res = YAML::XS::Dump($data);
        }
    } elsif ($fmt eq 'perl') {
        if ($pretty) {
            require Data::Dump::Color;
            $res = Data::Dump::Color::dump($data);
        } else {
            require Data::Dump;
            $res = Data::Dump::dump($data);
        }
    } elsif ($fmt eq 'raw') {
        $res = $data;
    } else {
        warn "dt: Unknown output format '$fmt'\n";
        exit 99;
    }

    my $fh;
    if ($filename eq '-') {
        $fh = \*STDOUT;
    } else {
        if ((-f $filename) && !$Opts{overwrite}) {
            warn "dt: Skipped writing to '$filename': already exists\n";
            return;
        }
        open $fh, ">", $filename
            or die "Can't open '$filename': $!\n";
    }