File Coverage

blib/lib/Test2/Tools/EventDumper.pm

Criterion	Covered	Total	%
statement	159	160	99.3
branch	84	88	95.4
condition	56	74	75.6
subroutine	18	18	100.0
pod	3	13	23.0
total	320	353	90.6

package Test2::Tools::EventDumper;
use strict;
use warnings;

our $VERSION = '0.000011';

use Carp qw/croak/;
use Scalar::Util qw/blessed/;

our @EXPORT = qw/dump_event dump_events/;
use base 'Exporter';

my %QUOTE_MATCH = (
    '{' => '}',
    '(' => ')',
    '[' => ']',
    '/' => '/',
);

my %DEFAULTS = (
    qualify_functions    => 0,
    paren_functions      => 0,
    use_full_event_type  => 0,
    show_empty           => 0,
    add_line_numbers     => 0,
    call_when_can        => 1,
    convert_trace        => 1,
    shorten_single_field => 1,
    clean_fail_messages  => 1,

    field_order => {
        name           => 1,
        pass           => 2,
        effective_pass => 3,
        todo           => 4,
        max            => 5,
        directive      => 6,
        reason         => 7,
        trace          => 9999,
    },
    array_sort_order => 10000,
    other_sort_order => 9000,

    include_fields => undef,
    exclude_fields => {buffered => 1, nested => 1, in_subtest => 1, is_subtest => 1, subtest_id => 1, hubs => 1},

    indent_sequence => '    ',

    adjust_filename => \&adjust_filename,
);

sub adjust_filename {
    my $file = shift;
    $file =~ s{^.*[/\\]}{}g;
    return "match qr{\\Q$file\\E\$}";
}

sub dump_event {
    my ($event, %settings) = @_;

    croak "No event to dump"
        unless $event;

    croak "dump_event() requires a Test2::Event (or subclass) instance, Got: $event"
        unless blessed($event) && $event->isa('Test2::Event');

    my $settings = keys %settings ? parse_settings(\%settings) : \%DEFAULTS;

    my $out = do_event_dump($event, $settings);

    return finalize($out, $settings);
}

sub dump_events {
    my ($events, %settings) = @_;

    croak "No events to dump"
        unless $events;

    croak "dump_events() requires an array reference, Got: $events"
        unless ref($events) eq 'ARRAY';

    croak "dump_events() requires an array reference of Test2::Event (or subclass) instances, some array elements are not Test2::Event instances"
        if grep { !$_ || !blessed($_) || !$_->isa('Test2::Event') } @$events;

    my $settings = keys %settings ? parse_settings(\%settings) : \%DEFAULTS;

    my $out = do_array_dump($events, $settings);

    return finalize($out, $settings);
}

