File Coverage

blib/lib/Perinci/Result/Format.pm

Criterion	Covered	Total	%
statement	21	25	84.0
branch	7	12	58.3
condition	2	6	33.3
subroutine	4	4	100.0
pod	0	1	0.0
total	34	48	70.8

package Perinci::Result::Format;

our $DATE = '2015-11-29'; # DATE
our $VERSION = '0.45'; # VERSION

use 5.010001;
use strict;
use warnings;

our $Enable_Decoration = 1;
our $Enable_Cleansing  = 0;

# text formats are special. since they are more oriented towards human instead
# of machine, we remove envelope when status is 2xx, so users only see content.

# XXX color theme?

my $format_text = sub {
    my ($format, $res) = @_;

    my $stack_trace_printed;

    my $print_err = sub {
        require Color::ANSI::Util;
        require Term::Detect::Software;

        my $use_color = $ENV{COLOR} // 1;
        my $terminfo = Term::Detect::Software::detect_terminal_cached();
        $use_color = 0 if !$terminfo->{color_depth};
        my $colorize = sub {
            my ($color, $str) = @_;
            if ($use_color) {
                if (ref($color) eq 'ARRAY') {
                    (defined($color->[0]) ?
                         Color::ANSI::Util::ansifg($color->[0]):"").
                               (defined($color->[1]) ?
                                    Color::ANSI::Util::ansibg($color->[1]):"").
                                          $str . "\e[0m";
                } else {
                    Color::ANSI::Util::ansifg($color) . $str . "\e[0m";
                }
            } else {
                $str;
            }
        };

        my $res = shift;
        my $out = $colorize->("cc0000", "ERROR $res->[0]") .
            ($res->[1] ? ": $res->[1]" : "");
        $out =~ s/\n+\z//;
        my $clog; $clog = $res->[3]{logs}[0]
            if $res->[3] && $res->[3]{logs};
        if ($clog->{file} && $clog->{line}) {
            $out .= " (at ".$colorize->('3399cc', $clog->{file}).
                " line ".$colorize->('3399cc', $clog->{line}).")";
        }
        $out .= "\n";
        if ($clog->{stack_trace} && $INC{"Carp/Always.pm"} &&
                !$stack_trace_printed) {
            require Data::Dump::OneLine;
            my $i;
            for my $c (@{ $clog->{stack_trace} }) {
                next unless $i++; # skip first entry
                my $args;
                if (!$c->[4]) {
                    $args = "()";
                } elsif (!ref($c->[4])) {
                    $args = "(...)";
                } else {
                    # periutil 0.37+ stores call arguments in [4]

                    # XXX a flag to let user choose which

                    # dump version
                    #$args = Data::Dump::OneLine::dump1(@{ $c->[4] });
                    #$args = "($args)" if @{$c->[4]} < 2;

                    # stringify version
                    $args = Data::Dump::OneLine::dump1(
                        map {defined($_) ? "$_":$_} @{ $c->[4] });
                    $args = "($args)" if @{$c->[4]} == 1;
                }
                $out .= "    $c->[3]${args} called at $c->[1] line $c->[2]\n";
            }
            $stack_trace_printed++;
        }
        $out;
    };

    if (!defined($res->[2])) {
        my $out = $res->[0] =~ /\A(?:2..|304)\z/ ? "" : $print_err->($res);
        my $max = 30;
        my $i = 0;
        my $prev = $res;
        while (1) {
            if ($i > $max) {
                $out .= "  Previous error list too deep, stopping here\n";
                last;
            }
            last unless $prev = $prev->[3]{prev};
            last unless ref($prev) eq 'ARRAY';
            $out .= "  " . $print_err->($prev);
            $i++;
        }
        return $out;
    }
    my ($r, $opts);
    if ($res->[0] =~ /\A2../) {
        $r = $res->[2];
        my $rfo = $res->[3]{format_options} // {};
        my $tff = $res->[3]{'table.fields'};
        if ($rfo->{$format}) {
            $opts = $rfo->{$format};
        } elsif ($rfo->{any}) {
            $opts = $rfo->{any};
        } elsif ($tff) {
            $opts = {table_column_orders=>[$tff]};
        }
    } else {
        $r = $res;
    }
    $opts //= {};
    if ($format eq 'text') {
        return Data::Format::Pretty::format_pretty(
            $r, {%$opts, module=>'Console'});
    }
    if ($format eq 'text-simple') {
        return Data::Format::Pretty::format_pretty(
            $r, {%$opts, module=>'SimpleText'});
    }
    if ($format eq 'text-pretty') {
        return Data::Format::Pretty::format_pretty(
            $r, {%$opts, module=>'Text'});
    }
};

our %Formats = (
    # YAML::Tiny::Color currently does not support circular refs
    yaml          => ['YAML', 'text/yaml', {circular=>0}],
    json          => ['CompactJSON', 'application/json', {circular=>0}],
    'json-pretty' => ['JSON', 'application/json', {circular=>0}],
    text          => [$format_text, 'text/plain', {circular=>0}],
    'text-simple' => [$format_text, 'text/plain', {circular=>0}],
    'text-pretty' => [$format_text, 'text/plain', {circular=>0}],
    'perl'        => ['Perl', 'text/x-perl', {circular=>1}],
    #'php'         => ['PHP', 'application/x-httpd-php', {circular=>0}],
    'phpserialization' => ['PHPSerialization', 'application/vnd.php.serialized', {circular=>0}],
    'ruby'        => ['Ruby', 'application/x-ruby', {circular=>1}],
);

sub format {
    require Data::Format::Pretty;

    my ($res, $format, $is_naked) = @_;

    my $fmtinfo = $Formats{$format} or return undef;
    my $formatter = $fmtinfo->[0];

    state $cleanser;
    if ($Enable_Cleansing && !$fmtinfo->[2]{circular}) {
        # currently we only have one type of cleansing, oriented towards JSON
        if (!$cleanser) {
            require Data::Clean::JSON;
            $cleanser = Data::Clean::JSON->get_cleanser;
        }
        $res = $cleanser->clone_and_clean($res);
    }

    my $deco = $Enable_Decoration;

    if (ref($formatter) eq 'CODE') {
        return $formatter->($format, $res);
    } else {
        my %o;
        $o{color} = 0 if !$deco && $format =~ /json|yaml|perl/;
        my $data = $is_naked ? $res->[2] : $res;
        return Data::Format::Pretty::format_pretty(
            $data, {%o, module=>$formatter});
    }
}

1;
# ABSTRACT: Format envelope result

__END__