#!/usr/pkg/bin/perl

=begin metadata

Name: od
Description: dump files in octal and other formats
Author: Mark Kahn, mkahn@vbe.com
Author: Michael Mikonos
License: perl

=end metadata

=cut


use strict;

use File::Basename qw(basename);
use Getopt::Std qw(getopts);

use constant EX_SUCCESS => 0;
use constant EX_FAILURE => 1;
use constant LINESZ => 16;
use constant PRINTMAX => 126;

use vars qw/ $opt_A $opt_a $opt_B $opt_b $opt_c $opt_D $opt_d $opt_e $opt_F
    $opt_f $opt_H $opt_h $opt_i $opt_j $opt_l $opt_N $opt_O $opt_o $opt_s
    $opt_t $opt_v $opt_X $opt_x /;

our $VERSION = '1.4';

my ($offset1, $radix, $data, @arr, $lim);
my ($lastline, $strfmt, $ml);

my %charescs = (
    0  => ' \0',
    7  => ' \a',
    8  => ' \b',
    9  => ' \t',
    10 => ' \n',
    11 => ' \v',
    12 => ' \f',
    13 => ' \r',
    92 => ' \\\\',
);

# embedded space allows formatting without sprintf
my %charname = (
    0  => 'nul',
    1  => 'soh',
    2  => 'stx',
    3  => 'etx',
    4  => 'eot',
    5  => 'enq',
    6  => 'ack',
    7  => 'bel',
    8  => ' bs',
    9  => ' ht',
    10 => ' nl',
    11 => ' vt',
    12 => ' ff',
    13 => ' cr',
    14 => ' so',
    15 => ' si',
    16 => 'dle',
    17 => 'dc1',
    18 => 'dc2',
    19 => 'dc3',
    20 => 'dc4',
    21 => 'nak',
    22 => 'syn',
    23 => 'etb',
    24 => 'can',
    25 => ' em',
    26 => 'sub',
    27 => 'esc',
    28 => ' fs',
    29 => ' gs',
    30 => ' rs',
    31 => ' us',
    32 => ' sp',
    127 => 'del',
);

$offset1 = 0;
$lastline = '';

my $Program = basename($0);

getopts('A:aBbcDdeFfHhij:lN:Oost:vXx') or help();
if (defined $opt_A) {
    if ($opt_A !~ m/\A[doxn]\z/) {
	warn "$Program: unexpected radix: '$opt_A'\n";
	exit EX_FAILURE;
    }
    if ($opt_A ne 'n') {
	$radix = $opt_A;
    }
}
else {
    $radix = 'o';
}

if (defined $opt_j) {
    if ($opt_j =~ m/\D/) {
	warn "$Program: bad argument to -j: '$opt_j'\n";
	exit EX_FAILURE;
    }
}
if (defined $opt_N) {
    if ($opt_N =~ m/\D/) {
	warn "$Program: bad argument to -N: '$opt_N'\n";
	exit EX_FAILURE;
    }
    $lim = $opt_N;
}

my $fmt;
if ($opt_a) {
    $fmt = \&char7bit;
}
elsif ($opt_b) {
    $fmt = \&octal1;
}
elsif ($opt_c) {
    $fmt = \&char1;
}
elsif ($opt_D) {
    $fmt = \&udecimal4;
}
elsif ($opt_d) {
    $fmt = \&udecimal2;
}
elsif ($opt_e || $opt_F) {
    $fmt = \&float8;
}
elsif ($opt_f) {
    $fmt = \&float4;
}
elsif ($opt_H || $opt_X) {
    $fmt = \&hex4;
}
elsif ($opt_h || $opt_x) {
    $fmt = \&hex2;
}
elsif ($opt_i || $opt_s) {
    $fmt = \&decimal2;
}
elsif ($opt_l) {
    $fmt = \&long;
}
elsif ($opt_O) {
    $fmt = \&octal4;
}
elsif ($opt_B || $opt_o) {
    $fmt = \&octal2;
}
else {
    $fmt = \&octal2;
}

