File Coverage

blib/lib/Test/HexDifferences/HexDump.pm

Criterion	Covered	Total	%
statement	81	85	95.2
branch	30	36	83.3
condition	10	12	83.3
subroutine	10	10	100.0
pod	1	1	100.0
total	132	144	91.6

package Test::HexDifferences::HexDump;  ## no critic (TidyCode)

use strict;
use warnings;

our $VERSION = '0.008';

use Hash::Util qw(lock_keys);
use Sub::Exporter -setup => {
    exports => [
        qw(hex_dump),
    ],
    groups  => {
        default => [ qw(hex_dump) ],
    },
};

my $default_format = "%a : %4C : %d\n";

sub hex_dump {
    my ($data, $attr_ref) = @_;

    defined $data
        or return $data;
    ref $data
        and return $data;
    $attr_ref
        = ref $attr_ref eq 'HASH'
        ? $attr_ref
        : {};
    my $data_pool = {
        # global
        data               => $data,
        format             => $attr_ref->{format}  || "$default_format%*x",
        address            => $attr_ref->{address} || 0,
        output             => q{},
        # to format a block
        format_block       => undef,
        data_length        => undef,
        is_multibyte_error => undef,
    };
    lock_keys %{$data_pool};
    BLOCK:
    while ( length $data_pool->{data} ) {
        _next_format($data_pool);
        _format_items($data_pool);
    }

    return $data_pool->{output};
}

sub _next_format {
    my $data_pool = shift;

    my $is_match = $data_pool->{format} =~ s{
        \A
          ( .*? [^%] )               # format of the block
          % ( 0* [1-9] \d* | [*] ) x # repetition factor
    } {
        my $new_count = $2 eq q{*} ? q{*} : $2 - 1;
        $data_pool->{format_block} = $1;
        $new_count
        ? "$1\%${new_count}x"
        : q{};
    }xmse;
    if ( $data_pool->{is_multibyte_error} || ! $is_match ) {
        $data_pool->{format}             = "$default_format%*x";
        $data_pool->{format_block}       = $default_format;
        $data_pool->{is_multibyte_error} = 0;
        return;
    }

    return;
}

sub _format_items {
    my $data_pool = shift;

    $data_pool->{data_length} = 0;
    RUN: {
        # % written as %%
        $data_pool->{format_block} =~ s{
            \A % ( % )
        } {
            do {
                $data_pool->{output} .= $1;
                q{};
            }
        }xmse and redo RUN;
        # \n written as %\n will be ignored
        $data_pool->{format_block} =~ s{
            \A % [\n]
        }{}xms and redo RUN;
        # address
        _format_address($data_pool)
            and redo RUN;
        # words
        _format_word($data_pool)
            and redo RUN;
        # display ASCII
        _format_ascii($data_pool)
            and redo RUN;
        # display any other char
        $data_pool->{format_block} =~ s{
            \A (.)
        } {
            do {
                $data_pool->{output} .= $1;
                q{};
            }
        }xmse and redo RUN;
        if ( $data_pool->{data_length} ) {
            # clear already displayed data
            substr $data_pool->{data}, 0, $data_pool->{data_length}, q{};
            $data_pool->{data_length} = 0;
        }
    }

    return;
}

sub _format_address {
    my $data_pool = shift;

    return $data_pool->{format_block} =~ s{
        \A % ( 0* [48]? ) a
    } {
        do {
            my $length = $1 || 4;
            $data_pool->{output}
                .= sprintf "%0${length}X", $data_pool->{address};
            q{};
        }
    }xmse;
}

my $big_endian    = q{>};
my $little_endian = q{<};
my $machine_endian
    = ( pack 'S', 1 ) eq ( pack 'n', 1 )
    ? $big_endian # network order
    : $little_endian;
my %format_of = (
    'C'  => { # unsigned char
        bytes  => 1,
        endian => $big_endian,
    },
    'S'  => { # unsigned 16-bit, endian depends on machine
        bytes  => 2,
        endian => $machine_endian,
    },
    'S<' => { # unsigned 16-bit, little-endian
        bytes  => 2,
        endian => $little_endian,
    },
    'S>' => { # unsigned 16-bit, big-endian
        bytes  => 2,
        endian => $big_endian,
    },
    'v'  => { # unsigned 16-bit, little-endian
        bytes  => 2,
        endian => $little_endian,
    },
    'n'  => { # unsigned 16-bit, big-endian
        bytes  => 2,
        endian => $big_endian,
    },
    'L'  => { # unsigned 32-bit, endian depends on machine
        bytes  => 4,
        endian => $machine_endian,
    },
    'L<' => { # unsigned 32-bit, little-endian
        bytes  => 4,
        endian => $little_endian,
    },
    'L>' => { # unsigned 32-bit, big-endian
        bytes  => 4,
        endian => $big_endian,
    },
    'V'  => { # unsigned 32-bit, little-endian
        bytes  => 4,
        endian => $little_endian,
    },
    'N'  => { # unsigned 32-bit, big-endian
        bytes  => 4,
        endian => $big_endian,
    },
    'Q'  => { # unsigned 64-bit, endian depends on machine
        bytes  => 8,
        endian => $machine_endian,
    },
    'Q<' => { # unsigned 64-bit, little-endian
        bytes  => 8,
        endian => $little_endian,
    },
    'Q>' => { # unsigned 64-bit, big-endian
        bytes  => 8,
        endian => $big_endian,
    },
);

sub _format_word {
    my $data_pool = shift;

    return $data_pool->{format_block} =~ s{
        \A
        % ( 0* [1-9] \d* )?
        ( [LSQ] [<>] | [CVNvnLSQ] )
    } {
        do {
            my ($byte_length, $endian)
                = @{ $format_of{$2} }{ qw(bytes endian) };
            $data_pool->{output} .= join q{ }, map {
                (
                    length $data_pool->{data}
                    >= $data_pool->{data_length} + $byte_length
                )
                ? do {
                    my @unpacked
                        = unpack
                            q{C} x $byte_length,
                            substr
                                $data_pool->{data},
                                $data_pool->{data_length},
                                $byte_length;
                    if ( $endian eq q{<} ) {
                        @unpacked = reverse @unpacked;
                    }
                    my $hex = sprintf
                        '%02X' x $byte_length,
                        @unpacked;
                    $data_pool->{data_length} += $byte_length;
                    $data_pool->{address}     += $byte_length;
                    $hex;
                }
                : do {
                    if ( $byte_length > 1 ) {
                        $data_pool->{is_multibyte_error}++;
                    }
                    q{ } x 2 x $byte_length;
                };
            } 1 .. ( $1 || 1 );
            q{};
        }
    }xmse;
}

sub _format_ascii {
    my $data_pool = shift;

    return $data_pool->{format_block} =~ s{
        \A %d
    } {
        do {
            my $data = substr $data_pool->{data}, 0, $data_pool->{data_length};
            $data =~ s{
                ( ['"\\] )
                | ( [!-~] )
                | .
            } {
                defined $1   ? q{.}
                : defined $2 ? $2
                :              q{.}
            }xmsge;
            $data_pool->{output} .= $data;
            q{};
        }
    }xmse;
}

# $Id$

1;

__END__