sub finalize {
    my ($out, $settings) = @_;

    $out =~ s[(\s+)$][join '' => grep { $_ eq "\n" } split //, $1]msge;

    if ($settings->{add_line_numbers}) {
        my $line = 1;
        my $count = length( 0 + map { 1 } split /\n/, $out );
        $out =~ s/^/sprintf("L%0${count}i: ", $line++)/gmse;
        $out =~ s/^L\d+: $//gms;
    }

    return $out;
}

sub parse_settings {
    my $settings = shift;

    my %out;
    my %clone = %$settings;

    for my $field (qw/field_order include_fields exclude_fields/) {
        next unless exists  $clone{$field}; # Nothing to do.
        next unless defined $clone{$field}; # Do not modify an undef

        # Remove it from the clone
        my $order = delete $clone{$field};

        croak "settings field '$field' must be either an arrayref or hashref, got: $order"
            unless ref($order) =~ m/^(ARRAY|HASH)$/;

        my $count = 1;
        $out{$field} = ref($order) eq 'HASH' ? $order : {map { $_ => $count++ } @$order};
    }

    return {
        %DEFAULTS,
        %clone,
        %out,
    };
}

sub do_event_dump {
    my ($event, $settings) = @_;

    my ($ps, $pe) = ($settings->{qualify_functions} || $settings->{paren_functions}) ? ('(', ')') : (' ', '');
    my $qf = $settings->{qualify_functions} ? "Test2::Tools::Compare::" : "";

    my $start = "${qf}event${ps}" . render_event($event, $settings);

    my @fields = get_fields($event, $settings);

    my @rows = map { get_rows($event, $_, $settings) } @fields;
    shift @rows while @rows && !@{$rows[0]}; # Strip leading empty rows

    my $nest = "";
    if (@rows == 0) {
        $start .= " => {";
    }
    elsif (@rows == 1 && $settings->{shorten_single_field} && !$rows[0]->[3]) {
        $start .= " => {";
        my ($row) = @rows;
        $nest = quote_key($row->[1]) . " => $row->[2]";
    }
    else {
        $start .= " => sub {\n";

        for my $row (@rows) {
            unless (@$row) {
                $nest .= "\n";
                next;
            }

            my ($func, $field, $qval, $comment) = @$row;
            my $key = quote_key($field);
            $nest .= "${qf}${func}${ps}${key} => ${qval}${pe};";
            $nest .= " # $comment" if $comment;
            $nest .= "\n";
        }

        $nest =~ s/^/$settings->{indent_sequence}/mg;
    }

    return "${start}${nest}}${pe}";
}

sub do_array_dump {
    my ($array, $settings) = @_;

    my ($ps, $pe) = ($settings->{qualify_functions} || $settings->{paren_functions}) ? ('(sub ', ')') : (' ', '');
    my $qf = $settings->{qualify_functions} ? "Test2::Tools::Compare::" : "";

    my $out = "${qf}array${ps}\{\n";

    my $nest = "";
    my $not_first = 0;
    for my $event (@$array) {
        $nest .= "\n" if $not_first++;
        $nest .= do_event_dump($event, $settings) . ";\n"
    }
    $nest .= "${qf}end();\n";
    $nest =~ s/^/$settings->{indent_sequence}/mg;

    $out .= $nest;
    $out .= "}${pe}";

    return $out;
}

sub quote_val {
    my ($val, $settings) = @_;

    return 'undef' unless defined $val;

    return $val if $val =~ m/^\d+$/;

    return 'match qr{^\\n?Failed test}'
        if $settings->{clean_fail_messages} && $val =~ m/^\n?Failed test/;

    return quote_str(@_);
}

sub quote_key {
    my ($val, $settings) = @_;

    return $val if $val =~ m/^\d+$/;
    return $val if $val =~ m/^\w+$/;

    return quote_str(@_);
}

sub quote_str {
    my ($val, $settings) = @_;

    my $use_qq = 0;
    $use_qq = 1 if $val =~ s/\n/\\n/g;
    $use_qq = 1 if $val =~ s/\r/\\r/g;
    $use_qq = 1 if $val =~ s/[\b]/\\b/g;

    my @delims = ('"', grep {$QUOTE_MATCH{$_}} qw<{ ( [ />);
    unshift @delims => "'" unless $use_qq;
    my ($s1) = grep { $val !~ m/\Q$_\E/ } @delims;

    unless($s1) {
        $s1 = $delims[0];
        $val =~ s/$s1/\\$s1/g;
    }

    my $s2 = $QUOTE_MATCH{$s1} || $s1;

    $use_qq = 0 if $s1 eq '"';

    my $qq = ($QUOTE_MATCH{$s1} || $use_qq) ? 'qq' : '';

    return "${qq}${s1}${val}${s2}";
}

sub render_event {
    my ($event, $settings) = @_;
    my $type = blessed($event);

    return quote_key("+$type", $settings)
        if $settings->{use_full_event_type}
        || $type !~ m/^Test2::Event::(.+)$/;

    return quote_key($1, $settings);
}

sub get_fields {
    my ($event, $settings) = @_;

    my @fields = grep { $_ !~ m/^_/ } keys %$event;

    push @fields => keys %{$settings->{include_fields}}
        if $settings->{include_fields};

    my %seen;
    my $exclude = $settings->{exclude_fields} || {};
    @fields = grep { !$seen{$_}++ && !$exclude->{$_} } @fields;

    @fields = grep { exists $event->{$_} && defined $event->{$_} && length $event->{$_} } @fields
        unless $settings->{show_empty};

    return sort {
        my $a_has_array = ref($event->{$a}) eq 'ARRAY';
        my $b_has_array = ref($event->{$b}) eq 'ARRAY';

        my $av = $a_has_array ? $settings->{array_sort_order} : ($settings->{field_order}->{$a} || $settings->{other_sort_order});
        my $bv = $b_has_array ? $settings->{array_sort_order} : ($settings->{field_order}->{$b} || $settings->{other_sort_order});

        return $av <=> $bv || $a cmp $b;
    } @fields;
}

sub get_rows {
    my ($event, $field, $settings) = @_;

    return ['field', $field, 'DNE()']
        unless exists $event->{$field};

    my ($func, $val);
    if ($settings->{call_when_can} && $event->can($field)) {
        $func = 'call';
        $val = $event->$field;
    }
    else {
        $func = 'field';
        $val = $event->{$field};
    }

    if ($settings->{convert_trace} && $field eq 'trace' && blessed($val) && ($val->isa('Test2::Util::Trace') || $val->isa('Test2::EventFacet::Trace'))) {
        my $file = $settings->{adjust_filename}->($val->file);
        return (
            [],
            [ 'prop', 'file', $file ],
            [ 'prop', 'line', $val->line ],
        );
    }

    my $ref = ref $val;

    return [ $func, $field, quote_val($val, $settings) ]
        unless $ref;

    return ( [], [ $func, $field, do_array_dump($val, $settings) ] )
        if $ref eq 'ARRAY' && !grep { !blessed($_) || !$_->isa('Test2::Event') } @$val;

    return [ $func, $field, 'T()', "Unknown value: " . (blessed($val) || $ref) ];
}

__END__