if (defined $opt_t) {
    if ($opt_t eq 'x1') {
        $fmt = \&hex1;
    } elsif ($opt_t eq 'x2') {
        $fmt = \&hex2;
    } elsif ($opt_t eq 'x4') {
        $fmt = \&hex4;
    } elsif ($opt_t eq 'x8') {
        $fmt = \&hex8;
    } elsif ($opt_t eq 'o1') {
        $fmt = \&octal1;
    } elsif ($opt_t eq 'o2') {
        $fmt = \&octal2;
    } elsif ($opt_t eq 'o4') {
        $fmt = \&octal4;
    } elsif ($opt_t eq 'o8') {
        $fmt = \&octal8;
    } elsif ($opt_t eq 'd1') {
        $fmt = \&decimal1;
    } elsif ($opt_t eq 'd2') {
        $fmt = \&decimal2;
    } elsif ($opt_t eq 'd4') {
        $fmt = \&decimal4;
    } elsif ($opt_t eq 'd8') {
        $fmt = \&decimal8;
    } elsif ($opt_t eq 'u1') {
        $fmt = \&udecimal1;
    } elsif ($opt_t eq 'u2') {
        $fmt = \&udecimal2;
    } elsif ($opt_t eq 'u4') {
        $fmt = \&udecimal4;
    } elsif ($opt_t eq 'u8') {
        $fmt = \&udecimal8;
    } elsif ($opt_t eq 'f4') {
        $fmt = \&float4;
    } elsif ($opt_t eq 'f8') {
        $fmt = \&float8;
    } elsif ($opt_t eq 'a') {
        $fmt = \&char7bit;
    } elsif ($opt_t eq 'c') {
        $fmt = \&char1;
    } else {
        warn "$Program: unexpected output format specifier\n";
        exit EX_FAILURE;
    }
    if ($opt_t =~ m/\A[doux]8\Z/) {
        my $has_quad = eval {
            unpack 'Q', '';
            1;
        };
        unless ($has_quad) {
            warn "$Program: 64-bit perl needed for $opt_t format\n";
            exit EX_FAILURE;
        }
    }
}

my $nread = 0;
my $rc = EX_SUCCESS;
foreach my $file (@ARGV) {
    if (-d $file) {
	warn "$Program: '$file' is a directory\n";
	$rc = EX_FAILURE;
	next;
    }
    my $fh;
    unless (open $fh, '<', $file) {
	warn "$Program: cannot open '$file': $!\n";
	$rc = EX_FAILURE;
	next;
    }
    binmode $fh;

    do_skip($fh) if $opt_j;
    dump_file($fh);
    close $fh;
}
unless (@ARGV) {
    do_skip(*STDIN) if $opt_j;
    dump_file(*STDIN);
}
dump_line() if (defined $data);
emit_offset(1);
exit $rc;

sub VERSION_MESSAGE {
    print "$Program version $VERSION\n";
    exit EX_SUCCESS;
}

sub limit_reached {
    return defined($lim) && $nread >= $lim;
}

sub emit_offset {
    my $nl = shift;
    return unless $radix;
    printf "%.8$radix%s", $offset1, $nl ? "\n" : ' ';
}

sub dump_line {
    unless ($opt_v) {
	if (diffdata()) {
	    $lastline = $data . '|';
	    $ml = 0;
	} else {
	    print "*\n" unless $ml;
	    $ml = 1;
	}
    }
    unless ($ml) {
	emit_offset();
	&$fmt;
	printf "$strfmt\n", @arr;
    }
    $offset1 += length $data;
    undef $data;
}

sub dump_file {
    my $fh = shift;
    my $buf;

    while (!limit_reached() && !eof($fh)) {
	my $len = read $fh, $buf, 1;
	unless (defined $len) {
	    warn "$Program: read error: $!\n";
	    $rc = EX_FAILURE;
	    return;
	}
	$data .= $buf;
	$nread++;

	dump_line() if (length($data) == LINESZ);
    }
}

