od

#!/usr/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_b $opt_c $opt_d $opt_f $opt_i $opt_j $opt_l $opt_N
$opt_o $opt_v $opt_x /;

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

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

$offset1 = 0;
$lastline = '';

my $Program = basename($0);

getopts('A:bcdfij:lN:ovx') 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_b) {
    $fmt = \&octal1;
}
elsif ($opt_c) {
    $fmt = \&char1;
}
elsif ($opt_d) {
    $fmt = \&udecimal;
}
elsif ($opt_f) {
    $fmt = \&float;
}
elsif ($opt_i) {
    $fmt = \&decimal;
}
elsif ($opt_l) {
    $fmt = \&long;
}
elsif ($opt_o) {
    $fmt = \&octal2;
}
elsif ($opt_x) {
    $fmt = \&hex;
}
else {
    $fmt = \&octal2;
}

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

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

    while (!limit_reached() && !eof($fh)) {
	$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) {
	$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 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 udecimal {
    if (length($data) & 1) { # pad to 16 bit
        @arr = unpack 'S*', $data . "\0";
    }
    else {
        @arr = unpack 'S*', $data;
    }
    $strfmt = '%5u ' x (scalar @arr);
}

sub float {
    my $remain = length($data) % 4;
    if ($remain) { # pad to 32 bit
        my $pad = "\0" x $remain;
        @arr = unpack 'f*', $data . $pad;
    }
    else {
	@arr = unpack 'f*', $data;
    }
    $strfmt = '%6.6e ' x (scalar @arr);
}

sub decimal {
    if (length($data) & 1) { # pad to 16 bit
        @arr = unpack 's*', $data . "\0";
    }
    else {
        @arr = unpack 's*', $data;
    }
    $strfmt = '%5d ' x (scalar @arr);
}

sub long {
    my $remain = length($data) % 4;
    if ($remain) { # pad to 32 bit
        my $pad = "\0" x $remain;
        @arr = unpack 'L*', $data . $pad;
    }
    else {
	@arr = unpack 'L*', $data;
    }
    $strfmt = '%10ld ' x (scalar @arr);
}

sub octal2 {
    if (length($data) & 1) { # pad to 16 bit
        @arr = unpack 'S*', $data . "\0";
    }
    else {
        @arr = unpack 'S*', $data;
    }
    $strfmt = '%.6o ' x (scalar @arr);
}

sub hex {
    if (length($data) & 1) { # pad to 16 bit
        @arr = unpack 'S*', $data . "\0";
    }
    else {
        @arr = unpack 'S*', $data;
    }
    $strfmt = '%.4x ' x (scalar @arr);
}

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

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

=head1 NAME

od - dump files in octal and other formats

=head1 SYNOPSIS

B<od> [ I<-bcdfiloxv> ] [I<-j skip_n_bytes>] [I<-N read_n_bytes>] [ I<-A radix> ] [ 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.

=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.