# Data-Hexify.pm -- Perl extension for hexdumping arbitrary data
# RCS Info        : $Id: Data-Hexify.pm,v 1.6 2004/11/05 09:17:14 jv Exp $
# Author          : Johan Vromans
# Created On      : Sat Jun 19 12:31:21 2004
# Last Modified By: Johan Vromans
# Last Modified On: Fri Nov  5 10:17:11 2004
# Update Count    : 37
# Status          : Unknown, Use with caution!

package Data::Hexify;

use 5.006;
use strict;
use warnings;

################ Exporter Section ################

require Exporter;
our @ISA         = qw(Exporter);
our @EXPORT      = qw(Hexify);
our %EXPORT_TAGS = ( all => [ @EXPORT ] );
our @EXPORT_OK   = ( @{ $EXPORT_TAGS{all} } );

################ Preamble ################

our $VERSION = '1.00';

use Carp;

my $usage = "Usage: Hexify(<data ref> [ , <hash or hashref> ])\n";

################ Code ################

sub Hexify {

    use bytes;

    # First argument: data or reference to the data.
    my $data = shift;
    my $dr = ref($data) ? $data : \$data;

    my $start  = 0;		# first byte to dump
    my $lastplusone = length($$dr); # first byte not to dump
    my $align  = 1;		# align
    my $chunk  = 16;		# bytes per line
    my $first  = $start;	# number of 1st byte
    my $dups   = 0;		# output identical lines
    my $group  = 1;		# group per # bytes

    my $show   = sub { my $t = shift;
		       $t =~ tr /\000-\037\177-\377/./;
		       $t;
		 };

    # Check for second argument.
    if ( @_ ) {

	# Second argument: options hash or hashref.
	my %atts = ( align      => $align,
		     chunk      => $chunk,
		     showdata   => $show,
		     start      => $start,
		     length     => $lastplusone - $start,
		     duplicates => $dups,
		     first      => undef,
		     group	=> 1,
		   );

	if ( @_ == 1 ) {	# hash ref
	    my $a = shift;
	    croak($usage) unless ref($a) eq 'HASH';
	    %atts = ( %atts, %$a );
	}
	elsif ( @_ % 2 ) {	# odd
	    croak($usage);
	}
	else {			# assume hash
	    %atts = ( %atts, @_ );
	}

	my $length;
	$start  = delete($atts{start});
	$length = delete($atts{length});
	$align  = delete($atts{align});
	$chunk  = delete($atts{chunk});
	$show   = delete($atts{showdata});
	$dups   = delete($atts{duplicates});
	$group  = delete($atts{group});
	$first  = defined($atts{first}) ? $atts{first}  : $start;
	delete($atts{first});

	if ( %atts ) {
	    croak("Hexify: unrecognized options: ".
		  join(" ", sort(keys(%atts))));
	}

	# Sanity
	$start = 0 if $start < 0;
	$lastplusone = $start + $length;
	$lastplusone = length($$dr)
	  if $lastplusone > length($$dr);
	$chunk = 16 if $chunk <= 0;
	if ( $chunk % $group ) {
	    croak("Hexify: chunk ($chunk) must be a multiple of group ($group)");
	}
    }
    $group *= 2;

    #my $fmt = "  %04x: %-" . (3 * $chunk - 1) . "s  %-" . $chunk . "s\n";
    my $fmt = "  %04x: %-" . (2*$chunk + $chunk/($group/2) - 1) . "s  %-" . $chunk . "s\n";
    my $ret = "";

    if ( $align && (my $r = $first % $chunk) ) {
	# This piece of code can be merged into the main loop.
	# However, this piece is only executed infrequently.
	my $lead = " " x $r;
	my $firstn = $chunk - $r;
	$first -= $r;
	my $n = $lastplusone - $start;
	$n = $firstn if $n > $firstn;
	my $ss = substr($$dr, $start, $n);
	(my $hex = $lead . $lead . unpack("H*",$ss)) =~ s/(.{$group})(?!$)/$1 /g;
	$ret .= sprintf($fmt, $first, $hex,
			$lead . $show->($ss));
	$start += $n;
	$first += $chunk;
    }

    my $same = "";
    my $didsame = 0;
    my $dupline = "          |\n";

    while ( $start < $lastplusone ) {
	my $n = $lastplusone - $start;
	$n = $chunk if $n > $chunk;
	my $ss = substr($$dr, $start, $n);

	if ( !$dups ) {
	    if ( $ss eq $same && ($start + $n) < $lastplusone ) {
		if ( !$didsame ) {
		    $ret .= $dupline;
		    $same = $ss;
		    $didsame = 1;
		}
		next;
	    }
	    else {
		$same = "";
		$didsame = 0;
	    }
	}
	$same = $ss;

	(my $hex = unpack("H*", $ss)) =~ s/(.{$group})(?!$)/$1 /g;
	$ret .= sprintf($fmt, $first, $hex, $show->($ss));
    }
    continue {
	$start += $chunk;
	$first += $chunk;
    }

    $ret;
}