sub do_skip {
    my $fh = shift;
    my $buf;

    while ($opt_j > 0) {
	my $len = read $fh, $buf, 1;
	if ($len == 0) {
	    warn "$Program: skip past end of input\n";
	    exit EX_FAILURE;
	}
	unless (defined $len) {
	    warn "$Program: read error: $!\n";
	    exit EX_FAILURE;
	}
	$opt_j--;
	$offset1++;
    }
}

sub octal1 {
    @arr = unpack 'C*', $data;
    $strfmt = '%.3o ' x (scalar @arr);
}

sub decimal1 {
    @arr = unpack 'c*', $data;
    $strfmt = '%4d ' x (scalar @arr);
}

sub udecimal1 {
    @arr = unpack 'C*', $data;
    $strfmt = '%3u ' x (scalar @arr);
}

sub hex1 {
    @arr = unpack 'C*', $data;
    $strfmt = '%.2x ' x (scalar @arr);
}

sub char1 {
    @arr = ();
    my @arr1 = unpack 'C*', $data;
    for my $val (@arr1) {
        if (exists $charescs{$val}) {
	    $arr[0] .= $charescs{$val} . " ";
	}
	elsif ($val > PRINTMAX || chr($val) !~ m/[[:print:]]/) {
	    $arr[0] .= sprintf('%03o ', $val);
	}
	else {
	    $arr[0] .= "  " . chr($val) . " ";
	}
    }
    $strfmt = '%s';
}

sub char7bit {
    @arr = ();
    my @arr1 = unpack 'C*', $data;
    for my $val (@arr1) {
        my $n = $val & 0x7f;
        if (exists $charname{$n}) {
            $arr[0] .= $charname{$n} . " ";
        }
        else {
	    $arr[0] .= "  " . chr($n) . " ";
        }
    }
    $strfmt = '%s';
}

sub udecimal2 {
    @arr = unpack 'S*', $data . zeropad(length($data), 2);
    $strfmt = '%5u ' x (scalar @arr);
}

sub float4 {
    @arr = unpack 'f*', $data . zeropad(length($data), 4);
    $strfmt = '%15.7e ' x (scalar @arr);
}

sub float8 {
    @arr = unpack 'd*', $data . zeropad(length($data), 8);
    $strfmt = '%24.16e ' x (scalar @arr);
}

sub decimal2 {
    @arr = unpack 's*', $data . zeropad(length($data), 2);
    $strfmt = '%6d ' x (scalar @arr);
}

sub long {
    @arr = unpack 'L*', $data . zeropad(length($data), 4);
    $strfmt = '%10ld ' x (scalar @arr);
}

sub octal2 {
    @arr = unpack 'S*', $data . zeropad(length($data), 2);
    $strfmt = '%.6o ' x (scalar @arr);
}

sub octal4 {
    @arr = unpack 'L*', $data . zeropad(length($data), 4);
    $strfmt = '%.11o ' x (scalar @arr);
}

sub decimal4 {
    @arr = unpack 'L*', $data . zeropad(length($data), 4);
    $strfmt = '%11d ' x (scalar @arr);
}

sub udecimal4 {
    @arr = unpack 'L*', $data . zeropad(length($data), 4);
    $strfmt = '%11u ' x (scalar @arr);
}

sub hex2 {
    @arr = unpack 'S*', $data . zeropad(length($data), 2);
    $strfmt = '%.4x ' x (scalar @arr);
}

sub hex4 {
    @arr = unpack 'L*', $data . zeropad(length($data), 4);
    $strfmt = '%.8x ' x (scalar @arr);
}

sub hex8 {
    @arr = unpack 'Q*', $data . zeropad(length($data), 8);
    $strfmt = '%.16x ' x (scalar @arr);
}

sub octal8 {
    @arr = unpack 'Q*', $data . zeropad(length($data), 8);
    $strfmt = '%.22o ' x (scalar @arr);
}

