File Coverage

bin/od

Criterion	Covered	Total	%
statement	100	221	45.2
branch	44	130	33.8
condition	11	24	45.8
subroutine	17	38	44.7
pod			n/a
total	172	413	41.6

#!/usr/bin/perl

=begin metadata

Name: od
Description: dump files in octal and other formats
Author: Mark Kahn, [e-mail]
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__