################ Selftest ################

unless ( caller ) {

    package main;
    my $data = pack("C*", 0..255);
    my $res = "";
    $res .= Data::Hexify::Hexify(\$data,
				 length => 48);
    $res .= Data::Hexify::Hexify(\$data,
				 start => 14, length => 48);
    $res .= Data::Hexify::Hexify(\$data,
				 start => 3, length => 4);
    $res .= Data::Hexify::Hexify(\$data,
				 start => 3, length => 4, first => 7);
    my $exp = <<'EOD';
  0000: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f  ................
  0010: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f  ................
  0020: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f   !"#$%&'()*+,-./
  0000:                                           0e 0f                ..
  0010: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f  ................
  0020: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f   !"#$%&'()*+,-./
  0030: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d        0123456789:;<=  
  0000:          03 04 05 06                                ....         
  0000:                      03 04 05 06                        ....     
EOD

    die("Selftest error:\n".
	"Got:\n$res".
	"Expected:\n$exp") unless $res eq $exp;
}

################ End of Selftest ################

__END__

=head1 NAME

Data::Hexify - Perl extension for hexdumping arbitrary data

=head1 SYNOPSIS

  use Data::Hexify;
  print STDERR Hexify(\$blob);

=head1 DESCRIPTION

This module exports one subroutine: C<Hexify>.

C<Hexify> formats arbitrary (possible binary) data into a format
suitable for hex dumps in the style of C<xd> or C<hexl>.

The first, or only, argument to C<Hexify> contains the data, or a
reference to the data, to be hexified. Hexify will return a string that
prints as follows:

  0000: 70 61 63 6b 61 67 65 20 44 61 74 61 3a 3a 48 65  package Data::He
  0010: 78 69 66 79 3b 0a 0a 75 73 65 20 35 2e 30 30 36  xify;..use 5.006

and so on. At the left is the (hexadecimal) index of the data, then a
number of hex bytes, followed by the chunk of data with unprintables
replaced by periods.

The optional second argument to C<Hexify> must be a hash or a hash
reference, containing values for any of the following parameters:

=over 4

=item first

The first byte of the data to be processed. Default is to start from
the beginning of the data.

=item length

The number of bytes to be processed. Default is to proceed all data.

=item chunk

The number of bytes to be processed per line of output. Default is 16.

=item group

The number of bytes to be grouped together. Default is 1 (no
grouping). If used, it must be a divisor of the chunk size.

=item duplicates

When set, duplicate lines of output are suppressed and replaced by a
single line reading C<**SAME**>.

Duplicate suppression is enabled by default.

=item showdata

A reference to a subroutine that is used to produce a printable string
from a chunk of data. By default, a subroutine is used that replaces
unwanted bytes by periods.

The subroutine gets the chunk of data passed as argument, and should
return a printable string of at most C<chunksize> characters.

=item align

Align the result to C<chunksize> bytes. This is relevant only when
processing data not from the beginning. For example, when C<first> is 10,
the result would become:

  0000:                ...    74 61 3a 3a 48 65            ta::He
  0010: 78 69 66 79 3b ... 65 20 35 2e 30 30 36  xify;..use 5.006
  ... and so on ...

Alignment is on by default. Without alignment, the result would be:

  000a: 74 61 3a 3a 48 ... 79 3b 0a 0a 75 73 65  ta::Hexify;..use
  001a: 20 35 2e 30 30 ... 73 65 20 73 74 72 69   5.006;.use stri
  ... and so on ...

=item start

Pretend that the data started at this byte (while in reality it starts
at byte C<first>). The above example, with C<< start => 0 >>, becomes:

  0000: 74 61 3a 3a 48 ... 79 3b 0a 0a 75 73 65  ta::Hexify;..use
  0010: 20 35 2e 30 30 ... 73 65 20 73 74 72 69   5.006;.use stri
  ... and so on ...

=back

=head1 SEE ALSO

L<Data::Dumper>, L<YAML>.

=head1 AUTHOR

Johan Vromans, E<lt>jvromans@squirrel.nlE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2004 Squirrel Consultancy

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.6.0 or,
at your option, any other version of Perl 5 you may have available.

=cut