sub udecimal8 {
    @arr = unpack 'Q*', $data . zeropad(length($data), 8);
    $strfmt = '%22u ' x (scalar @arr);
}

sub decimal8 {
    @arr = unpack 'Q*', $data . zeropad(length($data), 8);
    $strfmt = '%22d ' x (scalar @arr);
}

sub zeropad {
    my ($len, $wantbytes) = @_;
    my $remain = $len % $wantbytes;
    return '' unless $remain;
    return "\0" x ($wantbytes - $remain);
}

sub diffdata {
    my $currdata = $data . '|';
    return ($currdata eq $lastline) ? 0 : 1;
}

sub help {
    print "usage: od [-aBbcDdeFfHhilOosXxv] [-A radix] [-j skip_bytes] ",
        "[-N limit_bytes] [-t type] [file]...\n";
    exit EX_FAILURE;
}
__END__

=head1 NAME

od - dump files in octal and other formats

=head1 SYNOPSIS

B<od> [ I<-aBbcDdeFfHhilOosXxv> ] [I<-j skip_bytes>] [I<-N limit_bytes>]
      [ I<-A radix> ] [ I<-t type> ] [ F<file>... ]

=head1 DESCRIPTION

B<od> writes  to  the  standard output the contents of the given
files, or of the standard input if no files are specified.  Each  line
of  the  output  consists of the offset in the input file in the leftmost
column of each  line,  followed by  one or more columns of data from the
file, in a format controlled by the options.  By default, od prints the
file offsets  in octal and the file data as two-byte octal numbers.

=head2 OPTIONS

The following options are available:

=over 4

=item -A Radix

Select offset prefix format: 'd' for decimal, 'o' for octal, 'x' for hexadecimal, 'n' for none.

=item -a

Dump characters in 7-bit ASCII format, ignoring the highest bit of each byte.
The names of ASCII control characters are displayed.

=item -B

Same as -o

=item -b

Single-byte octal display.

=item -c

Display characters literally, with non-printable characters displayed as C escape sequences.

=item -D

Four-byte unsigned decimal display.

=item -d

Two-byte unsigned decimal display.

=item -e

Eight-byte floating point display.

=item -F

Same as -e

=item -f

Show input as floating point numbers in exponent form.

=item -H

Four-byte hex display.

=item -h

Two-byte hex display.

=item -i

Show two-byte signed decimal integers.

=item -j Skip

Ignore the first Skip bytes of input.

=item -l

Show four-byte signed decimal integers.

=item -N Bytes

Set the number of maximum input bytes read.

=item -O

Four-byte octal display.

=item -o

Format input as two-byte octal numbers.

=item -s

Same as -i

=item -t Type

Select output format as one of the following:

    a      ASCII character names. Same as -a
    c      Characters with C escapes. Same as -c
    o1     1-byte unsigned octal
    o2     2-byte unsigned octal
    o4     4-byte unsigned octal
    o8     8-byte unsigned octal
    d1     1-byte signed decimal
    d2     2-byte signed decimal
    d4     4-byte signed decimal
    d8     8-byte signed decimal
    u1     1-byte unsigned decimal
    u2     2-byte unsigned decimal
    u4     4-byte unsigned decimal
    u8     8-byte unsigned decimal
    x1     1-byte unsigned hexadecimal
    x2     2-byte unsigned hexadecimal
    x4     4-byte unsigned hexadecimal
    x8     8-byte unsigned hexadecimal
    f4     4-byte floating point. Same as -f
    f8     8-byte floating point. Same as -F

This option overrides other formatting options.

=item -X

Same as -H

=item -x

Same as -h

=item -v

Show all lines, even if they are identical to the previous line.

=back

=head1 SEE ALSO

od(1)

=head1 AUTHOR

Mark Kahn,  I<mkahn@vbe.com>.

=head1 COPYRIGHT and LICENSE

This program is copyright (c) Mark Kahn 1999.

This program is free and open software. You may use, modify, distribute,
and sell this program (and any modified variants) in any way you wish,
provided you do not restrict others from doing the same.
